Received: from PURCCVM.BITNET by FINTUVM.UTU.FI (Mailer X1.25) with BSMTP id 3383; Thu, 11 Aug 88 11:14:47 EET Received: from PURCCVM by PURCCVM.BITNET (Mailer X1.25) with BSMTP id 1401; Tue, 09 Aug 88 09:16:59 EST Received: from j.cc.purdue.edu by VM.CC.PURDUE.EDU ; Tue, 09 Aug 88 09:16:51 EST Received: by j.cc.purdue.edu (5.54/1.14) id AA10352; Tue, 9 Aug 88 09:15:39 EST Date: Tue, 9 Aug 88 09:15:39 EST From: ain@j.cc.purdue.edu (Patrick White) Message-Id: <8808091415.AA10352@j.cc.purdue.edu> To: fys-ma@fintuvm.BITNET Subject: comp.binaries.amiga: binaries/amiga/volume8/scheme.d.sh2 Newsgroups: comp.binaries.amiga Subject: scheme (docs 2 of 2) Keywords: scheme, lisp dialect, language, tested Approved: ain@j.cc.purdue.edu (Patrick White) Program Name: scheme (docs 2 of 2) Submitted by: qix@vx.lcs.mit.edu (Ed Puckett) Summary: statically scoped and properly tail-recursive dialect of lisp. Poster Boy: Patrick White (ain@j.cc.purdue.edu) Archive Name: binaries/amiga/volume8/scheme.d.sh2.Z tested NOTES: I re-did the uuencode of the scheme program itself since it was done with an older version of uuencode that used spaces instead of back-quotes. I don't know lisp nor scheme, so I didn't exhaustively test it.. I ran it, it game me lots of error messages, and I managed to exit it -- I'd say it works :-) . -- Pat White (co-moderator comp.sources/binaries.amiga) ARPA/UUCP: j.cc.purdue.edu!ain BITNET: PATWHITE@PURCCVM PHONE: (317) 743-8421 U.S. Mail: 320 Brown St. apt. 406, West Lafayette, IN 47906 [archives at: j.cc.purdue.edu.ARPA] ======================================== # This is a shell archive. # Remove everything above and including the cut line. # Then run the rest of the file through sh. #----cut here-----cut here-----cut here-----cut here----# #!/bin/sh # shar: Shell Archiver # Run the following text with /bin/sh to create: # ext.doc # load-patches.scm # repl.scm # special-forms.scm # streams.scm # This archive created: Mon Aug 8 09:30:51 1988 # By: Patrick White (PUCC Land, USA) cat << \SHAR_EOF > ext.doc ============================================== EXTENSIONS NOT PRESENT IN THE REVISED^3 REPORT ============================================== Scheme Version 1.2 19-March-1988 The following summarizes features included in the system which are not defined by the "Revised^3 Report on the Algorithmic Language Scheme". ================================================================================ ========================= SPECIAL FORM MANIPULATION ========================= -------------------------------------------------------------------------------- add-syntax! PRIMITIVE PROCEDURE (add-syntax! symbol function) A symbol is associated with the special form whose evaluation function is given by "function". This function will be passed the special form expression (in its entirety) and the current environment whenever the special form is encountered by the evaluator. The result of evaluating the special form is the result returned by the function. IN: symbol: symbol function: two argument function OUT: #u EXAMPLE: :=> (add-syntax! 'rqlist (lambda (exp env) (reverse (cdr exp)))) #u :=> (rqlist a b c) (c b a) -------------------------------------------------------------------------------- delete-syntax! PRIMITIVE PROCEDURE (delete-syntax! symbol) The special form associated with the given symbol is removed from the system. IN: symbol:symbol OUT: #u EXAMPLE: :=> (delete-syntax! 'define) #u :=> (define x 1) *** ERROR: unbound-variable define -------------------------------------------------------------------------------- get-syntax-definitions PRIMITIVE PROCEDURE (get-syntax-definitions) A copy of the system's special forms association list is returned. The builtin special forms' evaluation functions show up as #[enigma!] objects -- they are not actual procedures, but instead they are pointers to code. IN: --- OUT: association list: ((symbol . code) ...) ================================================================================ ======================= CONSTANTS AND VARIABLES ======================= -------------------------------------------------------------------------------- #u CONSTANT "The Unit" is the only member of the Unit domain, just as #t and #f are the two members of the Boolean domain. It is returned from functions which would otherwise have no meaningful return value, typically those functions which cause side-effects. -------------------------------------------------------------------------------- command-name VARIABLE This symbol is set during system initialization. Its value is the name of the executable file invoked to start the Scheme system. In C parlance, it is the value of argv[0]. If the program is invoked from the Workbench, command-name has the value "". EXAMPLE: From CLI: 1> Scheme x y z In Scheme: :=> command-name "Scheme" -------------------------------------------------------------------------------- command-line VARIABLE This symbol is set during system initialization. Its value is the arguments supplied on the command line when the Scheme system was started. If the program is invoked from the Workbench, command-line has the value "". EXAMPLE: From CLI: 1> Scheme x y z In Scheme: :=> command-line "x y z\ " ; note that newline character is included -------------------------------------------------------------------------------- startup-file VARIABLE This symbol is set during system initialization. Its value is the name of the startup file loaded into Scheme as the last step of system initialization. If the startup file was not found, startup-file has the value "". Currently, only one filename is attempted, "S:Scheme-init.scm". ================================================================================ ==================== HEAP SIZE MANAGEMENT ==================== -------------------------------------------------------------------------------- change-size PRIMITIVE PROCEDURE (change-size new-size) The heap memory blocks' sizes are changed to new-size bytes. IN: new-size: exact integer OUT: () if failed because request was too small #f if failed because memory not available #t if successful -------------------------------------------------------------------------------- extend-size PRIMITIVE PROCEDURE (extend-size amount-to-expand) The heap memory blocks' sizes are increased by amount-to-expand bytes. IN: amount-to-expand: exact integer OUT: () if failed because resulting size was too small #f if failed because memory not available #t if successful -------------------------------------------------------------------------------- shrink-size PRIMITIVE PROCEDURE (shrink-size amount-to-shrink) The heap memory blocks' sizes are decreased by amount-to-shrink bytes. IN: amount-to-shrink: exact integer OUT: () if failed because resulting size was too small #f if failed because memory not available #t if successful -------------------------------------------------------------------------------- minimize-size PRIMITIVE PROCEDURE (minimize-size) The heap memory blocks' sizes are decreased to a minimum size. IN: --- OUT: #f if failed because memory not available #t if successful -------------------------------------------------------------------------------- current-size PRIMITIVE PROCEDURE (current-size) The current size in bytes of each of the heap memory blocks is returned. IN: --- OUT: size: exact integer -------------------------------------------------------------------------------- collect-garbage PRIMITIVE PROCEDURE (collect-garbage) A garbage-collection is performed. IN: --- OUT: #u ================================================================================ ================== INTERRUPT-HANDLING ================== Unless otherwise noted in what follows, "interrupt" refers to an event within the Scheme system, and not a hardware event in the Amiga system, though Amiga interrupts may ultimately produce Scheme interrupts. The Scheme system responds to interrupts by generating an error at the point in the process where they are first detected. The reason passed to the error handler is the symbol INTERRUPT, and the cause is the interrupt flags value as an exact integer. Currently, two types of interrupts are recognized by the system: breaks and hard breaks. Breaks are caused by CTRL-C, CTRL-D and CTRL-E. Hard breaks are caused by CTRL-F. Amiga interrupts are handled by an exception handler associated with the Scheme task. When the handler executes, it sets a bit associated with the event in the Scheme system's interrupt flags. The interpreter will acts on these flags later. In conjunction with the interrupt flags, the system maintains an interrupt mask. This integer's bits indicate which of the interrupt flags are currently allowed to cause an interrupt. Interrupts posted to a flag whose mask bit is 0 will be ignored until the mask bit becomes 1. Breaks set interrupt bit 0. Hard breaks set interrupt bit 1. Interrupt bits 0-7 are reserved for the system, and bits 8-15 are intended for the user. There are currently only 16 interrupt bits. -------------------------------------------------------------------------------- current-interrupt-flags PRIMITIVE PROCEDURE (current-interrupt-flags) The current state of the pending interrupt flags is returned. IN: --- OUT: flags: exact integer -------------------------------------------------------------------------------- set-interrupt-flags! PRIMITIVE PROCEDURE (set-interrupt-flags! flags-mask affect-mask) The current state of the pending interrupt flags is modified. Only the flags indicated in affect-mask are affected; their values are set as indicated by flags mask. This function can be used to simulate a break. IN: flags-mask: exact positive integer affect-mask: exact positive integer OUT: #u EXAMPLE: (set-interrupt-flags! 1 1) ; simulate CTRL-C -------------------------------------------------------------------------------- current-interrupt-mask PRIMITIVE PROCEDURE (current-interrupt-mask) The current state of the interrupt mask is returned. IN: --- OUT: mask: exact integer -------------------------------------------------------------------------------- with-interrupt-mask PRIMITIVE PROCEDURE (with-interrupt-mask mask-mask affect-mask thunk) This function provides a controlled method of setting the value of the interrupt mask. The bits indicated by affect-mask in the current interrupt mask are set according to the corresponding bits in mask-mask, then the thunk's body is executed. When finished, the original mask is restored. The mask's value is "dynamically-wound". Any entry or exit (even if nonlocal through a continuation) will cause the mask to be set to the appropriate value. See dynamic-wind. IN: mask-mask: exact integer affect-mask: exact integer thunk: 0-argument procedure object OUT: return value from thunk EXAMPLE: (with-interrupt-mask #b0000000000000010 #b1111111111111111 (lambda () ) ; allow only hard breaks This function could be defined as follows, given a mythical interrupt-mask- setting function: (define (with-interrupt-mask mask affect-mask thunk) (let ((old-mask (current-interrupt-mask)) (new-mask (logical-or (logical-and affect-mask mask) (logical-and (logical-not affect-mask) (current-interrupt-mask))) )) (dynamic-wind (lambda () (SET-INTERRUPT-MASK! new-mask)) thunk (lambda () (SET-INTERRUPT-MASK! old-mask)) ))) ================================================================================ ============== ERROR HANDLING ============== The system maintains a continuation which is called each time an error occurs. Currently, the continuation is thrown a packet (a list) of three things: the reason, the cause and a continuation of the faulted process. The format of this packet may change in the future. For example, (let ((n 1) (d 0)) (if (= 0 d) (error 'bad-value d) (/ n d))) will cause the error handler continuation to be invoked with the packet (bad-value 1 ) where is a newly-made continuation of the process near the point of the error. The continuations passed into the error handler are sometimes from a point prior to the actual error. Errors occurring inside primitive procedures return to the continuation of the erroring primitive. WARNING ------- Continuations passed into the error handler whose reason is special-form-syntax-error are currently unstable. I think all the others are OK, but if you see one from a special-form-syntax-error, DON'T USE IT. These continuations will most likely cause a system crash if applied. I will be working on this problem, but for now, error handlers (and/or debuggers) should not use special-form-syntax-error continuations. -------------------------------------------------------------------------------- current-error-continuation PRIMITIVE PROCEDURE (current-error-continuation) The current error continuation is returned. IN: --- OUT: err-cont: continuation -------------------------------------------------------------------------------- error-context PRIMITIVE PROCEDURE (error-context error-handler-continuation body-thunk) This function provides a controlled method of installing a new error continuation. The body-thunk is executed with this new handler in place. When finished, the original handler is restored. The error handler continuation is "dynamically-wound". Any entry or exit (even if nonlocal through another continuation) will cause the handler to be set appropriately. See dynamic-wind. IN: error-handler-continuation: continuation thunk: 0-argument procedure object OUT: return value from thunk EXAMPLE: :=> (define ec (call/cc (lambda (return) (display (call/cc (lambda (later) (return later)))) (newline)))) returns --> ec :=> (error-context ec (lambda () (let ((n 1) (d 0)) (if (= 0 d) (error 'bad-value d) (/ n d))))) prints --> (bad-value 0 #[closure]) returns --> ec :=> ec returns --> #u This function could be defined as follows, given a mythical error-handler- setting function: (define (error-context error-handler-continuation body-thunk) (let ((old-handler (current-error-continuation))) (dynamic-wind (lambda () (SET-ERROR-HANDLER! error-handler-continuation)) body-thunk (lambda () (SET-ERROR-HANDLER! old-handler)) ))) -------------------------------------------------------------------------------- error PRIMITIVE PROCEDURE (error reason cause) Generate an error. The current error handler will be thrown the reason and cause along with a continuation of the current process. ================================================================================ ============================== MISCELLANEOUS SYSTEM FUNCTIONS ============================== -------------------------------------------------------------------------------- abort-system PRIMITIVE PROCEDURE (abort-system) (abort-system exitval) The Scheme system is aborted. If exitval is supplied, it is the return value returned to AmigaDOS. Otherwise, 0 is returned. IN: exitval: exact integer (optional) OUT: nothing! -------------------------------------------------------------------------------- file-exists? PRIMITIVE PROCEDURE (file-exists? filename) This function returns whether or not a file could be Lock()'ed. The file is not left in a locked state, however. IN: filename: string OUT: boolean -------------------------------------------------------------------------------- sleep PRIMITIVE PROCEDURE (sleep nticks) The system sleeps for roughly nticks/50 seconds. IN: nticks: exact integer OUT: #u -------------------------------------------------------------------------------- call-system PRIMITIVE PROCEDURE (call-system command) The command is issued via an AmigaDOS Execute() call. IN: command: string OUT: boolean ================================================================================ === I/O === -------------------------------------------------------------------------------- read-raw-bytes PRIMITIVE PROCEDURE (read-raw-bytes size) (read-raw-bytes size port) An attempt is made to read the number of bytes specified by "size", and a string is returned formed by those which were read. The length of the returned string is the number of bytes actually read. If the port argument is not supplied, the current input port is used. The number of bytes read will be less than "size" if an end-of-file is encountered. If the file is at end-of-file when read-raw-bytes is called, an empty string will be returned. Interactive files sometimes return fewer bytes as the result of a newline. IN: size: exact integer port: port (optional) OUT: string -------------------------------------------------------------------------------- write-raw-bytes PRIMITIVE PROCEDURE (write-raw-bytes string) (write-raw-bytes string port) The text of the given string is written in raw format to "port", or to the current output port if no port argument is supplied. IN: string: string port: port (optional) OUT: #u ================================================================================ =================== LOW-LEVEL ACCESSORS =================== These functions allow access to the low-level representations of objects. Some are dangerous, and can cause system crashes if used improperly. These have names prefixed with "!". In the descriptions below, "rep" values are of the form (tags . value). Both tags and value are exact integers. -------------------------------------------------------------------------------- obj->rep PRIMITIVE PROCEDURE (obj->rep obj) The representation of obj is returned. IN: obj: any Scheme object OUT: (tags . value) EXAMPLE: :=> (obj->rep '()) (130 . 1) -------------------------------------------------------------------------------- !rep->obj PRIMITIVE PROCEDURE (!rep->obj rep) An object is returned, assuming that the tags and value describe a valid object. This can cause a crash if you introduce bad stuff into the system. IN: (tags . value) OUT: an object EXAMPLE: :=> (!rep->obj '(130 . 1)) () -------------------------------------------------------------------------------- !storage-ref PRIMITIVE PROCEDURE (!storage-ref obj offset) Given that the rep of obj is (tags . value), the object stored at memory location (+ value (* 4 offset)) is returned. IN: obj: any object offset: exact integer OUT: an object EXAMPLE: :=> (!storage-ref '(a b) 0) (b) :=> (!storage-ref '(a b) 1) a -------------------------------------------------------------------------------- !storage-set! PRIMITIVE PROCEDURE (!storage-set! obj offset obj-to-store) Given that the rep of obj is (tags . value), obj-to-store is stored at memory location (+ value (* 4 offset)). IN: obj: any object offset: exact integer obj-to-store: any object OUT: #u EXAMPLE: :=> (define obj '(a b)) obj :=> (!storage-set! obj 0 'c) #u :=> obj (a . c) -------------------------------------------------------------------------------- !storage-rep-ref PRIMITIVE PROCEDURE (!storage-rep-ref obj offset) Given that the rep of obj is (tags . value), the rep of the object stored at memory location (+ value (* 4 offset)) is returned. This function is slightly safer than !storage-ref!...you will not pollute the system with non-objects. IN: obj: any object offset: exact integer OUT: (tags . value) for referenced object EXAMPLE: :=> (!storage-rep-ref '(() . b) 1) (130 . 1) -------------------------------------------------------------------------------- !storage-rep-set! PRIMITIVE PROCEDURE (!storage-rep-set! obj offset rep-to-store) Given that the rep of obj is (tags . value), obj-to-store is stored at memory location (+ value (* 4 offset)). IN: obj: any object offset: exact integer rep-to-store: (tags . value) OUT: #u EXAMPLE: :=> (define obj '(a b)) obj :=> (!storage-rep-set! obj 0 '(130 . 1)) #u :=> obj (a) -------------------------------------------------------------------------------- !byte-ref PRIMITIVE PROCEDURE (!byte-ref obj offset) Given that the rep of obj is (tags . value), the byte stored at memory location (+ value offset) is returned. IN: obj: any object offset: exact integer OUT: byte: exact integer EXAMPLE: :=> (!byte-ref '(a . ()) 0) 130 -------------------------------------------------------------------------------- !byte-set! PRIMITIVE PROCEDURE (!byte-set! obj offset byte) Given that the rep of obj is (tags . value), byte is stored at memory location (+ value offset). IN: obj: any object offset: exact integer byte: any object OUT: #u EXAMPLE: :=> (define obj (a . 0)) obj :=> (!byte-set! obj 3 7) #u :=> obj (a . 7) ================================================================================ =========================== PROCEDURE OBJECT TYPE TESTS =========================== The following tests further subdivide the class of objects for which procedure? returns #t. -------------------------------------------------------------------------------- primitive? PRIMITIVE PROCEDURE (primitive? obj) IN: obj: any object OUT: #t if obj is a primitive procedure #f otherwise -------------------------------------------------------------------------------- compound-procedure? PRIMITIVE PROCEDURE (compound-procedure? obj) IN: obj: any object OUT: #t if obj is a compound procedure (produced by lambda) #f otherwise -------------------------------------------------------------------------------- compiled? PRIMITIVE PROCEDURE (compiled? obj) Currently, no system functions produce compiled procedure objects. IN: obj: any object OUT: #t if obj is a compiled procedure #f otherwise -------------------------------------------------------------------------------- thunk? PRIMITIVE PROCEDURE (thunk? obj) Currently, no external system functions produce thunk objects. The system's thunk type is not merely a procedure of 0 arguments, but a special 0-argument procedure type used internally. IN: obj: any object OUT: #t if obj is a procedure #f otherwise -------------------------------------------------------------------------------- promise? PRIMITIVE PROCEDURE (promise? obj) IN: obj: any object OUT: #t if obj is a promise (0-argument procedure returned by delay) #f otherwise -------------------------------------------------------------------------------- continuation? PRIMITIVE PROCEDURE (continuation? obj) IN: obj: any object OUT: #t if obj is a continuation #f otherwise ================================================================================ ============= MISCELLANEOUS ============= -------------------------------------------------------------------------------- eval PRIMITIVE PROCEDURE (eval exp env) The expression is evaluated in the given environment, and the result returned. IN: exp: a Scheme expression env: an environment object OUT: the result of evaluating exp in env EXAMPLE: :=> (eval '(+ 2 3) (the-environment)) 5 -------------------------------------------------------------------------------- dynamic-wind PRIMITIVE PROCEDURE (dynamic-wind entry-thunk body-thunk exit-thunk) This function provides a controlled method of ensuring the dynamic state of a process. The entry-thunk's code is executed, then the body-thunk's code and finally the exit-thunk's code. The result is that which was returned by body-thunk. Any exit, local or nonlocal, causes the exit-thunk to be applied. Any entry, local or nonlocal, causes the entry-thunk to be applied. The entry and exit thunks are applied with the interrupt mask set to accept hard breaks only. It will probably cause problems if an entry or exit thunk is interrupted. IN: entry-thunk: 0-argument procedure object body-thunk: 0-argument procedure object exit-thunk: 0-argument procedure object OUT: return value from body-thunk EXAMPLE: :=> (define dwind-test (dynamic-wind (lambda () (display "ENTRY") (newline)) (lambda () (call/cc (lambda (cont) cont))) (lambda () (display "EXIT") (newline)))) prints --> ENTRY prints --> EXIT returns --> dwind-test :=> (define wound-cont dwind-test) ; 'cause dwind-test gets clobbered wound-cont :=> (wound-cont 'hello) prints --> ENTRY prints --> EXIT returns --> dwind-test :=> dwind-test returns --> hello :=> (wound-cont 'aloha) prints --> ENTRY prints --> EXIT returns --> dwind-test :=> dwind-test returns --> aloha -------------------------------------------------------------------------------- char->string PRIMITIVE PROCEDURE (char->string char) A string representing the given character is returned. The string is such that the reader operating on it would return the given character. IN: char: character OUT: string: a string formed by prepending #\ to a character specifier: (char->integer char) character specifier -------------------- ------------------- #x00 nul #x01 soh #x02 stx #x03 etx #x04 eot #x05 enq #x06 ack #x07 bel #x08 bs #x09 ht #x0A lf #x0B vt #x0C ff #x0D cr #x0E so #x0F si #x10 dle #x11 dc1 #x12 dc2 #x13 dc3 #x14 dc4 #x15 nak #x16 syn #x17 etb #x18 can #x19 em #x1A sub #x1B esc #x1C fs #x1D gs #x1E rs #x1F us #x20 space #x21 through #x7E the character #x7F rub #x80 through #xFF the character EXAMPLE: :=> (char->string #\space) "#\\space" ; \ is escaped -------------------------------------------------------------------------------- string->char PRIMITIVE PROCEDURE (string->char string) A string representation of a character (such as char->string would return) is converted to its corresponding character. Character case is ignored. In addition, the following strings are recognized: "#\\null" --> #\nul "#\\bell" --> #\bel "#\\tab" --> #\ht "#\\newline" --> #\lf Unrecognized strings cause #u to be returned. IN: string: string OUT: char: character if successful #u if unsuccessful -------------------------------------------------------------------------------- call-with-quotient&remainder PRIMITIVE PROCEDURE (call-with-quotient&remainder number1 number2 proc) This function lets you get both the quotient and the remainder with one call. IN: number1: number number2: number proc: 2-argument procedure OUT: return value from proc EXAMPLE: :=> (call-with-quotient&remainder 229 11 (lambda (q r) (display (cons q r)))) (20 . 9)#u -------------------------------------------------------------------------------- fluid-let SPECIAL FORM (fluid-let (binding1 ...) exp1 ...) (fluid-let () exp1 ...) This special form is just like the "let" special form, except that the bindings are dynamic instead of static. It is unlike MIT Scheme's fluid-let in that the bindings are in a separate environment, and must be accessed with the special form "fluid". EXAMPLE: :=> (define (p x) (cons x (fluid x))) p :=> (fluid-let ((x 'fluid-var)) (p 'lexical-var)) (lexical-var . fluid-var) -------------------------------------------------------------------------------- fluid SPECIAL FORM (fluid symbol) This special form provides access to variables in the fluid environment. ================================================================================ ======= STREAMS ======= -------------------------------------------------------------------------------- the-empty-stream VARIABLE This is a distinguished object representing the empty stream. (stream? the-empty-stream) returns #t. -------------------------------------------------------------------------------- stream? PRIMITIVE PROCEDURE (stream? obj) IN: obj: any object OUT: #t if obj is a stream object #f otherwise -------------------------------------------------------------------------------- empty-stream? PRIMITIVE PROCEDURE (empty-stream? obj) IN: obj: any object OUT: #t if obj is the-empty-stream #f otherwise -------------------------------------------------------------------------------- cons-stream SPECIAL FORM (cons-stream obj1 obj2) A stream object is returned whose "head" is obj1 and "tail" is obj2. Obj1 is evaluated prior to building the stream object, obj2 is not evaluated until a "tail" is performed on the stream object. Even so, obj2 will be evaluated but once; it is memoized. IN: obj1: any object obj2: any object OUT: stream object -------------------------------------------------------------------------------- head PRIMITIVE PROCEDURE (head stream) IN: stream: stream OUT: an object EXAMPLE: :=> (define s (cons-stream (begin (display "HEAD") (newline)) (begin (display "TAIL") (newline)))) prints --> "HEAD" returns --> s :=> (head s) returns --> #u -------------------------------------------------------------------------------- tail PRIMITIVE PROCEDURE (tail stream) IN: stream: stream OUT: an object EXAMPLE: :=> (define s (cons-stream (begin (display "HEAD") (newline)) (begin (display "TAIL") (newline)))) prints --> "HEAD" returns --> s :=> (tail s) prints --> "TAIL" returns --> #u :=> (tail s) returns --> #u ; note memoization ================================================================================ ============ ENVIRONMENTS ============ -------------------------------------------------------------------------------- the-environment SPECIAL FORM (the-environment) This special form returns the current environment from the point where it is evaluated. EXAMPLE: :=> (let ((a 'first)) (let ((env (the-environment))) (let ((a 'second)) (cons a (eval 'a env))))) (second . first) -------------------------------------------------------------------------------- environment? PRIMITIVE PROCEDURE (environment? obj) IN: obj: any object OUT: #t if obj is an environment object #f otherwise -------------------------------------------------------------------------------- make-environment SPECIAL FORM (make-environment exp1 ...) The given expressions are evaluated in order in a separate environment enclosed by the current environment, and the resulting environment is returned. (make-environment exp1 ...) is equivalent to (let () exp1 ... (the-environment)) IN: exps: Scheme expressions OUT: resulting environment object -------------------------------------------------------------------------------- access SPECIAL FORM (access symbol1 env) (access symbol1 symbol2 ... env) Symbol1 is looked up in the environment bound to symbol2 which is looked up in the environment bound to ... which is looked up in the environment bound to env. At least one symbol must be specified as in (access 'a (the-environment)). IN: symbols: symbol env: environment object OUT: the value bound to symbol1 EXAMPLE: :=> (define package (make-environment (define a 'one) (define inner-package (make-environment (define a 'two) (define inner-inner-package (make-environment (define a 'three) )) )) )) package :=> (vector (access a package) (access a inner-package package) (access a inner-inner-package inner-package package)) #(one two three) SHAR_EOF cat << \SHAR_EOF > load-patches.scm ;;; load-patches.scm (define path-object (let () (define *CURRENT-DIR* ":") (define (extend-filename name add-slash?) (cond ((zero? (string-length name)) name) ; don't add slash (else (let ((name-chars (let ((last-char (string-ref name (- (string-length name) 1)))) (if (or (not add-slash?) (eq? last-char #\/) (eq? last-char #\:)) (string->list name) (append (string->list name) '(#\/)) )))) (cond ((null? name-chars) *CURRENT-DIR*) ((or (memq #\: name-chars) (eq? (car name-chars) #\/)) (list->string name-chars)) (else (string-append *CURRENT-DIR* (list->string name-chars)))))))) (define (cd . dirlist) (cond ((= (length dirlist) 0) *CURRENT-DIR*) ((= (length dirlist) 1) (let ((fullname (extend-filename (car dirlist) #t))) (if (file-exists? fullname) (set! *CURRENT-DIR* fullname) (error "file not found" fullname)))) (else (error "use zero or one argument" dirlist)))) (lambda (m) (cond ((eq? m 'cd) cd) ((eq? m 'extend-filename) extend-filename))) )) (define cd (path-object 'cd)) (define extend-filename (path-object 'extend-filename)) (define load (let () (define original-load load) (define last-file-list '()) (define (ld file) (original-load (extend-filename file #f))) (define (do-load file-list) (for-each ld file-list)) (lambda file-list (if (null? file-list) (do-load last-file-list) (begin (set! last-file-list file-list) (do-load file-list)))) )) ;;; EOF load-patches.scm SHAR_EOF cat << \SHAR_EOF > repl.scm ;;; repl.scm (define (make-id-cont) (call/cc (lambda (return) (call/cc (lambda (later) (return later))) ))) (define (make-error-handler interrupt-mask affected-interrupts restart-cont) (define (error-handler packet) (display "Yeeow! ") (display (cadr packet)) (newline) (display (car packet)) (newline) (display "Interrupt flags/mask: ") (display (number->string (current-interrupt-flags) '(int (radix x e)))) (display #\/) (display (number->string (current-interrupt-mask) '(int (radix x e)))) (newline) (newline) (collect-garbage) (restart-cont "hello-again") ) (with-interrupt-mask interrupt-mask affected-interrupts (lambda () (call/cc (lambda (return) (error-handler (call/cc (lambda (later) (return later)) )))))) ) (define (read-until stop-char omit?) (define (get-next input-list) (let ((c (read-char))) (cond ((eof-object? c) (finish input-list)) ((eq? c stop-char) (finish (if omit? input-list (cons c input-list)))) (else (get-next (cons c input-list)))))) (define (finish lst) (reverse lst)) (get-next '())) (define (check-system-call cmdchar obj) (if (symbol? obj) (let ((chars (string->list (symbol->string obj)))) (if (and (not (null? chars)) (eq? cmdchar (car chars))) (let ((cmd (list->string (append (cdr chars) (read-until #\newline #t))))) (call-system cmd) #t))))) (define *LEVEL* 0) (define (repl repl-read repl-eval repl-print) (define cmdchar #\~) (define internal-repl (let ((*LAST-IN* 'undefined) (*LAST-OUT* 'undefined)) (let ((internal-env (the-environment))) (lambda () (newline) (display *LEVEL*) (display "=> ") (let ((obj (repl-read))) (cond ((eof-object? obj) 'done) (else (cond ((check-system-call cmdchar obj) (newline)) (else (let ((result (repl-eval obj internal-env))) (eval `(set! *LAST-IN* ',obj) internal-env) (eval `(set! *LAST-OUT* ',result) internal-env) (repl-print result) (newline)))) (internal-repl)))))))) (define protected-repl (call/cc (lambda (return) (error-context (make-error-handler #x0002 #xFFFF (with-interrupt-mask #x0002 #xFFFF (lambda () (call/cc (lambda (return) (call/cc (lambda (later) (return later))) (protected-repl "hello-again")))) )) (lambda () (call/cc (lambda (later) (return later))) (internal-repl)))))) (if (procedure? protected-repl) (begin (set! *LEVEL* (+ *LEVEL* 1)) (protected-repl "first-time")) (set! *LEVEL* (- *LEVEL* 1)))) ;;; EOF repl.scm SHAR_EOF cat << \SHAR_EOF > special-forms.scm ;;; special-forms.scm (add-syntax! 'let* (let () (define (first-loop bindings body-exps) (define (loop binding1 rest-bindings) (if (null? rest-bindings) `(let (,binding1) . ,body-exps) `(let (,binding1) ,(loop (car rest-bindings) (cdr rest-bindings))) )) (if (null? bindings) `(let () . body-exps) (loop (car bindings) (cdr bindings)) )) (lambda (exp env) (eval (first-loop (cadr exp) (cddr exp)) env) ))) (add-syntax! 'case (let () (define (find-case-exps-to-eval key clauses) (cond ((null? clauses) '(())) ((eq? (caar clauses) 'else) (cdar clauses)) ((memv key (caar clauses)) (cdar clauses)) (else (find-case-exps-to-eval key (cdr clauses))))) (lambda (exp env) (eval (cons 'begin (find-case-exps-to-eval (eval (cadr exp) env) (cddr exp))) env) ))) SHAR_EOF cat << \SHAR_EOF > streams.scm ;;; streams.scm (define (display-stream s) (define (display-stream-elements s) (if (empty-stream? s) #u (begin (display (head s)) (display " ") (display-stream-elements (tail s))))) (display "#[ ") (display-stream-elements s) (display "]") #u) (define (map-stream proc s) (if (empty-stream? s) the-empty-stream (cons-stream (proc (head s)) (map-stream proc (tail s))))) (define (map-2-streams op s1 s2) (if (or (empty-stream? s1) (empty-stream? s2)) (if (and (empty-stream? s1) (empty-stream? s2)) the-empty-stream (error "streams different lengths" (list s1 s2))) (cons-stream (op (head s1) (head s2)) (map-2-streams op (tail s1) (tail s2))))) (define (interleave-streams s1 s2) (if (empty-stream? s1) s2 (cons-stream (head s1) (interleave-streams s2 (tail s1))))) (define (filter-stream pred s) (cond ((empty-stream? s) the-empty-stream) ((pred (head s)) (cons-stream (head s) (filter-stream pred (tail s)))) (else (filter-stream pred (tail s))))) (define (sieve-stream pred-f s) (cons-stream (head s) (sieve-stream pred-f (filter-stream (pred-f (head s)) (tail s))))) (define (list->stream lst) (define (iter l s) (if l (iter (cdr l) (cons-stream (car l) s)) s)) (iter lst the-empty-stream)) ;------------------------------------------------------------------------------- (define ones (cons-stream 1 ones)) (define (integers-from n) (cons-stream n (integers-from (+ 1 n)))) (define natural-numbers (integers-from 0)) (define fibonacci-numbers (cons-stream 1 (cons-stream 1 (map-2-streams + fibonacci-stream (tail fibonacci-stream))))) (define prime-numbers (sieve-stream (lambda (divisor) (lambda (test-val) (not (zero? (remainder test-val divisor))))) (integers-from 2))) ; EOF streams.scm SHAR_EOF # End of shell archive exit 0