├── DIFFERENCES ├── README ├── RELEASE ├── dylan-examples.dyl ├── examples-from-book.text ├── full-test.scm ├── kits ├── MIT │ ├── README │ ├── dylan-examples.output │ ├── mit-rep.scm │ ├── mit-specific.scm │ ├── restart-example.dyl │ ├── src │ │ ├── class-structure.scm │ │ ├── class.scm │ │ ├── common.scm │ │ ├── comp-class.scm │ │ ├── comp-exc.scm │ │ ├── comp-method.scm │ │ ├── comp-sf.scm │ │ ├── comp-util.scm │ │ ├── comp.scm │ │ ├── compiler.scm │ │ ├── gambit-specific.scm │ │ ├── generic.scm │ │ ├── implementation-specific │ │ ├── load-compiler.scm │ │ ├── load-runtime.scm │ │ ├── load-thomas.scm │ │ ├── mit-rep.scm │ │ ├── portable-rep.scm │ │ ├── rep.scm │ │ ├── runtime-bitstrings.scm │ │ ├── runtime-collections-array.scm │ │ ├── runtime-collections-deque.scm │ │ ├── runtime-collections-generic1.scm │ │ ├── runtime-collections-generic2.scm │ │ ├── runtime-collections-iterate.scm │ │ ├── runtime-collections-list.scm │ │ ├── runtime-collections-range.scm │ │ ├── runtime-collections-string.scm │ │ ├── runtime-collections-table.scm │ │ ├── runtime-collections-vector.scm │ │ ├── runtime-collections.scm │ │ ├── runtime-exceptions.scm │ │ ├── runtime-functions.scm │ │ ├── runtime-internal.scm │ │ ├── runtime-methods.scm │ │ ├── runtime-top.scm │ │ ├── runtime.scm │ │ ├── scc-rep.scm │ │ ├── scc-specific.scm │ │ ├── support.scm │ │ └── thomas.sf │ └── thomas.sf ├── gambit │ ├── README │ ├── compile │ ├── dylan-examples.output │ ├── gambit-specific.scm │ ├── hash.scm │ ├── poplat.scm │ ├── restart-example.dyl │ └── src │ │ ├── class-structure.scm │ │ ├── class.scm │ │ ├── common.scm │ │ ├── comp-class.scm │ │ ├── comp-exc.scm │ │ ├── comp-method.scm │ │ ├── comp-sf.scm │ │ ├── comp-util.scm │ │ ├── comp.scm │ │ ├── compiler.scm │ │ ├── dynwnd.scm │ │ ├── generic.scm │ │ ├── hash.scm │ │ ├── implementation-specific │ │ ├── implementation-specific.scm │ │ ├── load-compiler.scm │ │ ├── load-runtime.scm │ │ ├── load-thomas.scm │ │ ├── mit-rep.scm │ │ ├── mit-specific.scm │ │ ├── msort.scm │ │ ├── poplat.scm │ │ ├── portable-rep.scm │ │ ├── record.scm │ │ ├── rep.scm │ │ ├── runtime-bitstrings.scm │ │ ├── runtime-collections-array.scm │ │ ├── runtime-collections-deque.scm │ │ ├── runtime-collections-generic1.scm │ │ ├── runtime-collections-generic2.scm │ │ ├── runtime-collections-iterate.scm │ │ ├── runtime-collections-list.scm │ │ ├── runtime-collections-range.scm │ │ ├── runtime-collections-string.scm │ │ ├── runtime-collections-table.scm │ │ ├── runtime-collections-vector.scm │ │ ├── runtime-collections.scm │ │ ├── runtime-exceptions.scm │ │ ├── runtime-functions.scm │ │ ├── runtime-internal.scm │ │ ├── runtime-methods.scm │ │ ├── runtime-top.scm │ │ ├── runtime.scm │ │ ├── scc-rep.scm │ │ ├── scc-specific.scm │ │ └── support.scm └── scc │ ├── DECstation.o │ ├── README │ ├── aftergc.sc │ ├── callcc.c │ ├── dylan-examples.output │ ├── dynwind.sc │ ├── hash.sc │ ├── heap.c │ ├── heap.h │ ├── implementation-specific │ ├── main.sc │ ├── makefile │ ├── mit.sc │ ├── msort.sc │ ├── poplat.sc │ ├── record.sc │ ├── scc-rep.scm │ ├── scc-specific.sc │ ├── scinit.c │ └── src │ ├── class-structure.scm │ ├── class.scm │ ├── common.scm │ ├── comp-class.scm │ ├── comp-exc.scm │ ├── comp-method.scm │ ├── comp-sf.scm │ ├── comp-util.scm │ ├── comp.scm │ ├── compiler.scm │ ├── gambit-specific.scm │ ├── generic.scm │ ├── implementation-specific │ ├── load-compiler.scm │ ├── load-runtime.scm │ ├── load-thomas.scm │ ├── mit-rep.scm │ ├── mit-specific.scm │ ├── portable-rep.scm │ ├── rep.scm │ ├── runtime-bitstrings.scm │ ├── runtime-collections-array.scm │ ├── runtime-collections-deque.scm │ ├── runtime-collections-generic1.scm │ ├── runtime-collections-generic2.scm │ ├── runtime-collections-iterate.scm │ ├── runtime-collections-list.scm │ ├── runtime-collections-range.scm │ ├── runtime-collections-string.scm │ ├── runtime-collections-table.scm │ ├── runtime-collections-vector.scm │ ├── runtime-collections.scm │ ├── runtime-exceptions.scm │ ├── runtime-functions.scm │ ├── runtime-internal.scm │ ├── runtime-methods.scm │ ├── runtime-top.scm │ ├── runtime.scm │ ├── scc-rep.scm │ ├── scc-specific.scm │ └── support.scm ├── portable ├── dynwind.scm ├── hash.scm ├── msort.scm ├── poplat.scm └── record.scm └── src ├── README ├── class-structure.scm ├── class.scm ├── common.scm ├── comp-class.scm ├── comp-exc.scm ├── comp-method.scm ├── comp-sf.scm ├── comp-util.scm ├── comp.scm ├── compiler.scm ├── generic.scm ├── load-compiler.scm ├── load-runtime.scm ├── load-thomas.scm ├── portable-rep.scm ├── runtime-bitstrings.scm ├── runtime-collections-array.scm ├── runtime-collections-deque.scm ├── runtime-collections-generic1.scm ├── runtime-collections-generic2.scm ├── runtime-collections-iterate.scm ├── runtime-collections-list.scm ├── runtime-collections-range.scm ├── runtime-collections-string.scm ├── runtime-collections-table.scm ├── runtime-collections-vector.scm ├── runtime-collections.scm ├── runtime-exceptions.scm ├── runtime-functions.scm ├── runtime-internal.scm ├── runtime-methods.scm ├── runtime-top.scm ├── runtime.scm └── support.scm /DIFFERENCES: -------------------------------------------------------------------------------- 1 | -*-Indented-Text-*- 2 | 3 | Known Problems in Thomas 4 | (and a comparison to Dylan(TM)) 5 | ------------------------------- 6 | 7 | I. Non-Portable Elements of Thomas 8 | 9 | In addition to the file src/implementation-specific.scm, we are aware 10 | of one assumption we make about the underlying Scheme system which is 11 | not guaranteed by the IEEE standard. We assume that any exact 12 | non-integer is a ratio. We know of no implementations of Scheme in 13 | which this is NOT true, but mention it here for completeness. 14 | 15 | Some implementations of Scheme do not support the entire numerical 16 | hierarchy as described in the IEEE standard (it is not required that 17 | they do so). If part of the hierarchy is omitted in the 18 | implementation, this will be visible within the Thomas implementation. 19 | This most often manifests itself in a lack of complex numbers, large 20 | rationals, or very large integers. 21 | 22 | II. Known differences from the book "Dylan(TM) an object-oriented 23 | dynamic language" by Apple Computer Eastern Research and 24 | Technology, April 1992. 25 | 26 | 1) In order to use Scheme's READ to handle Thomas expressions, Thomas 27 | uses !key and !rest wherever the Dylan(TM) book uses #key or #rest. 28 | 29 | 2) Thomas variable names are restricted to the subset of Scheme names 30 | that don't start with "!" or "dylan:". This avoids name clashes 31 | between user variable names and compiler-generated variables. 32 | 33 | 3) Thomas doesn't remember the initial case of symbols, since it 34 | inherits the case from the underlying Scheme system. Thus some 35 | implementations of Thomas store symbols in upper case, some in 36 | lower case, and some preserve case. All implementations are 37 | otherwise case-insensitive for symbols, keywords and variable 38 | names. 39 | 40 | 4) Thomas doesn't fully handle sealed classes, abstract classes, or 41 | read-only module variables. 42 | 43 | 5) Thomas doesn't support the REMOVE-SLOT operation. We don't really 44 | understand the full intent of this operation in a variety of 45 | circumstances. 46 | 47 | 6) Thomas doesn't do collection alignment for tables (as specified on 48 | pages 128 and 129); other collection types should be OK. Fixing 49 | this would be a very nice contribution to the Thomas implementation 50 | (hint, hint). 51 | 52 | 7) Thomas doesn't do (SETTER DIRECT-SUPERCLASSES). This is somewhere 53 | between an oversight (we honestly didn't notice it and it isn't in 54 | the index) and a pain to write. Again, help would be appreciated. 55 | 56 | 8) Thomas doesn't do virtual slots in a way that supports their use as 57 | "filtered slots" as described on pages 58 and 59. We find the 58 | description confusing, and require implementors to allocate an 59 | object of the supertype to store the "hidden" slot value rather 60 | than relying on NEXT-METHOD to find the hidden slot in the object 61 | itself. 62 | 63 | 9) Some implementations of Scheme do not recognize the same set of literal 64 | character names as specified in the book. IEEE Scheme requires the 65 | character literals #\space and #\newline. Dylan also specifies 66 | #\rubout, #\page, #\tab, #\backspace, #\return, and #\linefeed. 67 | 68 | III. Additions to the Thomas language 69 | 70 | All implementations of Thomas provide four methods not mentioned in 71 | Dylan(TM): 72 | 73 | (display ) derived from Scheme's DISPLAY 74 | (newline) derived from Scheme'S NEWLINE 75 | (print ) same as write-line 76 | (write-line ) NEWLINE, then WRITE 77 | 78 | Some implementations add additional methods or generic functions. 79 | These are documented in the file kits//README. 80 | 81 | $Id: DIFFERENCES,v 1.4 1992/09/25 16:42:12 birkholz Exp $ 82 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | -*-Indented-Text-*- 2 | 3 | Overview of the DEC Thomas->Scheme Compiler. 4 | 5 | This is the directory for Thomas, a compiler written at Digital Equipment 6 | Corporation's Cambridge Research Laboratory. Thomas compiles a language 7 | compatible with the language described in the book "Dylan(TM) an 8 | object-oriented dynamic language" by Apple Computer Eastern Research and 9 | Technology, April 1992; the file DIFFERENCES lists the known differences. 10 | 11 | We have made every effort to minimize the differences between Thomas and 12 | Dylan(TM), and to remove bugs, but help from others would be greatly 13 | appreciated. The original development team consisted of: 14 | 15 | Matt Birkholz (Birkholz@crl.dec.com) 16 | Jim Miller (JMiller@crl.dec.com) 17 | Ron Weiss (RWeiss@crl.dec.com) 18 | 19 | In addition, Joel Bartlett (Bartlett@wrl.dec.com), Marc Feeley 20 | (Feeley@iro.umontreal.ca), Guillermo Rozas (Jinx@zurich.ai.mit.edu) and 21 | Ralph Swick (Swick@crl.dec.com) contributed time and energy to the initial 22 | release. 23 | 24 | Comments, questions, suggestions, help, etc. should be directed to: 25 | info-thomas@crl.dec.com 26 | Requests to be added to this mailing list should be sent to: 27 | info-thomas-request@crl.dec.com 28 | 29 | All general comments about Thomas should go to the above address. Comments 30 | specifically about Thomas running in a particular Scheme implementation 31 | should be directed to the maintainer of the implementation. As of 32 | September 11, 1992 these maintainers are as follows: 33 | 34 | MIT CScheme: info-thomas-cscheme@crl.dec.com 35 | scc: info-thomas-scc@crl.dec.com 36 | gambit: feeley@iro.umontreal.ca 37 | 38 | * * * 39 | 40 | In building Thomas, our goals (in order of priority) were: 41 | 42 | (1) To learn about the Dylan(TM) language, by building an implementation 43 | based solely on the description in the book. 44 | 45 | (2) To help others learn about the language by producing source code for an 46 | implementation that was well structured, easy to read, and was 47 | publically available. 48 | 49 | (3) To build a system we could use to actually write small Dylan(TM) 50 | programs, to get a feel for the language through using it. 51 | 52 | We feel we have met these three goals as well as can be expected in a four 53 | week project with three people. It was never our intention to produce an 54 | implementation that performs well, and Thomas has no optimizations of any 55 | kind. It does not perform well. This reflects our goals and not 56 | necessarily the design of the language itself. 57 | 58 | Thomas is NOT Dylan(TM). We have not received approval for the use of the 59 | trademark, and we have not received a copy of a test suite other than the 60 | examples from the book itself. We may, at some future date, pursue these 61 | issues with Apple. The Thomas system was built with no direct input, aid, 62 | assistance or discussion with Apple. All design and implementation 63 | decisions in Thomas reflect choices by the Thomas implementors based on 64 | reading the book published by Apple. These decisions must not be 65 | construed in any way as deriving from Apple Computer Corporation or its 66 | employees. 67 | 68 | * * * 69 | 70 | The Thomas system is being distributed in a form compatible with three 71 | existing public implementations of Scheme. Each has its own subdirectory 72 | (in ./kits) with a README file: 73 | 74 | MIT -- MIT's CScheme implementation, available for Vax (Ultrix, Berkeley 75 | Unix, and possibly VMS); Unix on the MIPS, 680x0, Alpha, and HP 76 | Precision Architecture; and Intel 386/486 under MS/DOS and Windows 77 | 3.0. In order to use Thomas in MIT CScheme, you must have a working 78 | installation of MIT CScheme on your system. The MIT CScheme system 79 | is available by ftp from altdorf.ai.mit.edu. 80 | 81 | scc -- DEC's Scheme->C system, available for VAX/ULTRIX, DECstation, SGI 82 | Iris, Amiga, Sun3, Sun4, DNx500, DN1000 386 (running SYS V Unix), 83 | NeXT, HP9000/700 and Sony News 3200 systems. This subdirectory 84 | includes an object module that can be linked on a DECStation to 85 | produce a running Scheme interpreter, as well as the files needed 86 | to install Thomas in an existing Scheme->C system on other 87 | machines. Scheme->C (scc) is available by ftp from 88 | gatekeeper.pa.dec.com. 89 | 90 | gambit -- Marc Feeley's Scheme system for (primarily) the Motorola 680x0 91 | family of machines including the Macintosh. You must have a 92 | working installation of Gambit to use this version. Gambit is 93 | available by ftp from trex.iro.umontreal.ca 94 | 95 | * * * 96 | 97 | Brief description of the top-level directory of Thomas. 98 | 99 | RELEASE -- Release notes; what's changed in this release. 100 | 101 | DIFFERENCES -- Known differences between the language handled by Thomas and 102 | the language as specified in "Dylan(TM) an object-oriented dynamic 103 | language" by Apple Computer Eastern Research and Technology, April 104 | 1992. 105 | 106 | README -- This file. 107 | 108 | kits/MIT -- Symbolic links to all files required to implement Thomas in MIT 109 | CScheme. 110 | 111 | kits/gambit -- Symbolic links to all files required to implement Thomas in 112 | Marc Feeley's Gambit system. 113 | 114 | kits/scc -- Symbolic links to all files required to implement Thomas in 115 | Digital Equipment Corporation's Scheme->C system. 116 | 117 | There are also a number of files of interest primarily to people porting or 118 | implementing Thomas. 119 | 120 | dylan-examples.dyl -- Edited and commented examples from the 121 | Dylan(TM) book. 122 | 123 | examples-from-book.text -- Source of examples from the Dylan(TM) book, as 124 | extracted and edited by Andrew Shalit of Apple Computer Eastern 125 | Research and Technology. This is the "raw" version from which 126 | dylan-examples.dyl was derived. 127 | 128 | full-test.scm -- A Scheme program which can be used for regression 129 | testing of Thomas. This program reads and executes the examples 130 | given in dylan-examples.dyl. Additional examples can be found in 131 | examples-from-book.text, and in some of the kits//src/ files. 132 | 133 | portable -- A subdirectory containing code extracted from the MIT CScheme 134 | runtime system and edited to make it portable (within limits as 135 | explained at the start of each file) to other implementations of 136 | Scheme. The code in these files is required by the current 137 | implementation of Thomas, and these sources are supplied to aid 138 | people who wish to port Thomas to other Scheme systems. 139 | 140 | src -- The source code for the Thomas system. This contains all of the 141 | code needed for the MIT CScheme version of Thomas. Augmented by 142 | the sources in portable and in the implementation-specific 143 | subdirectory for a particular Scheme implementation it should be 144 | sufficient to rebuild Thomas. 145 | 146 | $Id: README,v 1.5 1992/09/25 16:36:21 birkholz Exp $ 147 | -------------------------------------------------------------------------------- /RELEASE: -------------------------------------------------------------------------------- 1 | -*-Indented-Text-*- 2 | 3 | Thomas version 1.1 contains the following changes from version 1.0: 4 | 5 | * runtime-collections-generic.scm was too large to be compiled by Gambit. 6 | We've split it into runtime-collections-generic1.scm and 7 | runtime-collections-generic2.scm. 8 | 9 | * sorted-applicable-methods now uses a new topological sort that uses a 10 | number we call "class specificity". Intuitively, class specificity 11 | increases every time a class is specialized to produce a subclass. 12 | Computationally, class specificity is the largest number of subclass links 13 | between and the class. For example, consider this class 14 | heterarchy: 15 | 16 | specificity = 0 17 | / | \ 18 | specificity = 1 19 | \ / / 20 | / specificity = 2 21 | \ / 22 | specificity = 3 23 | 24 | Thus, during method dispatch on an object of type , Thomas considers 25 | methods specialized by class to be more specific than those specialized 26 | by or , which are in turn more specific than any specialized by 27 | . Notice that the ordering of methods specialized by and 28 | is not specified. Methods specialized on or are not applicable 29 | because is not a subclass of either. 30 | 31 | * portable-rep.scm and scc-rep.scm now also support the 32 | `empty-thomas-environment!' operation. 33 | 34 | $Id: RELEASE,v 1.3 1992/09/25 16:37:00 birkholz Exp $ 35 | -------------------------------------------------------------------------------- /full-test.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: full-test.scm,v 1.2 1992/09/21 21:26:17 birkholz Exp $ 39 | 40 | (define (display-simple-condition condition) 41 | (display (dylan-call dylan:condition-format-string condition)) 42 | (do ((args (dylan-call dylan:condition-format-arguments condition) 43 | (cdr args))) 44 | ((null? args)) 45 | (display " ") (write (car args)))) 46 | 47 | (define (display-condition condition) 48 | (newline) 49 | (let ((condition-type (get-type condition))) 50 | (cond 51 | ((eq? condition-type ) 52 | (display ";Error: ") (display-simple-condition condition)) 53 | ((eq? condition-type ) 54 | (display ";Warning: ") (display-simple-condition condition)) 55 | ((eq? condition-type ) 56 | (display ";Error: ") 57 | (write (dylan-call dylan:type-error-value condition)) 58 | (display " is not an instance of ") 59 | (display (class.debug-name 60 | (dylan-call dylan:type-error-expected-type 61 | condition)))) 62 | (else 63 | (display ";Unhandled dylan condition: ") 64 | (write condition))))) 65 | 66 | (define (make-expression preamble compiled-output) 67 | `(BEGIN 68 | ,@preamble 69 | (LET* ((!MULTIPLE-VALUES (VECTOR '())) 70 | (!RESULT ,compiled-output)) 71 | (IF (EQ? !RESULT !MULTIPLE-VALUES) 72 | (LET RESULT-LOOP 73 | ((COUNT 1) 74 | (RESULTS (VECTOR-REF !MULTIPLE-VALUES 0))) 75 | (IF (PAIR? RESULTS) 76 | (LET ((RESULT (CAR RESULTS))) 77 | (NEWLINE) 78 | (DISPLAY ";Value[")(DISPLAY COUNT)(DISPLAY "]: ") 79 | (WRITE RESULT) 80 | (RESULT-LOOP (+ 1 COUNT) (CDR RESULTS))) 81 | (NEWLINE))) 82 | (BEGIN 83 | (NEWLINE)(DISPLAY ";Value: ")(WRITE !RESULT)(NEWLINE)))))) 84 | 85 | (define (test file) 86 | (with-input-from-file file 87 | (lambda () 88 | (let loop ((module-variables '())) 89 | (let ((sexpr (read))) 90 | (if (eof-object? sexpr) 91 | (begin 92 | (newline) 93 | (newline)) 94 | (begin 95 | (pp sexpr) 96 | (loop 97 | ;; Return from here with new module-variables. 98 | (call-with-current-continuation 99 | (lambda (error-exit) 100 | (dylan::catch-all-conditions 101 | (lambda () 102 | (dylan::handler-bind 103 | ; type 104 | (make-dylan-callable ; function 105 | (lambda (condition next-handler) 106 | next-handler 107 | (display-condition condition) 108 | (newline) 109 | (error-exit module-variables))) 110 | (make-dylan-callable ; test 111 | (lambda (condition) 112 | condition 113 | #T)) 114 | (make-dylan-callable ; description 115 | (lambda (stream) 116 | (display "error handler from full-test.scm" 117 | stream))) 118 | (lambda () 119 | (compile-expression 120 | sexpr '!MULTIPLE-VALUES module-variables 121 | (lambda (new-vars preamble compiled-output) 122 | (implementation-specific:eval 123 | (make-expression preamble compiled-output)) 124 | (append new-vars module-variables))))))))))))))))) 125 | 126 | (define (test-dylan-examples) (test "dylan-examples.dyl")) 127 | -------------------------------------------------------------------------------- /kits/MIT/README: -------------------------------------------------------------------------------- 1 | -*-Indented-Text-*- 2 | 3 | This is the directory for the MIT CScheme implementation of Thomas, a 4 | compiler written at Digital Equipment Corporation's Cambridge Research 5 | Laboratory. Thomas compiles a language compatible with the language 6 | described in the book "Dylan(TM) an object-oriented dynamic language" by 7 | Apple Computer Eastern Research and Technology, April 1992; the file 8 | DIFFERENCES lists the known differences. 9 | 10 | We have made every effort to minimize the differences between Thomas and 11 | Dylan(TM), and to remove bugs, but help from others would be greatly 12 | appreciated. The original development team consisted of: 13 | 14 | Matt Birkholz (Birkholz@crl.dec.com) 15 | Jim Miller (JMiller@crl.dec.com) 16 | Ron Weiss (RWeiss@crl.dec.com) 17 | 18 | In addition, Joel Bartlett (Bartlett@wrl.dec.com), Marc Feeley 19 | (Feeley@iro.umontreal.ca), Guillermo Rozas (Jinx@zurich.ai.mit.edu) and 20 | Ralph Swick (Swick@crl.dec.com) contributed time and energy to the initial 21 | release. 22 | 23 | * * * 24 | 25 | INSTALLATION 26 | 27 | To install this version of Thomas you must already have MIT's CScheme 7.2 28 | or later. If you have an earlier version of CScheme, some minor 29 | modifications will have to be made. It may be helpful to know where 30 | CScheme is storing its library files (typically either in the directory 31 | /usr/local/lib/mit-scheme or in a directory specified by the environment 32 | variable MITSCHEME_LIBRARY_PATH). CScheme can be obtained by anonymous 33 | FTP from altdorf.ai.mit.edu. 34 | 35 | The implementation of Thomas is largely in IEEE standard Scheme and resides 36 | in ../src/. Some generic utilities are available as IEEE standard packages 37 | independent of Thomas and reside in ../portable/. A small amount of code 38 | is CScheme-specific and resides in this directory. The src/ subdirectory of 39 | this directory contains symbolic links to all the various pieces needed to 40 | produce a working Thomas in CScheme. 41 | 42 | The rest of these instructions assume you already know how to use CScheme. 43 | 44 | 1) There are three ways to use Thomas: as a compiler, as a runtime 45 | execution environment, or as an interactive environment. Each is 46 | described below. In general, you will probably find it easiest to 47 | load up the appropriate file (from the "src" subdirectory of this 48 | directory) and dump a complete band. Then in the future you can 49 | specify -band and a file name to restart the appropriate version of 50 | Thomas. Dumping the band (using DISK-SAVE) into the Scheme library 51 | directory is likely to be the easiest technique, although you can 52 | dump the band in any directory and then specify the directory 53 | explicitly when you start Scheme. 54 | 55 | a) Compiler: Load the file "load-compiler". This provides two 56 | main procedures: 57 | 58 | (THOMAS . expressions) compiles the Thomas EXPRESSIONS 59 | and puts the resulting Scheme expression into . 60 | 61 | (THOMAS->SCHEME input output) compiles the INPUT file consisting of 62 | Thomas expressions, generating a single Scheme expression into the 63 | OUTPUT file. 64 | 65 | b) Runtime Execution: Load the file "load-runtime". This provides a 66 | Scheme environment into which the output of the Thomas compiler can 67 | be loaded for execution. 68 | 69 | c) Interactive Environment: Load the file "load-thomas". This gives you 70 | two procedures: 71 | 72 | (THOMAS-REP) starts a read-eval-print (REP) loop which works like 73 | an ordinary CScheme REP loop, but uses a Thomas evaluator instead 74 | of a Scheme evaluator. Errors that are not trapped by your Thomas 75 | code will invoke another Scheme (NOT Thomas) REP loop. 76 | 77 | (EMPTY-THOMAS-ENVIRONMENT!) forgets about previously defined 78 | module variables created by (THOMAS-REP). This is the only way 79 | (short of restarting Scheme) to clean out the Thomas environment if 80 | things become messed up. In CScheme, we actually create a new 81 | environment, discarding the old environment and any old variables. 82 | 83 | 2) While Thomas can run fully interpreted, it will be considerably faster 84 | if you first generate ".bin" files. To make these files, you will need 85 | to load a band that has "SF" included in it; typically this can be done 86 | by adding "-compiler" to the command line arguments you use to invoke 87 | Scheme. If that doesn't work, check with the person who installed 88 | Scheme or read the Scheme installation instructions. With Scheme/SF 89 | loaded and with your working directory set to the subdirectory "src" 90 | under this directory, evaluate the Scheme expression (load 91 | "thomas.sf"). This should read in all of the .scm files and convert 92 | them to .bin files. 93 | 94 | You may also wish to compile some or all of the files. This can be 95 | done, after generating the .bin files, by evaluating the Scheme 96 | expression (compile-directory "."). 97 | 98 | Here is a sample session with Thomas: 99 | 100 | Scheme saved on Thursday July 23, 1992 at 1:30:08 PM 101 | Release 7.2.0 (alpha) 102 | Microcode 11.116 103 | Runtime 14.153 104 | SF 4.23 105 | Liar (MIPS) 4.91 106 | 107 | (load "load-thomas") 108 | 109 | ;Loading "load-thomas.bin" -- done 110 | ;Loading "implementation-specific" -- done 111 | <...> 112 | ;Loading "runtime-exceptions.bin" -- done 113 | ;Loading "rep.bin" -- done 114 | ;Value: done 115 | 116 | (thomas-rep) 117 | Entering Thomas 118 | (There are now 0 defined names available.) 119 | 120 | ;Package: (thomas) 121 | 122 | (define x 3) 123 | Result: x 124 | 125 | x 126 | Result: 3 127 | 128 | (define-method double ((N )) (+ n n)) 129 | Result: double 130 | 131 | (double x) 132 | Result: 6 133 | 134 | * * * 135 | 136 | Language Extensions 137 | 138 | The CScheme version of Thomas includes three additional predefined methods: 139 | (PP ) calls the Scheme pretty printer. 140 | (SCHEME-VARIABLE ) returns the value of a Scheme variable 141 | that is visible from the normal user interaction environment. 142 | This can be used to access any Scheme object, but results are 143 | unpredictable unless the object has a type that corresponds to 144 | one of the non-procedural Thomas types. Common types that can 145 | be accessed this way are booleans, symbols, strings, numbers, 146 | the empty list, as well as vectors or lists composed of these. 147 | (SCHEME-PROCEDURE ) also returns the value of a Scheme 148 | variable that is visible from the normal user interaction 149 | environment. It assumes (without checking) that it is 150 | applicable and converts it to a Thomas method. From within 151 | Thomas it will appear to take an arbitrary number of arguments, 152 | but will issue an error if the number supplied doesn't match 153 | the number expected by the Scheme procedure. 154 | 155 | $Id: MIT_README,v 1.2 1992/09/23 16:06:25 birkholz Exp $ 156 | -------------------------------------------------------------------------------- /kits/MIT/mit-rep.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: mit-rep.scm,v 1.3 1992/09/21 21:29:31 birkholz Exp $ 39 | 40 | ;;; Use a package called (THOMAS), but also keep a list of known module 41 | ;;; variables in !thomas-rep-module-variables in that environment. 42 | 43 | (define (empty-thomas-environment!) 44 | (let ((package (name->package '(THOMAS))) 45 | (parent (name->package '())) 46 | (set-package/children! 47 | (environment-lookup (->environment '(package)) 48 | 'set-package/children!))) 49 | (set-package/children! parent 50 | (delq! package (package/children parent))) 51 | (package/add-child! parent 'THOMAS 52 | (let ((!THOMAS-REP-MODULE-VARIABLES '())) 53 | (extend-top-level-environment (nearest-repl/environment) 54 | '(!THOMAS-REP-MODULE-VARIABLES) 55 | '(())))) 56 | unspecific)) 57 | 58 | (define (thomas-rep) 59 | (repl/start (make-thomas-repl) 60 | (cmdl-message/active 61 | (lambda (port) 62 | (let ((n-names 63 | (length (environment-bindings 64 | (->environment '(THOMAS)))))) 65 | (newline port) 66 | (display "Entering Thomas" port) 67 | (newline port) 68 | (display "(There " port) 69 | (display (if (= n-names 1) "is" "are") port) 70 | (display " now " port) 71 | (display n-names port) 72 | (display " defined name" port) 73 | (display (if (= n-names 1) "" "s") port) 74 | (display "s available.)" port) 75 | (newline port)))))) 76 | 77 | (define make-thomas-repl 78 | (let ((make-repl-state 79 | (environment-lookup (->environment '(runtime rep)) 'make-repl-state)) 80 | (default-repl-operations 81 | (environment-lookup (->environment '(runtime rep)) 82 | 'default-repl-operations))) 83 | (lambda () 84 | (let ((p (nearest-repl))) 85 | (make-cmdl p ; parent 86 | (cmdl/port p) ; port 87 | thomas-repl-driver ; driver 88 | (make-repl-state ; state 89 | "?" ; prompt 90 | (->environment '(Thomas)) ; environment 91 | false ; condition 92 | ) 93 | default-repl-operations ; operations 94 | ))))) 95 | 96 | ;;; This is a modified copy of repl-driver from runtime/rep.scm 97 | 98 | (define (thomas-repl-driver repl) 99 | (let ((reader-history (repl/reader-history repl))) 100 | (fluid-let ((standard-error-hook false) 101 | (standard-warning-hook false)) 102 | (let ((env (->environment '(THOMAS)))) 103 | (let loop () 104 | (thomas-eval (let ((s-expression 105 | (prompt-for-command-expression 106 | (string-append 107 | (number->string (cmdl/level repl)) 108 | " " 109 | (repl/prompt repl)) 110 | (cmdl/port repl)))) 111 | (repl-history/record! reader-history s-expression) 112 | s-expression) 113 | env) 114 | (loop)))))) 115 | 116 | (define (thomas-eval sexpr environment) 117 | (compile-expression 118 | sexpr 119 | '!MULTIPLE-VALUES 120 | (environment-lookup environment '!THOMAS-REP-MODULE-VARIABLES) 121 | (lambda (new-vars preamble compiled-output) 122 | (eval 123 | `(BEGIN 124 | ,@preamble 125 | (LET* ((!MULTIPLE-VALUES (VECTOR '())) 126 | (!RESULT ,compiled-output)) 127 | (IF (EQ? !RESULT !MULTIPLE-VALUES) 128 | (LET RESULT-LOOP 129 | ((COUNT 1) 130 | (RESULTS (VECTOR-REF !MULTIPLE-VALUES 0))) 131 | (IF (PAIR? RESULTS) 132 | (LET ((RESULT (CAR RESULTS))) 133 | (NEWLINE) 134 | (DISPLAY ";Value[")(DISPLAY COUNT)(DISPLAY "]: ") 135 | (WRITE RESULT) 136 | (RESULT-LOOP (+ 1 COUNT) (CDR RESULTS))) 137 | (NEWLINE))) 138 | (IF (UNDEFINED-VALUE? !RESULT) 139 | (BEGIN 140 | (NEWLINE)(DISPLAY ";No value")(NEWLINE)) 141 | (BEGIN 142 | (NEWLINE)(DISPLAY ";Value: ")(WRITE !RESULT)(NEWLINE))))) 143 | (SET! !THOMAS-REP-MODULE-VARIABLES 144 | (APPEND ',new-vars !THOMAS-REP-MODULE-VARIABLES))) 145 | environment)))) 146 | 147 | (empty-thomas-environment!) 148 | 149 | (display " 150 | Apply thomas-rep to start a Thomas read-eval-print loop. 151 | ") 152 | -------------------------------------------------------------------------------- /kits/MIT/restart-example.dyl: -------------------------------------------------------------------------------- 1 | ; -*- Scheme -*- 2 | ;* Copyright 1992 Digital Equipment Corporation 3 | ;* All Rights Reserved 4 | ;* 5 | ;* Permission to use, copy, and modify this software and its documentation is 6 | ;* hereby granted only under the following terms and conditions. Both the 7 | ;* above copyright notice and this permission notice must appear in all copies 8 | ;* of the software, derivative works or modified versions, and any portions 9 | ;* thereof, and both notices must appear in supporting documentation. 10 | ;* 11 | ;* Users of this software agree to the terms and conditions set forth herein, 12 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 13 | ;* right and license under any changes, enhancements or extensions made to the 14 | ;* core functions of the software, including but not limited to those affording 15 | ;* compatibility with other hardware or software environments, but excluding 16 | ;* applications which incorporate this software. Users further agree to use 17 | ;* their best efforts to return to Digital any such changes, enhancements or 18 | ;* extensions that they make and inform Digital of noteworthy uses of this 19 | ;* software. Correspondence should be provided to Digital at: 20 | ;* 21 | ;* Director, Cambridge Research Lab 22 | ;* Digital Equipment Corp 23 | ;* One Kendall Square, Bldg 700 24 | ;* Cambridge MA 02139 25 | ;* 26 | ;* This software may be distributed (but not offered for sale or transferred 27 | ;* for compensation) to third parties, provided such third parties agree to 28 | ;* abide by the terms and conditions of this notice. 29 | ;* 30 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 31 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 32 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 33 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 34 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 35 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 36 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 37 | ;* SOFTWARE. 38 | 39 | ; $Id: MIT_restart-example.dyl,v 1.1 1992/09/22 20:55:21 birkholz Exp $ 40 | 41 | ;;;; Example from pages 144-6. (Punted initial example code.) 42 | ;;;; Many changed were necessary. So many that they aren't noted here. 43 | 44 | ;;; Classes such as used in these examples are 45 | ;;; invented for the example and are not part of the specification 46 | ;;; This example shows minimal handling of a file-not-found error 47 | 48 | ;;; This is the same example improved so the restart handler that 49 | ;;; reads another file can only be reached by a handler for the 50 | ;;; associated condition, useful if there are nested errors. 51 | 52 | (define (operating-system-open filename) 53 | (call-with-current-continuation 54 | (lambda (continuation) 55 | (bind-condition-handler 56 | (list condition-type:file-operation-error) 57 | (lambda (condition) 58 | (if (and (string=? "open" (access-condition condition 'VERB)) 59 | (string=? "file" (access-condition condition 'NOUN)) 60 | (string-ci=? "no such file or directory" 61 | (access-condition condition 'REASON))) 62 | (continuation 'file-not-found))) 63 | (lambda () 64 | (open-input-file filename)))))) 65 | ;;;Value: operating-system-open 66 | 67 | (define-class () 68 | (file-name init-keyword: file-name:)) 69 | ;;;Value: 70 | 71 | (define-class () 72 | (condition init-keyword: condition: 73 | getter: restart-condition) 74 | (file-name init-keyword: file-name:)) 75 | ;;;Value: 76 | 77 | (define-method open (the-file) 78 | (bind ((result ((scheme-procedure 'operating-system-open) the-file))) 79 | (cond ((id? result 'file-not-found) 80 | (bind ((condition (make file-name: the-file))) 81 | (handler-case (error condition) 82 | (( 83 | test: (compose (curry id? condition) restart-condition) 84 | condition: restart 85 | description: 86 | (method (stream) 87 | (format stream 88 | "Read a different file instead of ~A" the-file))) 89 | (open (file-name restart)))))) 90 | (else: result)))) 91 | ;;;Value: open 92 | 93 | (handler-bind ( 94 | (method (condition next-handler) 95 | (signal (make 96 | condition: condition 97 | file-name: "/dev/null")))) 98 | (open "file-that-doesnt-exist") 99 | ) 100 | ;;;Value: #[input-port 778 for file: #[pathname 779 "/dev/null"]] 101 | -------------------------------------------------------------------------------- /kits/MIT/src/class-structure.scm: -------------------------------------------------------------------------------- 1 | ../../../src/class-structure.scm -------------------------------------------------------------------------------- /kits/MIT/src/class.scm: -------------------------------------------------------------------------------- 1 | ../../../src/class.scm -------------------------------------------------------------------------------- /kits/MIT/src/common.scm: -------------------------------------------------------------------------------- 1 | ../../../src/common.scm -------------------------------------------------------------------------------- /kits/MIT/src/comp-class.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp-class.scm -------------------------------------------------------------------------------- /kits/MIT/src/comp-exc.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp-exc.scm -------------------------------------------------------------------------------- /kits/MIT/src/comp-method.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp-method.scm -------------------------------------------------------------------------------- /kits/MIT/src/comp-sf.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp-sf.scm -------------------------------------------------------------------------------- /kits/MIT/src/comp-util.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp-util.scm -------------------------------------------------------------------------------- /kits/MIT/src/comp.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp.scm -------------------------------------------------------------------------------- /kits/MIT/src/compiler.scm: -------------------------------------------------------------------------------- 1 | ../../../src/compiler.scm -------------------------------------------------------------------------------- /kits/MIT/src/gambit-specific.scm: -------------------------------------------------------------------------------- 1 | ../../../src/gambit-specific.scm -------------------------------------------------------------------------------- /kits/MIT/src/generic.scm: -------------------------------------------------------------------------------- 1 | ../../../src/generic.scm -------------------------------------------------------------------------------- /kits/MIT/src/implementation-specific: -------------------------------------------------------------------------------- 1 | ../mit-specific.scm -------------------------------------------------------------------------------- /kits/MIT/src/load-compiler.scm: -------------------------------------------------------------------------------- 1 | ../../../src/load-compiler.scm -------------------------------------------------------------------------------- /kits/MIT/src/load-runtime.scm: -------------------------------------------------------------------------------- 1 | ../../../src/load-runtime.scm -------------------------------------------------------------------------------- /kits/MIT/src/load-thomas.scm: -------------------------------------------------------------------------------- 1 | ../../../src/load-thomas.scm -------------------------------------------------------------------------------- /kits/MIT/src/mit-rep.scm: -------------------------------------------------------------------------------- 1 | ../mit-rep.scm -------------------------------------------------------------------------------- /kits/MIT/src/portable-rep.scm: -------------------------------------------------------------------------------- 1 | ../../../src/portable-rep.scm -------------------------------------------------------------------------------- /kits/MIT/src/rep.scm: -------------------------------------------------------------------------------- 1 | ../mit-rep.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-bitstrings.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-bitstrings.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-collections-array.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-array.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-collections-deque.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-deque.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-collections-generic1.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-generic1.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-collections-generic2.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-generic2.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-collections-iterate.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-iterate.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-collections-list.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-list.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-collections-range.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-range.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-collections-string.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-string.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-collections-table.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-table.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-collections-vector.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-vector.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-collections.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-exceptions.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-exceptions.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-functions.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-functions.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-internal.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-internal.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-methods.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-methods.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime-top.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-top.scm -------------------------------------------------------------------------------- /kits/MIT/src/runtime.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime.scm -------------------------------------------------------------------------------- /kits/MIT/src/scc-rep.scm: -------------------------------------------------------------------------------- 1 | ../../../src/scc-rep.scm -------------------------------------------------------------------------------- /kits/MIT/src/scc-specific.scm: -------------------------------------------------------------------------------- 1 | ../../../src/scc-specific.scm -------------------------------------------------------------------------------- /kits/MIT/src/support.scm: -------------------------------------------------------------------------------- 1 | ../../../src/support.scm -------------------------------------------------------------------------------- /kits/MIT/src/thomas.sf: -------------------------------------------------------------------------------- 1 | ../thomas.sf -------------------------------------------------------------------------------- /kits/MIT/thomas.sf: -------------------------------------------------------------------------------- 1 | #| Copyright 1992 Digital Equipment Corporation 2 | All Rights Reserved 3 | 4 | Permission to use, copy, and modify this software and its documentation is 5 | hereby granted only under the following terms and conditions. Both the 6 | above copyright notice and this permission notice must appear in all copies 7 | of the software, derivative works or modified versions, and any portions 8 | thereof, and both notices must appear in supporting documentation. 9 | 10 | Users of this software agree to the terms and conditions set forth herein, 11 | and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | right and license under any changes, enhancements or extensions made to the 13 | core functions of the software, including but not limited to those affording 14 | compatibility with other hardware or software environments, but excluding 15 | applications which incorporate this software. Users further agree to use 16 | their best efforts to return to Digital any such changes, enhancements or 17 | extensions that they make and inform Digital of noteworthy uses of this 18 | software. Correspondence should be provided to Digital at: 19 | 20 | Director, Cambridge Research Lab 21 | Digital Equipment Corp 22 | One Kendall Square, Bldg 700 23 | Cambridge MA 02139 24 | 25 | This software may be distributed (but not offered for sale or transferred 26 | for compensation) to third parties, provided such third parties agree to 27 | abide by the terms and conditions of this notice. 28 | 29 | THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | SOFTWARE. |# 37 | 38 | ; $Id: thomas.sf,v 1.2 1992/09/25 14:15:39 birkholz Exp $ 39 | 40 | ;;;; Syntaxing Thomas source with (declare (usual-integrations)). 41 | 42 | (fluid-let ((sf/default-declarations (cons '(usual-integrations) 43 | sf/default-declarations))) 44 | (sf-directory ".")) -------------------------------------------------------------------------------- /kits/gambit/README: -------------------------------------------------------------------------------- 1 | -*-Indented-Text-*- 2 | 3 | This is the directory for the Gambit implementation of Thomas, a 4 | compiler written at Digital Equipment Corporation's Cambridge Research 5 | Laboratory. Thomas compiles a language compatible with the language 6 | described in the book "Dylan(TM) an object-oriented dynamic language" by 7 | Apple Computer Eastern Research and Technology, April 1992; the file 8 | DIFFERENCES lists the known differences. 9 | 10 | We have made every effort to minimize the differences between Thomas and 11 | Dylan(TM), and to remove bugs, but help from others would be greatly 12 | appreciated. The original development team consisted of: 13 | 14 | Matt Birkholz (Birkholz@crl.dec.com) 15 | Jim Miller (JMiller@crl.dec.com) 16 | Ron Weiss (RWeiss@crl.dec.com) 17 | 18 | In addition, Joel Bartlett (Bartlett@wrl.dec.com), Marc Feeley 19 | (Feeley@iro.umontreal.ca), Guillermo Rozas (Jinx@zurich.ai.mit.edu) and 20 | Ralph Swick (Swick@crl.dec.com) contributed time and energy to the initial 21 | release. 22 | 23 | * * * 24 | 25 | INSTALLATION 26 | 27 | To install this version of Thomas you must already have Gambit 1.8 28 | or later. Gambit can be obtained by anonymous FTP from 29 | trex.iro.umontreal.ca. If you do not have access to FTP, send electronic 30 | mail to Feeley@iro.umontreal.ca to discuss other arrangements. 31 | 32 | The implementation of Thomas is largely in IEEE standard Scheme and resides 33 | in ../src/. Some generic utilities are available as IEEE standard packages 34 | independent of Thomas and reside in ../portable/. A small amount of code 35 | is Gambit-specific and resides in this directory. The src/ subdirectory of 36 | this directory contains symbolic links to all the various pieces needed to 37 | produce a working Thomas in Gambit. 38 | 39 | The rest of these instructions assume you already know how to use Gambit. 40 | 41 | 1) There are three ways to use Thomas: as a compiler, as a runtime 42 | execution environment, or as an interactive environment. Each is 43 | described below. 44 | 45 | a) Compiler: Load the file "load-compiler". This provides two 46 | main procedures: 47 | 48 | (THOMAS . expressions) compiles the Thomas EXPRESSIONS 49 | and puts the resulting Scheme expression into . 50 | 51 | (THOMAS->SCHEME input output) compiles the INPUT file consisting of 52 | Thomas expressions, generating a single Scheme expression into the 53 | OUTPUT file. 54 | 55 | b) Runtime Execution: Load the file "load-runtime". This provides a 56 | Scheme environment into which the output of the Thomas compiler can 57 | be loaded for execution. 58 | 59 | c) Interactive Environment: Load the file "load-thomas". This gives you 60 | two procedures: 61 | 62 | (THOMAS-REP) starts a read-eval-print (REP) loop which works like 63 | an ordinary Gambit REP loop, but uses a Thomas evaluator instead 64 | of a Scheme evaluator. Errors that are not trapped by your Thomas 65 | code will invoke another Gambit (NOT Thomas) REP loop. Exiting from 66 | this REP loop will take you back to the top-level, beyond the simple 67 | Thomas-REP. You must apply thomas-rep to restart the Thomas-REP. 68 | 69 | (EMPTY-THOMAS-ENVIRONMENT!) forgets about previously defined 70 | module variables created by (THOMAS-REP). This is the only way 71 | (short of restarting Scheme) to clean out the Thomas environment if 72 | things become messed up. 73 | 74 | 2) While Thomas can run fully interpreted, it will be considerably faster 75 | if you compile it. The file "compile" is provided to assist you in 76 | doing this. It includes a useful declaration at the beginning of every 77 | file to be compiled, and invokes the compiler with an appropriately 78 | sized heap. Note that we were not able to run all of dylan-examples.dyl 79 | with a compiled Thomas system. (There appears to be a problem at 80 | garbage collection time.) To run the compiled system: 81 | 82 | csh> ~/gsi -- -h10000 -c2000 83 | Gambit (v1.8) 84 | 85 | : (load "load-thomas") 86 | Loading common 87 | Loading support 88 | . 89 | . 90 | . 91 | 92 | Loading rep 93 | 94 | Apply thomas-rep to start a Thomas read-eval-print loop. 95 | "load-thomas.O" 96 | 97 | : (thomas-rep) 98 | 99 | Entering Thomas read-eval-print-loop. 100 | Exit by typing "thomas:done" 101 | 102 | ? (define x 5) 103 | 104 | Value: x 105 | ? (define-method double ((n )) (+ n n)) 106 | 107 | Value: double 108 | ? (define-method double ((s )) (concatenate s s)) 109 | 110 | Value: double 111 | ? (double x) 112 | 113 | Value: 10 114 | ? (double "foo") 115 | 116 | Value: "foofoo" 117 | ? (double '(1 2)) 118 | 119 | *** ERROR -- generic-dispatch -- no applicable methods ... 120 | 121 | 1: ,t 122 | 123 | : (exit) 124 | 125 | * * * 126 | 127 | Language Extensions 128 | 129 | The Gambit Scheme version of Thomas includes three additional predefined 130 | methods: 131 | (PP ) calls the Scheme pretty printer. 132 | (SCHEME-VARIABLE ) returns the value of a Scheme variable 133 | that is visible from the normal user interaction environment. 134 | This can be used to access any Scheme object, but results are 135 | unpredictable unless the object has a type that corresponds to 136 | one of the non-procedural Thomas types. Common types that can 137 | be accessed this way are booleans, symbols, strings, numbers, 138 | the empty list, as well as vectors or lists composed of these. 139 | (SCHEME-PROCEDURE ) also returns the value of a Scheme 140 | variable that is visible from the normal user interaction 141 | environment. It assumes (without checking) that it is 142 | applicable and converts it to a Thomas method. From within 143 | Thomas it will appear to take an arbitrary number of arguments, 144 | but will issue an error if the number supplied doesn't match 145 | the number expected by the Scheme procedure. 146 | 147 | $Id: gambit_README,v 1.3 1992/09/25 16:44:15 birkholz Exp $ 148 | -------------------------------------------------------------------------------- /kits/gambit/compile: -------------------------------------------------------------------------------- 1 | #/bin/csh 2 | # $Id: gambit_compile,v 1.1 1992/09/23 17:24:00 birkholz Exp $ 3 | 4 | foreach p (*.scm) 5 | mv $p temp 6 | echo "(##declare (standard-bindings))" > $p 7 | cat temp >> $p 8 | gsc $p -- -h10000 9 | mv temp $p 10 | end 11 | -------------------------------------------------------------------------------- /kits/gambit/hash.scm: -------------------------------------------------------------------------------- 1 | ; -*-Scheme-*- 2 | ; 3 | ; $Id: gambit_hash.scm,v 1.2 1992/09/23 15:24:00 birkholz Exp $ 4 | ; $MIT-Header: prop1d.scm,v 14.4 89/09/15 17:16:35 GMT jinx Exp $ 5 | ; 6 | ; Copyright (c) 1988, 1989 Massachusetts Institute of Technology 7 | ; 8 | ; This material was developed by the Scheme project at the Massachusetts 9 | ; Institute of Technology, Department of Electrical Engineering and 10 | ; Computer Science. Permission to copy this software, to redistribute 11 | ; it, and to use it for any purpose is granted, subject to the following 12 | ; restrictions and understandings. 13 | ; 14 | ; 1. Any copy made of this software must include this copyright notice 15 | ; in full. 16 | ; 17 | ; 2. Users of this software agree to make their best efforts (a) to 18 | ; return to the MIT Scheme project any improvements or extensions that 19 | ; they make, so that these may be included in future releases; and (b) 20 | ; to inform MIT of noteworthy uses of this software. 21 | ; 22 | ; 3. All materials developed as a consequence of the use of this 23 | ; software shall duly acknowledge such use, in accordance with the usual 24 | ; standards of acknowledging credit in academic research. 25 | ; 26 | ; 4. MIT has made no warrantee or representation that the operation of 27 | ; this software will be error-free, and MIT is under no obligation to 28 | ; provide any services, by way of maintenance, update, or otherwise. 29 | ; 30 | ; 5. In conjunction with products arising from the use of this material, 31 | ; there shall be no use of the name of the Massachusetts Institute of 32 | ; Technology nor of any adaptation thereof in any advertising, 33 | ; promotional, or sales literature without prior written consent from 34 | ; MIT in each case. 35 | 36 | ; This file requires the following non-IEEE primitives: 37 | 38 | ; ##weak-cons, ##weak-car, ##weak-cdr, ##weak-set-cdr! for manipulating 39 | ; "weak-cons cells," whose cdr is normal but whose car turns to #F 40 | ; during a garbage collection if no non-weak references are found to 41 | ; the object in the car. 42 | 43 | ; ##gc-finalize registers a thunk (procedure of no arguments) to be called 44 | ; after each garbage collection is complete and before Scheme resumes 45 | ; running. 46 | 47 | ;;;; One Dimensional Property Tables 48 | 49 | (define (initialize-oned-table-package!) 50 | (set! population-of-oned-tables (make-population))) 51 | 52 | (define population-of-oned-tables #f) 53 | 54 | (define (gc-oned-tables!) 55 | (map-over-population! population-of-oned-tables oned-table/clean!)) 56 | 57 | (define (make-oned-table) 58 | (let ((table (list oned-table-tag))) 59 | (add-to-population! population-of-oned-tables table) 60 | table)) 61 | 62 | (define (oned-table? object) 63 | (and (pair? object) 64 | (eq? (car object) oned-table-tag))) 65 | 66 | (define oned-table-tag 67 | "1D table") 68 | 69 | (define false-key 70 | "false key") 71 | 72 | (define (weak-assq key table) 73 | (let loop ((previous table) (alist (cdr table))) 74 | (and (not (null? alist)) 75 | (let ((entry (car alist)) 76 | (next (cdr alist))) 77 | (let ((key* (##weak-car entry))) 78 | (cond ((not key*) 79 | (set-cdr! previous next) 80 | (loop previous next)) 81 | ((eq? key* key) 82 | entry) 83 | (else 84 | (loop alist next)))))))) 85 | 86 | (define (oned-table/get table key default) 87 | (let ((entry (weak-assq (or key false-key) table))) 88 | (if entry 89 | (##weak-cdr entry) 90 | default))) 91 | 92 | (define (oned-table/lookup table key if-found if-not-found) 93 | (let ((entry (weak-assq (or key false-key) table))) 94 | (if entry 95 | (if-found (##weak-cdr entry)) 96 | (if-not-found)))) 97 | 98 | (define (oned-table/put! table key value) 99 | (let ((key (or key false-key))) 100 | (let ((entry (weak-assq key table))) 101 | (if entry 102 | (##weak-set-cdr! entry value) 103 | (set-cdr! table 104 | (cons (##weak-cons key value) 105 | (cdr table)))) 106 | #f))) 107 | 108 | (define (oned-table/remove! table key) 109 | (let ((key (or key false-key))) 110 | (let loop ((previous table) (alist (cdr table))) 111 | (if (not (null? alist)) 112 | (let ((key* (##weak-car (car alist))) 113 | (next (cdr alist))) 114 | (loop (if (or (not key*) (eq? key* key)) 115 | ;; Might as well clean whole list. 116 | (begin 117 | (set-cdr! previous next) 118 | previous) 119 | alist) 120 | next)))))) 121 | 122 | (define (oned-table/clean! table) 123 | (let loop ((previous table) (alist (cdr table))) 124 | (if (not (null? alist)) 125 | (let ((next (cdr alist))) 126 | (loop (if (##weak-car (car alist)) 127 | alist 128 | (begin 129 | (set-cdr! previous next) 130 | previous)) 131 | next))))) 132 | 133 | (define (oned-table/alist table) 134 | (let loop ((previous table) (alist (cdr table)) (result '())) 135 | (if (null? alist) 136 | result 137 | (let ((entry (car alist)) 138 | (next (cdr alist))) 139 | (let ((key (##weak-car entry))) 140 | (if (not key) 141 | (begin 142 | (set-cdr! previous next) 143 | (loop previous next result)) 144 | (loop alist 145 | next 146 | (cons (cons (and (not (eq? key false-key)) key) 147 | (##weak-cdr entry)) 148 | result)))))))) 149 | 150 | (define (oned-table/for-each proc table) 151 | (let loop ((previous table) (alist (cdr table))) 152 | (if (not (null? alist)) 153 | (let ((entry (car alist)) 154 | (next (cdr alist))) 155 | (let ((key (##weak-car entry))) 156 | (if key 157 | (begin 158 | (proc (and (not (eq? key false-key)) key) 159 | (##weak-cdr entry)) 160 | (loop alist next)) 161 | (begin 162 | (set-cdr! previous next) 163 | (loop previous next)))))))) 164 | 165 | (initialize-oned-table-package!) 166 | 167 | (set! ##gc-finalize ; setup GC finalization for populations and 1d tables 168 | (lambda () 169 | (gc-all-populations!) 170 | (gc-oned-tables!))) 171 | -------------------------------------------------------------------------------- /kits/gambit/poplat.scm: -------------------------------------------------------------------------------- 1 | ; -*-Scheme-*- 2 | ; 3 | ; $Id: gambit_poplat.scm,v 1.1 1992/09/22 20:56:57 birkholz Exp $ 4 | ; 5 | ; Copyright (c) 1988 Massachusetts Institute of Technology 6 | ; 7 | ; This material was developed by the Scheme project at the Massachusetts 8 | ; Institute of Technology, Department of Electrical Engineering and 9 | ; Computer Science. Permission to copy this software, to redistribute 10 | ; it, and to use it for any purpose is granted, subject to the following 11 | ; restrictions and understandings. 12 | ; 13 | ; 1. Any copy made of this software must include this copyright notice 14 | ; in full. 15 | ; 16 | ; 2. Users of this software agree to make their best efforts (a) to 17 | ; return to the MIT Scheme project any improvements or extensions that 18 | ; they make, so that these may be included in future releases; and (b) 19 | ; to inform MIT of noteworthy uses of this software. 20 | ; 21 | ; 3. All materials developed as a consequence of the use of this 22 | ; software shall duly acknowledge such use, in accordance with the usual 23 | ; standards of acknowledging credit in academic research. 24 | ; 25 | ; 4. MIT has made no warrantee or representation that the operation of 26 | ; this software will be error-free, and MIT is under no obligation to 27 | ; provide any services, by way of maintenance, update, or otherwise. 28 | ; 29 | ; 5. In conjunction with products arising from the use of this material, 30 | ; there shall be no use of the name of the Massachusetts Institute of 31 | ; Technology nor of any adaptation thereof in any advertising, 32 | ; promotional, or sales literature without prior written consent from 33 | ; MIT in each case. 34 | 35 | ; This file requires the following non-IEEE primitives: 36 | 37 | ; ##weak-pair?, ##weak-cons, ##weak-car, ##weak-cdr, ##weak-set-cdr! for 38 | ; manipulating "weak-cons cells," whose cdr is normal but whose car 39 | ; turns to #F during a garbage collection if no non-weak references 40 | ; are found to the object in the car. 41 | 42 | ; ##gc-finalization is bound to a procedure (in hash.scm) that calls 43 | ; gc-all-populations! after each garbage collection is complete and before 44 | ; Scheme resumes execution. 45 | 46 | ;;;; Populations 47 | 48 | ;;; A population is a collection of objects. This collection has the 49 | ;;; property that if one of the objects in the collection is reclaimed 50 | ;;; as garbage, then it is no longer an element of the collection. 51 | 52 | (define (initialize-population-package!) 53 | (set! population-of-populations (##weak-cons population-tag '()))) 54 | 55 | (define bogus-false '(BOGUS-FALSE)) 56 | (define population-tag '(POPULATION)) 57 | 58 | (define (canonicalize object) 59 | (if (eq? object #f) bogus-false object)) 60 | 61 | (define (uncanonicalize object) 62 | (if (eq? object bogus-false) #f object)) 63 | 64 | (define (gc-population! population) 65 | (let loop ((l1 population) (l2 (##weak-cdr population))) 66 | (cond ((null? l2) #t) 67 | ((eq? (##weak-car l2) #f) 68 | (##weak-set-cdr! l1 (##weak-cdr l2)) 69 | (loop l1 (##weak-cdr l1))) 70 | (else (loop l2 (##weak-cdr l2)))))) 71 | 72 | (define (gc-all-populations!) 73 | (gc-population! population-of-populations) 74 | (map-over-population! population-of-populations gc-population!)) 75 | 76 | (define population-of-populations #f) 77 | 78 | (define (make-population) 79 | (let ((population (##weak-cons population-tag '()))) 80 | (add-to-population! population-of-populations population) 81 | population)) 82 | 83 | (define (population? object) 84 | (and (##weak-pair? object) 85 | (eq? (##weak-car object) population-tag))) 86 | 87 | (define (add-to-population! population object) 88 | (let ((object (canonicalize object))) 89 | (let loop ((previous population) (this (##weak-cdr population))) 90 | (if (null? this) 91 | (##weak-set-cdr! population 92 | (##weak-cons object (##weak-cdr population))) 93 | (let ((entry (##weak-car this)) 94 | (next (##weak-cdr this))) 95 | (cond ((not entry) 96 | (##weak-set-cdr! previous next) 97 | (loop previous next)) 98 | ((not (eq? object entry)) 99 | (loop this next)))))))) 100 | 101 | (define (remove-from-population! population object) 102 | (let ((object (canonicalize object))) 103 | (let loop ((previous population) (this (##weak-cdr population))) 104 | (if (not (null? this)) 105 | (let ((entry (##weak-car this)) 106 | (next (##weak-cdr this))) 107 | (if (or (not entry) (eq? object entry)) 108 | (begin (##weak-set-cdr! previous next) 109 | (loop previous next)) 110 | (loop this next))))))) 111 | 112 | ;;;; Higher level operations 113 | 114 | (define (map-over-population population procedure) 115 | (let loop ((l1 population) (l2 (##weak-cdr population))) 116 | (cond ((null? l2) '()) 117 | ((eq? (##weak-car l2) #f) 118 | (##weak-set-cdr! l1 (##weak-cdr l2)) 119 | (loop l1 (##weak-cdr l1))) 120 | (else 121 | (cons (procedure (uncanonicalize (##weak-car l2))) 122 | (loop l2 (##weak-cdr l2))))))) 123 | 124 | (define (map-over-population! population procedure) 125 | (let loop ((l1 population) (l2 (##weak-cdr population))) 126 | (cond ((null? l2) #t) 127 | ((eq? (##weak-car l2) #f) 128 | (##weak-set-cdr! l1 (##weak-cdr l2)) 129 | (loop l1 (##weak-cdr l1))) 130 | (else 131 | (procedure (uncanonicalize (##weak-car l2))) 132 | (loop l2 (##weak-cdr l2)))))) 133 | 134 | (define (for-all-inhabitants? population predicate) 135 | (let loop ((l1 population) (l2 (##weak-cdr population))) 136 | (or (null? l2) 137 | (if (eq? (##weak-car l2) #f) 138 | (begin (##weak-set-cdr! l1 (##weak-cdr l2)) 139 | (loop l1 (##weak-cdr l1))) 140 | (and (predicate (uncanonicalize (##weak-car l2))) 141 | (loop l2 (##weak-cdr l2))))))) 142 | 143 | (define (exists-an-inhabitant? population predicate) 144 | (let loop ((l1 population) (l2 (##weak-cdr population))) 145 | (and (not (null? l2)) 146 | (if (eq? (##weak-car l2) #f) 147 | (begin (##weak-set-cdr! l1 (##weak-cdr l2)) 148 | (loop l1 (##weak-cdr l1))) 149 | (or (predicate (uncanonicalize (##weak-car l2))) 150 | (loop l2 (##weak-cdr l2))))))) 151 | 152 | (initialize-population-package!) 153 | -------------------------------------------------------------------------------- /kits/gambit/restart-example.dyl: -------------------------------------------------------------------------------- 1 | ; -*- Scheme -*- 2 | ;* Copyright 1992 Digital Equipment Corporation 3 | ;* All Rights Reserved 4 | ;* 5 | ;* Permission to use, copy, and modify this software and its documentation is 6 | ;* hereby granted only under the following terms and conditions. Both the 7 | ;* above copyright notice and this permission notice must appear in all copies 8 | ;* of the software, derivative works or modified versions, and any portions 9 | ;* thereof, and both notices must appear in supporting documentation. 10 | ;* 11 | ;* Users of this software agree to the terms and conditions set forth herein, 12 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 13 | ;* right and license under any changes, enhancements or extensions made to the 14 | ;* core functions of the software, including but not limited to those affording 15 | ;* compatibility with other hardware or software environments, but excluding 16 | ;* applications which incorporate this software. Users further agree to use 17 | ;* their best efforts to return to Digital any such changes, enhancements or 18 | ;* extensions that they make and inform Digital of noteworthy uses of this 19 | ;* software. Correspondence should be provided to Digital at: 20 | ;* 21 | ;* Director, Cambridge Research Lab 22 | ;* Digital Equipment Corp 23 | ;* One Kendall Square, Bldg 700 24 | ;* Cambridge MA 02139 25 | ;* 26 | ;* This software may be distributed (but not offered for sale or transferred 27 | ;* for compensation) to third parties, provided such third parties agree to 28 | ;* abide by the terms and conditions of this notice. 29 | ;* 30 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 31 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 32 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 33 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 34 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 35 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 36 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 37 | ;* SOFTWARE. 38 | 39 | ; $Id: gambit_restart-example.dyl,v 1.1 1992/09/22 20:57:38 birkholz Exp $ 40 | 41 | ;;;; Example from pages 144-6. (Punted initial example code.) 42 | ;;;; Many changes were necessary. So many, that they aren't noted here. 43 | 44 | ;;; Classes such as used in these examples are 45 | ;;; invented for the example and are not part of the specification 46 | ;;; This example shows minimal handling of a file-not-found error 47 | 48 | ;;; This is the same example improved so the restart handler that 49 | ;;; reads another file can only be reached by a handler for the 50 | ;;; associated condition, useful if there are nested errors. 51 | 52 | (define (operating-system-open filename) 53 | (or (##open-input-file filename) 'file-not-found)) 54 | ;;;Value: operating-system-open 55 | 56 | (define-class () 57 | (file-name init-keyword: file-name:)) 58 | ;;;Value: 59 | 60 | (define-class () 61 | (condition init-keyword: condition: 62 | getter: restart-condition) 63 | (file-name init-keyword: file-name:)) 64 | ;;;Value: 65 | 66 | (define-method open (the-file) 67 | (bind ((result ((scheme-procedure 'operating-system-open) the-file))) 68 | (cond ((id? result 'file-not-found) 69 | (bind ((condition (make file-name: the-file))) 70 | (handler-case (error condition) 71 | (( 72 | test: (compose (curry id? condition) restart-condition) 73 | condition: restart 74 | description: 75 | (method (stream) 76 | (format stream 77 | "Read a different file instead of ~A" the-file))) 78 | (open (file-name restart)))))) 79 | (else: result)))) 80 | ;;;Value: open 81 | 82 | (handler-bind ( 83 | (method (condition next-handler) 84 | (signal (make 85 | condition: condition 86 | file-name: "/dev/null")))) 87 | (open "file-that-doesnt-exist") 88 | ) 89 | ;;;Value: #[input-port "/dev/null"] 90 | -------------------------------------------------------------------------------- /kits/gambit/src/class-structure.scm: -------------------------------------------------------------------------------- 1 | ../../../src/class-structure.scm -------------------------------------------------------------------------------- /kits/gambit/src/class.scm: -------------------------------------------------------------------------------- 1 | ../../../src/class.scm -------------------------------------------------------------------------------- /kits/gambit/src/common.scm: -------------------------------------------------------------------------------- 1 | ../../../src/common.scm -------------------------------------------------------------------------------- /kits/gambit/src/comp-class.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp-class.scm -------------------------------------------------------------------------------- /kits/gambit/src/comp-exc.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp-exc.scm -------------------------------------------------------------------------------- /kits/gambit/src/comp-method.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp-method.scm -------------------------------------------------------------------------------- /kits/gambit/src/comp-sf.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp-sf.scm -------------------------------------------------------------------------------- /kits/gambit/src/comp-util.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp-util.scm -------------------------------------------------------------------------------- /kits/gambit/src/comp.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp.scm -------------------------------------------------------------------------------- /kits/gambit/src/compiler.scm: -------------------------------------------------------------------------------- 1 | ../../../src/compiler.scm -------------------------------------------------------------------------------- /kits/gambit/src/dynwnd.scm: -------------------------------------------------------------------------------- 1 | ../../../portable/dynwnd.sc -------------------------------------------------------------------------------- /kits/gambit/src/generic.scm: -------------------------------------------------------------------------------- 1 | ../../../src/generic.scm -------------------------------------------------------------------------------- /kits/gambit/src/hash.scm: -------------------------------------------------------------------------------- 1 | ../hash.scm -------------------------------------------------------------------------------- /kits/gambit/src/implementation-specific: -------------------------------------------------------------------------------- 1 | ../gambit-specific.scm -------------------------------------------------------------------------------- /kits/gambit/src/implementation-specific.scm: -------------------------------------------------------------------------------- 1 | ../gambit-specific.scm -------------------------------------------------------------------------------- /kits/gambit/src/load-compiler.scm: -------------------------------------------------------------------------------- 1 | ../../../src/load-compiler.scm -------------------------------------------------------------------------------- /kits/gambit/src/load-runtime.scm: -------------------------------------------------------------------------------- 1 | ../../../src/load-runtime.scm -------------------------------------------------------------------------------- /kits/gambit/src/load-thomas.scm: -------------------------------------------------------------------------------- 1 | ../../../src/load-thomas.scm -------------------------------------------------------------------------------- /kits/gambit/src/mit-rep.scm: -------------------------------------------------------------------------------- 1 | ../../../src/mit-rep.scm -------------------------------------------------------------------------------- /kits/gambit/src/mit-specific.scm: -------------------------------------------------------------------------------- 1 | ../../../src/mit-specific.scm -------------------------------------------------------------------------------- /kits/gambit/src/msort.scm: -------------------------------------------------------------------------------- 1 | ../../../portable/msort.sc -------------------------------------------------------------------------------- /kits/gambit/src/poplat.scm: -------------------------------------------------------------------------------- 1 | ../poplat.scm -------------------------------------------------------------------------------- /kits/gambit/src/portable-rep.scm: -------------------------------------------------------------------------------- 1 | ../../../src/portable-rep.scm -------------------------------------------------------------------------------- /kits/gambit/src/record.scm: -------------------------------------------------------------------------------- 1 | ../record.scm -------------------------------------------------------------------------------- /kits/gambit/src/rep.scm: -------------------------------------------------------------------------------- 1 | portable-rep.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-bitstrings.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-bitstrings.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-collections-array.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-array.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-collections-deque.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-deque.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-collections-generic1.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-generic1.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-collections-generic2.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-generic2.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-collections-iterate.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-iterate.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-collections-list.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-list.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-collections-range.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-range.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-collections-string.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-string.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-collections-table.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-table.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-collections-vector.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-vector.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-collections.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-exceptions.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-exceptions.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-functions.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-functions.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-internal.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-internal.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-methods.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-methods.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime-top.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-top.scm -------------------------------------------------------------------------------- /kits/gambit/src/runtime.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime.scm -------------------------------------------------------------------------------- /kits/gambit/src/scc-rep.scm: -------------------------------------------------------------------------------- 1 | ../../../src/scc-rep.scm -------------------------------------------------------------------------------- /kits/gambit/src/scc-specific.scm: -------------------------------------------------------------------------------- 1 | ../../../src/scc-specific.scm -------------------------------------------------------------------------------- /kits/gambit/src/support.scm: -------------------------------------------------------------------------------- 1 | ../../../src/support.scm -------------------------------------------------------------------------------- /kits/scc/DECstation.o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pablomarx/Thomas/c8ab3f6fa92a9a39667fe37dfe060b651affb18e/kits/scc/DECstation.o -------------------------------------------------------------------------------- /kits/scc/aftergc.sc: -------------------------------------------------------------------------------- 1 | ;;; Scheme->C 2 | ;;; 3 | ;;; An orderly extension to AFTER-COLLECT to allow a number of modules to 4 | ;;; add and delete a cleanup procedure. 5 | ; $Id: scc_aftergc.sc,v 1.2 1992/09/23 15:11:22 birkholz Exp $ 6 | 7 | (module aftergc (top-level after-gc)) 8 | 9 | (define TAG-CLEANUPS '()) ;;; A-list of tags and clean-up procedures. 10 | 11 | (set! after-collect 12 | (lambda ignore 13 | (for-each (lambda (tag-cleanup) ((cdr tag-cleanup))) 14 | tag-cleanups))) 15 | 16 | (define (AFTER-GC tag cleanup) 17 | (let ((x (assoc tag tag-cleanups))) 18 | (if x (set! tag-cleanups (remq! x tag-cleanups))) 19 | (if tag (set! tag-cleanups (cons (cons tag cleanup) tag-cleanups))) 20 | tag)) 21 | -------------------------------------------------------------------------------- /kits/scc/callcc.c: -------------------------------------------------------------------------------- 1 | /* SCHEME->C */ 2 | 3 | /* Copyright 1989 Digital Equipment Corporation 4 | * All Rights Reserved 5 | * 6 | * Permission to use, copy, and modify this software and its documentation is 7 | * hereby granted only under the following terms and conditions. Both the 8 | * above copyright notice and this permission notice must appear in all copies 9 | * of the software, derivative works or modified versions, and any portions 10 | * thereof, and both notices must appear in supporting documentation. 11 | * 12 | * Users of this software agree to the terms and conditions set forth herein, 13 | * and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 14 | * right and license under any changes, enhancements or extensions made to the 15 | * core functions of the software, including but not limited to those affording 16 | * compatibility with other hardware or software environments, but excluding 17 | * applications which incorporate this software. Users further agree to use 18 | * their best efforts to return to Digital any such changes, enhancements or 19 | * extensions that they make and inform Digital of noteworthy uses of this 20 | * software. Correspondence should be provided to Digital at: 21 | * 22 | * Director of Licensing 23 | * Western Research Laboratory 24 | * Digital Equipment Corporation 25 | * 250 University Avenue 26 | * Palo Alto, California 94301 27 | * 28 | * This software may be distributed (but not offered for sale or transferred 29 | * for compensation) to third parties, provided such third parties agree to 30 | * abide by the terms and conditions of this notice. 31 | * 32 | * THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 33 | * WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 34 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 35 | * CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 36 | * DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 37 | * PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 38 | * ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 39 | * SOFTWARE. 40 | */ 41 | 42 | /* The following procedures implement CALL-WITH-CURRENT-CONTINUATION. 43 | CALLCCCONTINUING is the function that is executed when a continuation is 44 | applied. It is called with the result to be returned and the procedure's 45 | closure which is the continuation created by the initial call to 46 | TSC_CALLWITHCURRENTCONTINUATION. It will unwind the stack until the right 47 | return point is found. If it is not found, then it will restore the stack 48 | from the continuation(s). Once the stack is known to have the right 49 | contents, it will restore the correct state with longjmp. 50 | */ 51 | 52 | /* External declarations */ 53 | 54 | #include "objects.h" 55 | #include "scinit.h" 56 | #include "heap.h" 57 | #include "callcc.h" 58 | #include "apply.h" 59 | #include "signal.h" 60 | #ifdef MIPS 61 | extern sc_setsp(); 62 | #endif 63 | 64 | #ifdef VAX 65 | #define longjmp( x, y ) sc_longjmp( x, y ) 66 | #define setjmp( x ) sc_setjmp( x ) 67 | #endif 68 | 69 | extern TSCP dynwind_new_2dcall_2fcc(); 70 | 71 | TSCP sc_clink; /* Pointer to inner most continuation on stack. */ 72 | 73 | /* Static declarations for data structures internal to the module. These 74 | variables may be static as they are only used under MUTEX. */ 75 | 76 | static TSCP callccresult, /* Passes result across longjmp. */ 77 | callcccp; /* Preserves cp during stack rebuilding. */ 78 | 79 | static int *fp, /* Temps for constructing continuation */ 80 | *tp, 81 | *tos, 82 | rcount, 83 | count; 84 | 85 | static callcccontinuing( result, cp ) 86 | TSCP result, cp; 87 | { 88 | MUTEXON; 89 | callccresult = result; 90 | callcccp = cp; 91 | /* Unwind CLINK to see if this continuation is currently on the 92 | stack. */ 93 | while (sc_clink != EMPTYLIST) { 94 | if (sc_clink == cp) 95 | longjmp( (T_U(cp))->continuation.savedstate, 1 ); 96 | sc_clink = (T_U(sc_clink))->continuation.continuation; 97 | } 98 | /* Continuation is not currently on the stack, so transfer to it and 99 | it will restore the stack. */ 100 | #ifdef MIPS 101 | sc_setsp( (T_U(callcccp))->continuation.address ); 102 | #endif 103 | longjmp( (T_U(callcccp))->continuation.savedstate, 1 ); 104 | } 105 | 106 | /* Use the call-with-current-continuation provided by dynamic-wind. Make the 107 | old call-with-current-continuation available for use from dynamic-wind. 108 | */ 109 | 110 | TSCP sc_ntinuation_1af38b9f_v; 111 | 112 | TSCP sc_ntinuation_1af38b9f( function ) 113 | TSCP function; 114 | { 115 | return( dynwind_new_2dcall_2fcc( function ) ); 116 | } 117 | 118 | TSCP sc_old_2dcall_2fcc( function ) 119 | TSCP function; 120 | { 121 | SCP cp; /* Pointer to the continuation */ 122 | int *save_fp, /* Save static values across heap allocate */ 123 | save_count; 124 | 125 | MUTEXON; 126 | if (sc_clink == EMPTYLIST) 127 | fp = sc_stackbase; 128 | else 129 | fp = (T_U(sc_clink))->continuation.address; 130 | count = ((unsigned)(fp)-(unsigned)(STACKPTR))/4; 131 | save_fp = fp; 132 | save_count = count; 133 | cp = sc_allocateheap( NULLCONTINUATIONSIZE+count+2+sc_maxdisplay, 134 | CONTINUATIONTAG, 135 | NULLCONTINUATIONSIZE+count+sc_maxdisplay ); 136 | fp = save_fp; 137 | count = save_count; 138 | tos = STACKPTR; 139 | cp->continuation.continuation = sc_clink; 140 | cp->continuation.stacktrace = sc_stacktrace; 141 | sc_clink = U_TX( cp ); 142 | cp->continuation.address = tos; 143 | tp = &cp->continuation.word0; 144 | rcount = sc_maxdisplay; 145 | while (rcount--) *tp++ = (int)sc_display[ rcount ]; 146 | while (count--) *tp++ = *tos++; 147 | MUTEXOFF; 148 | if (setjmp( cp->continuation.savedstate ) == 0) { 149 | callccresult = sc_apply_2dtwo( function, 150 | sc_cons( sc_makeprocedure( 1, 0, 151 | callcccontinuing, 152 | U_TX( cp ) ), 153 | EMPTYLIST ) ); 154 | sc_clink = T_U( sc_clink )->continuation.continuation; 155 | return( callccresult ); 156 | } 157 | /* Return here when the continuation is invoked. */ 158 | if (sc_clink == EMPTYLIST) { 159 | sc_clink = callcccp; 160 | while (sc_clink != EMPTYLIST) { 161 | tp = (T_U(sc_clink))->continuation.address; 162 | fp = &(T_U(sc_clink))->continuation.word0+sc_maxdisplay; 163 | count = (T_U(sc_clink))->continuation.length-sc_maxdisplay- 164 | NULLCONTINUATIONSIZE; 165 | while (count--) *tp++ = *fp++; 166 | sc_clink = (T_U(sc_clink))->continuation.continuation; 167 | } 168 | } 169 | tp = &T_U( callcccp )->continuation.word0; 170 | rcount = sc_maxdisplay; 171 | while (rcount--) sc_display[ rcount ] = (TSCP)(*tp++); 172 | sc_clink = T_U( callcccp )->continuation.continuation; 173 | sc_stacktrace = T_U( callcccp )->continuation.stacktrace; 174 | /* Move result onto the stack under mutex */ 175 | function = callccresult; 176 | MUTEXOFF; 177 | return( function ); 178 | } 179 | 180 | -------------------------------------------------------------------------------- /kits/scc/dynwind.sc: -------------------------------------------------------------------------------- 1 | ; "dynwind.scm", wind-unwind-protect for Scheme 2 | ; Copyright (c) 1992, Aubrey Jaffer 3 | ; Modified for Scheme->C by Joel Bartlett 4 | ; $Id: scc_dynwind.sc,v 1.2 1992/09/23 15:12:31 birkholz Exp $ 5 | 6 | ;This facility is a generalization of Common Lisp `unwind-protect', 7 | ;designed to take into account the fact that continuations produced by 8 | ;CALL-WITH-CURRENT-CONTINUATION may be reentered. 9 | 10 | ; (dynamic-wind ) procedure 11 | 12 | ;The arguments , , and must all be procedures 13 | ;of no arguments (thunks). 14 | 15 | ;DYNAMIC-WIND calls , , and then . The value 16 | ;returned of is returned as the result of DYNAMIC-WIND. 17 | ; is also called just before calls any continuations 18 | ;created by CALL-WITH-CURRENT-CONTINUATION. If captures its 19 | ;continuation as an escape procedure, is invoked just before 20 | ;continuing that continuation. 21 | 22 | (module dynwind (top-level dynamic-wind)) 23 | 24 | (define-external (old-call/cc proc) sc) 25 | 26 | (define *winds* '()) 27 | 28 | (define (dynamic-wind ) 29 | () 30 | (set! *winds* (cons (cons ) *winds*)) 31 | (let ((ans ())) 32 | (set! *winds* (cdr *winds*)) 33 | () 34 | ans)) 35 | 36 | (define (new-call/cc proc) 37 | (let ((winds *winds*)) 38 | (old-call/cc 39 | (lambda (cont) 40 | (proc (lambda (c2) 41 | (dynamic:do-winds *winds* winds) 42 | (cont c2))))))) 43 | 44 | (define (dynamic:do-winds from to) 45 | (set! *winds* from) 46 | (cond ((eq? from to)) 47 | ((null? from) 48 | (dynamic:do-winds from (cdr to)) 49 | ((caar to))) 50 | ((null? to) 51 | ((cdar from)) 52 | (dynamic:do-winds (cdr from) to)) 53 | (else 54 | ((cdar from)) 55 | (dynamic:do-winds (cdr from) (cdr to)) 56 | ((caar to)))) 57 | (set! *winds* to)) 58 | -------------------------------------------------------------------------------- /kits/scc/hash.sc: -------------------------------------------------------------------------------- 1 | ; -*-Scheme-*- 2 | ; 3 | ; $Id: scc_hash.sc,v 1.2 1992/09/23 15:22:43 birkholz Exp $ 4 | ; $MIT-Header: prop1d.scm,v 14.4 89/09/15 17:16:35 GMT jinx Exp $ 5 | ; 6 | ; Copyright (c) 1988, 1989 Massachusetts Institute of Technology 7 | ; 8 | ; This material was developed by the Scheme project at the Massachusetts 9 | ; Institute of Technology, Department of Electrical Engineering and 10 | ; Computer Science. Permission to copy this software, to redistribute 11 | ; it, and to use it for any purpose is granted, subject to the following 12 | ; restrictions and understandings. 13 | ; 14 | ; 1. Any copy made of this software must include this copyright notice 15 | ; in full. 16 | ; 17 | ; 2. Users of this software agree to make their best efforts (a) to 18 | ; return to the MIT Scheme project any improvements or extensions that 19 | ; they make, so that these may be included in future releases; and (b) 20 | ; to inform MIT of noteworthy uses of this software. 21 | ; 22 | ; 3. All materials developed as a consequence of the use of this 23 | ; software shall duly acknowledge such use, in accordance with the usual 24 | ; standards of acknowledging credit in academic research. 25 | ; 26 | ; 4. MIT has made no warrantee or representation that the operation of 27 | ; this software will be error-free, and MIT is under no obligation to 28 | ; provide any services, by way of maintenance, update, or otherwise. 29 | ; 30 | ; 5. In conjunction with products arising from the use of this material, 31 | ; there shall be no use of the name of the Massachusetts Institute of 32 | ; Technology nor of any adaptation thereof in any advertising, 33 | ; promotional, or sales literature without prior written consent from 34 | ; MIT in each case. 35 | 36 | ; This file requires the following non-IEEE primitives: 37 | 38 | ; weak-cons, weak-car, weak-cdr, set-weak-cdr! for manipulating 39 | ; "weak-cons cells," whose cdr is normal but whose car turns to #F 40 | ; during a garbage collection if no non-weak references are found to 41 | ; the object in the car. 42 | 43 | ; after-gc registers a thunk (procedure of no arguments) to be called 44 | ; after each garbage collection is complete and before Scheme resumes 45 | ; running. 46 | 47 | ;;;; One Dimensional Property Tables 48 | 49 | (define (initialize-oned-table-package!) 50 | (set! population-of-oned-tables (make-population)) 51 | (after-gc 'oned-table gc-oned-tables!)) 52 | 53 | (define population-of-oned-tables #f) 54 | 55 | (define (gc-oned-tables!) 56 | (map-over-population! population-of-oned-tables oned-table/clean!)) 57 | 58 | (define (make-oned-table) 59 | (let ((table (list oned-table-tag))) 60 | (add-to-population! population-of-oned-tables table) 61 | table)) 62 | 63 | (define (oned-table? object) 64 | (and (pair? object) 65 | (eq? (car object) oned-table-tag))) 66 | 67 | (define oned-table-tag 68 | "1D table") 69 | 70 | (define false-key 71 | "false key") 72 | 73 | (define (weak-assq key table) 74 | (let loop ((previous table) (alist (cdr table))) 75 | (and (not (null? alist)) 76 | (let ((entry (car alist)) 77 | (next (cdr alist))) 78 | (let ((key* (car entry))) 79 | (cond ((not key*) 80 | (set-cdr! previous next) 81 | (loop previous next)) 82 | ((eq? key* key) 83 | entry) 84 | (else 85 | (loop alist next)))))))) 86 | 87 | (define (oned-table/get table key default) 88 | (let ((entry (weak-assq (or key false-key) table))) 89 | (if entry 90 | (cdr entry) 91 | default))) 92 | 93 | (define (oned-table/lookup table key if-found if-not-found) 94 | (let ((entry (weak-assq (or key false-key) table))) 95 | (if entry 96 | (if-found (cdr entry)) 97 | (if-not-found)))) 98 | 99 | (define (oned-table/put! table key value) 100 | (let ((key (or key false-key))) 101 | (let ((entry (weak-assq key table))) 102 | (if entry 103 | (set-cdr! entry value) 104 | (set-cdr! table 105 | (cons (weak-cons key value) 106 | (cdr table)))) 107 | #f))) 108 | 109 | (define (oned-table/remove! table key) 110 | (let ((key (or key false-key))) 111 | (let loop ((previous table) (alist (cdr table))) 112 | (if (not (null? alist)) 113 | (let ((key* (car (car alist))) 114 | (next (cdr alist))) 115 | (loop (if (or (not key*) (eq? key* key)) 116 | ;; Might as well clean whole list. 117 | (begin 118 | (set-cdr! previous next) 119 | previous) 120 | alist) 121 | next)))))) 122 | 123 | (define (oned-table/clean! table) 124 | (let loop ((previous table) (alist (cdr table))) 125 | (if (not (null? alist)) 126 | (let ((next (cdr alist))) 127 | (loop (if (car (car alist)) 128 | alist 129 | (begin 130 | (set-cdr! previous next) 131 | previous)) 132 | next))))) 133 | 134 | (define (oned-table/alist table) 135 | (let loop ((previous table) (alist (cdr table)) (result '())) 136 | (if (null? alist) 137 | result 138 | (let ((entry (car alist)) 139 | (next (cdr alist))) 140 | (let ((key (car entry))) 141 | (if (not key) 142 | (begin 143 | (set-cdr! previous next) 144 | (loop previous next result)) 145 | (loop alist 146 | next 147 | (cons (cons (and (not (eq? key false-key)) key) 148 | (cdr entry)) 149 | result)))))))) 150 | 151 | (define (oned-table/for-each proc table) 152 | (let loop ((previous table) (alist (cdr table))) 153 | (if (not (null? alist)) 154 | (let ((entry (car alist)) 155 | (next (cdr alist))) 156 | (let ((key (car entry))) 157 | (if key 158 | (begin 159 | (proc (and (not (eq? key false-key)) key) 160 | (cdr entry)) 161 | (loop alist next)) 162 | (begin 163 | (set-cdr! previous next) 164 | (loop previous next)))))))) 165 | 166 | (initialize-oned-table-package!) 167 | -------------------------------------------------------------------------------- /kits/scc/implementation-specific: -------------------------------------------------------------------------------- 1 | ; $Id: scc_implementation-specific,v 1.1 1992/09/23 15:15:06 birkholz Exp $ 2 | 3 | ;;; The implementation specific procedures are already a part of sci. 4 | -------------------------------------------------------------------------------- /kits/scc/main.sc: -------------------------------------------------------------------------------- 1 | ;;; Main program for extensions to 01nob91jfb Scheme->C 2 | ; $Id: scc_main.sc,v 1.2 1992/09/23 15:15:50 birkholz Exp $ 3 | 4 | (module main (main main) (with aftergc mit sccspecific)) 5 | 6 | (define (MAIN clargs) 7 | (set-write-circle! #t stdout-port) 8 | (set-write-length! 20 stdout-port) 9 | (set-write-level! 5 stdout-port) 10 | (set-write-circle! #t stderr-port) 11 | (set-write-length! 20 stderr-port) 12 | (set-write-level! 5 stderr-port) 13 | (read-eval-print)) 14 | -------------------------------------------------------------------------------- /kits/scc/makefile: -------------------------------------------------------------------------------- 1 | # This file compiles the extensions to the 01nov91jfb release of Scheme->C. 2 | # $Id: scc_makefile,v 1.4 1992/09/23 17:58:00 birkholz Exp $ 3 | 4 | # Defaults: 5 | 6 | .SUFFIXES: 7 | .SUFFIXES: .sc .c .o 8 | 9 | # Directory containing the source for the 01nov91jfb release of Scheme->C: 10 | 11 | SCRTDIR = /crl/src/schemetoc/src 12 | 13 | # Currently installed 01nov91jfb Scheme->C compiler: 14 | 15 | SCC = /usr/local/bin/scc 16 | 17 | # Currently installed 01nov91jfb Scheme->C compiler library: 18 | 19 | SCCLIB = /usr/local/lib/schemetoc/libsc.a 20 | 21 | CFLAGS = -O -I${SCRTDIR}/scrt 22 | SCFLAGS = 23 | 24 | OBJS = aftergc.o callcc.o dynwind.o heap.o main.o mit.o scinit.o scc-specific.o 25 | 26 | .c.o: 27 | ${CC} -c ${CFLAGS} -D${cpu} -I. $*.c 28 | 29 | .sc.o: 30 | ${SCC} -c ${SCFLAGS} ${CFLAGS} $*.sc 31 | 32 | mit.sc: poplat.sc hash.sc record.sc msort.sc 33 | 34 | release: 35 | make noprogs DECstation.o scc.tar.Z 36 | 37 | sci: ${OBJS} 38 | ${SCC} -o sci ${SCFLAGS} ${CFLAGS} ${OBJS} 39 | 40 | DECstation.o: ${OBJS} main.o 41 | ld -r -o DECstation.o ${OBJS} ${SCCLIB} 42 | 43 | sci-for-DECstation: 44 | cc -o sci DECstation.o -lm 45 | 46 | scc.tar.Z: ${OBJS} DECstation.o 47 | rm -f scc.tar.Z 48 | tar -cf scc.tar DECstation.o README aftergc.sc callcc.c \ 49 | dynwind.sc hash.sc heap.c heap.h implementation-specific \ 50 | main.sc makefile mit.sc msort.sc poplat.sc record.sc \ 51 | scc-rep.scm scc-specific.sc scinit.c 52 | compress scc.tar 53 | 54 | clean: 55 | rm -f *.o 56 | 57 | noprogs: 58 | rm -f sci 59 | -------------------------------------------------------------------------------- /kits/scc/mit.sc: -------------------------------------------------------------------------------- 1 | ;;; Additions from MIT C-Scheme. 2 | ; $Id: scc_mit.sc,v 1.3 1992/09/23 15:06:35 birkholz Exp $ 3 | 4 | (module mit) 5 | 6 | (define-external AFTER-GC top-level) 7 | 8 | (define-external (WEAK-CONS x y) sc) 9 | 10 | (include "poplat.sc") 11 | (include "hash.sc") 12 | (include "record.sc") 13 | (include "msort.sc") 14 | -------------------------------------------------------------------------------- /kits/scc/msort.sc: -------------------------------------------------------------------------------- 1 | ../../portable/msort.scm -------------------------------------------------------------------------------- /kits/scc/poplat.sc: -------------------------------------------------------------------------------- 1 | ; -*-Scheme-*- 2 | ; 3 | ; $Id: scc_poplat.sc,v 1.2 1992/09/23 15:29:08 birkholz Exp $ 4 | ; $MIT-Header: poplat.scm,v 14.2 88/06/13 11:49:48 GMT cph Rel $ 5 | ; 6 | ; Copyright (c) 1988 Massachusetts Institute of Technology 7 | ; 8 | ; This material was developed by the Scheme project at the Massachusetts 9 | ; Institute of Technology, Department of Electrical Engineering and 10 | ; Computer Science. Permission to copy this software, to redistribute 11 | ; it, and to use it for any purpose is granted, subject to the following 12 | ; restrictions and understandings. 13 | ; 14 | ; 1. Any copy made of this software must include this copyright notice 15 | ; in full. 16 | ; 17 | ; 2. Users of this software agree to make their best efforts (a) to 18 | ; return to the MIT Scheme project any improvements or extensions that 19 | ; they make, so that these may be included in future releases; and (b) 20 | ; to inform MIT of noteworthy uses of this software. 21 | ; 22 | ; 3. All materials developed as a consequence of the use of this 23 | ; software shall duly acknowledge such use, in accordance with the usual 24 | ; standards of acknowledging credit in academic research. 25 | ; 26 | ; 4. MIT has made no warrantee or representation that the operation of 27 | ; this software will be error-free, and MIT is under no obligation to 28 | ; provide any services, by way of maintenance, update, or otherwise. 29 | ; 30 | ; 5. In conjunction with products arising from the use of this material, 31 | ; there shall be no use of the name of the Massachusetts Institute of 32 | ; Technology nor of any adaptation thereof in any advertising, 33 | ; promotional, or sales literature without prior written consent from 34 | ; MIT in each case. 35 | 36 | ; This file requires the following non-IEEE primitives: 37 | 38 | ; weak-pair?, weak-cons, weak-car, weak-cdr, set-weak-cdr! for 39 | ; manipulating "weak-cons cells," whose cdr is normal but whose car 40 | ; turns to #F during a garbage collection if no non-weak references 41 | ; are found to the object in the car. 42 | 43 | ; after-gc registers a thunk (procedure of no arguments) to be called 44 | ; after each garbage collection is complete and before Scheme resumes 45 | ; execution. 46 | 47 | ;;;; Populations 48 | 49 | ;;; A population is a collection of objects. This collection has the 50 | ;;; property that if one of the objects in the collection is reclaimed 51 | ;;; as garbage, then it is no longer an element of the collection. 52 | 53 | (define (initialize-population-package!) 54 | (set! population-of-populations (weak-cons population-tag '())) 55 | (after-gc 'population gc-all-populations!)) 56 | 57 | (define bogus-false '(BOGUS-FALSE)) 58 | (define population-tag '(POPULATION)) 59 | 60 | (define-in-line (canonicalize object) 61 | (if (eq? object #f) bogus-false object)) 62 | 63 | (define-in-line (uncanonicalize object) 64 | (if (eq? object bogus-false) #f object)) 65 | 66 | (define (gc-population! population) 67 | (let loop ((l1 population) (l2 (cdr population))) 68 | (cond ((null? l2) #t) 69 | ((eq? (car l2) #f) 70 | (set-cdr! l1 (cdr l2)) 71 | (loop l1 (cdr l1))) 72 | (else (loop l2 (cdr l2)))))) 73 | 74 | (define (gc-all-populations!) 75 | (gc-population! population-of-populations) 76 | (map-over-population! population-of-populations gc-population!)) 77 | 78 | (define population-of-populations #f) 79 | 80 | (define (make-population) 81 | (let ((population (weak-cons population-tag '()))) 82 | (add-to-population! population-of-populations population) 83 | population)) 84 | 85 | (define (population? object) 86 | (and (pair? object) 87 | (eq? (car object) population-tag))) 88 | 89 | (define (add-to-population! population object) 90 | (let ((object (canonicalize object))) 91 | (let loop ((previous population) (this (cdr population))) 92 | (if (null? this) 93 | (set-cdr! population (weak-cons object (cdr population))) 94 | (let ((entry (car this)) 95 | (next (cdr this))) 96 | (cond ((not entry) 97 | (set-cdr! previous next) 98 | (loop previous next)) 99 | ((not (eq? object entry)) 100 | (loop this next)))))))) 101 | 102 | (define (remove-from-population! population object) 103 | (let ((object (canonicalize object))) 104 | (let loop ((previous population) (this (cdr population))) 105 | (if (not (null? this)) 106 | (let ((entry (car this)) 107 | (next (cdr this))) 108 | (if (or (not entry) (eq? object entry)) 109 | (begin (set-cdr! previous next) 110 | (loop previous next)) 111 | (loop this next))))))) 112 | 113 | ;;;; Higher level operations 114 | 115 | (define (map-over-population population procedure) 116 | (let loop ((l1 population) (l2 (cdr population))) 117 | (cond ((null? l2) '()) 118 | ((eq? (car l2) #f) 119 | (set-cdr! l1 (cdr l2)) 120 | (loop l1 (cdr l1))) 121 | (else 122 | (cons (procedure (uncanonicalize (car l2))) 123 | (loop l2 (cdr l2))))))) 124 | 125 | (define (map-over-population! population procedure) 126 | (let loop ((l1 population) (l2 (cdr population))) 127 | (cond ((null? l2) #t) 128 | ((eq? (car l2) #f) 129 | (set-cdr! l1 (cdr l2)) 130 | (loop l1 (cdr l1))) 131 | (else 132 | (procedure (uncanonicalize (car l2))) 133 | (loop l2 (cdr l2)))))) 134 | 135 | (define (for-all-inhabitants? population predicate) 136 | (let loop ((l1 population) (l2 (cdr population))) 137 | (or (null? l2) 138 | (if (eq? (car l2) #f) 139 | (begin (set-cdr! l1 (cdr l2)) 140 | (loop l1 (cdr l1))) 141 | (and (predicate (uncanonicalize (car l2))) 142 | (loop l2 (cdr l2))))))) 143 | 144 | (define (exists-an-inhabitant? population predicate) 145 | (let loop ((l1 population) (l2 (cdr population))) 146 | (and (not (null? l2)) 147 | (if (eq? (car l2) #f) 148 | (begin (set-cdr! l1 (cdr l2)) 149 | (loop l1 (cdr l1))) 150 | (or (predicate (uncanonicalize (car l2))) 151 | (loop l2 (cdr l2))))))) 152 | 153 | (initialize-population-package!) 154 | -------------------------------------------------------------------------------- /kits/scc/record.sc: -------------------------------------------------------------------------------- 1 | ; -*-Scheme-*- 2 | ; 3 | ; $Id: scc_record.sc,v 1.2 1992/09/23 15:32:13 birkholz Exp $ 4 | ; $MIT-Header: /scheme/users/cph/src/runtime/RCS/record.scm,v 1.12 1991/11/26 06:50:09 cph Exp $ 5 | ; 6 | ; Copyright (c) 1989-91 Massachusetts Institute of Technology 7 | ; 8 | ; This material was developed by the Scheme project at the Massachusetts 9 | ; Institute of Technology, Department of Electrical Engineering and 10 | ; Computer Science. Permission to copy this software, to redistribute 11 | ; it, and to use it for any purpose is granted, subject to the following 12 | ; restrictions and understandings. 13 | ; 14 | ; 1. Any copy made of this software must include this copyright notice 15 | ; in full. 16 | ; 17 | ; 2. Users of this software agree to make their best efforts (a) to 18 | ; return to the MIT Scheme project any improvements or extensions that 19 | ; they make, so that these may be included in future releases; and (b) 20 | ; to inform MIT of noteworthy uses of this software. 21 | ; 22 | ; 3. All materials developed as a consequence of the use of this 23 | ; software shall duly acknowledge such use, in accordance with the usual 24 | ; standards of acknowledging credit in academic research. 25 | ; 26 | ; 4. MIT has made no warrantee or representation that the operation of 27 | ; this software will be error-free, and MIT is under no obligation to 28 | ; provide any services, by way of maintenance, update, or otherwise. 29 | ; 30 | ; 5. In conjunction with products arising from the use of this material, 31 | ; there shall be no use of the name of the Massachusetts Institute of 32 | ; Technology nor of any adaptation thereof in any advertising, 33 | ; promotional, or sales literature without prior written consent from 34 | ; MIT in each case. 35 | 36 | ; This file requires the following non-IEEE primitives: 37 | 38 | ; error:wrong-type-argument and error:bad-range-argument each signal Scheme 39 | ; conditions indicating an argument of the wrong type or invalid value 40 | ; (respectively). 41 | 42 | ;;;; Implementations of these procedures for Scheme->C 43 | 44 | (define (error:wrong-type-argument record-type expected-type procedure) 45 | (error 'record-package "~s ~s~%" 46 | (string-append (symbol->string procedure) 47 | ": wrong argument type. Expected " 48 | expected-type 49 | ", got ") 50 | record-type)) 51 | 52 | (define (error:bad-range-argument field-name procedure-name) 53 | (error 'record-package "~s ~s~%" 54 | (string-append (symbol->string procedure-name) 55 | ": unknown field name") 56 | field-name)) 57 | 58 | ;;;; Records 59 | 60 | ;;; adapted from JAR's implementation 61 | ;;; conforms to R4RS proposal 62 | 63 | (define record-type-marker 64 | (string->symbol "#[(runtime record)record-type-marker]")) 65 | 66 | (define (make-record-type type-name field-names) 67 | (vector record-type-marker type-name (map (lambda (x) x) field-names))) 68 | 69 | (define (record-type? object) 70 | (and (vector? object) 71 | (= (vector-length object) 3) 72 | (eq? (vector-ref object 0) record-type-marker))) 73 | 74 | (define (record-type-name record-type) 75 | (if (not (record-type? record-type)) 76 | (error:wrong-type-argument record-type "record type" 'RECORD-TYPE-NAME)) 77 | (vector-ref record-type 1)) 78 | 79 | (define (record-type-field-names record-type) 80 | (if (not (record-type? record-type)) 81 | (error:wrong-type-argument record-type "record type" 82 | 'RECORD-TYPE-FIELD-NAMES)) 83 | (map (lambda (x) x) (vector-ref record-type 2))) 84 | 85 | (define (record-type-record-length record-type) 86 | (+ (length (vector-ref record-type 2)) 1)) 87 | 88 | (define (record-type-field-index record-type field-name procedure-name) 89 | (let loop ((field-names (vector-ref record-type 2)) (index 1)) 90 | (if (null? field-names) 91 | (error:bad-range-argument field-name procedure-name)) 92 | (if (eq? field-name (car field-names)) 93 | index 94 | (loop (cdr field-names) (+ index 1))))) 95 | 96 | (define (record-type-error record record-type procedure) 97 | (error:wrong-type-argument 98 | record 99 | (string-append "record of type " 100 | (let ((type-name (vector-ref record-type 1))) 101 | (cond ((string? type-name) type-name) 102 | ((symbol? type-name) type-name) 103 | (else "<>")))) 104 | procedure)) 105 | 106 | (define (record-constructor record-type . field-names) 107 | (if (not (record-type? record-type)) 108 | (error:wrong-type-argument record-type "record type" 109 | 'RECORD-CONSTRUCTOR)) 110 | (let ((field-names 111 | (if (null? field-names) 112 | (vector-ref record-type 2) 113 | (car field-names)))) 114 | (let ((record-length (record-type-record-length record-type)) 115 | (number-of-inits (length field-names)) 116 | (indexes 117 | (map (lambda (field-name) 118 | (record-type-field-index record-type 119 | field-name 120 | 'RECORD-CONSTRUCTOR)) 121 | field-names))) 122 | (lambda field-values 123 | (if (not (= (length field-values) number-of-inits)) 124 | (error "wrong number of arguments to record constructor" 125 | field-values record-type field-names)) 126 | (let ((record (make-vector record-length))) 127 | (vector-set! record 0 record-type) 128 | (for-each (lambda (index value) (vector-set! record index value)) 129 | indexes 130 | field-values) 131 | record))))) 132 | 133 | (define (record? object) 134 | (and (vector? object) 135 | (> (vector-length object) 0) 136 | (record-type? (vector-ref object 0)))) 137 | 138 | (define (record-type-descriptor record) 139 | (if (not (record? record)) 140 | (error:wrong-type-argument record "record" 'RECORD-TYPE-DESCRIPTOR)) 141 | (vector-ref record 0)) 142 | 143 | (define (record-copy record) 144 | (list->vector (vector->list record))) 145 | 146 | (define (record-predicate record-type) 147 | (if (not (record-type? record-type)) 148 | (error:wrong-type-argument record-type "record type" 'RECORD-PREDICATE)) 149 | (let ((record-length (record-type-record-length record-type))) 150 | (lambda (object) 151 | (and (vector? object) 152 | (= (vector-length object) record-length) 153 | (eq? (vector-ref object 0) record-type))))) 154 | 155 | (define (record-accessor record-type field-name) 156 | (if (not (record-type? record-type)) 157 | (error:wrong-type-argument record-type "record type" 'RECORD-ACCESSOR)) 158 | (let ((record-length (record-type-record-length record-type)) 159 | (procedure-name `(RECORD-ACCESSOR ,record-type ',field-name)) 160 | (index 161 | (record-type-field-index record-type field-name 'RECORD-ACCESSOR))) 162 | (lambda (record) 163 | (if (not (and (vector? record) 164 | (= (vector-length record) record-length) 165 | (eq? (vector-ref record 0) record-type))) 166 | (record-type-error record record-type procedure-name)) 167 | (vector-ref record index)))) 168 | 169 | (define (record-modifier record-type field-name) 170 | (if (not (record-type? record-type)) 171 | (error:wrong-type-argument record-type "record type" 'RECORD-UPDATER)) 172 | (let ((record-length (record-type-record-length record-type)) 173 | (procedure-name `(RECORD-UPDATER ,record-type ',field-name)) 174 | (index 175 | (record-type-field-index record-type field-name 'RECORD-UPDATER))) 176 | (lambda (record field-value) 177 | (if (not (and (vector? record) 178 | (= (vector-length record) record-length) 179 | (eq? (vector-ref record 0) record-type))) 180 | (record-type-error record record-type procedure-name)) 181 | (vector-set! record index field-value)))) 182 | 183 | (define record-updater 184 | record-modifier) 185 | -------------------------------------------------------------------------------- /kits/scc/scc-rep.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: scc-rep.scm,v 1.2 1992/09/18 21:22:34 birkholz Exp $ 39 | 40 | ;;; Just use current (user?) environment and keep a list of known module 41 | ;;; variables in thomas-rep-module-variables. 42 | 43 | (define thomas-rep-module-variables '()) 44 | 45 | (define (empty-thomas-environment!) 46 | ;; Just dump thomas-rep-module-variables. 47 | (set! thomas-rep-module-variables '())) 48 | 49 | (define (thomas-rep) 50 | (define *SAVE-RESET* reset) 51 | (newline) 52 | (display "Entering Thomas read-eval-print-loop.") 53 | (newline) 54 | (display "Exit by typing \"thomas:done\"") 55 | (newline) 56 | (dylan::catch-all-conditions 57 | (lambda () 58 | (let loop () 59 | (call-with-current-continuation 60 | (lambda (ret) (set! reset (lambda () (ret #f))))) 61 | (newline) 62 | (display "? ") 63 | (let ((input (read))) 64 | (if (and (eq? input 'thomas:done)) 65 | (begin (set! reset *save-reset*) 66 | 'thomas:done) 67 | (compile-expression 68 | input '!MULTIPLE-VALUES thomas-rep-module-variables 69 | (lambda (new-vars preamble compiled-output) 70 | (implementation-specific:eval 71 | `(BEGIN 72 | ,@preamble 73 | (LET* ((!MULTIPLE-VALUES (VECTOR '())) 74 | (!RESULT ,compiled-output)) 75 | (NEWLINE) 76 | (IF (EQ? !RESULT !MULTIPLE-VALUES) 77 | (LET* ((RESULT (VECTOR-REF !MULTIPLE-VALUES 0)) 78 | (COUNT (LENGTH RESULT))) 79 | (DISPLAY COUNT) 80 | (DISPLAY " value") 81 | (IF (NOT (= COUNT 1)) (DISPLAY "s")) 82 | (DISPLAY ":") 83 | (FOR-EACH (LAMBDA (X) (NEWLINE) (WRITE X)) RESULT)) 84 | (BEGIN 85 | (DISPLAY "Result: ") 86 | (WRITE !RESULT)))))) 87 | (set! thomas-rep-module-variables 88 | (append new-vars thomas-rep-module-variables)) 89 | (loop))))))))) 90 | 91 | (display " 92 | Apply thomas-rep to start a Thomas read-eval-print loop. 93 | ") 94 | -------------------------------------------------------------------------------- /kits/scc/scc-specific.sc: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: scc-specific.scm,v 1.16 1992/09/23 15:35:25 birkholz Exp $ 39 | 40 | ;;; This file contains the definitions of all functions used in the 41 | ;;; implementation of Dylan which aren't part of R4RS. 42 | 43 | (module sccspecific) 44 | 45 | ;;;; Populations 46 | 47 | ;(load "aftergc.sc") 48 | ;(load "poplat.sc") 49 | 50 | ;;;; Hash tables that use weak links for objects 51 | 52 | ;(load "hash.sc") 53 | 54 | ;;;; Record package 55 | 56 | ;(load "record.sc") 57 | 58 | ;;;; Compiler's error procedure. 59 | 60 | (define (dylan::error string . args) 61 | (error 'dylan::error (string-append string ": ~A") args)) 62 | 63 | ;;;; Load-up 64 | 65 | (define (dylan::load string) 66 | (load (string-append string ".scm"))) 67 | 68 | (define (implementation-specific:generate-file in-exprs out-expr) 69 | (define (print x) (newline) (display x)) 70 | (print ";;;; Compiled output:") 71 | (print "") 72 | (print "(module dylan-compiled-code)") 73 | (print "") 74 | (pp out-expr) 75 | (newline)) 76 | 77 | ;;;; Eval 78 | 79 | (define (implementation-specific:eval expression) 80 | (eval expression)) 81 | 82 | ;;;; Interface between Dylan condition system (runtime-exceptions.scm) and 83 | ;;;; native condition system. 84 | 85 | (define *dylan-handlers* (list)) 86 | (define *scc-error-handler* *error-handler*) 87 | (define scc-error-tag (list 'scc 'error)) 88 | 89 | (define (implementation-specific:push-handler 90 | type function test description thunk) 91 | (dynamic-wind 92 | (lambda () 93 | (set! *dylan-handlers* (cons (list type function test description) 94 | *dylan-handlers*))) 95 | thunk 96 | (lambda () 97 | (set! *dylan-handlers* (cdr *dylan-handlers*))))) 98 | 99 | (define (implementation-specific:get-dylan-handler-frames) 100 | *dylan-handlers*) 101 | 102 | (define (implementation-specific:enter-debugger dylan-condition) 103 | (*scc-error-handler* 104 | 'enter-debugger "Dylan condition ~A" dylan-condition)) 105 | 106 | (define (implementation-specific:induce-error format-string format-args) 107 | (*scc-error-handler* 'induce-error 108 | (string-append format-string ": ~A") 109 | format-args)) 110 | 111 | (define (implementation-specific:induce-type-error value class-name) 112 | (*scc-error-handler* 113 | 'induce-type-error "Type error. ~A not of type ~A." 114 | value class-name)) 115 | 116 | (define (implementation-specific:signal-unhandled-dylan-condition 117 | dylan-condition) 118 | (*scc-error-handler* 119 | 'signal-unhandled-dylan-condition "Dylan condition ~A" dylan-condition)) 120 | 121 | (define (implementation-specific:warning format-string format-args) 122 | (apply *scc-error-handler* 'warning format-string format-args)) 123 | 124 | (define (implementation-specific:catch-all-errors handler thunk) 125 | (let ((old-handler 'xxx)) 126 | (dynamic-wind 127 | (lambda () 128 | (set! old-handler *error-handler*) 129 | (set! *error-handler* 130 | (lambda (procedure-name format-string . args) 131 | (handler `(,scc-error-tag 132 | ,procedure-name 133 | ,format-string 134 | ,@args))))) 135 | thunk 136 | (lambda () 137 | (set! *error-handler* old-handler))))) 138 | 139 | (define (implementation-specific:get-error-message scheme-condition) 140 | (if (and (pair? scheme-condition) 141 | (eq? (car scheme-condition) scc-error-tag)) 142 | (string-append (symbol->string (cadr scheme-condition)) 143 | (caddr scheme-condition)) 144 | (*scc-error-handler* 'get-error-message 145 | "Not a Scheme error: ~A" 146 | scheme-condition))) 147 | 148 | (define (implementation-specific:get-error-arguments scheme-condition) 149 | (if (and (pair? scheme-condition) 150 | (eq? (car scheme-condition) scc-error-tag)) 151 | (cdddr scheme-condition) 152 | (*scc-error-handler* 'get-error-arguments 153 | "Not a Scheme error: ~A" 154 | scheme-condition))) 155 | 156 | (define (implementation-specific:is-reflected-error? f-string f-args) 157 | #F) 158 | 159 | (define (implementation-specific:let-scheme-handle-it serious) 160 | ;; This can't happen if is-reflected-error? is returning #F 161 | (car 34)) 162 | 163 | ;;;; Additional Dylan bindings 164 | 165 | (define (dylan:scheme-variable-ref mv nm variable-name) 166 | (eval variable-name)) 167 | 168 | (define (dylan:scheme-procedure-ref mv nm variable-name) 169 | (make-dylan-callable (eval variable-name))) 170 | 171 | (define (dylan:pp mv nm obj) 172 | mv nm ; Ignored 173 | (pp obj)) 174 | 175 | (define implementation-specific:additional-dylan-bindings 176 | `((pp dylan:pp) 177 | (scheme-variable dylan:scheme-variable-ref) 178 | (scheme-procedure dylan:scheme-procedure-ref))) 179 | 180 | ;;;; Other things 181 | 182 | ;;; For conversion from strings to symbols, we need a function that 183 | ;;; canonicalizes the case of the string. 184 | 185 | (define (canonicalize-string-for-symbol string) 186 | (list->string (map char-upcase (string->list string)))) 187 | 188 | ;(load "msort.sc") 189 | 190 | (define (write-line x) 191 | (write x) 192 | (newline)) 193 | 194 | ;; pp -- already provided 195 | 196 | ;(load "dynwnd.sc") 197 | 198 | ;;; Imaginary numbers aren't supported by all implementations 199 | (define (get-+i) 200 | (error 'get-+i "Complex numbers aren't supported")) 201 | 202 | (define (numerator x) x) 203 | (define (denominator x) 1) 204 | (define (angle x) 0) 205 | (define (magnitude x) x) 206 | (define (real-part x) x) 207 | (define (imag-part x) 0) 208 | (define (make-polar mag angle) 209 | (if (zero? angle) 210 | mag 211 | (get-+i))) 212 | (define (make-rectangular x y) 213 | (if (zero? y) 214 | x 215 | (get-+i))) 216 | (define (rationalize x . y) 217 | (error 'rationalize "We aren't rational")) 218 | -------------------------------------------------------------------------------- /kits/scc/src/class-structure.scm: -------------------------------------------------------------------------------- 1 | ../../../src/class-structure.scm -------------------------------------------------------------------------------- /kits/scc/src/class.scm: -------------------------------------------------------------------------------- 1 | ../../../src/class.scm -------------------------------------------------------------------------------- /kits/scc/src/common.scm: -------------------------------------------------------------------------------- 1 | ../../../src/common.scm -------------------------------------------------------------------------------- /kits/scc/src/comp-class.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp-class.scm -------------------------------------------------------------------------------- /kits/scc/src/comp-exc.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp-exc.scm -------------------------------------------------------------------------------- /kits/scc/src/comp-method.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp-method.scm -------------------------------------------------------------------------------- /kits/scc/src/comp-sf.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp-sf.scm -------------------------------------------------------------------------------- /kits/scc/src/comp-util.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp-util.scm -------------------------------------------------------------------------------- /kits/scc/src/comp.scm: -------------------------------------------------------------------------------- 1 | ../../../src/comp.scm -------------------------------------------------------------------------------- /kits/scc/src/compiler.scm: -------------------------------------------------------------------------------- 1 | ../../../src/compiler.scm -------------------------------------------------------------------------------- /kits/scc/src/gambit-specific.scm: -------------------------------------------------------------------------------- 1 | ../../../src/gambit-specific.scm -------------------------------------------------------------------------------- /kits/scc/src/generic.scm: -------------------------------------------------------------------------------- 1 | ../../../src/generic.scm -------------------------------------------------------------------------------- /kits/scc/src/implementation-specific: -------------------------------------------------------------------------------- 1 | ../implementation-specific -------------------------------------------------------------------------------- /kits/scc/src/load-compiler.scm: -------------------------------------------------------------------------------- 1 | ../../../src/load-compiler.scm -------------------------------------------------------------------------------- /kits/scc/src/load-runtime.scm: -------------------------------------------------------------------------------- 1 | ../../../src/load-runtime.scm -------------------------------------------------------------------------------- /kits/scc/src/load-thomas.scm: -------------------------------------------------------------------------------- 1 | ../../../src/load-thomas.scm -------------------------------------------------------------------------------- /kits/scc/src/mit-rep.scm: -------------------------------------------------------------------------------- 1 | ../../../src/mit-rep.scm -------------------------------------------------------------------------------- /kits/scc/src/mit-specific.scm: -------------------------------------------------------------------------------- 1 | ../../../src/mit-specific.scm -------------------------------------------------------------------------------- /kits/scc/src/portable-rep.scm: -------------------------------------------------------------------------------- 1 | ../../../src/portable-rep.scm -------------------------------------------------------------------------------- /kits/scc/src/rep.scm: -------------------------------------------------------------------------------- 1 | ../scc-rep.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-bitstrings.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-bitstrings.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-collections-array.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-array.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-collections-deque.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-deque.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-collections-generic1.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-generic1.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-collections-generic2.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-generic2.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-collections-iterate.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-iterate.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-collections-list.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-list.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-collections-range.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-range.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-collections-string.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-string.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-collections-table.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-table.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-collections-vector.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections-vector.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-collections.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-collections.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-exceptions.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-exceptions.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-functions.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-functions.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-internal.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-internal.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-methods.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-methods.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime-top.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime-top.scm -------------------------------------------------------------------------------- /kits/scc/src/runtime.scm: -------------------------------------------------------------------------------- 1 | ../../../src/runtime.scm -------------------------------------------------------------------------------- /kits/scc/src/scc-rep.scm: -------------------------------------------------------------------------------- 1 | ../../../src/scc-rep.scm -------------------------------------------------------------------------------- /kits/scc/src/scc-specific.scm: -------------------------------------------------------------------------------- 1 | ../../../src/scc-specific.scm -------------------------------------------------------------------------------- /kits/scc/src/support.scm: -------------------------------------------------------------------------------- 1 | ../../../src/support.scm -------------------------------------------------------------------------------- /portable/dynwind.scm: -------------------------------------------------------------------------------- 1 | ; "dynwind.scm", wind-unwind-protect for Scheme 2 | ; Copyright (c) 1992, Aubrey Jaffer 3 | 4 | ;This facility is a generalization of Common Lisp `unwind-protect', 5 | ;designed to take into account the fact that continuations produced by 6 | ;CALL-WITH-CURRENT-CONTINUATION may be reentered. 7 | 8 | ; (dynamic-wind ) procedure 9 | 10 | ;The arguments , , and must all be procedures 11 | ;of no arguments (thunks). 12 | 13 | ;DYNAMIC-WIND calls , , and then . The value 14 | ;returned of is returned as the result of DYNAMIC-WIND. 15 | ; is also called just before calls any continuations 16 | ;created by CALL-WITH-CURRENT-CONTINUATION. If captures its 17 | ;continuation as an escape procedure, is invoked just before 18 | ;continuing that continuation. 19 | 20 | (define *winds* '()) 21 | 22 | (define (dynamic-wind ) 23 | () 24 | (set! *winds* (cons (cons ) *winds*)) 25 | (let ((ans ())) 26 | (set! *winds* (cdr *winds*)) 27 | () 28 | ans)) 29 | 30 | (define call-with-current-continuation 31 | (let ((oldcc call-with-current-continuation)) 32 | (lambda (proc) 33 | (let ((winds *winds*)) 34 | (oldcc 35 | (lambda (cont) 36 | (proc (lambda (c2) 37 | (dynamic:do-winds *winds* winds) 38 | (cont c2))))))))) 39 | 40 | (define (dynamic:do-winds from to) 41 | (set! *winds* from) 42 | (cond ((eq? from to)) 43 | ((null? from) 44 | (dynamic:do-winds from (cdr to)) 45 | ((caar to))) 46 | ((null? to) 47 | ((cdar from)) 48 | (dynamic:do-winds (cdr from) to)) 49 | (else 50 | ((cdar from)) 51 | (dynamic:do-winds (cdr from) (cdr to)) 52 | ((caar to)))) 53 | (set! *winds* to)) 54 | -------------------------------------------------------------------------------- /portable/hash.scm: -------------------------------------------------------------------------------- 1 | ; -*-Scheme-*- 2 | ; 3 | ; $Id: hash.scm,v 1.5 1992/09/23 15:23:06 birkholz Exp $ 4 | ; $MIT-Header: prop1d.scm,v 14.4 89/09/15 17:16:35 GMT jinx Exp $ 5 | ; 6 | ; Copyright (c) 1988, 1989 Massachusetts Institute of Technology 7 | ; 8 | ; This material was developed by the Scheme project at the Massachusetts 9 | ; Institute of Technology, Department of Electrical Engineering and 10 | ; Computer Science. Permission to copy this software, to redistribute 11 | ; it, and to use it for any purpose is granted, subject to the following 12 | ; restrictions and understandings. 13 | ; 14 | ; 1. Any copy made of this software must include this copyright notice 15 | ; in full. 16 | ; 17 | ; 2. Users of this software agree to make their best efforts (a) to 18 | ; return to the MIT Scheme project any improvements or extensions that 19 | ; they make, so that these may be included in future releases; and (b) 20 | ; to inform MIT of noteworthy uses of this software. 21 | ; 22 | ; 3. All materials developed as a consequence of the use of this 23 | ; software shall duly acknowledge such use, in accordance with the usual 24 | ; standards of acknowledging credit in academic research. 25 | ; 26 | ; 4. MIT has made no warrantee or representation that the operation of 27 | ; this software will be error-free, and MIT is under no obligation to 28 | ; provide any services, by way of maintenance, update, or otherwise. 29 | ; 30 | ; 5. In conjunction with products arising from the use of this material, 31 | ; there shall be no use of the name of the Massachusetts Institute of 32 | ; Technology nor of any adaptation thereof in any advertising, 33 | ; promotional, or sales literature without prior written consent from 34 | ; MIT in each case. 35 | 36 | ; This file requires the following non-IEEE primitives: 37 | 38 | ; weak-cons, weak-car, weak-cdr, set-weak-cdr! for manipulating 39 | ; "weak-cons cells," whose cdr is normal but whose car turns to #F 40 | ; during a garbage collection if no non-weak references are found to 41 | ; the object in the car. 42 | 43 | ; after-gc registers a thunk (procedure of no arguments) to be called 44 | ; after each garbage collection is complete and before Scheme resumes 45 | ; running. 46 | 47 | ;;;; One Dimensional Property Tables 48 | 49 | (define (initialize-oned-table-package!) 50 | (set! population-of-oned-tables (make-population)) 51 | (after-gc gc-oned-tables!)) 52 | 53 | (define population-of-oned-tables #f) 54 | 55 | (define (gc-oned-tables!) 56 | (map-over-population! population-of-oned-tables oned-table/clean!)) 57 | 58 | (define (make-oned-table) 59 | (let ((table (list oned-table-tag))) 60 | (add-to-population! population-of-oned-tables table) 61 | table)) 62 | 63 | (define (oned-table? object) 64 | (and (pair? object) 65 | (eq? (car object) oned-table-tag))) 66 | 67 | (define oned-table-tag 68 | "1D table") 69 | 70 | (define false-key 71 | "false key") 72 | 73 | (define (weak-assq key table) 74 | (let loop ((previous table) (alist (cdr table))) 75 | (and (not (null? alist)) 76 | (let ((entry (car alist)) 77 | (next (cdr alist))) 78 | (let ((key* (weak-car entry))) 79 | (cond ((not key*) 80 | (set-cdr! previous next) 81 | (loop previous next)) 82 | ((eq? key* key) 83 | entry) 84 | (else 85 | (loop alist next)))))))) 86 | 87 | (define (oned-table/get table key default) 88 | (let ((entry (weak-assq (or key false-key) table))) 89 | (if entry 90 | (weak-cdr entry) 91 | default))) 92 | 93 | (define (oned-table/lookup table key if-found if-not-found) 94 | (let ((entry (weak-assq (or key false-key) table))) 95 | (if entry 96 | (if-found (weak-cdr entry)) 97 | (if-not-found)))) 98 | 99 | (define (oned-table/put! table key value) 100 | (let ((key (or key false-key))) 101 | (let ((entry (weak-assq key table))) 102 | (if entry 103 | (set-weak-cdr! entry value) 104 | (set-cdr! table 105 | (cons (weak-cons key value) 106 | (cdr table)))) 107 | #f))) 108 | 109 | (define (oned-table/remove! table key) 110 | (let ((key (or key false-key))) 111 | (let loop ((previous table) (alist (cdr table))) 112 | (if (not (null? alist)) 113 | (let ((key* (weak-car (car alist))) 114 | (next (cdr alist))) 115 | (loop (if (or (not key*) (eq? key* key)) 116 | ;; Might as well clean whole list. 117 | (begin 118 | (set-cdr! previous next) 119 | previous) 120 | alist) 121 | next)))))) 122 | 123 | (define (oned-table/clean! table) 124 | (let loop ((previous table) (alist (cdr table))) 125 | (if (not (null? alist)) 126 | (let ((next (cdr alist))) 127 | (loop (if (weak-car (car alist)) 128 | alist 129 | (begin 130 | (set-cdr! previous next) 131 | previous)) 132 | next))))) 133 | 134 | (define (oned-table/alist table) 135 | (let loop ((previous table) (alist (cdr table)) (result '())) 136 | (if (null? alist) 137 | result 138 | (let ((entry (car alist)) 139 | (next (cdr alist))) 140 | (let ((key (weak-car entry))) 141 | (if (not key) 142 | (begin 143 | (set-cdr! previous next) 144 | (loop previous next result)) 145 | (loop alist 146 | next 147 | (cons (cons (and (not (eq? key false-key)) key) 148 | (weak-cdr entry)) 149 | result)))))))) 150 | 151 | (define (oned-table/for-each proc table) 152 | (let loop ((previous table) (alist (cdr table))) 153 | (if (not (null? alist)) 154 | (let ((entry (car alist)) 155 | (next (cdr alist))) 156 | (let ((key (weak-car entry))) 157 | (if key 158 | (begin 159 | (proc (and (not (eq? key false-key)) key) 160 | (weak-cdr entry)) 161 | (loop alist next)) 162 | (begin 163 | (set-cdr! previous next) 164 | (loop previous next)))))))) 165 | 166 | (initialize-oned-table-package!) 167 | -------------------------------------------------------------------------------- /portable/msort.scm: -------------------------------------------------------------------------------- 1 | ; -*-Scheme-*- 2 | ; 3 | ; $Id: msort.scm,v 1.2 1992/09/22 20:31:33 birkholz Exp $ 4 | ; $MIT-Header: msort.scm,v 14.1 88/06/13 11:47:52 GMT cph Rel $ 5 | ; 6 | ; Copyright (c) 1988 Massachusetts Institute of Technology 7 | ; 8 | ; This material was developed by the Scheme project at the Massachusetts 9 | ; Institute of Technology, Department of Electrical Engineering and 10 | ; Computer Science. Permission to copy this software, to redistribute 11 | ; it, and to use it for any purpose is granted, subject to the following 12 | ; restrictions and understandings. 13 | ; 14 | ; 1. Any copy made of this software must include this copyright notice 15 | ; in full. 16 | ; 17 | ; 2. Users of this software agree to make their best efforts (a) to 18 | ; return to the MIT Scheme project any improvements or extensions that 19 | ; they make, so that these may be included in future releases; and (b) 20 | ; to inform MIT of noteworthy uses of this software. 21 | ; 22 | ; 3. All materials developed as a consequence of the use of this 23 | ; software shall duly acknowledge such use, in accordance with the usual 24 | ; standards of acknowledging credit in academic research. 25 | ; 26 | ; 4. MIT has made no warrantee or representation that the operation of 27 | ; this software will be error-free, and MIT is under no obligation to 28 | ; provide any services, by way of maintenance, update, or otherwise. 29 | ; 30 | ; 5. In conjunction with products arising from the use of this material, 31 | ; there shall be no use of the name of the Massachusetts Institute of 32 | ; Technology nor of any adaptation thereof in any advertising, 33 | ; promotional, or sales literature without prior written consent from 34 | ; MIT in each case. 35 | 36 | ;;;; Merge Sort 37 | 38 | ; Requires an "error" procedure. 39 | 40 | ;; Functional and unstable 41 | 42 | (define (sort obj pred) 43 | (define (loop l) 44 | (if (and (pair? l) (pair? (cdr l))) 45 | (split l '() '()) 46 | l)) 47 | 48 | (define (split l one two) 49 | (if (pair? l) 50 | (split (cdr l) two (cons (car l) one)) 51 | (merge (loop one) (loop two)))) 52 | 53 | (define (merge one two) 54 | (cond ((null? one) two) 55 | ((pred (car two) (car one)) 56 | (cons (car two) 57 | (merge (cdr two) one))) 58 | (else 59 | (cons (car one) 60 | (merge (cdr one) two))))) 61 | 62 | (cond ((or (pair? obj) (null? obj)) 63 | (loop obj)) 64 | ((vector? obj) 65 | (sort! (vector-copy obj) pred)) 66 | (else 67 | (error "sort: argument should be a list or vector" obj)))) 68 | 69 | ;; This merge sort is stable for partial orders (for predicates like 70 | ;; <=, rather than like <). 71 | 72 | (define (sort! v pred) 73 | (define (sort-internal! vec temp low high) 74 | (if (< low high) 75 | (let* ((middle (quotient (+ low high) 2)) 76 | (next (+ 1 middle))) 77 | (sort-internal! temp vec low middle) 78 | (sort-internal! temp vec next high) 79 | (let loop ((p low) (p1 low) (p2 next)) 80 | (if (not (> p high)) 81 | (cond ((> p1 middle) 82 | (vector-set! vec p (vector-ref temp p2)) 83 | (loop (+ 1 p) p1 (+ 1 p2))) 84 | ((or (> p2 high) 85 | (pred (vector-ref temp p1) 86 | (vector-ref temp p2))) 87 | (vector-set! vec p (vector-ref temp p1)) 88 | (loop (+ 1 p) (+ 1 p1) p2)) 89 | (else 90 | (vector-set! vec p (vector-ref temp p2)) 91 | (loop (+ 1 p) p1 (+ 1 p2))))))))) 92 | 93 | (if (not (vector? v)) 94 | (error "sort!: argument not a vector" v)) 95 | 96 | (sort-internal! v 97 | (vector-copy v) 98 | 0 99 | (- (vector-length v) 1)) 100 | v) 101 | -------------------------------------------------------------------------------- /portable/poplat.scm: -------------------------------------------------------------------------------- 1 | ; -*-Scheme-*- 2 | ; 3 | ; $Id: poplat.scm,v 1.4 1992/09/23 15:28:08 birkholz Exp $ 4 | ; $MIT-Header: poplat.scm,v 14.2 88/06/13 11:49:48 GMT cph Rel $ 5 | ; 6 | ; Copyright (c) 1988 Massachusetts Institute of Technology 7 | ; 8 | ; This material was developed by the Scheme project at the Massachusetts 9 | ; Institute of Technology, Department of Electrical Engineering and 10 | ; Computer Science. Permission to copy this software, to redistribute 11 | ; it, and to use it for any purpose is granted, subject to the following 12 | ; restrictions and understandings. 13 | ; 14 | ; 1. Any copy made of this software must include this copyright notice 15 | ; in full. 16 | ; 17 | ; 2. Users of this software agree to make their best efforts (a) to 18 | ; return to the MIT Scheme project any improvements or extensions that 19 | ; they make, so that these may be included in future releases; and (b) 20 | ; to inform MIT of noteworthy uses of this software. 21 | ; 22 | ; 3. All materials developed as a consequence of the use of this 23 | ; software shall duly acknowledge such use, in accordance with the usual 24 | ; standards of acknowledging credit in academic research. 25 | ; 26 | ; 4. MIT has made no warrantee or representation that the operation of 27 | ; this software will be error-free, and MIT is under no obligation to 28 | ; provide any services, by way of maintenance, update, or otherwise. 29 | ; 30 | ; 5. In conjunction with products arising from the use of this material, 31 | ; there shall be no use of the name of the Massachusetts Institute of 32 | ; Technology nor of any adaptation thereof in any advertising, 33 | ; promotional, or sales literature without prior written consent from 34 | ; MIT in each case. 35 | 36 | ; This file requires the following non-IEEE primitives: 37 | 38 | ; weak-pair?, weak-cons, weak-car, weak-cdr, set-weak-cdr! for 39 | ; manipulating "weak-cons cells," whose cdr is normal but whose car 40 | ; turns to #F during a garbage collection if no non-weak references 41 | ; are found to the object in the car. 42 | 43 | ; after-gc registers a thunk (procedure of no arguments) to be called 44 | ; after each garbage collection is complete and before Scheme resumes 45 | ; execution. 46 | 47 | ;;;; Populations 48 | 49 | ;;; A population is a collection of objects. This collection has the 50 | ;;; property that if one of the objects in the collection is reclaimed 51 | ;;; as garbage, then it is no longer an element of the collection. 52 | 53 | (define (initialize-population-package!) 54 | (set! population-of-populations (weak-cons population-tag '())) 55 | (after-gc gc-all-populations!)) 56 | 57 | (define bogus-false '(BOGUS-FALSE)) 58 | (define population-tag '(POPULATION)) 59 | 60 | (define (canonicalize object) 61 | (if (eq? object #f) bogus-false object)) 62 | 63 | (define (uncanonicalize object) 64 | (if (eq? object bogus-false) #f object)) 65 | 66 | (define (gc-population! population) 67 | (let loop ((l1 population) (l2 (weak-cdr population))) 68 | (cond ((null? l2) #t) 69 | ((eq? (weak-car l2) #f) 70 | (set-weak-cdr! l1 (weak-cdr l2)) 71 | (loop l1 (weak-cdr l1))) 72 | (else (loop l2 (weak-cdr l2)))))) 73 | 74 | (define (gc-all-populations!) 75 | (gc-population! population-of-populations) 76 | (map-over-population! population-of-populations gc-population!)) 77 | 78 | (define population-of-populations #f) 79 | 80 | (define (make-population) 81 | (let ((population (weak-cons population-tag '()))) 82 | (add-to-population! population-of-populations population) 83 | population)) 84 | 85 | (define (population? object) 86 | (and (weak-pair? object) 87 | (eq? (weak-car object) population-tag))) 88 | 89 | (define (add-to-population! population object) 90 | (let ((object (canonicalize object))) 91 | (let loop ((previous population) (this (weak-cdr population))) 92 | (if (null? this) 93 | (set-weak-cdr! population 94 | (weak-cons object (weak-cdr population))) 95 | (let ((entry (weak-car this)) 96 | (next (weak-cdr this))) 97 | (cond ((not entry) 98 | (set-weak-cdr! previous next) 99 | (loop previous next)) 100 | ((not (eq? object entry)) 101 | (loop this next)))))))) 102 | 103 | (define (remove-from-population! population object) 104 | (let ((object (canonicalize object))) 105 | (let loop ((previous population) (this (weak-cdr population))) 106 | (if (not (null? this)) 107 | (let ((entry (weak-car this)) 108 | (next (weak-cdr this))) 109 | (if (or (not entry) (eq? object entry)) 110 | (begin (set-weak-cdr! previous next) 111 | (loop previous next)) 112 | (loop this next))))))) 113 | 114 | ;;;; Higher level operations 115 | 116 | (define (map-over-population population procedure) 117 | (let loop ((l1 population) (l2 (weak-cdr population))) 118 | (cond ((null? l2) '()) 119 | ((eq? (weak-car l2) #f) 120 | (set-weak-cdr! l1 (weak-cdr l2)) 121 | (loop l1 (weak-cdr l1))) 122 | (else 123 | (cons (procedure (uncanonicalize (weak-car l2))) 124 | (loop l2 (weak-cdr l2))))))) 125 | 126 | (define (map-over-population! population procedure) 127 | (let loop ((l1 population) (l2 (weak-cdr population))) 128 | (cond ((null? l2) #t) 129 | ((eq? (weak-car l2) #f) 130 | (set-weak-cdr! l1 (weak-cdr l2)) 131 | (loop l1 (weak-cdr l1))) 132 | (else 133 | (procedure (uncanonicalize (weak-car l2))) 134 | (loop l2 (weak-cdr l2)))))) 135 | 136 | (define (for-all-inhabitants? population predicate) 137 | (let loop ((l1 population) (l2 (weak-cdr population))) 138 | (or (null? l2) 139 | (if (eq? (weak-car l2) #f) 140 | (begin (set-weak-cdr! l1 (weak-cdr l2)) 141 | (loop l1 (weak-cdr l1))) 142 | (and (predicate (uncanonicalize (weak-car l2))) 143 | (loop l2 (weak-cdr l2))))))) 144 | 145 | (define (exists-an-inhabitant? population predicate) 146 | (let loop ((l1 population) (l2 (weak-cdr population))) 147 | (and (not (null? l2)) 148 | (if (eq? (weak-car l2) #f) 149 | (begin (set-weak-cdr! l1 (weak-cdr l2)) 150 | (loop l1 (weak-cdr l1))) 151 | (or (predicate (uncanonicalize (weak-car l2))) 152 | (loop l2 (weak-cdr l2))))))) 153 | 154 | (initialize-population-package!) 155 | -------------------------------------------------------------------------------- /portable/record.scm: -------------------------------------------------------------------------------- 1 | ; -*-Scheme-*- 2 | ; 3 | ; $Id: record.scm,v 1.3 1992/09/23 15:30:30 birkholz Exp $ 4 | ; $MIT-Header: /scheme/users/cph/src/runtime/RCS/record.scm,v 1.12 1991/11/26 06:50:09 cph Exp $ 5 | ; 6 | ; Copyright (c) 1989-91 Massachusetts Institute of Technology 7 | ; 8 | ; This material was developed by the Scheme project at the Massachusetts 9 | ; Institute of Technology, Department of Electrical Engineering and 10 | ; Computer Science. Permission to copy this software, to redistribute 11 | ; it, and to use it for any purpose is granted, subject to the following 12 | ; restrictions and understandings. 13 | ; 14 | ; 1. Any copy made of this software must include this copyright notice 15 | ; in full. 16 | ; 17 | ; 2. Users of this software agree to make their best efforts (a) to 18 | ; return to the MIT Scheme project any improvements or extensions that 19 | ; they make, so that these may be included in future releases; and (b) 20 | ; to inform MIT of noteworthy uses of this software. 21 | ; 22 | ; 3. All materials developed as a consequence of the use of this 23 | ; software shall duly acknowledge such use, in accordance with the usual 24 | ; standards of acknowledging credit in academic research. 25 | ; 26 | ; 4. MIT has made no warrantee or representation that the operation of 27 | ; this software will be error-free, and MIT is under no obligation to 28 | ; provide any services, by way of maintenance, update, or otherwise. 29 | ; 30 | ; 5. In conjunction with products arising from the use of this material, 31 | ; there shall be no use of the name of the Massachusetts Institute of 32 | ; Technology nor of any adaptation thereof in any advertising, 33 | ; promotional, or sales literature without prior written consent from 34 | ; MIT in each case. 35 | 36 | ; This file requires the following non-IEEE primitives: 37 | 38 | ; error:wrong-type-argument and error:bad-range-argument each signal Scheme 39 | ; conditions indicating an argument of the wrong type or invalid value 40 | ; (respectively). 41 | 42 | ;;;; Records 43 | 44 | ;;; adapted from JAR's implementation 45 | ;;; conforms to R4RS proposal 46 | 47 | (define record-type-marker 48 | (string->symbol "#[(runtime record)record-type-marker]")) 49 | 50 | (define (make-record-type type-name field-names) 51 | (vector record-type-marker type-name (map (lambda (x) x) field-names))) 52 | 53 | (define (record-type? object) 54 | (and (vector? object) 55 | (= (vector-length object) 3) 56 | (eq? (vector-ref object 0) record-type-marker))) 57 | 58 | (define (record-type-name record-type) 59 | (if (not (record-type? record-type)) 60 | (error:wrong-type-argument record-type "record type" 'RECORD-TYPE-NAME)) 61 | (vector-ref record-type 1)) 62 | 63 | (define (record-type-field-names record-type) 64 | (if (not (record-type? record-type)) 65 | (error:wrong-type-argument record-type "record type" 66 | 'RECORD-TYPE-FIELD-NAMES)) 67 | (map (lambda (x) x) (vector-ref record-type 2))) 68 | 69 | (define (record-type-record-length record-type) 70 | (+ (length (vector-ref record-type 2)) 1)) 71 | 72 | (define (record-type-field-index record-type field-name procedure-name) 73 | (let loop ((field-names (vector-ref record-type 2)) (index 1)) 74 | (if (null? field-names) 75 | (error:bad-range-argument field-name procedure-name)) 76 | (if (eq? field-name (car field-names)) 77 | index 78 | (loop (cdr field-names) (+ index 1))))) 79 | 80 | (define (record-type-error record record-type procedure) 81 | (error:wrong-type-argument 82 | record 83 | (string-append "record of type " 84 | (let ((type-name (vector-ref record-type 1))) 85 | (cond ((string? type-name) type-name) 86 | ((symbol? type-name) type-name) 87 | (else "<>")))) 88 | procedure)) 89 | 90 | (define (record-constructor record-type . field-names) 91 | (if (not (record-type? record-type)) 92 | (error:wrong-type-argument record-type "record type" 93 | 'RECORD-CONSTRUCTOR)) 94 | (let ((field-names 95 | (if (null? field-names) 96 | (vector-ref record-type 2) 97 | (car field-names)))) 98 | (let ((record-length (record-type-record-length record-type)) 99 | (number-of-inits (length field-names)) 100 | (indexes 101 | (map (lambda (field-name) 102 | (record-type-field-index record-type 103 | field-name 104 | 'RECORD-CONSTRUCTOR)) 105 | field-names))) 106 | (lambda field-values 107 | (if (not (= (length field-values) number-of-inits)) 108 | (error "wrong number of arguments to record constructor" 109 | field-values record-type field-names)) 110 | (let ((record (make-vector record-length))) 111 | (vector-set! record 0 record-type) 112 | (for-each (lambda (index value) (vector-set! record index value)) 113 | indexes 114 | field-values) 115 | record))))) 116 | 117 | (define (record? object) 118 | (and (vector? object) 119 | (> (vector-length object) 0) 120 | (record-type? (vector-ref object 0)))) 121 | 122 | (define (record-type-descriptor record) 123 | (if (not (record? record)) 124 | (error:wrong-type-argument record "record" 'RECORD-TYPE-DESCRIPTOR)) 125 | (vector-ref record 0)) 126 | 127 | (define (record-copy record) 128 | (list->vector (vector->list record))) 129 | 130 | (define (record-predicate record-type) 131 | (if (not (record-type? record-type)) 132 | (error:wrong-type-argument record-type "record type" 'RECORD-PREDICATE)) 133 | (let ((record-length (record-type-record-length record-type))) 134 | (lambda (object) 135 | (and (vector? object) 136 | (= (vector-length object) record-length) 137 | (eq? (vector-ref object 0) record-type))))) 138 | 139 | (define (record-accessor record-type field-name) 140 | (if (not (record-type? record-type)) 141 | (error:wrong-type-argument record-type "record type" 'RECORD-ACCESSOR)) 142 | (let ((record-length (record-type-record-length record-type)) 143 | (procedure-name `(RECORD-ACCESSOR ,record-type ',field-name)) 144 | (index 145 | (record-type-field-index record-type field-name 'RECORD-ACCESSOR))) 146 | (lambda (record) 147 | (if (not (and (vector? record) 148 | (= (vector-length record) record-length) 149 | (eq? (vector-ref record 0) record-type))) 150 | (record-type-error record record-type procedure-name)) 151 | (vector-ref record index)))) 152 | 153 | (define (record-modifier record-type field-name) 154 | (if (not (record-type? record-type)) 155 | (error:wrong-type-argument record-type "record type" 'RECORD-UPDATER)) 156 | (let ((record-length (record-type-record-length record-type)) 157 | (procedure-name `(RECORD-UPDATER ,record-type ',field-name)) 158 | (index 159 | (record-type-field-index record-type field-name 'RECORD-UPDATER))) 160 | (lambda (record field-value) 161 | (if (not (and (vector? record) 162 | (= (vector-length record) record-length) 163 | (eq? (vector-ref record 0) record-type))) 164 | (record-type-error record record-type procedure-name)) 165 | (vector-set! record index field-value)))) 166 | 167 | (define record-updater 168 | record-modifier) 169 | -------------------------------------------------------------------------------- /src/README: -------------------------------------------------------------------------------- 1 | -*-Indented-Text-*- 2 | 3 | Sources for the Thomas implementation 4 | 5 | All files here are implementation independent (as far as we know). 6 | 7 | Load-Up Files 8 | 9 | These files simply load others. Each file has a brief comment 10 | describing the ones it loads. 11 | 12 | load-compiler.scm builds a Thomas to Scheme compiler. 13 | load-runtime.scm builds a Scheme implementation of the Thomas runtime 14 | system. 15 | load-thomas.scm loads both the compiler and the runtime system as well 16 | as the file rep.scm which contains an interactive read-eval-print 17 | loop for Thomas. 18 | 19 | $Id: src_README,v 1.3 1992/09/25 13:41:08 birkholz Exp $ 20 | -------------------------------------------------------------------------------- /src/class-structure.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: class-structure.scm,v 1.4 1992/09/20 08:42:02 birkholz Exp $ 39 | 40 | ;;;; Build the class structure for Dylan runtime environment. 41 | 42 | (define 43 | (make-dylan-class ' '() '() #T)) 44 | 45 | ;;;; Number classes 46 | 47 | ;;; Abstract 48 | 49 | (define 50 | (make-dylan-class ' (list ) '() #F)) 51 | 52 | ;;; Sealed 53 | 54 | (define 55 | (make-dylan-class ' (list ) '() #F)) 56 | (define 57 | (make-dylan-class ' (list ) '() #F)) 58 | (define 59 | (make-dylan-class ' (list ) '() #F)) 60 | (define 61 | (make-dylan-class ' (list ) '() #F)) 62 | (define 63 | (make-dylan-class ' (list ) '() #F)) 64 | (define 65 | (make-dylan-class ' (list ) '() #F)) 66 | (define 67 | (make-dylan-class ' (list ) '() #F)) 68 | (define 69 | (make-dylan-class ' (list ) '() #F)) 70 | (define 71 | (make-dylan-class ' (list ) '() #F)) 72 | (define 73 | (make-dylan-class ' (list ) '() #F)) 74 | 75 | ;;;; Collections 76 | 77 | ;;; Abstract 78 | 79 | (define 80 | (make-dylan-class ' (list ) '() #F)) 81 | (define 82 | (make-dylan-class ' (list ) '() #F)) 83 | (define 84 | (make-dylan-class ' (list ) '() #F)) 85 | (define 86 | (make-dylan-class ' (list ) '() #F)) 87 | (define 88 | (make-dylan-class ' 89 | (list 90 | ) '() #F)) 91 | (define 92 | (make-dylan-class ' 93 | (list ) '() #F)) 94 | 95 | ;;; Instantiable 96 | 97 | (define 98 | (make-dylan-class ' (list ) '() #F)) 99 | (define 100 | (make-dylan-class '
(list ) '() #F)) 101 | (define 102 | (make-dylan-class ' (list ) '() #F)) 103 | (define 104 | (make-dylan-class ' (list ) '() #F)) 105 | (define 106 | (make-dylan-class ' (list ) '() #F)) 107 | (define 108 | (make-dylan-class ' (list ) '() #F)) 109 | (define 110 | (make-dylan-class ' (list ) '() #F)) 111 | 112 | ;;; Sealed 113 | 114 | (define 115 | (make-dylan-class ' (list ) '() #F)) 116 | (define 117 | (make-dylan-class ' (list ) '() #F)) 118 | (define 119 | (make-dylan-class ' (list ) '() #F)) 120 | (define 121 | (make-dylan-class ' (list ) '() #F)) 122 | (define 123 | (make-dylan-class ' (list ) '() #F)) 124 | (define 125 | (make-dylan-class ' (list ) '() #F)) 126 | 127 | ;;;; Conditions 128 | 129 | (define 130 | (make-dylan-class ' (list ) '() #F)) 131 | (define 132 | (make-dylan-class ' (list ) '() #F)) 133 | (define 134 | (make-dylan-class ' (list ) '() #F)) 135 | (define 136 | (make-dylan-class ' (list ) '() #F)) 137 | (define 138 | (make-dylan-class ' (list ) '() #F)) 139 | (define 140 | (make-dylan-class ' (list ) '() #F)) 141 | (define 142 | (make-dylan-class ' (list ) '() #F)) 143 | (define 144 | (make-dylan-class ' (list ) '() #F)) 145 | (define 146 | (make-dylan-class ' (list ) '() #F)) 147 | (define 148 | (make-dylan-class ' (list ) '() #F)) 149 | 150 | ;;;; Others 151 | 152 | (define ; Abstract 153 | (make-dylan-class ' (list ) '() #F)) 154 | (define ; Instantiable 155 | (make-dylan-class ' (list ) '() #F)) 156 | (define ; Abstract 157 | (make-dylan-class ' (list ) '() #F)) 158 | (define ; Abstract 159 | (make-dylan-class ' (list ) '() #F)) 160 | (define ; Abstract 161 | (make-dylan-class ' (list ) '() #F)) 162 | (define ; Abstract 163 | (make-dylan-class ' (list ) '() #F)) 164 | (define ; Instantiable 165 | (make-dylan-class ' (list ) '() #F)) 166 | (define ; Instantiable 167 | (make-dylan-class ' (list ) '() #F)) 168 | (define ; Instantiable 169 | (make-dylan-class ' (list ) '() #F)) 170 | -------------------------------------------------------------------------------- /src/common.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: common.scm,v 1.3 1992/09/09 23:06:25 birkholz Exp $ 39 | 40 | (dylan::load "support") 41 | -------------------------------------------------------------------------------- /src/comp-exc.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: comp-exc.scm,v 1.8 1992/09/09 20:30:50 jmiller Exp $ 39 | 40 | ;;;; More of the compiler: exception handler special forms 41 | ;;;; 42 | ;;;; HANDLER-BIND, HANDLER-CASE 43 | 44 | (define (compile-one-binding module-vars bound-vars really-compile) 45 | (lambda (type compiled-func compiled-form keywords continue) 46 | (let ((test (dylan::find-keyword 47 | keywords 'TEST: 48 | (lambda () '(METHOD (CONDITION) CONDITION #T)))) 49 | (desc (dylan::find-keyword 50 | keywords 'DESCRIPTION: 51 | (lambda () '(METHOD (STREAM) STREAM #F))))) 52 | (compile-forms (list type test desc) 53 | module-vars bound-vars really-compile #F 54 | (lambda (comp-handler-spec module-vars) 55 | (continue 56 | `(DYLAN::HANDLER-BIND 57 | ,(car comp-handler-spec) ; Type 58 | ,compiled-func ; Function 59 | ,(cadr comp-handler-spec) ; Test 60 | ,(caddr comp-handler-spec) ; Description 61 | (LAMBDA () ,compiled-form)) 62 | module-vars)))))) 63 | 64 | (define (compile-HANDLER-BIND-form 65 | e module-vars bound-vars really-compile multiple-values? continue) 66 | (must-be-list-of-at-least-length e 1 "HANDLER-BIND: bad syntax") 67 | (let ((handler-spec (car e)) 68 | (form (if (null? (cdr e)) #F `(BEGIN ,@(cdr e))))) 69 | (must-be-list-of-at-least-length 70 | handler-spec 2 "HANDLER-BIND: bad syntax for handler specification") 71 | (let ((keywords (cddr handler-spec))) 72 | (validate-keywords keywords '(TEST: DESCRIPTION:) dylan::error) 73 | (let ((type (car handler-spec)) 74 | (func (cadr handler-spec))) 75 | (compile-forms (list func form) ; Form is a reduction 76 | module-vars bound-vars 77 | really-compile multiple-values? 78 | (lambda (compiled-func-and-forms module-vars) 79 | ((compile-one-binding module-vars bound-vars 80 | really-compile) 81 | type 82 | (car compiled-func-and-forms) 83 | (cadr compiled-func-and-forms) 84 | keywords 85 | continue))))))) 86 | 87 | (define (compile-HANDLER-CASE-form 88 | e module-vars bound-vars really-compile multiple-values? continue) 89 | (must-be-list-of-at-least-length e 1 "HANDLER-CASE: bad syntax") 90 | (let ((protected-form (car e)) 91 | (protections (cdr e))) 92 | (for-each (lambda (protection) 93 | (must-be-list-of-at-least-length 94 | protection 1 95 | "HANDLER-CASE: bad protection clause") 96 | (must-be-list-of-at-least-length 97 | (car protection) 1 98 | "HANDLER-CASE: bad handler description")) 99 | protections) 100 | (really-compile protected-form module-vars bound-vars multiple-values? 101 | (lambda (compiled-form module-vars) 102 | (let loop ((protections protections) 103 | (code `(LET ((!HANDLER-CASE:VALUE ,compiled-form)) 104 | (!HANDLER-CASE:EXIT 105 | (LAMBDA () !HANDLER-CASE:VALUE)))) 106 | (module-vars module-vars)) 107 | (if (null? protections) 108 | (continue 109 | `((CALL-WITH-CURRENT-CONTINUATION 110 | (LAMBDA (!HANDLER-CASE:EXIT) ,code))) 111 | module-vars) 112 | (let* ((this-binding (car protections)) 113 | (protection (car this-binding)) 114 | (forms (cdr this-binding)) 115 | (type (car protection)) 116 | (keywords (cdr protection)) 117 | (condition 118 | (dylan::find-keyword keywords 'CONDITION: 119 | (lambda () #F)))) 120 | (really-compile 121 | (if forms `(BEGIN ,@forms) #F) module-vars 122 | (if condition (cons condition bound-vars) bound-vars) 123 | multiple-values? 124 | (lambda (compiled-function-body module-vars) 125 | ((compile-one-binding module-vars bound-vars really-compile) 126 | type 127 | `(LAMBDA (!HANDLER-CASE:MULTIPLE-VALUES 128 | !NEXT-METHOD 129 | ,(or condition '!CONDITION) 130 | !NEXT-HANDLER) 131 | !HANDLER-CASE:MULTIPLE-VALUES ; Ignore 132 | !NEXT-METHOD ; Ignore 133 | !NEXT-HANDLER ; Ignore 134 | ,(or condition '!CONDITION) ; Ignore 135 | (!HANDLER-CASE:EXIT 136 | (LAMBDA () ,compiled-function-body))) 137 | code 138 | keywords 139 | (lambda (compiled-code module-vars) 140 | (loop (cdr protections) 141 | compiled-code 142 | module-vars)))))))))))) 143 | -------------------------------------------------------------------------------- /src/comp-util.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: comp-util.scm,v 1.12 1992/09/05 16:05:18 jmiller Exp $ 39 | 40 | ;;;; Utility procedures for use at compile time only 41 | ;;;; 42 | ;;;; Name operations: new-name, name->module-getter, 43 | ;;;; name->module-setter, name->setter, 44 | ;;;; variable->name, variable-name?, 45 | ;;;; name->keyword, dylan-special-name? 46 | ;;;; General: cant-parse, list-of-length?, list-of-at-least-length?, 47 | ;;;; must-be-list-of-length, must-be-list-of-at-least-length, 48 | ;;;; set-difference 49 | ;;;; Compiler specific: module-refs, add-variable, add-module-variable 50 | 51 | ;;; Name operations. These convert from Dylan names (including 52 | ;;; (SETTER x) and Keyword:) to Scheme forms. 53 | 54 | ; new-name is now in support.scm, since it is used at runtime as well as compile time 55 | 56 | (define (name->module-getter name) 57 | (new-name "dylan:module-get/" (variable->name name) "/")) 58 | (define (name->module-setter name) 59 | (new-name "dylan:module-set/" (variable->name name) "/!")) 60 | 61 | (define (name->setter name) 62 | (new-name "dylan:setter/" name "/")) 63 | 64 | (define (name->scheme-safe-name name) 65 | (new-name "dylan:scheme-safe/" name "/")) 66 | 67 | (define scheme-reserved-names 68 | '(=> and begin case cond define delay do else if lambda let let* 69 | letrec or quasiquote quote set! unquote unquote-splicing)) 70 | 71 | (define (variable->name dylan-variable) 72 | (if (symbol? dylan-variable) 73 | (cond ((assq dylan-variable dylan::scheme-names-of-predefined-names) 74 | => cadr) 75 | ((memq dylan-variable scheme-reserved-names) 76 | (name->scheme-safe-name dylan-variable)) 77 | (else dylan-variable)) 78 | (name->setter (cadr dylan-variable)))) 79 | 80 | (define (variable-name? x) 81 | (define (simple-variable-name? x) 82 | (and (symbol? x) 83 | (not (keyword? x)) 84 | (not (dylan-special-name? x)))) 85 | (or (simple-variable-name? x) 86 | (and (list-of-length? x 2) 87 | (eq? (car x) 'SETTER) 88 | (simple-variable-name? (cadr x))))) 89 | 90 | (define (name->keyword symbol) 91 | (new-name "" symbol ":")) 92 | 93 | (define (dylan-special-name? x) 94 | ;; The Scheme reader doesn't allow Dylan's #rest, etc. so we 95 | ;; simulate them with !rest and preclude the use of variable names 96 | ;; that begin with "dylan:" or "!" 97 | (and (symbol? x) 98 | (let* ((string (symbol->string x)) 99 | (length (string-length string)) 100 | (chars (string->list string))) 101 | (or (and (> length 0) (char=? #\! (car chars))) 102 | (and (> length 5) (string-ci=? "dylan:" 103 | (substring string 0 6))))))) 104 | 105 | ; (keyword? obj) is used at runtime: see support.scm 106 | 107 | ;;; General support operations needed only at compile time 108 | 109 | (define (cant-parse reason orig-l l) 110 | (dylan::error (string-append "illegal parameter list in " reason) 111 | orig-l l)) 112 | 113 | (define (list-of-length? l n) 114 | (cond ((and (= n 0) (null? l)) #T) 115 | ((or (= n 0) (not (pair? l))) #F) 116 | (else (list-of-length? (cdr l) (- n 1))))) 117 | 118 | (define (list-of-at-least-length? l n) 119 | (and (list? l) 120 | (let loop ((l l) (n n)) 121 | (cond ((= n 0) #T) 122 | ((not (pair? l)) #F) 123 | (else (loop (cdr l) (- n 1))))))) 124 | 125 | (define (must-be-list-of-length l n error-message) 126 | (or (list-of-length? l n) 127 | (dylan::error error-message l))) 128 | 129 | (define (must-be-list-of-at-least-length l n error-message) 130 | (or (list-of-at-least-length? l n) 131 | (dylan::error error-message l))) 132 | 133 | (define (module-refs 134 | variable bound-vars module-vars continue core) 135 | ;; Called to generate code to deal with direct references to module 136 | ;; variables. name is the variable name, core is a procedure to 137 | ;; generate the main body. 138 | (let* ((name (variable->name variable)) 139 | (hidden? (memq name bound-vars))) 140 | (continue 141 | (if hidden? 142 | `(LET ((!OLD-VALUE (,(name->module-getter name)))) 143 | ,(core '!OLD-VALUE 144 | (lambda (val) `(,(name->module-setter name) ,val)))) 145 | (core name (lambda (val) `(SET! ,name ,val)))) 146 | (add-module-variable name hidden? module-vars)))) 147 | 148 | ;;; Compile a list of forms, producing a list of corresponding Scheme 149 | ;;; forms and the (updated) module variables. 150 | 151 | (define (add-variable name bound-vars module-vars) 152 | (if (or (memq name bound-vars) 153 | (memq name dylan::predefined-variables)) 154 | module-vars 155 | (adjoin name module-vars memq))) 156 | 157 | (define (add-module-variable 158 | name require-accessor-fns module-vars) 159 | (if (or require-accessor-fns (not (memq name dylan::predefined-names))) 160 | (adjoin name module-vars memq) 161 | module-vars)) 162 | 163 | (define (must-be-unique objects predicate error-string) 164 | (if (not (unique? objects predicate)) 165 | (dylan::error error-string (car objects) objects))) 166 | -------------------------------------------------------------------------------- /src/comp.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: comp.scm,v 1.1 1992/09/09 22:08:15 jmiller Exp $ 39 | 40 | (for-each dylan::load '("comp-util" 41 | "compiler" 42 | "comp-method" 43 | "comp-class" 44 | "comp-sf" 45 | "comp-exc")) 46 | 47 | -------------------------------------------------------------------------------- /src/load-compiler.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: load-compiler.scm,v 1.12 1992/09/09 22:08:33 jmiller Exp $ 39 | 40 | (load "implementation-specific") 41 | 42 | (dylan::load "common") 43 | (dylan::load "comp") 44 | -------------------------------------------------------------------------------- /src/load-runtime.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: load-runtime.scm,v 1.3 1992/09/09 22:07:04 jmiller Exp $ 39 | 40 | (load "implementation-specific") 41 | (dylan::load "common") 42 | (dylan::load "runtime") 43 | -------------------------------------------------------------------------------- /src/load-thomas.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: load-thomas.scm,v 1.3 1992/09/10 01:11:19 jmiller Exp birkholz $ 39 | 40 | (load "implementation-specific") 41 | (dylan::load "common") 42 | (dylan::load "comp") 43 | (dylan::load "runtime") 44 | (dylan::load "rep") 45 | -------------------------------------------------------------------------------- /src/portable-rep.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: portable-rep.scm,v 1.8 1992/09/21 21:30:56 birkholz Exp $ 39 | 40 | ;;; Just use current (user?) environment and keep a list of known module 41 | ;;; variables in thomas-rep-module-variables. 42 | 43 | (define thomas-rep-module-variables '()) 44 | 45 | (define (empty-thomas-environment!) 46 | ;; Just dump thomas-rep-module-variables. 47 | (set! thomas-rep-module-variables '())) 48 | 49 | (define (thomas-rep) 50 | (newline) 51 | (display "Entering Thomas read-eval-print-loop.") 52 | (newline) 53 | (display "Exit by typing \"thomas:done\"") 54 | (newline) 55 | (dylan::catch-all-conditions 56 | (lambda () 57 | (let loop () 58 | (newline) 59 | (display "? ") 60 | (let ((input (read))) 61 | (newline) 62 | (if (and (eq? input 'thomas:done)) 63 | 'thomas:done 64 | (compile-expression 65 | input '!MULTIPLE-VALUES thomas-rep-module-variables 66 | (lambda (new-vars preamble compiled-output) 67 | (implementation-specific:eval 68 | `(BEGIN 69 | ,@preamble 70 | (LET* ((!MULTIPLE-VALUES (VECTOR '())) 71 | (!RESULT ,compiled-output)) 72 | (IF (EQ? !RESULT !MULTIPLE-VALUES) 73 | (LET RESULT-LOOP 74 | ((COUNT 1) 75 | (RESULTS (VECTOR-REF !MULTIPLE-VALUES 0))) 76 | (IF (PAIR? RESULTS) 77 | (LET ((RESULT (CAR RESULTS))) 78 | (NEWLINE) 79 | (DISPLAY ";Value[")(DISPLAY COUNT) 80 | (DISPLAY "]: ")(WRITE RESULT) 81 | (RESULT-LOOP (+ 1 COUNT) (CDR RESULTS))) 82 | (NEWLINE))) 83 | (BEGIN 84 | (NEWLINE)(DISPLAY ";Value: ")(WRITE !RESULT) 85 | (NEWLINE)))))) 86 | (set! thomas-rep-module-variables 87 | (append new-vars thomas-rep-module-variables)) 88 | (loop))))))))) 89 | 90 | (display " 91 | Apply thomas-rep to start a Thomas read-eval-print loop. 92 | ") 93 | -------------------------------------------------------------------------------- /src/runtime-bitstrings.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: runtime-bitstrings.scm,v 1.7 1992/09/03 16:20:45 jmiller Exp $ 39 | 40 | ;;;; Support for handling integers as bit strings 41 | 42 | ;;; 43 | ;;; UTILITY FUNCTIONS 44 | ;;; 45 | 46 | (define (flip-bit bit) (if (= 0 bit) 1 0)) 47 | 48 | (define (negate-bits l) 49 | (let loop ((answer '()) 50 | (remainder (reverse (map flip-bit l)))) 51 | (cond ((null? remainder) l) ; (0 0 0 0 ...) was input 52 | ((= (car remainder) 0) 53 | (append (reverse (cdr remainder)) '(1) answer)) 54 | (else (loop (cons (flip-bit (car remainder)) answer) 55 | (cdr remainder)))))) 56 | 57 | (define (integer->bits integer) 58 | (if (negative? integer) 59 | (let ((nbits (negate-bits (cdr (integer->bits (- integer)))))) 60 | (if (zero? (car nbits)) 61 | (cons 1 nbits) 62 | nbits)) 63 | (let loop ((bits '()) 64 | (value integer)) 65 | (cond ((zero? value) (cons 0 bits)) 66 | ((even? value) (loop (cons 0 bits) (quotient value 2))) 67 | (else (loop (cons 1 bits) 68 | (quotient (- value 1) 2))))))) 69 | 70 | (define (pad-bitstring-to n bits) 71 | (let ((basic-bits (length bits))) 72 | (if (< n basic-bits) 73 | (dylan-call dylan:error "bitstring internal length error")) 74 | (append 75 | (vector->list 76 | (make-vector (- n basic-bits) (if (null? bits) 0 (car bits)))) 77 | bits))) 78 | 79 | (define (integers->same-length integer1 integer2 continue) 80 | (let ((bits1 (integer->bits integer1)) 81 | (bits2 (integer->bits integer2))) 82 | (let ((length1 (length bits1)) 83 | (length2 (length bits2))) 84 | (cond ((= length1 length2) (continue bits1 bits2)) 85 | ((< length1 length2) 86 | (continue (pad-bitstring-to length2 bits1) bits2)) 87 | (else 88 | (continue bits1 (pad-bitstring-to length1 bits2))))))) 89 | 90 | (define (bits->integer bits) 91 | (define (unsigned->integer bits) 92 | (let loop ((result 0) 93 | (bits bits)) 94 | (if (null? bits) 95 | result 96 | (loop (+ (car bits) (* 2 result)) (cdr bits))))) 97 | (cond ((zero? (car bits)) (unsigned->integer (cdr bits))) 98 | ((null? (cdr bits)) -1) 99 | (else (- (unsigned->integer (negate-bits (cdr bits))))))) 100 | 101 | (define (logical-bitstr vals) 102 | ;; Vals is a vector '#(0/0 0/1 1/0 1/1) 103 | (lambda (int1 int2) 104 | (bits->integer 105 | (integers->same-length int1 int2 106 | (lambda (bits1 bits2) 107 | (map (lambda (a b) (vector-ref vals (+ (* 2 a) b))) 108 | bits1 bits2)))))) 109 | 110 | (define (logical-op-only-rest-args no-arg-value vals) 111 | (lambda all-integers 112 | (if (not all-integers) 113 | no-arg-value 114 | (let loop ((integers-left (cdr all-integers)) 115 | (op-result (car all-integers))) 116 | (if (null? integers-left) 117 | op-result 118 | (loop (cdr integers-left) 119 | ((logical-bitstr vals) op-result (car integers-left)))))))) 120 | 121 | ;;; 122 | ;;; DYLAN FUNCTIONS 123 | ;;; 124 | 125 | (define dylan:ash 126 | ;; Assume (ash int count) shifts int left by count bits if count>0, right if 127 | ;; count<0 128 | (dylan::generic-fn 'ash two-integers 129 | (lambda (integer shift) 130 | (dylan-call dylan:floor (* (expt 2 shift) integer))))) 131 | 132 | ; (cond ((or (zero? shift) (zero? integer)) integer) 133 | ; ((positive? shift) (* (expt 2 shift) integer)) 134 | ; (else 135 | ; (let ((bits (integer->bits integer))) 136 | ; (if (>= (- shift) (length bits)) 137 | ; (if (negative? integer) -1 0) 138 | ; (quotient integer (expt 2 (- shift)))))))))) 139 | 140 | (define dylan:logand 141 | (dylan::generic-fn 'logand only-rest-args 142 | (logical-op-only-rest-args -1 '#(0 0 0 1)))) 143 | 144 | (define dylan:logandc1 145 | (dylan::generic-fn 'logandc1 two-integers 146 | (logical-bitstr '#(0 1 0 0)))) 147 | 148 | (define dylan:logandc2 149 | (dylan::generic-fn 'logandc2 two-integers 150 | (logical-bitstr '#(0 0 1 0)))) 151 | 152 | (define dylan:logbit? 153 | ;; Assuming this is a bit index primitive with 0 being the low bit 154 | ;; and assuming it should treat the integer as sign extended 155 | ;; Number representation is 2's complement (sign extended) 156 | (dylan::generic-fn 'logbit two-integers 157 | (lambda (index integer) 158 | (if (negative? index) 159 | (dylan-call dylan:error "logbit? -- negative index" index integer)) 160 | (let* ((integer-bits (integer->bits integer)) 161 | (bit-index (- (length integer-bits) index 1))) 162 | (if (negative? bit-index) 163 | (negative? integer) 164 | (= (list-ref integer-bits (- (length integer-bits) index 1)) 1)))))) 165 | 166 | (define dylan:logeqv 167 | (dylan::generic-fn 'logeqv two-integers 168 | (logical-op-only-rest-args -1 '#(1 0 0 1)))) 169 | 170 | (define dylan:logior 171 | (dylan::generic-fn 'logior only-rest-args 172 | (logical-op-only-rest-args 0 '#(0 1 1 1)))) 173 | 174 | (define dylan:lognand 175 | (dylan::generic-fn 'lognand two-integers 176 | (logical-bitstr '#(1 1 1 0)))) 177 | 178 | (define dylan:lognor 179 | (dylan::generic-fn 'lognor two-integers 180 | (logical-bitstr '#(1 0 0 0)))) 181 | 182 | (define dylan:lognot 183 | (dylan::generic-fn 'lognot one-integer 184 | (lambda (integer) 185 | (bits->integer (map flip-bit (integer->bits integer)))))) 186 | 187 | (define dylan:logorc1 188 | (dylan::generic-fn 'logorc1 two-integers 189 | (logical-bitstr '#(1 1 0 1)))) 190 | 191 | (define dylan:logorc2 192 | (dylan::generic-fn 'logorc2 two-integers 193 | (logical-bitstr '#(1 0 1 1)))) 194 | 195 | (define dylan:logxor 196 | (dylan::generic-fn 'logxor two-integers 197 | (logical-op-only-rest-args 0 '#(0 1 1 0)))) -------------------------------------------------------------------------------- /src/runtime-collections-table.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: runtime-collections-table.scm,v 1.16 1992/08/31 05:30:12 birkholz Exp $ 39 | 40 | ;;;; Specializations for tables. 41 | 42 | (add-method dylan:shallow-copy 43 | (dylan::function->method 44 | (make-param-list `((TABLE ,
)) #F #F #F) 45 | (lambda (table) 46 | (let* ((new-table (dylan-call dylan:make
)) 47 | (key-sequence (dylan-call dylan:key-sequence table))) 48 | (do ((state (dylan-call dylan:initial-state key-sequence) 49 | (dylan-call dylan:next-state key-sequence state))) 50 | ((not state) 51 | (dylan-call dylan:as 52 | (dylan-call dylan:class-for-copy table) 53 | new-table)) 54 | (let ((key (dylan-call dylan:current-element key-sequence state))) 55 | (dylan-call dylan:setter/element/ 56 | new-table 57 | key 58 | (dylan-call dylan:element table key)))))))) 59 | (add-method dylan:as 60 | (dylan::function->method 61 | (make-param-list `((CLASS ,(dylan::make-singleton
)) 62 | (COLLECTION ,)) #F #F #F) 63 | (lambda (class collection) 64 | class 65 | (if (dylan-call dylan:instance? collection
) 66 | collection 67 | (let ((table (dylan-call dylan:make
)) 68 | (key-sequence (dylan-call dylan:key-sequence collection))) 69 | (do ((state (dylan-call dylan:initial-state key-sequence) 70 | (dylan-call dylan:next-state key-sequence state))) 71 | ((not state) table) 72 | (let ((cur-element 73 | (dylan-call dylan:current-element key-sequence state))) 74 | (dylan-call dylan:setter/element/ table cur-element 75 | (dylan-call 76 | dylan:element collection cur-element))))))))) 77 | 78 | 79 | 80 | ;;; 81 | ;;; TABLE SPECIALIZED MAKE 82 | ;;;
creates an empty hash table 83 | ;;; 84 | (define *HASH-TABLE-SIZE* 500) 85 | 86 | (define dylan:get-hash-table "define dylan:get-hash-table") 87 | (define dylan:set-hash-table! "define dylan:set-hash-table!") 88 | (create-private-slot
"internal-hash-table" 89 | (lambda (set get) 90 | (set! dylan:set-hash-table! set) 91 | (set! dylan:get-hash-table get))) 92 | (add-method dylan:make 93 | (dylan::function->method 94 | (make-param-list `((TABLE ,(dylan::make-singleton
))) #F #F #T) 95 | (lambda (class . rest) 96 | class ; ignored 97 | rest ; ignored 98 | (let ((instance (dylan::make-
))) 99 | (dylan-call dylan:set-hash-table! instance 100 | (make-vector *hash-table-size* '())) 101 | instance)))) 102 | 103 | ;;;; 104 | ;;;; Operations on Tables (page 120) 105 | ;;;; 106 | (define (dylan-assoc key alist) ; Use dylan:binary= to compare keys 107 | (let loop ((rest-alist alist)) 108 | (if rest-alist 109 | (if (dylan-call dylan:binary= key (caar rest-alist)) 110 | (car rest-alist) 111 | (loop (cdr rest-alist))) 112 | #F))) 113 | 114 | (define dylan:remove-key! 115 | (dylan::generic-fn 'remove-key! 116 | (make-param-list `((TABLE ,
) (KEY ,)) #F #F #F) 117 | (lambda (table key) 118 | (let* ((hash-table (dylan-call dylan:get-hash-table table)) 119 | (hash-index (dylan-call dylan:=hash key)) 120 | (hash-entry (vector-ref hash-table hash-index)) 121 | (match (dylan-assoc key hash-entry))) 122 | (if match 123 | (vector-set! hash-table hash-index 124 | (dylan-call dylan:remove hash-entry match)) 125 | 'no-match))))) 126 | 127 | 128 | (add-method dylan:setter/element/ 129 | (dylan::function->method 130 | (make-param-list 131 | `((TABLE ,
) (KEY ,) (NEW-VALUE ,)) #F #F #F) 132 | (lambda (table key new-value) 133 | (let ((hash-index (remainder (dylan-call dylan:=hash key) 134 | *HASH-TABLE-SIZE*)) 135 | (hash-table (dylan-call dylan:get-hash-table table))) 136 | (if (>= hash-index (vector-length hash-table)) 137 | (dylan-call dylan:error "((setter element)
) -- internal error, size out of sync" table hash-index key new-value) 138 | (let* ((hash-entry (vector-ref hash-table hash-index)) 139 | (match (dylan-assoc key hash-entry))) 140 | (if match 141 | (set-cdr! match (list new-value)) 142 | (vector-set! hash-table hash-index 143 | (cons (list key new-value) 144 | hash-entry))) 145 | new-value)))))) 146 | 147 | 148 | 149 | (define (grow-vector-by v increase) 150 | (let* ((n-old-values (vector-length v)) 151 | (new-v (make-vector (+ n-old-values increase)))) 152 | (vector-iterate v 153 | (lambda (i entry) (vector-set! new-v i entry))) 154 | new-v)) 155 | 156 | 157 | (add-method dylan:map-into 158 | (dylan::function->method 159 | (make-param-list 160 | `((TABLE ,
) (PROCEDURE ,) (COLLECTION ,)) 161 | #F 'REST #F) 162 | (lambda (table proc coll-1 . rest) 163 | (let loop ((key-sequence (dylan-call dylan:key-sequence coll-1)) 164 | (rest-coll rest)) 165 | (if rest-coll 166 | (loop (dylan-call dylan:intersection key-sequence 167 | (dylan-call dylan:key-sequence (car rest-coll))) 168 | (cdr rest-coll)) 169 | (let ((all-collections (cons coll-1 rest))) 170 | (do ((state (dylan-call dylan:initial-state key-sequence) 171 | (dylan-call dylan:next-state key-sequence state))) 172 | ((not state) table) 173 | (let ((current-key (dylan-call 174 | dylan:current-element key-sequence state))) 175 | (dylan-call 176 | dylan:setter/element/ 177 | table 178 | current-key 179 | (dylan-call dylan:apply proc 180 | (map (lambda (coll) 181 | (dylan-call 182 | dylan:element coll current-key)) 183 | all-collections))))))))))) 184 | 185 | ;;; 186 | ;;; Mutable Collections 187 | ;;; 188 | 189 | (add-method dylan:setter/current-element/ 190 | (dylan::function->method 191 | (make-param-list 192 | `((TABLE ,
) (STATE ,) (new-value ,)) #F #F #F) 193 | (lambda (table state new-value) 194 | (dylan-call dylan:setter/element/ 195 | table 196 | (dylan-call dylan:current-key table state) 197 | new-value)))) 198 | -------------------------------------------------------------------------------- /src/runtime-collections.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: runtime-collections.scm,v 1.19 1992/09/09 22:12:55 jmiller Exp $ 39 | 40 | ;;;;; RUNTIME-COLLECTIONS.SCM 41 | 42 | ;;;;; The specializations of method based on collection type are in the file: 43 | ;;;;; runtime-collections-xxx.scm (where xxx is collection type) 44 | 45 | ;;; Class definitions on pages 111 and 112 imply specialization for 46 | ;;; the make operation. 47 | ;;; 48 | ;;; General theory of operation: some of the collection types are 49 | ;;; handled very, very specially to make them more efficient. In 50 | ;;; particular: 51 | ;;; : implemented as a Scheme string, 52 | ;;; : implemented as a Scheme vector 53 | ;;; , , : implemented in Scheme 54 | ;;; 55 | ;;; All other collection types are instances (in the sense of 56 | ;;; "created by calling make-instance in class.scm"). 57 | ;;; 58 | ;;; Consequences of this decision: any generic operation on a class 59 | ;;; which is a superclass of one of the special classes MUST BE 60 | ;;; SPECIALIZED for the special case. This can either be done by 61 | ;;; conditionalizing the code that handles the superclass or by 62 | ;;; providing a specific method for the special subclass. 63 | 64 | 65 | ;;; KNOWN PROBLEMS 66 | 67 | ;;; 68 | ;;; UTILITY FUNCTIONS 69 | ;;; 70 | (define (one-arg name type fn) 71 | (dylan::function->method 72 | (make-param-list `((,name ,type)) #F #F #F) fn)) 73 | 74 | (define (but-last list) 75 | (reverse (cdr (reverse list)))) 76 | 77 | (define (create-private-slot owner type-restriction name continue) 78 | ;; Adds a new slot to an existing class, and returns the getter and 79 | ;; setter generic functions to be used for the slot. 80 | (define the-getter 81 | (dylan::generic-fn (new-name "dylan:" name "-getter") 82 | (make-param-list `((ARRAY ,)) #F #F #F) 83 | #F)) 84 | 85 | (define the-setter 86 | (dylan::generic-fn (new-name "dylan:" name "-setter!") 87 | (make-param-list `((ARRAY ,) (VALUE ,)) #F #F #F) 88 | #F)) 89 | 90 | (dylan::add-slot owner 91 | type-restriction 'INSTANCE the-setter the-getter 92 | (new-name "" name "") #F #F #F #F #F) 93 | 94 | (continue the-setter the-getter)) 95 | -------------------------------------------------------------------------------- /src/runtime-internal.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: runtime-internal.scm,v 1.9 1992/09/20 08:20:20 birkholz Exp $ 39 | 40 | ;;;; This file contains the functions that are referenced only 41 | ;;;; directly by the output of the Dylan to Scheme compiler, rather 42 | ;;;; than user code written in Dylan. 43 | ;;;; 44 | ;;;; Many of the functions here are just renamings of ordinary Scheme 45 | ;;;; functions. The renaming is necessary to prevent name clashes 46 | ;;;; between Dylan and Scheme variables at run time. 47 | 48 | (define (dylan::free-variable-ref value name) 49 | (if (eq? value the-unassigned-value) 50 | (dylan-call dylan:error "unbound variable" name) 51 | value)) 52 | 53 | (define dylan::call/cc ; Used for BIND-EXIT 54 | call-with-current-continuation) 55 | 56 | (define (dylan::dotimes count result-fn fn) 57 | ;; Used for DOTIMES special form 58 | (let loop ((n 0)) 59 | (if (>= n count) 60 | (result-fn) 61 | (begin 62 | (fn n) 63 | (loop (+ n 1)))))) 64 | 65 | (define (dylan::while test thunk) 66 | ;; Used for UNTIL and WHILE special forms 67 | (let loop () 68 | (if (test) 69 | (begin (thunk) (loop)) 70 | #F))) 71 | 72 | (define (dylan::apply multiple-values? operator-thunk . operand-thunks) 73 | ;; Used for combinations. 74 | ;; Forces left-to-right evaluation, and adds an initial #F next 75 | ;; method argument. 76 | (let loop ((rands '()) 77 | (rest operand-thunks)) 78 | (if (null? rest) 79 | (apply (operator-thunk) 80 | multiple-values? 81 | NEXT-METHOD:NOT-GENERIC 82 | (reverse rands)) 83 | (let ((next ((car rest)))) 84 | (loop (cons next rands) (cdr rest)))))) 85 | 86 | (define dylan::scheme-apply apply) 87 | 88 | (define dylan::dynamic-wind ; Used for UNWIND-PROTECT 89 | dynamic-wind) 90 | 91 | (define (dylan::type-check value class) ; Used for BIND 92 | ; (let ((type-of-object (get-type value))) 93 | ; (if (not (subclass? type-of-object class)) 94 | ; (dylan-call dylan:error 95 | ; "BINDing-time restriction violation" class value))) 96 | ;; Should signal a ! 97 | (dylan-call dylan:check-type value class)) 98 | 99 | (define dylan::list list) ; BIND 100 | (define dylan::cons cons) ; BIND 101 | (define dylan::car car) ; BIND 102 | (define dylan::vector vector) ; BIND 103 | (define dylan::vector-ref vector-ref) ; BIND 104 | (define dylan::not not) ; DEFINE-GENERIC-FUNCTION, UNLESS 105 | (define dylan::eq? eq?) ; DEFINE-GENERIC-FUNCTION 106 | (define dylan::class? class?) ; DEFINE-CLASS 107 | (define dylan::make-param-list ; METHOD 108 | make-param-list) 109 | (define dylan::add-method add-method) ; DEFINE-METHOD 110 | (define dylan::null? null?) ; COND 111 | 112 | (define (dylan::for-each fn . collections) 113 | (for-each 114 | (lambda (collection) 115 | (if (not (subclass? (get-type collection) )) 116 | (dylan-call dylan:error "for-each -- not a collection" collection))) 117 | collections) 118 | (collections-iterate fn 119 | (lambda (result) 120 | (and result (lambda () (car result)))) 121 | #F 122 | collections)) 123 | -------------------------------------------------------------------------------- /src/runtime.scm: -------------------------------------------------------------------------------- 1 | ;* Copyright 1992 Digital Equipment Corporation 2 | ;* All Rights Reserved 3 | ;* 4 | ;* Permission to use, copy, and modify this software and its documentation is 5 | ;* hereby granted only under the following terms and conditions. Both the 6 | ;* above copyright notice and this permission notice must appear in all copies 7 | ;* of the software, derivative works or modified versions, and any portions 8 | ;* thereof, and both notices must appear in supporting documentation. 9 | ;* 10 | ;* Users of this software agree to the terms and conditions set forth herein, 11 | ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free 12 | ;* right and license under any changes, enhancements or extensions made to the 13 | ;* core functions of the software, including but not limited to those affording 14 | ;* compatibility with other hardware or software environments, but excluding 15 | ;* applications which incorporate this software. Users further agree to use 16 | ;* their best efforts to return to Digital any such changes, enhancements or 17 | ;* extensions that they make and inform Digital of noteworthy uses of this 18 | ;* software. Correspondence should be provided to Digital at: 19 | ;* 20 | ;* Director, Cambridge Research Lab 21 | ;* Digital Equipment Corp 22 | ;* One Kendall Square, Bldg 700 23 | ;* Cambridge MA 02139 24 | ;* 25 | ;* This software may be distributed (but not offered for sale or transferred 26 | ;* for compensation) to third parties, provided such third parties agree to 27 | ;* abide by the terms and conditions of this notice. 28 | ;* 29 | ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL 30 | ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF 31 | ;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT 32 | ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL 33 | ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR 34 | ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS 35 | ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS 36 | ;* SOFTWARE. 37 | 38 | ; $Id: runtime.scm,v 1.22 1992/09/18 23:56:44 birkholz Exp $ 39 | 40 | (for-each dylan::load 41 | '("class" ; Dylan Class data type. 42 | "generic" ; Generic dispatch mechanism. 43 | "class-structure" ; The heterarchy. 44 | "runtime-top" ; Common parameter lists, etc. 45 | "runtime-internal" ; Procedures called by 46 | ; expansion of code, not by 47 | ; users 48 | "runtime-methods" ; Predefined methods 49 | "runtime-functions" ; Predefined functions and 50 | ; generic functions 51 | "runtime-bitstrings" ; Integers as bitstrings 52 | "runtime-collections" ; Collections, sequences, ... 53 | "runtime-collections-iterate" ; Iteration + Collection Keys 54 | "runtime-collections-generic1" ; Collection generic functions 55 | "runtime-collections-generic2" ; More generic collection operations. 56 | "runtime-collections-array" ; Arrays 57 | "runtime-collections-deque" ; Deques 58 | "runtime-collections-list" ; Lists 59 | "runtime-collections-range" ; Ranges 60 | "runtime-collections-string" ; Strings 61 | "runtime-collections-table" ; Tables 62 | "runtime-collections-vector" ; Vectors 63 | "runtime-exceptions")) ; Exceptions 64 | --------------------------------------------------------------------------------