From: Chris Hanson Date: Wed, 14 Nov 1990 14:58:18 +0000 (+0000) Subject: Various small cleanups for 7.1 release. X-Git-Tag: 20090517-FFI~11060 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=00fc4c5d1b5005da0cf833a4e38e30fc44573235;p=mit-scheme.git Various small cleanups for 7.1 release. --- diff --git a/v7/src/sicp/compat.scm b/v7/src/sicp/compat.scm index d929eb44b..a4f6342fe 100644 --- a/v7/src/sicp/compat.scm +++ b/v7/src/sicp/compat.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -40,7 +40,6 @@ MIT in each case. |# ;;; 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)) @@ -49,28 +48,18 @@ MIT in each case. |# (int:->string divided radix) (flo:->string divided radix))) (int:->string q radix)))) - -(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) - (stringstring symbol1) - (symbol->string symbol2))) + (stringstring 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) @@ -78,28 +67,20 @@ MIT in each case. |# (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) @@ -115,9 +96,8 @@ MIT in each case. |# (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) @@ -127,8 +107,9 @@ MIT in each case. |# (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))) (define (close-channel port) @@ -136,48 +117,45 @@ MIT in each case. |# ((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)) @@ -185,5 +163,5 @@ MIT in each case. |# (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 diff --git a/v7/src/sicp/genenv.scm b/v7/src/sicp/genenv.scm index 9718ed37a..4b33fc9b7 100644 --- a/v7/src/sicp/genenv.scm +++ b/v7/src/sicp/genenv.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -41,7 +41,7 @@ MIT in each case. |# (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) @@ -73,44 +73,29 @@ MIT in each case. |# (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 diff --git a/v7/src/sicp/graphics.scm b/v7/src/sicp/graphics.scm index ecf61c325..454a8fb85 100644 --- a/v7/src/sicp/graphics.scm +++ b/v7/src/sicp/graphics.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -42,18 +42,18 @@ MIT in each case. |# (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))) @@ -76,22 +76,20 @@ MIT in each case. |# (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 diff --git a/v7/src/sicp/sbuild.scm b/v7/src/sicp/sbuild.scm index 4f0fc5ebb..a15f2d4dc 100644 --- a/v7/src/sicp/sbuild.scm +++ b/v7/src/sicp/sbuild.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -35,10 +35,10 @@ MIT in each case. |# ;;;; 6.001 Student Environment (declare (usual-integrations)) - + (define student-system (make-system "Student (6.001)" - 14 1 + 14 2 `((,system-global-environment "compat" "graphics" "strmac" "stream" "genenv" "studen")))) diff --git a/v7/src/sicp/studen.scm b/v7/src/sicp/studen.scm index 4528482fe..bf083a52b 100644 --- a/v7/src/sicp/studen.scm +++ b/v7/src/sicp/studen.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -94,8 +94,9 @@ MIT in each case. |# (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!) @@ -104,17 +105,21 @@ MIT in each case. |# "/" (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) @@ -127,26 +132,31 @@ MIT in each case. |# (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.")))) @@ -154,18 +164,20 @@ MIT in each case. |# ;;;; 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?)) @@ -204,7 +216,7 @@ MIT in each case. |# (AND . AND*) (APPEND) (APPEND-STREAMS) - (APPLICABLE?) + (APPLICABLE? . PROCEDURE?) (APPLY) (ASCII) (ASSOC) @@ -435,12 +447,11 @@ MIT in each case. |# (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) @@ -460,13 +471,13 @@ MIT in each case. |# (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)))