#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/compat.scm,v 1.1 1990/09/10 18:08:10 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/compat.scm,v 1.2 1990/11/14 14:57:44 cph Exp $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
;;; rationals at all, since the Chipmunks don't.
(in-package (->environment '(runtime number))
-
(define (rat:->string q radix)
(if (ratnum? q)
(let ((divided (flo:/ (int:->flonum (ratnum-numerator q))
(int:->string divided radix)
(flo:->string divided radix)))
(int:->string q radix))))
-\f
-(syntax-table-define system-global-syntax-table 'CONJUNCTION
- (syntax-table-ref system-global-syntax-table 'AND))
-
-(syntax-table-define system-global-syntax-table 'DISJUNCTION
- (syntax-table-ref system-global-syntax-table 'OR))
(define (alphaless? symbol1 symbol2)
- (string<? (symbol->string symbol1)
- (symbol->string symbol2)))
+ (string<? (symbol->string symbol1) (symbol->string symbol2)))
(define (and* . args)
- (define (and-loop args)
+ (let and-loop ((args args))
(or (null? args)
(and (car args)
- (and-loop (cdr args)))))
- (and-loop args))
+ (and-loop (cdr args))))))
(define (digit? object)
- (and (integer? object)
- (>= object 0)
- (<= object 9)))
+ (and (exact-nonnegative-integer? object) (<= object 9)))
(define (singleton-symbol? object)
(and (symbol? object)
(define (ascii object)
(cond ((singleton-symbol? object)
- (char->ascii
- (char-upcase (string-ref (symbol->string object) 0))))
+ (char->ascii (char-upcase (string-ref (symbol->string object) 0))))
((digit? object)
(char->ascii (string-ref (number->string object) 0)))
- (error "Not a singleton symbol" object)))
+ (else
+ (error:illegal-datum object 'ASCII))))
(define (atom? object)
(not (pair? object)))
(define (or* . args)
- (define (or-loop args)
+ (let or-loop ((args args))
(and (not (null? args))
(or (car args)
- (or-loop (cdr args)))))
- (or-loop args))
-
-(define (applicable? object)
- (or (procedure? object)
- (continuation? object)))
-
-(define (atom? object)
- (not (pair? object)))
+ (or-loop (cdr args))))))
(define char ascii->char)
(define (explode string)
(map (lambda (character)
(let ((string (char->string character)))
- (let ((number (string->number string)))
- (or number
- (string->symbol string)))))
+ (or (string->number string)
+ (string->symbol string))))
(string->list string)))
(define (implode list)
(string-ref (number->string element) 0))
((singleton-symbol? element)
(string-ref (symbol->string element) 0))
- (else (error "Element neither digit nor singleton symbol"
- element))))
+ (else
+ (error "Element neither digit nor singleton symbol"
+ element))))
list)))
\f
(define (close-channel port)
((output-port? port) (close-output-port port))
(else (error "CLOSE-CHANNEL: Wrong type argument" port))))
-(define (print object #!optional port)
- (cond ((unassigned? port) (set! port (current-output-port)))
- ((not (output-port? port)) (error "Bad output port" port)))
- (if (not (eq? object *the-non-printing-object*))
- (begin ((access :write-char port) char:newline)
- ((access unparse-object unparser-package) object port true)
- ((access :write-char port) #\Space)))
- *the-non-printing-object*)
-
(define (tyi #!optional port)
- (if (unassigned? port) (set! port (current-input-port)))
- (let ((char (read-char port)))
- (if (eof-object? char)
- char
- (char->ascii char))))
+ (let ((char
+ (read-char
+ (if (default-object? port)
+ (current-output-port)
+ (guarantee-output-port port)))))
+ (if (char? char)
+ (char->ascii char)
+ char)))
(define (tyipeek #!optional port)
- (if (unassigned? port) (set! port (current-input-port)))
- (let ((char (peek-char port)))
- (if (eof-object? char)
- char
- (char->ascii char))))
+ (let ((char
+ (peek-char
+ (if (default-object? port)
+ (current-output-port)
+ (guarantee-output-port port)))))
+ (if (char? char)
+ (char->ascii char)
+ char)))
(define (tyo ascii #!optional port)
- (if (unassigned? port) (set! port (current-output-port)))
- (write-char (ascii->char ascii) port))
+ (write-char (ascii->char ascii)
+ (if (default-object? port)
+ (current-output-port)
+ (guarantee-output-port port))))
(define (print-depth #!optional newval)
- (if (unassigned? newval) (set! newval false))
- (if (or (not newval)
- (and (integer? newval)
- (positive? newval)))
- (set! *unparser-list-depth-limit* newval)
- (error "PRINT-DEPTH: Wrong type argument" newval)))
+ (let ((newval (if (default-object? newval) false newval)))
+ (if (not (or (not newval) (and (exact-integer? newval) (> newval 0))))
+ (error:illegal-datum newval 'PRINT-DEPTH))
+ (set! *unparser-list-depth-limit* newval)
+ unspecific))
(define (print-breadth #!optional newval)
- (if (unassigned? newval) (set! newval false))
- (if (or (not newval)
- (and (integer? newval)
- (positive? newval)))
- (set! *unparser-list-breadth-limit* newval)
- (error "PRINT-BREADTH: Wrong type argument" newval)))
+ (let ((newval (if (default-object? newval) false newval)))
+ (if (not (or (not newval) (and (exact-integer? newval) (> newval 0))))
+ (error:illegal-datum newval 'PRINT-BREADTH))
+ (set! *unparser-list-breadth-limit* newval)
+ unspecific))
(define (vector-cons size fill)
(make-vector size fill))
(define (read-from-keyboard)
(let ((input (read)))
(if (eq? input 'abort)
- ((access default/abort-nearest (->environment '(runtime rep))))
+ (cmdl-interrupt/abort-nearest)
input)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/genenv.scm,v 1.1 1990/09/10 18:09:30 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/genenv.scm,v 1.2 1990/11/14 14:57:50 cph Exp $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
(define make-unassigned-object
microcode-object/unassigned)
-(let ((list-type (microcode-type 'LIST)))
+(let ()
(define (get-values descriptors frame receiver)
(define (inner descriptors names values unref)
(define (do-next name-here name-there)
(do-next (car this) (cdr this)))))))
(inner descriptors '() '() '()))
- (define (default-receiver frame unref)
- frame)
-
- ;; Kludge:
- ;; This wants to be map-unassigned from sdata.scm
-
- (define (default-process object)
- (car ((access &typed-pair-cons (->environment '(runtime scode-data)))
- list-type object '())))
-
- (define (compose f g)
- (lambda (x)
- (f (g x))))
-
(set! build-environment
(named-lambda (build-environment names source-frame
#!optional parent-frame
process receiver)
- (get-values
- names
- source-frame
- (lambda (names values unreferenceable)
- ((if (unassigned? receiver)
- default-receiver
- receiver)
- (apply (scode-eval (make-lambda lambda-tag:make-environment
- names
- '()
- '()
- '()
- '()
- (make-the-environment))
- (if (unassigned? parent-frame)
- source-frame
- parent-frame))
- (map (if (unassigned? process)
- default-process
- (compose default-process process))
- values))
- unreferenceable)))))
- 42)
+ (get-values names source-frame
+ (lambda (names values unreferenceable)
+ (if (default-object? receiver)
+ unreferenceable
+ (receiver
+ (apply (scode-eval (make-lambda lambda-tag:make-environment
+ names
+ '()
+ '()
+ '()
+ '()
+ (make-the-environment))
+ (if (default-object? parent-frame)
+ source-frame
+ parent-frame))
+ (map (if (default-object? process)
+ unmap-reference-trap
+ (lambda (x)
+ (unmap-reference-trap (process x))))
+ values))
+ unreferenceable))))))
+ 42)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/graphics.scm,v 1.1 1990/09/10 18:10:00 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/graphics.scm,v 1.2 1990/11/14 14:57:58 cph Exp $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
(define draw-line-to)
(define draw-point)
(define graphics-available?)
-(define graphics-text) ;Accepts different parameters on Chipmunks
+(define graphics-text)
(define init-graphics)
(define position-pen)
(define graphics-package
(make-environment
- (define graphics-device)
+ (define graphics-device #F)
(set! clear-graphics
(lambda ()
- (if (unassigned? graphics-device)
+ (if (not graphics-device)
(init-graphics))
(graphics-clear graphics-device)
(graphics-move-cursor graphics-device 0 0)))
(set! graphics-text
(lambda (text x y)
+ ;; Accepts different parameters on Chipmunks.
(graphics-draw-text graphics-device x y text)))
(set! init-graphics
(lambda ()
(let ((display (x-open-display #f)))
- (set! graphics-device (make-graphics-device
- x-graphics-device-type
- display
- "512x388"
- #f)))
- (graphics-set-coordinate-limits graphics-device
- -256 -195
- 255 194)
+ (set! graphics-device
+ (make-graphics-device x-graphics-device-type
+ display "512x388" #f)))
+ (graphics-set-coordinate-limits graphics-device -256 -195 255 194)
(graphics-move-cursor graphics-device 0 0)))
(set! position-pen
(lambda (x y)
(graphics-move-cursor graphics-device x y)))
+
))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/sbuild.scm,v 1.1 1990/09/10 18:10:26 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/sbuild.scm,v 1.2 1990/11/14 14:58:10 cph Exp $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
;;;; 6.001 Student Environment
(declare (usual-integrations))
-\f
+
(define student-system
(make-system "Student (6.001)"
- 14 1
+ 14 2
`((,system-global-environment
"compat" "graphics" "strmac" "stream" "genenv" "studen"))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/studen.scm,v 1.1 1990/09/10 18:13:21 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sicp/studen.scm,v 1.2 1990/11/14 14:58:18 cph Exp $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
(define (initialize-syntax!)
;; First hack the parser (reader) table
;; Remove backquote and comma
- (let ((undefined-entry (access parse-object/undefined-atom-delimiter
- (->environment '(runtime parser)))))
+ (let ((undefined-entry
+ (access parse-object/undefined-atom-delimiter
+ (->environment '(runtime parser)))))
(parser-table/set-entry! sicp-parser-table "`" undefined-entry)
(parser-table/set-entry! sicp-parser-table "," undefined-entry))
;; Add brackets as extended alphabetic since they are used in book (ugh!)
"/"
(lambda (parse-object collect-list)
(parser-table/set-entry! sicp-parser-table "[" parse-object collect-list)
- (parser-table/set-entry! sicp-parser-table "]" parse-object collect-list)))
+ (parser-table/set-entry! sicp-parser-table "]" parse-object
+ collect-list)))
;; Now, hack the syntax (special form) table.
- (for-each (lambda (name)
- (syntax-table-define
- sicp-syntax-table
- name
- (or (syntax-table-ref system-global-syntax-table name)
- (error "Missing syntactic keyword" name))))
- '(ACCESS BEGIN BKPT COLLECT COND CONJUNCTION CONS-STREAM DEFINE
- DELAY DISJUNCTION ERROR IF LAMBDA LET MAKE-ENVIRONMENT
- QUOTE SEQUENCE SET! THE-ENVIRONMENT))
+ (let ((move
+ (lambda (from to)
+ (syntax-table-define sicp-syntax-table to
+ (or (syntax-table-ref system-global-syntax-table from)
+ (error "Missing syntactic keyword" from))))))
+ (for-each (lambda (name) (move name name))
+ '(ACCESS BEGIN BKPT COLLECT COND CONS-STREAM DEFINE
+ DELAY ERROR IF LAMBDA LET MAKE-ENVIRONMENT
+ QUOTE SET! THE-ENVIRONMENT))
+ (move 'AND 'CONJUNCTION)
+ (move 'OR 'DISJUNCTION)
+ (move 'BEGIN 'SEQUENCE))
(set! *student-parser-table* (parser-table/copy sicp-parser-table))
(set! *student-syntax-table* (syntax-table/copy sicp-syntax-table))
#T)
(define (in-user-environment-chain? environment)
(or (eq? environment user-global-environment)
- (and (not (eq? environment system-global-environment))
- (environment-has-parent? environment)
+ (and (environment-has-parent? environment)
(in-user-environment-chain? (environment-parent environment)))))
-(define (enable-global-environment)
- ((access ic-environment/set-parent! (->environment '(runtime environment)))
- user-global-environment
- system-global-environment)
- 'ENABLED)
+(define ic-environment/remove-parent!)
+(define ic-environment/set-parent!)
+
+(let ((e (->environment '(runtime environment))))
+ (set! ic-environment/remove-parent! (access ic-environment/remove-parent! e))
+ (set! ic-environment/set-parent! (access ic-environment/set-parent! e)))
(define (disable-global-environment)
- ((access ic-environment/remove-parent! (->environment '(runtime environment)))
- user-global-environment)
+ (ic-environment/remove-parent! user-global-environment)
'DISABLED)
+(define (enable-global-environment)
+ (ic-environment/set-parent! user-global-environment
+ system-global-environment)
+ 'ENABLED)
+
(define (student-environment-warning-hook environment)
(if (not (in-user-environment-chain? environment))
(begin
(newline)
- (write-string "This environment is part of the Scheme system outside the student system.")
+ (write-string
+ "This environment is part of the Scheme system outside the student system.")
(newline)
(write-string
"Performing side-effects in it may damage to the system."))))
;;;; Feature hackery
(define (enable-language-features . prompt)
+ prompt
(without-interrupts
(lambda ()
(enable-global-environment)
- (enable-system-syntax)
- *the-non-printing-object*)))
+ (enable-system-syntax)))
+ unspecific)
(define (disable-language-features . prompt)
+ prompt
(without-interrupts
(lambda ()
(disable-global-environment)
- (disable-system-syntax)
- *the-non-printing-object*)))
+ (disable-system-syntax)))
+ unspecific)
(define (language-features-enabled?)
(global-environment-enabled?))
(AND . AND*)
(APPEND)
(APPEND-STREAMS)
- (APPLICABLE?)
+ (APPLICABLE? . PROCEDURE?)
(APPLY)
(ASCII)
(ASSOC)
(define student-band-pathname)
(define (initialize-system)
- (let ((old-init-file-pathname (init-file-pathname)))
- (set! init-file-pathname
+ (set! init-file-pathname
+ (let ((old-init-file-pathname (init-file-pathname)))
(lambda ()
- (merge-pathnames
- (make-pathname #f #f #f "sicp" #f #f)
- old-init-file-pathname))))
+ (merge-pathnames (make-pathname #f #f #f "sicp" #f #f)
+ old-init-file-pathname))))
(set! student-band-pathname
(merge-pathnames
(make-pathname #f #f #f "sicp" "bin" #f)
(define (reload #!optional filename)
(disk-restore
- (if (unassigned? filename)
+ (if (default-object? filename)
student-band-pathname
(merge-pathnames (->pathname filename)
student-band-pathname))))
(define (student-band #!optional filename)
- (if (not (unassigned? filename))
+ (if (not (default-object? filename))
(set! student-band-pathname
(merge-pathnames (->pathname filename)
student-band-pathname)))
projects / mit-scheme.git / commitdiff