bound variable. Eliminate all references to `#!false' and `#!true'.
Eliminate `canonicalize-filename-string', since pathname parsing is
now system-dependent. Install new quasiquote expander which does
vectors. Teach `eqv?' to handle null length vectors. Eliminate
`make-package' special form.
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 13.41 1987/01/23 00:07:35 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 13.42 1987/03/17 18:48:26 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
-;;; 5. In conjunction with products arising from the use of this
+;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;;; Advice package
(declare (usual-integrations))
-
+\f
(define advice-package
- (make-package advice-package
- ((the-args)
- (the-procedure)
- (the-result)
-
- (entry-advice-population (make-population))
- (exit-advice-population (make-population))
- )
-(define (*args*) the-args)
-(define (*proc*) the-procedure)
-(define (*result*) the-result)
+ (make-environment
+
+(define the-args)
+(define the-procedure)
+(define the-result)
+
+(define (*args*)
+ the-args)
+
+(define (*proc*)
+ the-procedure)
+
+(define (*result*)
+ the-result)
+
+(define entry-advice-population
+ (make-population))
+
+(define exit-advice-population
+ (make-population))
\f
;;;; Advice Wrappers
(define *args* (access *args* advice-package))
(define *proc* (access *proc* advice-package))
-(define *result* (access *result* advice-package))
(define *result* (access *result* advice-package))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 13.41 1987/01/23 00:11:14 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 13.42 1987/03/17 18:49:00 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
lambda-tag:shallow-fluid-let
lambda-tag:deep-fluid-let
lambda-tag:common-lisp-fluid-let
- lambda-tag:make-environment
- lambda-tag:make-package)))
+ lambda-tag:make-environment)))
(named-lambda (special-name? symbol)
- (memq symbol the-special-names))))
(memq symbol the-special-names))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/equals.scm,v 13.41 1987/01/23 00:11:42 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/equals.scm,v 13.42 1987/03/17 18:49:17 cph Rel $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
(if (eq? x y)
true
(and (primitive-type? (primitive-type x) y)
- (or (type? big-fixnum y)
- (type? big-flonum y))
- (= x y))))
+ (or (and (or (type? big-fixnum y)
+ (type? big-flonum y))
+ (= x y))
+ (and (type? vector y)
+ (zero? (vector-length x))
+ (zero? (vector-length y)))))))
(define (equal? x y)
(if (eq? x y)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 13.43 1987/02/15 15:42:08 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 13.44 1987/03/17 18:49:27 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
(define *error-code*)
(define *error-hook*)
-(define *error-decision-hook* #F)
+(define *error-decision-hook* false)
(define error-message
"")
(lambda ()
(fluid-let ((error-message message)
(error-irritant irritant))
- (*error-hook* environment message irritant #!FALSE)))))
+ (*error-hook* environment message irritant false)))))
(define ((error-handler-wrapper handler) error-code interrupt-enables)
(with-interrupts-reduced INTERRUPT-MASK-GC-OK
(error-irritant irritant))
(let ((environment (continuation-environment (rep-continuation))))
(if (continuation-undefined-environment? environment)
- (*error-hook* (rep-environment) message irritant #!TRUE)
- (*error-hook* environment message irritant #!FALSE)))))
+ (*error-hook* (rep-environment) message irritant true)
+ (*error-hook* environment message irritant false)))))
(define (standard-error-hook environment message irritant
substitute-environment?)
combination-second-operand)
(define-unbound-variable-error
- (list (make-primitive-procedure 'ADD-FLUID-BINDING! #!true))
+ (list (make-primitive-procedure 'ADD-FLUID-BINDING! true))
(lambda (obj)
(let ((object (combination-second-operand obj)))
(cond ((variable? object) (variable-name object))
(define-assignment-to-procedure-error
(list (make-primitive-procedure 'LEXICAL-ASSIGNMENT)
(make-primitive-procedure 'LOCAL-ASSIGNMENT)
- (make-primitive-procedure 'ADD-FLUID-BINDING! #!true)
- (make-primitive-procedure 'MAKE-FLUID-BINDING! #!true))
+ (make-primitive-procedure 'ADD-FLUID-BINDING! true)
+ (make-primitive-procedure 'MAKE-FLUID-BINDING! true))
combination-second-operand)
\f
;;;; Application Errors
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/events.scm,v 13.41 1987/01/23 00:12:11 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/events.scm,v 13.42 1987/03/17 18:49:40 cph Rel $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
-;;; 5. In conjunction with products arising from the use of this
+;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
(define receivers '())
(define queue-head '())
(define queue-tail '())
- (define event-in-progress? #!FALSE)
-
+ (define event-in-progress? false)
(lambda arguments
(if (null? queue-head)
(begin (set! queue-head (list arguments))
(set! queue-tail queue-head))
(begin (set-cdr! queue-tail (list arguments))
(set! queue-tail (cdr queue-tail))))
- (if (not (set! event-in-progress? #!TRUE))
+ (if (not (set! event-in-progress? true))
(begin (let ((arguments (car queue-head)))
(set! queue-head (cdr queue-head))
(let loop ((receivers receivers))
(if (not (null? receivers))
(begin (apply (car receivers) arguments)
(loop (cdr receivers))))))
- (set! event-in-progress? #!FALSE))))))
+ (set! event-in-progress? false))))))
(set! event-distributor?
(named-lambda (event-distributor? object)
(without-interrupts
(lambda ()
(set! (access receivers e)
- (operation event-receiver
- (access receivers e)))))))
+ (operation event-receiver (access receivers e)))))))
(set! add-event-receiver!
(make-receiver-modifier 'ADD-EVENT-RECEIVER!
(append! receivers (list receiver)))))
(set! remove-event-receiver!
- (make-receiver-modifier 'REMOVE-EVENT-RECEIVER!
- delq!))
+ (make-receiver-modifier 'REMOVE-EVENT-RECEIVER! delq!))
-)
)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/format.scm,v 13.41 1987/01/23 00:12:19 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/format.scm,v 13.42 1987/03/17 18:49:48 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
-;;; 5. In conjunction with products arising from the use of this
+;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
(define (parse-digit string supplied-arguments parsed-arguments modifiers
receiver)
- (let accumulate ((acc (char->digit (string-ref string 0) 10))
- (i 1))
+ (let accumulate ((acc (char->digit (string-ref string 0) 10)) (i 1))
(if (char-numeric? (string-ref string i))
- (accumulate (+ (* acc 10)
- (char->digit (string-ref string i) 10))
+ (accumulate (+ (* acc 10) (char->digit (string-ref string i) 10))
(1+ i))
(parse-dispatch (string-tail string i)
supplied-arguments
(define (parse-ignore string supplied-arguments parsed-arguments modifiers
receiver)
- (parse-dispatch (string-tail string 1)
- supplied-arguments
- parsed-arguments
- modifiers
- receiver))
+ (parse-dispatch (string-tail string 1) supplied-arguments parsed-arguments
+ modifiers receiver))
(define (parse-arity string supplied-arguments parsed-arguments modifiers
receiver)
(error "Too few arguments" 'FORMAT string))
(if (unassigned? n-columns)
(*unparse-string (car arguments))
- (unparse-string-into-fixed-size (car arguments) #!FALSE
+ (unparse-string-into-fixed-size (car arguments) false
n-columns modifiers))
(receiver string (cdr arguments)))
((memq 'COLON modifiers)
(*unparse-string (substring string 0 (- n-columns 4)))
(*unparse-string " ..."))
- (else
- (*unparse-string (substring string 0 n-columns))))))
+ (else (*unparse-string (substring string 0 n-columns))))))
\f
;;;; Dispatcher Setup
(add-dispatcher! #\V parse-argument)
(add-dispatcher! #\@ (parse-modifier 'AT))
(add-dispatcher! #\: (parse-modifier 'COLON))
-
+\f
;;;
;;; (format format-string arg arg ...)
;;; (format port format-string arg arg ...)
(add-dispatcher! #\C (format-wrapper format-code))
;;; end LET.
-)
)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcstat.scm,v 13.41 1987/01/23 00:13:34 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcstat.scm,v 13.42 1987/03/17 18:50:11 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
-;;; 5. In conjunction with products arising from the use of this
+;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
(define gc-history-mode)
(define gc-statistics-package
- (make-package gc-statistics-package ()
+ (make-environment
\f
;;;; Statistics Hooks
(with-interrupts-reduced INTERRUPT-MASK-NONE
(lambda (Old-Interrupt-Mask)
(measure-interval
- #!FALSE ;i.e. do not count the interval in RUNTIME.
+ false ;i.e. do not count the interval in RUNTIME.
(lambda (start-time)
(let ((old-state (gc-start-hook)))
(let ((new-space-remaining (primitive-datum (apply old-flip more))))
(define (statistics-reset!)
(set! meter 1)
(set! total-gc-time 0)
- (set! last-gc-start #!FALSE)
+ (set! last-gc-start false)
(set! last-gc-end (system-clock))
(reset-recorder! '()))
(define history)
(define (reset-recorder! old)
- (set! last-statistic #!FALSE)
+ (set! last-statistic false)
(reset-history! old))
(define (record-statistic! statistic)
(write-string "%) free: ") (write heap-left)))
(vector->list statistic)))
-)
)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/histry.scm,v 13.42 1987/02/15 15:43:36 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/histry.scm,v 13.43 1987/03/17 18:50:22 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
(define with-new-history)
(define history-package
- (make-package history-package
- ((set-current-history!
- (make-primitive-procedure 'SET-CURRENT-HISTORY!))
- (return-address-pop-from-compiled-code
- (make-return-address
- (microcode-return 'POP-FROM-COMPILED-CODE)))
-
- ;; VERTEBRA abstraction.
- (make-vertebra (make-primitive-procedure 'HUNK3-CONS))
- (vertebra-rib system-hunk3-cxr0)
- (deeper-vertebra system-hunk3-cxr1)
- (shallower-vertebra system-hunk3-cxr2)
- (set-vertebra-rib! system-hunk3-set-cxr0!)
- (set-deeper-vertebra! system-hunk3-set-cxr1!)
- (set-shallower-vertebra! system-hunk3-set-cxr2!)
-
- ;; REDUCTION abstraction.
- (make-reduction (make-primitive-procedure 'HUNK3-CONS))
- (reduction-expression system-hunk3-cxr0)
- (reduction-environment system-hunk3-cxr1)
- (next-reduction system-hunk3-cxr2)
- (set-reduction-expression! system-hunk3-set-cxr0!)
- (set-reduction-environment! system-hunk3-set-cxr1!)
- (set-next-reduction! system-hunk3-set-cxr2!)
- )
+ (let ((set-current-history!
+ (make-primitive-procedure 'SET-CURRENT-HISTORY!))
+ (return-address-pop-from-compiled-code
+ (make-return-address
+ (microcode-return 'POP-FROM-COMPILED-CODE)))
+
+ ;; VERTEBRA abstraction.
+ (make-vertebra (make-primitive-procedure 'HUNK3-CONS))
+ (vertebra-rib system-hunk3-cxr0)
+ (deeper-vertebra system-hunk3-cxr1)
+ (shallower-vertebra system-hunk3-cxr2)
+ (set-vertebra-rib! system-hunk3-set-cxr0!)
+ (set-deeper-vertebra! system-hunk3-set-cxr1!)
+ (set-shallower-vertebra! system-hunk3-set-cxr2!)
+
+ ;; REDUCTION abstraction.
+ (make-reduction (make-primitive-procedure 'HUNK3-CONS))
+ (reduction-expression system-hunk3-cxr0)
+ (reduction-environment system-hunk3-cxr1)
+ (next-reduction system-hunk3-cxr2)
+ (set-reduction-expression! system-hunk3-set-cxr0!)
+ (set-reduction-environment! system-hunk3-set-cxr1!)
+ (set-next-reduction! system-hunk3-set-cxr2!)
+ )
(declare (integrate-primitive-procedures
(make-vertebra hunk3-cons)
(define (create-history depth width)
(define (new-vertebra)
- (let ((head (make-reduction #!FALSE #!FALSE '())))
+ (let ((head (make-reduction false false '())))
(set-next-reduction!
head
(let reduction-loop ((n (-1+ width)))
(if (zero? n)
head
- (make-reduction #!FALSE
- #!FALSE
- (reduction-loop (-1+ n))))))
+ (make-reduction false false (reduction-loop (-1+ n))))))
(make-vertebra head '() '())))
(cond ((or (not (integer? depth))
;;; SET-CURRENT-HISTORY! is run.
(set! with-new-history
- (named-lambda (with-new-history thunk)
- (set-current-history!
- (let ((history (push-history! (create-history max-subproblems
- max-reductions))))
- (if (zero? max-subproblems)
-
- ;; In this case, we want the history to appear empty,
- ;; so when it pops up, there is nothing in it.
- history
-
- ;; Otherwise, record a dummy reduction, which will appear
- ;; in the history.
- (begin
- (record-evaluation-in-history! history
- (scode-quote #!FALSE)
- system-global-environment)
- (push-history! history)))))
+ (named-lambda (with-new-history thunk)
+ (set-current-history!
+ (let ((history
+ (push-history! (create-history max-subproblems
+ max-reductions))))
+ (if (zero? max-subproblems)
+
+ ;; In this case, we want the history to appear empty,
+ ;; so when it pops up, there is nothing in it.
+ history
+
+ ;; Otherwise, record a dummy reduction, which will appear
+ ;; in the history.
+ (begin
+ (record-evaluation-in-history! history
+ (scode-quote #F)
+ system-global-environment)
+ (push-history! history)))))
(thunk)))
;;;; Primitive History Operations
(let loop ((current history))
(cons current
(if (marked-vertebra? current)
- (cons (delay
- (unfold-and-reverse-rib (vertebra-rib current)))
+ (cons (delay (unfold-and-reverse-rib (vertebra-rib current)))
(delay
(let ((next (shallower-vertebra current)))
(if (eq? next history)
(reduction-environment reduction))))
(define (unfold-and-reverse-rib rib)
- (let loop ((current (next-reduction rib))
- (output 'WRAP-AROUND))
+ (let loop ((current (next-reduction rib)) (output 'WRAP-AROUND))
(let ((step
(if (dummy-compiler-reduction? current)
'()
output)))))
(if (eq? current rib)
step
- (loop (next-reduction current)
- step)))))
+ (loop (next-reduction current) step)))))
(define the-empty-history
(cons (vector-ref (get-fixed-objects-vector)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 13.42 1987/03/12 02:20:33 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 13.43 1987/03/17 18:50:41 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
-;;; 5. In conjunction with products arising from the use of this
+;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
'DONE)
(define character-buffer
- #!FALSE)
+ false)
(define (:peek-char)
(or character-buffer
character-buffer)))
(define (:discard-char)
- (set! character-buffer #!FALSE))
+ (set! character-buffer false))
\f
(define (:read-char)
(if character-buffer
- (set! character-buffer #!FALSE)
+ (set! character-buffer false)
(tty-read-char)))
(define (:read-string delimiters)
(define (:read-char-immediate)
(if character-buffer
- (set! character-buffer #!FALSE)
+ (set! character-buffer false)
(tty-read-char-immediate)))
(define (:char-ready? delay)
- (or character-buffer
- (tty-read-char-ready? delay)))
+ (or character-buffer (tty-read-char-ready? delay)))
(define (:read-start!)
(read-start-hook))
(define (:length)
(file-length file-channel))
\f
-(define buffer #!FALSE)
+(define buffer false)
(define start-index 0)
(define end-index -1)
(define (:close)
(set! end-index 0)
- (set! buffer #!FALSE)
+ (set! buffer false)
((access close-physical-channel primitive-io) file-channel))
(define (:peek-char)
\f
(define load)
(define load-noisily)
-(define load-noisily? #!FALSE)
+(define load-noisily? false)
(define read-file)
(let ()
(define default-pathname
- (make-pathname #!FALSE #!FALSE #!FALSE #!FALSE 'NEWEST))
+ (make-pathname false false false false 'NEWEST))
;;; This crufty piece of code, once it decides which file to load,
;;; does `file-exists?' on that file at least three times!!
(if (pair? filename)
(for-each kernel filename)
(kernel filename)))
-
+\f
(set! load
(named-lambda (load filename #!optional environment)
(if (unassigned? environment) (set! environment (rep-environment)))
(set! load-noisily
(named-lambda (load-noisily filename #!optional environment)
(if (unassigned? environment) (set! environment (rep-environment)))
- (fluid-let ((load-noisily? #!TRUE))
+ (fluid-let ((load-noisily? true))
(basic-load filename environment))))
(set! read-file
(named-lambda (transcript-off)
(if (not (photo-close))
(error "Transcript file already closed: TRANSCRIPT-OFF"))
- *the-non-printing-object*)))
*the-non-printing-object*)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 13.42 1987/02/15 15:43:59 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 13.43 1987/03/17 18:50:56 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
(define timer-interrupt
(let ((setup-timer-interrupt
- (make-primitive-procedure 'setup-timer-interrupt #T)))
+ (make-primitive-procedure 'SETUP-TIMER-INTERRUPT true)))
(named-lambda (timer-interrupt)
(setup-timer-interrupt '() '())
(error "Unhandled Timer interrupt received"))))
(define interrupt-system
- (make-package interrupt-system
- ((get-next-interrupt-character
- (make-primitive-procedure 'GET-NEXT-INTERRUPT-CHARACTER))
- (check-and-clean-up-input-channel
- (make-primitive-procedure 'CHECK-AND-CLEAN-UP-INPUT-CHANNEL))
- (index:interrupt-vector
- (fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR))
- (index:termination-vector
- (fixed-objects-vector-slot
- 'MICROCODE-TERMINATIONS-PROCEDURES))
- (^Q-Hook '()))
+ (let ((get-next-interrupt-character
+ (make-primitive-procedure 'GET-NEXT-INTERRUPT-CHARACTER))
+ (check-and-clean-up-input-channel
+ (make-primitive-procedure 'CHECK-AND-CLEAN-UP-INPUT-CHANNEL))
+ (index:interrupt-vector
+ (fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR))
+ (index:termination-vector
+ (fixed-objects-vector-slot
+ 'MICROCODE-TERMINATIONS-PROCEDURES))
+ (^Q-Hook '()))
\f
;;;; Soft interrupts
; (install-keyboard-interrupt! #\S ^S-interrupt-handler)
; (install-keyboard-interrupt! #\Q ^Q-interrupt-handler)
-(define STACK-OVERFLOW-SLOT 0)
-(define GC-SLOT 2)
-(define CHARACTER-SLOT 4)
-(define TIMER-SLOT 6)
-
+(define stack-overflow-slot 0)
+(define gc-slot 2)
+(define character-slot 4)
+(define timer-slot 6)
+\f
(define (install)
- (with-interrupts-reduced INTERRUPT-MASK-GC-OK
+ (with-interrupts-reduced interrupt-mask-gc-ok
(lambda (old-mask)
(let ((old-system-interrupt-vector
(vector-ref (get-fixed-objects-vector) index:interrupt-vector))
(old-termination-vector
(vector-ref (get-fixed-objects-vector) index:termination-vector)))
(let ((previous-gc-interrupt
- (vector-ref old-system-interrupt-vector GC-SLOT))
+ (vector-ref old-system-interrupt-vector gc-slot))
(previous-stack-interrupt
- (vector-ref old-system-interrupt-vector STACK-OVERFLOW-SLOT))
+ (vector-ref old-system-interrupt-vector stack-overflow-slot))
(system-interrupt-vector
(vector-cons (vector-length old-system-interrupt-vector)
default-interrupt-handler))
(vector-grow old-termination-vector
number-of-microcode-terminations)
old-termination-vector)
- (vector-cons number-of-microcode-terminations #F))))
+ (vector-cons number-of-microcode-terminations false))))
- (vector-set! system-interrupt-vector GC-SLOT previous-gc-interrupt)
- (vector-set! system-interrupt-vector STACK-OVERFLOW-SLOT
+ (vector-set! system-interrupt-vector gc-slot previous-gc-interrupt)
+ (vector-set! system-interrupt-vector stack-overflow-slot
previous-stack-interrupt)
- (vector-set! system-interrupt-vector CHARACTER-SLOT
+ (vector-set! system-interrupt-vector character-slot
external-interrupt-handler)
- (vector-set! system-interrupt-vector TIMER-SLOT
+ (vector-set! system-interrupt-vector timer-slot
timer-interrupt-handler)
;; slots 4-15 unused.
(dynamic-wind
(lambda ()
(set! old-handler
- (vector-set! interrupt-vector CHARACTER-SLOT old-handler)))
+ (vector-set! interrupt-vector character-slot old-handler)))
code
(lambda ()
- (vector-set! interrupt-vector CHARACTER-SLOT
+ (vector-set! interrupt-vector character-slot
(set! old-handler
- (vector-ref interrupt-vector CHARACTER-SLOT)))))))
+ (vector-ref interrupt-vector character-slot)))))))
;;; end INTERRUPT-SYSTEM package.
(the-environment)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 13.41 1987/01/23 00:15:18 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 13.42 1987/03/17 18:51:08 cph Rel $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
-;;; 5. In conjunction with products arising from the use of this
+;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
(define lambda-bound)
(define lambda-package
- (make-package lambda-package
- ((slambda-type (microcode-type 'LAMBDA))
- (slexpr-type (microcode-type 'LEXPR))
- (xlambda-type (microcode-type 'EXTENDED-LAMBDA))
- (internal-lambda-tag (make-named-tag "INTERNAL-LAMBDA"))
- (internal-lexpr-tag (make-named-tag "INTERNAL-LEXPR"))
- (lambda-optional-tag (make-interned-symbol "#!OPTIONAL"))
- (lambda-rest-tag (make-interned-symbol "#!REST")))
+ (let ((slambda-type (microcode-type 'LAMBDA))
+ (slexpr-type (microcode-type 'LEXPR))
+ (xlambda-type (microcode-type 'EXTENDED-LAMBDA))
+ (internal-lambda-tag (make-named-tag "INTERNAL-LAMBDA"))
+ (internal-lexpr-tag (make-named-tag "INTERNAL-LEXPR"))
+ (lambda-optional-tag (make-interned-symbol "#!OPTIONAL"))
+ (lambda-rest-tag (make-interned-symbol "#!REST")))
(define internal-lambda-tags
(list internal-lambda-tag internal-lexpr-tag))
-
+\f
;;;; Hairy Advice Wrappers
;;; The body of a LAMBDA object can be modified by transformation.
(define (clambda-bound clambda)
(slambda-components clambda
(lambda (name required body)
- (cons name
- (if (combination? body)
- (let ((operator (combination-operator body)))
- (if (is-internal-lambda? operator)
- (slambda-components operator
- (lambda (tag auxiliary body)
- (append required auxiliary)))
- required))
- required)))))
+ (if (combination? body)
+ (let ((operator (combination-operator body)))
+ (if (is-internal-lambda? operator)
+ (slambda-components operator
+ (lambda (tag auxiliary body)
+ (append required auxiliary)))
+ required))
+ required))))
(define (clambda-has-internal-lambda? clambda)
(let ((body (slambda-body clambda)))
(let ((operator (combination-operator body)))
(and (is-internal-lambda? operator)
operator)))))
-
+\f
(define clambda-wrap-body!)
(define clambda-wrapper-components)
(define clambda-unwrap-body!)
(lambda (name required body)
(slambda-components (combination-operator body)
(lambda (tag auxiliary body)
- (cons name (append required auxiliary)))))))
+ (append required auxiliary))))))
(define (clexpr-has-internal-lambda? clexpr)
(combination-operator (slexpr-body clexpr)))
-
+\f
(define clexpr-wrap-body!)
(define clexpr-wrapper-components)
(define clexpr-unwrap-body!)
(xlambda-unwrapped-body xlambda))))))))
(define (xlambda-bound xlambda)
- (vector->list (&triple-second xlambda)))
+ (let ((names (&triple-second xlambda)))
+ (subvector->list names 1 (vector-length names))))
(define (xlambda-has-internal-lambda? xlambda)
- #!FALSE)
-
+ false)
+\f
(define xlambda-wrap-body!)
(define xlambda-wrapper-components)
(define xlambda-unwrap-body!)
(set! xlambda-unwrapped-body unwrapped-body)
(set! set-xlambda-unwrapped-body! set-unwrapped-body!)))
\f
+;;;; Generic Lambda
+
(set! lambda?
(named-lambda (lambda? object)
(or (primitive-type? slambda-type object)
(block-declaration-text (car actions))
(make-sequence (cdr actions)))
(receiver name required optional rest auxiliary '() body)))))))
-\f
+
(define ((dispatch-0 op-name clambda-op clexpr-op xlambda-op) lambda)
((cond ((primitive-type? slambda-type lambda) clambda-op)
((primitive-type? slexpr-type lambda) clexpr-op)
((primitive-type? xlambda-type lambda) xlambda-op)
(else (error "Not a lambda" op-name lambda)))
lambda))
-
+\f
(define ((dispatch-1 op-name clambda-op clexpr-op xlambda-op) lambda arg)
((cond ((primitive-type? slambda-type lambda) clambda-op)
((primitive-type? slexpr-type lambda) clexpr-op)
(define slexpr-body slambda-body)
;;; end LAMBDA-PACKAGE.
-))
+(the-environment)))
+\f
+;;;; Alternative Component Views
(define (make-lambda* name required optional rest body)
(scan-defines body
(define (lambda-components** lambda receiver)
(lambda-components* lambda
(lambda (name required optional rest body)
- (let ((rest-list (if (null? rest) '() (list rest))))
- (receiver (list required optional rest-list)
- `(,name ,@required ,@optional ,@rest-list)
- body)))))
+ (receiver (vector name required optional rest)
+ (append required optional (if (null? rest) '() (list rest)))
+ body))))
+
+(define (lambda-pattern/name pattern)
+ (vector-ref pattern 0))
+
+(define (lambda-pattern/required pattern)
+ (vector-ref pattern 1))
+
+(define (lambda-pattern/optional pattern)
+ (vector-ref pattern 2))
+
+(define (lambda-pattern/rest pattern)
+ (vector-ref pattern 3))
(define (make-lambda** pattern bound body)
+
(define (split pattern bound receiver)
(cond ((null? pattern)
(receiver '() bound))
(lambda (copy tail)
(receiver (cons (car bound) copy)
tail))))))
- (split (first pattern) (cdr bound)
+
+ (split (lambda-pattern/required pattern) bound
(lambda (required tail)
- (split (second pattern) tail
+ (split (lambda-pattern/optional pattern) tail
(lambda (optional rest)
- (make-lambda* (car bound)
+ (make-lambda* (lambda-pattern/name pattern)
required
optional
(if (null? rest) rest (car rest))
- body))))))
body))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 13.41 1987/01/23 00:17:04 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 13.42 1987/03/17 18:51:44 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
(define-char #\`
(lambda ()
(discard-char)
- (list (access quasiquote-keyword syntaxer-package)
- (parse-object))))
+ (list 'QUASIQUOTE (parse-object))))
(define-char #\,
(lambda ()
(discard-char)
(if (char=? #\@ (peek-char))
(begin (discard-char)
- (list (access unquote-splicing-keyword syntaxer-package)
- (parse-object)))
- (list (access unquote-keyword syntaxer-package)
- (parse-object)))))
+ (list 'UNQUOTE-SPLICING (parse-object)))
+ (list 'UNQUOTE (parse-object)))))
(define-char #\"
(let ((delimiters (char-set #\" #\\)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 13.41 1987/01/23 00:17:46 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 13.42 1987/03/17 18:52:08 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
(print-guaranteed-column nodes optimistic)
(begin (tab-to pessimistic)
(print-column nodes pessimistic depth))))))
-
+\f
;;; Print a procedure definition. The bound variable pattern goes on
;;; the same line as the keyword, while everything else gets indented
;;; pessimistically. We may later want to modify this to make higher
(print-node (car nodes) optimistic 0)
(tab-to pessimistic)
(print-column (cdr nodes) pessimistic depth))))
-\f
+
;;; Print a binding form. There is a great deal of complication here,
;;; some of which is to gracefully handle the case of a badly-formed
;;; binder. But most important is the code that handles the name when
(else ;Ordinary LET.
(print-node (car nodes) optimistic 0)
(print-body (cdr nodes)))))))
-
+\f
(define dispatch-list
`((COND . ,forced-indentation)
(IF . ,forced-indentation)
(DEFINE . ,print-procedure)
(LAMBDA . ,print-procedure)
(NAMED-LAMBDA . ,print-procedure)))
-\f
+
;;;; Alignment
(declare (integrate fits-within?))
(define (make-prefix-node prefix subnode)
(cond ((or (list-node? subnode)
(symbol? subnode))
- (vector (+ (string-length prefix)
- (node-size subnode))
+ (vector (+ (string-length prefix) (node-size subnode))
prefix
subnode))
((prefix-node? subnode)
(make-prefix-node (string-append prefix (node-prefix subnode))
(node-subnode subnode)))
- (else
- (string-append prefix subnode))))
+ (else (string-append prefix subnode))))
(define prefix-node? vector?)
(define prefix-node-size vector-first)
(define (kernel as-code?)
(if (scode-constant? scode)
((access pp scheme-pretty-printer) scode as-code?)
- ((access pp scheme-pretty-printer) (prepare scode) #!TRUE)))
+ ((access pp scheme-pretty-printer) (prepare scode) true)))
(cond ((null? optionals)
- (kernel #!FALSE))
+ (kernel false))
((null? (cdr optionals))
(cond ((eq? (car optionals) 'AS-CODE)
- (kernel #!TRUE))
+ (kernel true))
((output-port? (car optionals))
(with-output-to-port (car optionals)
- (lambda () (kernel #!FALSE))))
+ (lambda () (kernel false))))
(else
(bad-arg (car optionals)))))
((null? (cddr optionals))
(cond ((eq? (car optionals) 'AS-CODE)
(if (output-port? (cadr optionals))
(with-output-to-port (cadr optionals)
- (lambda () (kernel #!TRUE)))
+ (lambda () (kernel true)))
(bad-arg (cadr optionals))))
((output-port? (car optionals))
(if (eq? (cadr optionals) 'AS-CODE)
(with-output-to-port (car optionals)
- (lambda () (kernel #!TRUE)))
+ (lambda () (kernel true)))
(bad-arg (cadr optionals))))
(else
(bad-arg (car optionals)))))
(define (pa procedure)
(if (not (compound-procedure? procedure))
(error "Must be a compound procedure" procedure))
- (pp (unsyntax-lambda-list (procedure-lambda procedure))))
(pp (unsyntax-lambda-list (procedure-lambda procedure))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scode.scm,v 13.41 1987/01/23 00:19:03 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scode.scm,v 13.42 1987/03/17 18:52:47 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
-;;; 5. In conjunction with products arising from the use of this
+;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;;; Constants
(define scode-constant?
- (let ((type-vector (make-vector number-of-microcode-types #!FALSE)))
+ (let ((type-vector (make-vector number-of-microcode-types false)))
(for-each (lambda (name)
- (vector-set! type-vector (microcode-type name) #!TRUE))
+ (vector-set! type-vector (microcode-type name) true))
'(NULL TRUE UNASSIGNED
FIXNUM BIGNUM FLONUM
CHARACTER STRING UNINTERNED-SYMBOL INTERNED-SYMBOL
(define set-definition-name! system-pair-set-car!)
(define definition-value &pair-cdr)
(define set-definition-value! &pair-set-cdr!)
-
+\f
;;;; ASSIGNMENT
(define assignment?)
(define in-package-environment &pair-car)
(define in-package-expression &pair-cdr)
-
+\f
;;;; DELAY
(define delay?)
(define delay-expression &singleton-element)
(define (delay-components delay receiver)
- (receiver (delay-expression delay)))
-
(receiver (delay-expression delay)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scomb.scm,v 13.41 1987/01/23 00:19:15 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scomb.scm,v 13.42 1987/03/17 18:52:59 cph Rel $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
-;;; 5. In conjunction with products arising from the use of this
+;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
(combination-components predicate
(lambda (operator operands)
(if (eq? operator not)
- (make-conditional (first operands) alternative #!TRUE)
+ (make-conditional (first operands) alternative true)
(&typed-pair-cons type predicate alternative))))
(&typed-pair-cons type predicate alternative))))
(receiver (unassigned?-name unassigned?)))
(define unbound?-name unassigned?-name)
-(define unbound?-components unassigned?-components)
-
(define unbound?-components unassigned?-components)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 13.42 1987/02/27 21:59:36 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 13.43 1987/03/17 18:53:27 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
(define lambda-tag:make-environment
(make-named-tag "MAKE-ENVIRONMENT-PROCEDURE"))
-(define lambda-tag:make-package
- (make-named-tag "MAKE-PACKAGE-PROCEDURE"))
-
(define syntax)
(define syntax*)
(define macro-spreader)
\f
;;;; Quasiquote
-(define quasiquote-keyword 'QUASIQUOTE)
-(define unquote-keyword 'UNQUOTE)
-(define unquote-splicing-keyword 'UNQUOTE-SPLICING)
-
(define expand-quasiquote)
(let ()
-(define (expand expression)
- (if (pair? expression)
- (cond ((eq? (car expression) unquote-keyword)
- (cadr expression))
- ((eq? (car expression) quasiquote-keyword)
- (expand (expand (cadr expression))))
- ((eq? (car expression) unquote-splicing-keyword)
- (error "EXPAND-QUASIQUOTE: Misplaced ,@" expression))
- ((and (pair? (car expression))
- (eq? (caar expression) unquote-splicing-keyword))
- (expand-spread (cadr (car expression))
- (expand (cdr expression))))
- (else
- (expand-pair (expand (car expression))
- (expand (cdr expression)))))
- (list 'QUOTE expression)))
-
-(define (expand-pair a d)
- (cond ((pair? d)
- (cond ((eq? (car d) 'QUOTE)
- (cond ((and (pair? a) (eq? (car a) 'QUOTE))
- (list 'QUOTE (cons (cadr a) (cadr d))))
- ((list? (cadr d))
- (cons* 'LIST
- a
- (map (lambda (element)
- (list 'QUOTE element))
- (cadr d))))
- (else
- (list 'CONS a d))))
- ((eq? (car d) 'CONS)
- (cons* 'CONS* a (cdr d)))
- ((memq (car d) '(LIST CONS*))
- (cons* (car d) a (cdr d)))
- (else
- (list 'CONS a d))))
- (else
- (list 'CONS a d))))
+(define (descend-quasiquote x level return)
+ (cond ((pair? x) (descend-quasiquote-pair x level return))
+ ((vector? x) (descend-quasiquote-vector x level return))
+ (else (return 'QUOTE x))))
+
+(define (descend-quasiquote-pair x level return)
+ (define (descend-quasiquote-pair* level)
+ (descend-quasiquote (car x) level
+ (lambda (car-mode car-arg)
+ (descend-quasiquote (cdr x) level
+ (lambda (cdr-mode cdr-arg)
+ (cond ((and (eq? car-mode 'QUOTE)
+ (eq? cdr-mode 'QUOTE))
+ (return 'QUOTE x))
+ ((eq? car-mode 'UNQUOTE-SPLICING)
+ (if (and (eq? cdr-mode 'QUOTE)
+ (null? cdr-arg))
+ (return 'UNQUOTE car-arg)
+ (return (system 'APPEND)
+ (list car-arg
+ (finalize-quasiquote cdr-mode cdr-arg)))))
+ ((and (eq? cdr-mode 'QUOTE)
+ (null? cdr-arg))
+ (return 'LIST
+ (list (finalize-quasiquote car-mode car-arg))))
+ ((and (eq? cdr-mode 'QUOTE)
+ (list? cdr-arg))
+ (return 'LIST
+ (cons (finalize-quasiquote car-mode car-arg)
+ (map (lambda (el)
+ (finalize-quasiquote 'QUOTE el))
+ cdr-arg))))
+ ((memq cdr-mode '(LIST CONS))
+ (return cdr-mode
+ (cons (finalize-quasiquote car-mode car-arg)
+ cdr-arg)))
+ (else
+ (return
+ 'CONS
+ (list (finalize-quasiquote car-mode car-arg)
+ (finalize-quasiquote cdr-mode cdr-arg))))))))))
+ (case (car x)
+ ((QUASIQUOTE) (descend-quasiquote-pair* (1+ level)))
+ ((UNQUOTE UNQUOTE-SPLICING)
+ (if (zero? level)
+ (return (car x) (cadr x))
+ (descend-quasiquote-pair* (- level 1))))
+ (else (descend-quasiquote-pair* level))))
\f
-(define (expand-spread a d)
- (cond ((pair? d)
- (cond ((eq? (car d) 'QUOTE)
- (cond ((and (pair? a) (eq? (car a) 'QUOTE))
- (list 'QUOTE (append (cadr a) (cadr d))))
- ((null? (cadr d))
- a)
- (else
- (list 'APPEND a d))))
- ((eq? (car d) 'APPEND)
- (cons* (car d) a (cdr d)))
- (else
- (list 'APPEND a d))))
+(define (descend-quasiquote-vector x level return)
+ (descend-quasiquote (vector->list x) level
+ (lambda (mode arg)
+ (case mode
+ ((QUOTE)
+ (return 'QUOTE x))
+ ((LIST)
+ (return (system 'VECTOR) arg))
(else
- (list 'APPEND a d))))
+ (return (system 'LIST->VECTOR)
+ (list (finalize-quasiquote mode arg))))))))
+
+(define (finalize-quasiquote mode arg)
+ (case mode
+ ((QUOTE) `',arg)
+ ((UNQUOTE) arg)
+ ((UNQUOTE-SPLICING) (error ",@ in illegal context" arg))
+ ((LIST) `(,(system 'LIST) ,@arg))
+ ((CONS)
+ (if (= (length arg) 2)
+ `(,(system 'CONS) ,@arg)
+ `(,(system 'CONS*) ,@arg)))
+ (else `(,mode ,@arg))))
+
+(define (system name)
+ `(ACCESS ,name #F))
(set! expand-quasiquote
-(named-lambda (expand-quasiquote expression)
- (syntax-expression (expand expression))))
+ (named-lambda (expand-quasiquote expression)
+ (syntax-expression (descend-quasiquote expression 0 finalize-quasiquote))))
)
\f
(if (symbol? name-or-pattern)
(syntax-bindings pattern-or-first
(lambda (names values)
- (make-combination (make-named-lambda name-or-pattern names
- (syntax-sequence rest))
- values)))
+ (make-letrec (list name-or-pattern)
+ (list (make-named-lambda name-or-pattern names
+ (syntax-sequence rest)))
+ (make-combination (make-variable name-or-pattern)
+ values))))
(syntax-bindings name-or-pattern
(lambda (names values)
(make-closed-block
lambda-tag:let names values
(syntax-sequence (cons pattern-or-first rest)))))))))
-(define syntax-MAKE-PACKAGE-form
- (spread-arguments
- (lambda (name bindings . body)
- (if (symbol? name)
- (syntax-bindings bindings
- (lambda (names values)
- (make-closed-block
- lambda-tag:make-package
- (cons name names)
- (cons unassigned-object values)
- (make-sequence* (make-assignment name the-environment-object)
- (if (null? body)
- the-environment-object
- (make-sequence* (syntax-sequence body)
- the-environment-object))))))
- (syntax-error "Bad package name" name)))))
-
(define syntax-MAKE-ENVIRONMENT-form
(spread-arguments
(lambda body
(define (make-closed-block tag names values body)
(make-combination (internal-make-lambda tag names '() '() body)
values))
+
+(define (make-letrec names values body)
+ (make-closed-block lambda-tag:let '() '()
+ (make-sequence (append! (map make-definition names values)
+ (list body)))))
\f
;;;; Lambda List Parser
(LOCAL-DECLARE . ,syntax-LOCAL-DECLARE-form)
(MACRO . ,syntax-MACRO-form)
(MAKE-ENVIRONMENT . ,syntax-MAKE-ENVIRONMENT-form)
- (MAKE-PACKAGE . ,syntax-MAKE-PACKAGE-form)
(NAMED-LAMBDA . ,syntax-NAMED-LAMBDA-form)
(OR . ,syntax-DISJUNCTION-form)
;; The funniness here prevents QUASIQUOTE from being
))))
;;; end SYNTAXER-PACKAGE
-)
-
-;;; Edwin Variables:
-;;; Scheme Environment: syntaxer-package
-;;; End:
)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 13.42 1987/03/12 02:19:48 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 13.43 1987/03/17 18:53:48 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
-;;; 5. In conjunction with products arising from the use of this
+;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
(lambda (eval-list pure-list constant-list)
(if (not (null? pure-list))
(begin (newline) (write-string "Purify")
- (purify (list->vector pure-list) #!TRUE)))
+ (purify (list->vector pure-list) true)))
(if (not (null? constant-list))
(begin (newline) (write-string "Constantify")
- (purify (list->vector constant-list) #!FALSE)))
+ (purify (list->vector constant-list) false)))
(append! eval-list (loop tail))))))))
(let ((files (format-files-list (access :files-lists system) compiled?)))
(set! (access :files system)
(let ((char (char-upcase (read-char))))
(cond ((char=? #\Y char)
(write-string "Yes")
- #!TRUE)
+ true)
((char=? #\N char)
(write-string "No")
- #!FALSE)
+ false)
(else (beep) (query prompt)))))
-)
-
)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 13.41 1987/01/23 00:21:55 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 13.42 1987/03/17 18:54:23 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
(define unexpand-definition
(definition-unexpander 'DEFINE 'DEFINE))
-
+\f
(define (unsyntax-COMMENT-object comment)
(comment-components comment
(lambda (text expression)
,@(unsyntax-cond-alternative alternative)))
(define (unsyntax-cond-alternative alternative)
- (cond ((false? alternative)
- '())
+ (cond ((false? alternative) '())
((disjunction? alternative)
(disjunction-components alternative unsyntax-cond-disjunction))
((conditional? alternative)
(conditional-components alternative unsyntax-cond-conditional))
- (else
- `((ELSE ,@(unsyntax-sequence alternative))))))
+ (else `((ELSE ,@(unsyntax-sequence alternative))))))
(define (unexpand-conjunction predicate consequent)
(if (conditional? consequent)
`(,(unsyntax-conditional predicate
consequent
alternative))))))
- `(,(unsyntax-object predicate)
- ,(unsyntax-object consequent))))
+ `(,(unsyntax-object predicate) ,(unsyntax-object consequent))))
(define (unsyntax-DISJUNCTION-object object)
`(OR ,@(disjunction-components object unexpand-disjunction)))
((eq? name lambda-tag:deep-fluid-let)
(unsyntax-deep-fluid-let required operands body))
((eq? name lambda-tag:shallow-fluid-let)
- (unsyntax-shallow-fluid-let required operands body))
+ (unsyntax-shallow-fluid-let required operands
+ body))
((eq? name lambda-tag:common-lisp-fluid-let)
- (unsyntax-common-lisp-fluid-let required operands body))
+ (unsyntax-common-lisp-fluid-let required operands
+ body))
((eq? name lambda-tag:make-environment)
(unsyntax-make-environment required operands body))
- ((eq? name lambda-tag:make-package)
- (unsyntax-make-package required operands body))
(else
`(LET ,name
,(unsyntax-let-bindings required operands)
(else
(cons (unsyntax-object operator)
(unsyntax-objects operands)))))))
-
+\f
(define (unsyntax-error-like-form operands name)
(cons* name
(unsyntax-object (first operands))
(null? environment)))))
(unsyntax-objects operands)
`(,(unsyntax-object operand))))))
- (else
- `(,(unsyntax-object operand)))))))
-\f
+ (else `(,(unsyntax-object operand)))))))
+
(define (unsyntax-shallow-FLUID-LET names values body)
(combination-components body
(lambda (operator operands)
(define (every-other list)
(if (null? list)
'()
- (cons (car list)
- (every-other (cddr list)))))
+ (cons (car list) (every-other (cddr list)))))
(define (extract-transfer-var assignment)
(assignment-components assignment
(lambda (name value)
(cond ((assignment? value)
- (assignment-components value
- (lambda (name value)
- name)))
+ (assignment-components value (lambda (name value) name)))
((combination? value)
(combination-components value
(lambda (operator operands)
(name (second operands))
(val (third operands)))
(cond ((symbol? name)
- `((ACCESS ,name ,(unsyntax-object env)) ,(unsyntax-object val)))
+ `((ACCESS ,name ,(unsyntax-object env))
+ ,(unsyntax-object val)))
((quotation? name)
(let ((var (quotation-expression name)))
(if (variable? var)
(define unsyntax-deep-FLUID-LET
(unsyntax-deep-or-common-FLUID-LET
- 'FLUID-LET (make-primitive-procedure 'add-fluid-binding! #!true)))
+ 'FLUID-LET (make-primitive-procedure 'add-fluid-binding! true)))
(define unsyntax-common-lisp-FLUID-LET
(unsyntax-deep-or-common-FLUID-LET
- 'FLUID-BIND (make-primitive-procedure 'make-fluid-binding! #!true)))
-\f
+ 'FLUID-BIND (make-primitive-procedure 'make-fluid-binding! true)))
+
(define (unsyntax-MAKE-ENVIRONMENT names values body)
`(MAKE-ENVIRONMENT ,@(except-last-pair (unsyntax-sequence body))))
-(define (unsyntax-MAKE-PACKAGE names values body)
- `(MAKE-PACKAGE ,(car names)
- ,(unsyntax-let-bindings (cdr names)
- (cdr values))
- ,@(except-last-pair (cdr (unsyntax-sequence body)))))
-
(define (unsyntax-let-bindings names values)
(map unsyntax-let-binding names values))
(,lambda-type ,unsyntax-LAMBDA-object))))
;;; end UNSYNTAXER-PACKAGE
-))
))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 1.1 1987/03/12 02:16:51 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 1.2 1987/03/17 18:54:38 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
(let ()
(set! string->pathname
-(named-lambda (string->pathname string)
- (parse-pathname (canonicalize-filename-string string)
- make-pathname)))
+ (named-lambda (string->pathname string)
+ (parse-pathname string make-pathname)))
(define (parse-pathname string receiver)
(let ((components (divide-into-components (string-trim string))))
(else (list string)))))
(set! home-directory-pathname
- (lambda ()
- (make-pathname #F
- (divide-into-components (get-environment-variable "HOME"))
- #F
- #F
- #F)))
+ (lambda ()
+ (make-pathname #F
+ (divide-into-components (get-environment-variable "HOME"))
+ #F
+ #F
+ #F)))
(define get-environment-variable
(let ((primitive (make-primitive-procedure 'GET-ENVIRONMENT-VARIABLE)))
(let ()
(set! pathname-unparse
-(named-lambda (pathname-unparse device directory name type version)
- (unparse-device
- device
- (unparse-directory directory
- (pathname-unparse-name name type version)))))
+ (named-lambda (pathname-unparse device directory name type version)
+ (unparse-device
+ device
+ (unparse-directory directory
+ (pathname-unparse-name name type version)))))
(define (unparse-device device rest)
(let ((device-string (unparse-component device)))
(error "Unrecognizable directory" directory))))
\f
(set! pathname-unparse-name
-(named-lambda (pathname-unparse-name name type version)
- (let ((name-string (unparse-component name))
- (type-string (unparse-component type))
- (version-string (unparse-version version)))
- (cond ((not name-string) "")
- ((not type-string) name-string)
- ((eq? type-string 'UNSPECIFIC) (string-append name-string "."))
- ((not version-string) (string-append name-string "." type-string))
- ((eq? version-string 'UNSPECIFIC)
- (string-append name-string "." type-string "."))
- (else
- (string-append name-string "." type-string "." version-string))))))
+ (named-lambda (pathname-unparse-name name type version)
+ (let ((name-string (unparse-component name))
+ (type-string (unparse-component type))
+ (version-string (unparse-version version)))
+ (cond ((not name-string) "")
+ ((not type-string) name-string)
+ ((eq? type-string 'UNSPECIFIC) (string-append name-string "."))
+ ((not version-string) (string-append name-string "." type-string))
+ ((eq? version-string 'UNSPECIFIC)
+ (string-append name-string "." type-string "."))
+ (else
+ (string-append name-string "." type-string "."
+ version-string))))))
(define (unparse-version version)
(if (eq? version 'NEWEST)
string))))))
(set! working-directory-pathname
-(named-lambda (working-directory-pathname)
- pathname))
+ (named-lambda (working-directory-pathname)
+ pathname))
(set! set-working-directory-pathname!
-(named-lambda (set-working-directory-pathname! name)
- (set! pathname
- (pathname-as-directory
- (pathname->absolute-pathname (->pathname name))))
- pathname))
+ (named-lambda (set-working-directory-pathname! name)
+ (set! pathname
+ (pathname-as-directory
+ (pathname->absolute-pathname (->pathname name))))
+ pathname))
;;; end WORKING-DIRECTORY-PACKAGE
))
(define init-file-pathname
- (make-pathname #F
- #F
- ".scheme"
- "init"
- #F))
(make-pathname #F #F ".scheme" "init" #F))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/vector.scm,v 13.41 1987/01/23 00:22:17 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/vector.scm,v 13.42 1987/03/17 18:55:01 cph Exp $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
-;;; 5. In conjunction with products arising from the use of this
+;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
(define-type-predicate vector? vector))
(define (make-vector size #!optional fill)
- (if (unassigned? fill) (set! fill #!FALSE))
+ (if (unassigned? fill) (set! fill false))
(vector-cons size fill))
(define (vector . elements)
(define (vector-fifth vector) (vector-ref vector 4))
(define (vector-sixth vector) (vector-ref vector 5))
(define (vector-seventh vector) (vector-ref vector 6))
-(define (vector-eighth vector) (vector-ref vector 7))
(define (vector-eighth vector) (vector-ref vector 7))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 13.41 1987/01/23 00:22:23 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 13.42 1987/03/17 18:55:18 cph Rel $
;;;
;;; Copyright (c) 1987 Massachusetts Institute of Technology
;;;
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
-;;; 5. In conjunction with products arising from the use of this
+;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
(declare (usual-integrations))
(define env-package
- (make-package env-package
- ((env)
- (current-frame)
- (current-frame-depth)
- (env-commands (make-command-set 'WHERE-COMMANDS)))
+ (let ((env)
+ (current-frame)
+ (current-frame-depth)
+ (env-commands (make-command-set 'WHERE-COMMANDS)))
\f
(define (define-where-command letter function help-text)
(define-letter-command env-commands letter function help-text))
(write-string "Depth (relative to starting frame): ")
(write depth)))
(newline)
- (let ((bindings (del-assq (environment-name frame)
- (environment-bindings frame))))
+ (let ((bindings (environment-bindings frame)))
(if (null? bindings)
(write-string "Has no bindings")
(begin (write-string "Has bindings:")
(,lambda-tag:shallow-fluid-let . FLUID-LET)
(,lambda-tag:deep-fluid-let . FLUID-LET)
(,lambda-tag:common-lisp-fluid-let . FLUID-BIND)
- (,lambda-tag:make-package . MAKE-PACKAGE)
(,lambda-tag:make-environment . MAKE-ENVIRONMENT))))
(lambda (frame)
(let ((name (environment-name frame)))
(write-string " special form"))
(begin (write-string "the procedure ")
(write name))))))))
-
+\f
(define (print-binding binding)
(define line-width 79)
(define name-width 40)
"Name of procedure which created current environment")
;;; end ENV-PACKAGE.
-))
+(the-environment)))
(define print-user-friendly-name
(access print-user-friendly-name env-package))
;;;; Exports
(define where
- (access where env-package debugger-package))
(access where env-package debugger-package))
\ No newline at end of file
projects / mit-scheme.git / commitdiff