-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 13.44 1987/06/30 20:58:10 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 14.1 1988/06/13 11:38:43 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Advice package
+;;; package: (runtime advice)
(declare (usual-integrations))
\f
-(define advice-package
- (make-environment
+(define (initialize-package!)
+ (set! entry-advice-population (make-population))
+ (set! exit-advice-population (make-population))
+ (set! particular-entry-advisor (particular-advisor primitive-advise-entry))
+ (set! particular-exit-advisor (particular-advisor primitive-advise-exit))
+ (set! particular-both-advisor primitive-advise-both)
+ (set! particular-entry-unadvisor primitive-unadvise-entry)
+ (set! particular-exit-unadvisor primitive-unadvise-exit)
+ (set! particular-both-unadvisor primitive-unadvise-both)
+ (set! primitive-trace-entry (particular-entry-advisor trace-entry-advice))
+ (set! primitive-trace-exit (particular-exit-advisor trace-exit-advice))
+ (set! primitive-trace-both
+ (particular-both-advisor trace-entry-advice trace-exit-advice))
+ (set! primitive-untrace
+ (particular-both-unadvisor trace-entry-advice trace-exit-advice))
+ (set! primitive-untrace-entry
+ (particular-entry-unadvisor trace-entry-advice))
+ (set! primitive-untrace-exit (particular-exit-unadvisor trace-exit-advice))
+ (set! primitive-break-entry (particular-entry-advisor break-entry-advice))
+ (set! primitive-break-exit (particular-exit-advisor break-exit-advice))
+ (set! primitive-break-both
+ (particular-both-advisor break-entry-advice break-exit-advice))
+ (set! primitive-unbreak
+ (particular-both-unadvisor break-entry-advice break-exit-advice))
+ (set! primitive-unbreak-entry
+ (particular-entry-unadvisor break-entry-advice))
+ (set! primitive-unbreak-exit (particular-exit-unadvisor break-exit-advice))
+ (set! advice (wrap-advice-extractor primitive-advice))
+ (set! entry-advice (wrap-advice-extractor primitive-entry-advice))
+ (set! exit-advice (wrap-advice-extractor primitive-exit-advice))
+ (set! advise-entry (wrap-general-advisor primitive-advise-entry))
+ (set! advise-exit (wrap-general-advisor primitive-advise-exit))
+ (set! wrap-entry-unadvisor
+ (wrap-unadvisor
+ (lambda (operation)
+ (map-over-population entry-advice-population operation))))
+ (set! wrap-exit-unadvisor
+ (wrap-unadvisor
+ (lambda (operation)
+ (map-over-population exit-advice-population operation))))
+ (set! wrap-both-unadvisor
+ (wrap-unadvisor
+ (lambda (operation)
+ (map-over-population entry-advice-population operation)
+ (map-over-population exit-advice-population operation))))
+ (set! unadvise (wrap-both-unadvisor primitive-unadvise-entire-lambda))
+ (set! unadvise-entry (wrap-entry-unadvisor primitive-unadvise-entire-entry))
+ (set! unadvise-exit (wrap-exit-unadvisor primitive-unadvise-entire-exit))
+ (set! untrace (wrap-both-unadvisor primitive-untrace))
+ (set! untrace-entry (wrap-entry-unadvisor primitive-untrace-entry))
+ (set! untrace-exit (wrap-exit-unadvisor primitive-untrace-exit))
+ (set! unbreak (wrap-both-unadvisor primitive-unbreak))
+ (set! unbreak-entry (wrap-entry-unadvisor primitive-unbreak-entry))
+ (set! unbreak-exit (wrap-exit-unadvisor primitive-unbreak-exit))
+ (set! trace-entry (wrap-advisor primitive-trace-entry))
+ (set! trace-exit (wrap-advisor primitive-trace-exit))
+ (set! trace-both (wrap-advisor primitive-trace-both))
+ (set! trace trace-both)
+ (set! break-entry (wrap-advisor primitive-break-entry))
+ (set! break-exit (wrap-advisor primitive-break-exit))
+ (set! break-both (wrap-advisor primitive-break-both))
+ (set! break break-both))
+\f
+;;;; Advice Wrappers
+
+(define entry-advice-population)
+(define exit-advice-population)
-(define the-args)
+(define the-arguments)
(define the-procedure)
(define the-result)
(define (*args*)
- the-args)
+ the-arguments)
(define (*proc*)
the-procedure)
(define (*result*)
the-result)
-(define entry-advice-population
- (make-population))
-
-(define exit-advice-population
- (make-population))
-\f
-;;;; Advice Wrappers
-
(define (add-lambda-advice! lambda advice-transformation)
- ((access lambda-wrap-body! lambda-package) lambda
- (lambda (body state cont)
+ (lambda-wrap-body! lambda
+ (lambda (body state receiver)
(if (null? state)
- (cont (make-advice-hook)
- (advice-transformation '() '() cons))
- (cont body
- (advice-transformation (car state) (cdr state) cons))))))
+ (receiver (make-advice-hook)
+ (advice-transformation '() '() cons))
+ (receiver body
+ (advice-transformation (car state) (cdr state) cons))))))
(define (remove-lambda-advice! lambda advice-transformation)
(lambda-advice lambda
(lambda (entry-advice exit-advice)
(advice-transformation entry-advice exit-advice
(lambda (new-entry-advice new-exit-advice)
- (if (and (null? new-entry-advice)
- (null? new-exit-advice))
- ((access lambda-unwrap-body! lambda-package) lambda)
- ((access lambda-wrap-body! lambda-package) lambda
- (lambda (body state cont)
- (cont body (cons new-entry-advice new-exit-advice))))))))))
-
-(define (lambda-advice lambda cont)
- ((access lambda-wrapper-components lambda-package) lambda
+ (if (and (null? new-entry-advice) (null? new-exit-advice))
+ (lambda-unwrap-body! lambda)
+ (lambda-wrap-body! lambda
+ (lambda (body state receiver)
+ state
+ (receiver body
+ (cons new-entry-advice new-exit-advice))))))))))
+
+(define (lambda-advice lambda receiver)
+ (lambda-wrapper-components lambda
(lambda (original-body state)
+ original-body
(if (null? state)
- (error "Procedure has no advice -- LAMBDA-ADVICE" lambda)
- (cont (car state)
- (cdr state))))))
+ (error "Procedure has no advice -- LAMBDA-ADVICE" lambda))
+ (receiver (car state) (cdr state)))))
(define (make-advice-hook)
(make-combination syntaxed-advice-procedure
(define syntaxed-advice-procedure
(scode-quote
- (ACCESS ADVISED-PROCEDURE-WRAPPER ADVICE-PACKAGE '())))
+ ((ACCESS PACKAGE/REFERENCE #F)
+ ((ACCESS FIND-PACKAGE #F) '(RUNTIME ADVICE))
+ 'ADVISED-PROCEDURE-WRAPPER)))
\f
;;;; The Advice Hook
(define (advised-procedure-wrapper environment)
(let ((procedure (environment-procedure environment))
(arguments (environment-arguments environment)))
- ((access lambda-wrapper-components lambda-package)
- (procedure-lambda procedure)
- (lambda (original-body state)
- (call-with-current-continuation
+ (lambda-wrapper-components (procedure-lambda procedure)
+ (lambda (original-body state)
+ (call-with-current-continuation
(lambda (continuation)
(define ((catching-proceeds receiver) advice)
(with-proceed-point
- (lambda (value)
- (if (null? value)
- '()
- (continuation (car value))))
+ (lambda (proceed-continuation values)
+ (if (null? values)
+ (proceed-continuation '())
+ (continuation (car values))))
(lambda ()
(receiver advice))))
(define (primitive-entry-advice lambda)
(lambda-advice lambda
(lambda (entry-advice exit-advice)
+ exit-advice
entry-advice)))
(define (primitive-exit-advice lambda)
(lambda-advice lambda
(lambda (entry-advice exit-advice)
+ entry-advice
exit-advice)))
(define (primitive-advise-entry lambda advice)
(add-lambda-advice! lambda
- (lambda (entry-advice exit-advice cont)
- (cont (if (memq advice entry-advice)
- entry-advice
- (begin (add-to-population! entry-advice-population lambda)
- (cons advice entry-advice)))
- exit-advice))))
+ (lambda (entry-advice exit-advice receiver)
+ (receiver (if (memq advice entry-advice)
+ entry-advice
+ (begin (add-to-population! entry-advice-population lambda)
+ (cons advice entry-advice)))
+ exit-advice))))
(define (primitive-advise-exit lambda advice)
(add-lambda-advice! lambda
- (lambda (entry-advice exit-advice cont)
- (cont entry-advice
- (if (memq advice exit-advice)
- exit-advice
- (begin (add-to-population! exit-advice-population lambda)
- (append! exit-advice (list advice))))))))
+ (lambda (entry-advice exit-advice receiver)
+ (receiver entry-advice
+ (if (memq advice exit-advice)
+ exit-advice
+ (begin (add-to-population! exit-advice-population lambda)
+ (append! exit-advice (list advice))))))))
(define ((primitive-advise-both new-entry-advice new-exit-advice) lambda)
(add-lambda-advice! lambda
- (lambda (entry-advice exit-advice cont)
- (cont (if (memq new-entry-advice entry-advice)
- entry-advice
- (begin (add-to-population! entry-advice-population lambda)
- (cons new-entry-advice entry-advice)))
- (if (memq new-exit-advice exit-advice)
- exit-advice
- (begin (add-to-population! exit-advice-population lambda)
- (append! exit-advice (list new-exit-advice))))))))
+ (lambda (entry-advice exit-advice receiver)
+ (receiver (if (memq new-entry-advice entry-advice)
+ entry-advice
+ (begin (add-to-population! entry-advice-population lambda)
+ (cons new-entry-advice entry-advice)))
+ (if (memq new-exit-advice exit-advice)
+ exit-advice
+ (begin (add-to-population! exit-advice-population lambda)
+ (append! exit-advice (list new-exit-advice))))))))
(define (eq?-adjoin object list)
(if (memq object list)
\f
(define (primitive-unadvise-entire-entry lambda)
(remove-lambda-advice! lambda
- (lambda (entry-advice exit-advice cont)
- (cont '() exit-advice)))
+ (lambda (entry-advice exit-advice receiver)
+ entry-advice
+ (receiver '() exit-advice)))
(remove-from-population! entry-advice-population lambda))
(define (primitive-unadvise-entire-exit lambda)
(remove-lambda-advice! lambda
- (lambda (entry-advice exit-advice cont)
- (cont entry-advice '())))
+ (lambda (entry-advice exit-advice receiver)
+ exit-advice
+ (receiver entry-advice '())))
(remove-from-population! exit-advice-population lambda))
(define (primitive-unadvise-entire-lambda lambda)
- ((access lambda-unwrap-body! lambda-package) lambda)
+ (lambda-unwrap-body! lambda)
(remove-from-population! entry-advice-population lambda)
(remove-from-population! exit-advice-population lambda))
(define ((primitive-unadvise-entry advice) lambda)
(remove-lambda-advice! lambda
- (lambda (entry-advice exit-advice cont)
+ (lambda (entry-advice exit-advice receiver)
(let ((new-entry-advice (delq! advice entry-advice)))
(if (null? new-entry-advice)
(remove-from-population! entry-advice-population lambda))
- (cont new-entry-advice exit-advice)))))
+ (receiver new-entry-advice exit-advice)))))
(define ((primitive-unadvise-exit advice) lambda)
(remove-lambda-advice! lambda
- (lambda (entry-advice exit-advice cont)
+ (lambda (entry-advice exit-advice receiver)
(let ((new-exit-advice (delq! advice exit-advice)))
(if (null? new-exit-advice)
(remove-from-population! exit-advice-population lambda))
- (cont entry-advice new-exit-advice)))))
+ (receiver entry-advice new-exit-advice)))))
(define ((primitive-unadvise-both old-entry-advice old-exit-advice) lambda)
(remove-lambda-advice! lambda
- (lambda (entry-advice exit-advice cont)
+ (lambda (entry-advice exit-advice receiver)
(let ((new-entry-advice (delq! old-entry-advice entry-advice))
(new-exit-advice (delq! old-exit-advice exit-advice)))
(if (null? new-entry-advice)
(remove-from-population! entry-advice-population lambda))
(if (null? new-exit-advice)
(remove-from-population! exit-advice-population lambda))
- (cont new-entry-advice new-exit-advice)))))
+ (receiver new-entry-advice new-exit-advice)))))
(define (((particular-advisor advisor) advice) lambda)
(advisor lambda advice))
-(define particular-entry-advisor (particular-advisor primitive-advise-entry))
-(define particular-exit-advisor (particular-advisor primitive-advise-exit))
-(define particular-both-advisor primitive-advise-both)
-(define particular-entry-unadvisor primitive-unadvise-entry)
-(define particular-exit-unadvisor primitive-unadvise-exit)
-(define particular-both-unadvisor primitive-unadvise-both)
+(define particular-entry-advisor)
+(define particular-exit-advisor)
+(define particular-both-advisor)
+(define particular-entry-unadvisor)
+(define particular-exit-unadvisor)
+(define particular-both-unadvisor)
\f
;;;; Trace
-(define (trace-entry-advice proc args env)
- (trace-display proc args))
+(define (trace-entry-advice procedure arguments environment)
+ environment
+ (trace-display procedure arguments))
-(define (trace-exit-advice proc args result env)
- (trace-display proc args result)
+(define (trace-exit-advice procedure arguments result environment)
+ environment
+ (trace-display procedure arguments result)
result)
-(define (trace-display proc args #!optional result)
+(define (trace-display procedure arguments #!optional result)
(newline)
- (let ((width (- (access printer-width implementation-dependencies) 3)))
+ (let ((width (- (output-port/x-size (current-output-port)) 3)))
(let ((output
(with-output-to-truncated-string
width
(lambda ()
- (if (unassigned? result)
+ (if (default-object? result)
(write-string "[Entering ")
(begin (write-string "[")
(write result)
(write-string " <== ")))
(write-string "<")
- (write proc)
+ (write procedure)
(for-each (lambda (arg) (write-char #\Space) (write arg))
- args)))))
+ arguments)))))
(if (car output) ; Too long?
(begin
(write-string (substring (cdr output) 0 (- width 5)))
(write-string " ... "))
(write-string (cdr output)))))
(write-string ">]"))
-
-(define primitive-trace-entry
- (particular-entry-advisor trace-entry-advice))
-
-(define primitive-trace-exit
- (particular-exit-advisor trace-exit-advice))
-
-(define primitive-trace-both
- (particular-both-advisor trace-entry-advice trace-exit-advice))
-
-(define primitive-untrace
- (particular-both-unadvisor trace-entry-advice trace-exit-advice))
-
-(define primitive-untrace-entry
- (particular-entry-unadvisor trace-entry-advice))
-
-(define primitive-untrace-exit
- (particular-exit-unadvisor trace-exit-advice))
+(define primitive-trace-entry)
+(define primitive-trace-exit)
+(define primitive-trace-both)
+(define primitive-untrace)
+(define primitive-untrace-entry)
+(define primitive-untrace-exit)
\f
;;;; Break
-(define (break-rep env message . info)
- (push-rep env
- (lambda ()
- (apply trace-display info)
- ((standard-rep-message message)))
- (standard-rep-prompt breakpoint-prompt)))
-
-(define (break-entry-advice proc args env)
- (fluid-let ((the-procedure proc)
- (the-args args))
- (break-rep env "Breakpoint on entry" proc args)))
-
-(define (break-exit-advice proc args result env)
- (fluid-let ((the-procedure proc)
- (the-args args)
- (the-result result))
- (break-rep env "Breakpoint on exit" proc args result))
- result)
-
-(define primitive-break-entry
- (particular-entry-advisor break-entry-advice))
-
-(define primitive-break-exit
- (particular-exit-advisor break-exit-advice))
+(define (break-rep environment message . info)
+ (breakpoint (cmdl-message/append
+ (cmdl-message/active (lambda () (apply trace-display info)))
+ (cmdl-message/standard message))
+ environment))
-(define primitive-break-both
- (particular-both-advisor break-entry-advice break-exit-advice))
+(define (break-entry-advice procedure arguments environment)
+ (fluid-let ((the-procedure procedure)
+ (the-arguments arguments))
+ (break-rep environment "Breakpoint on entry" procedure arguments)))
-(define primitive-unbreak
- (particular-both-unadvisor break-entry-advice break-exit-advice))
-
-(define primitive-unbreak-entry
- (particular-entry-unadvisor break-entry-advice))
+(define (break-exit-advice procedure arguments result environment)
+ (fluid-let ((the-procedure procedure)
+ (the-arguments arguments)
+ (the-result result))
+ (break-rep environment "Breakpoint on exit" procedure arguments result))
+ result)
-(define primitive-unbreak-exit
- (particular-exit-unadvisor break-exit-advice))
+(define primitive-break-entry)
+(define primitive-break-exit)
+(define primitive-break-both)
+(define primitive-unbreak)
+(define primitive-unbreak-entry)
+(define primitive-unbreak-exit)
\f
;;;; Top Level Wrappers
lambda
(lambda-components lambda
(lambda (name required optional rest auxiliary declarations body)
+ name required optional rest declarations
(if (memq (car path) auxiliary)
(loop (sequence-actions body))
(error "No internal definition by this name" (car path)))))))
(define ((wrap-advice-extractor extractor) procedure . path)
(list-copy (extractor (find-internal-lambda procedure path))))
-(define advice (wrap-advice-extractor primitive-advice))
-(define entry-advice (wrap-advice-extractor primitive-entry-advice))
-(define exit-advice (wrap-advice-extractor primitive-exit-advice))
+(define advice)
+(define entry-advice)
+(define exit-advice)
(define ((wrap-general-advisor advisor) procedure advice . path)
(advisor (find-internal-lambda procedure path) advice)
*the-non-printing-object*)
-(define advise-entry (wrap-general-advisor primitive-advise-entry))
-(define advise-exit (wrap-general-advisor primitive-advise-exit))
+(define advise-entry)
+(define advise-exit)
\f
(define (((wrap-unadvisor map-over-population) unadvisor) . procedure&path)
(if (null? procedure&path)
(cdr procedure&path))))
*the-non-printing-object*)
-(define wrap-entry-unadvisor
- (wrap-unadvisor
- (lambda (operation)
- (map-over-population entry-advice-population operation))))
-
-(define wrap-exit-unadvisor
- (wrap-unadvisor
- (lambda (operation)
- (map-over-population exit-advice-population operation))))
-
-(define wrap-both-unadvisor
- (wrap-unadvisor
- (lambda (operation)
- (map-over-population entry-advice-population operation)
- (map-over-population exit-advice-population operation))))
-
-(define unadvise (wrap-both-unadvisor primitive-unadvise-entire-lambda))
-(define unadvise-entry (wrap-entry-unadvisor primitive-unadvise-entire-entry))
-(define unadvise-exit (wrap-exit-unadvisor primitive-unadvise-entire-exit))
-
-(define untrace (wrap-both-unadvisor primitive-untrace))
-(define untrace-entry (wrap-entry-unadvisor primitive-untrace-entry))
-(define untrace-exit (wrap-exit-unadvisor primitive-untrace-exit))
-
-(define unbreak (wrap-both-unadvisor primitive-unbreak))
-(define unbreak-entry (wrap-entry-unadvisor primitive-unbreak-entry))
-(define unbreak-exit (wrap-exit-unadvisor primitive-unbreak-exit))
+(define wrap-entry-unadvisor)
+(define wrap-exit-unadvisor)
+(define wrap-both-unadvisor)
+(define unadvise)
+(define unadvise-entry)
+(define unadvise-exit)
+(define untrace)
+(define untrace-entry)
+(define untrace-exit)
+(define unbreak)
+(define unbreak-entry)
+(define unbreak-exit)
(define ((wrap-advisor advisor) procedure . path)
(advisor (find-internal-lambda procedure path))
*the-non-printing-object*)
-(define trace-entry (wrap-advisor primitive-trace-entry))
-(define trace-exit (wrap-advisor primitive-trace-exit))
-(define trace-both (wrap-advisor primitive-trace-both))
-
-(define break-entry (wrap-advisor primitive-break-entry))
-(define break-exit (wrap-advisor primitive-break-exit))
-(define break-both (wrap-advisor primitive-break-both))
-\f
-;;; end of ADVICE-PACKAGE.
-))
-
-;;;; Exports
-
-(define advice (access advice advice-package))
-(define entry-advice (access entry-advice advice-package))
-(define exit-advice (access exit-advice advice-package))
-
-(define advise-entry (access advise-entry advice-package))
-(define advise-exit (access advise-exit advice-package))
-
-(define unadvise (access unadvise advice-package))
-(define unadvise-entry (access unadvise-entry advice-package))
-(define unadvise-exit (access unadvise-exit advice-package))
-
-(define trace (access trace-both advice-package))
-(define trace-entry (access trace-entry advice-package))
-(define trace-exit (access trace-exit advice-package))
-(define trace-both (access trace-both advice-package))
-
-(define untrace (access untrace advice-package))
-(define untrace-entry (access untrace-entry advice-package))
-(define untrace-exit (access untrace-exit advice-package))
-
-(define break (access break-both advice-package))
-(define break-entry (access break-entry advice-package))
-(define break-exit (access break-exit advice-package))
-(define break-both (access break-both advice-package))
-
-(define unbreak (access unbreak advice-package))
-(define unbreak-entry (access unbreak-entry advice-package))
-(define unbreak-exit (access unbreak-exit advice-package))
-
-(define *args* (access *args* advice-package))
-(define *proc* (access *proc* advice-package))
-(define *result* (access *result* advice-package))
\ No newline at end of file
+(define trace-entry)
+(define trace-exit)
+(define trace-both)
+(define trace)
+(define break-entry)
+(define break-exit)
+(define break-both)
+(define break)
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/bitstr.scm,v 13.46 1987/08/10 20:26:15 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/bitstr.scm,v 14.1 1988/06/13 11:40:45 cph Rel $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Bit String Primitives
+;;; package: ()
(declare (usual-integrations))
\f
-(let-syntax ((define-primitives
- (macro names
- `(BEGIN ,@(map (lambda (name)
- `(LOCAL-ASSIGNMENT
- SYSTEM-GLOBAL-ENVIRONMENT
- ',name
- ,(make-primitive-procedure name)))
- names)))))
- (define-primitives
- bit-string-allocate make-bit-string bit-string?
- bit-string-length bit-string-ref bit-string-clear! bit-string-set!
- bit-string-zero? bit-string=?
- bit-string-fill! bit-string-move! bit-string-movec!
- bit-string-or! bit-string-and! bit-string-andc!
- bit-string-xor! bit-substring-move-right!
- bit-string->unsigned-integer unsigned-integer->bit-string
- read-bits! write-bits!
- bit-substring-find-next-set-bit))
+(define-primitives
+ bit-string-allocate make-bit-string bit-string?
+ bit-string-length bit-string-ref bit-string-clear! bit-string-set!
+ bit-string-zero? bit-string=?
+ bit-string-fill! bit-string-move! bit-string-movec!
+ bit-string-or! bit-string-and! bit-string-andc!
+ bit-string-xor! bit-substring-move-right!
+ bit-string->unsigned-integer unsigned-integer->bit-string
+ read-bits! write-bits!
+ bit-substring-find-next-set-bit)
+
+(define (bit-string-copy bit-string)
+ (let ((result (bit-string-allocate (bit-string-length bit-string))))
+ (bit-string-move! result bit-string)
+ result))
+
+(define (bit-string-not bit-string)
+ (let ((result (bit-string-allocate (bit-string-length bit-string))))
+ (bit-string-movec! result bit-string)
+ result))
+
+(define (bit-string-or x y)
+ (let ((result (bit-string-allocate (bit-string-length x))))
+ (bit-string-move! result x)
+ (bit-string-or! result y)
+ result))
+
+(define (bit-string-and x y)
+ (let ((result (bit-string-allocate (bit-string-length x))))
+ (bit-string-move! result x)
+ (bit-string-and! result y)
+ result))
+
+(define (bit-string-andc x y)
+ (let ((result (bit-string-allocate (bit-string-length x))))
+ (bit-string-move! result x)
+ (bit-string-andc! result y)
+ result))
+
+(define (bit-string-xor x y)
+ (let ((result (bit-string-allocate (bit-string-length x))))
+ (bit-string-move! result x)
+ (bit-string-xor! result y)
+ result))
+\f
+(define (bit-substring bit-string start end)
+ (let ((result (bit-string-allocate (- end start))))
+ (bit-substring-move-right! bit-string start end result 0)
+ result))
+
+(define (bit-substring-extend string start end length)
+ ;; Assumption: (<= (- end start) length)
+ (let ((result (make-bit-string length false)))
+ (bit-substring-move-right! string start end result 0)
+ result))
(define (bit-string-append x y)
(declare (integrate x y))
(declare (integrate bit-string-append))
(bit-string-append y x))
-(define (bit-substring bit-string start end)
- (let ((result (bit-string-allocate (- end start))))
- (bit-substring-move-right! bit-string start end result 0)
- result))
-
(define (signed-integer->bit-string nbits number)
(unsigned-integer->bit-string
nbits
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boole.scm,v 14.1 1988/05/20 00:51:46 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boole.scm,v 14.2 1988/06/13 11:40:52 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Boolean Operations
+;;; package: ()
(declare (usual-integrations))
\f
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boot.scm,v 13.46 1988/05/03 19:04:10 jinx Exp $
-;;;
-;;; Copyright (c) 1988 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Boot Utilities
-
-(declare (usual-integrations)
- (integrate-primitive-procedures
- compiled-code-address->block
- compiled-code-address->offset
- primitive-object-set-type))
-
-;;; The utilities in this file are the first thing loaded into the
-;;; world after the type tables. They shouldn't depend on anything else
-;;; except those tables.
-\f
-;;;; Primitive Operators
-
-(let-syntax ((define-global-primitives
- (macro names
- `(BEGIN
- ,@(map (lambda (name)
- `(DEFINE ,name ,(make-primitive-procedure name)))
- names)))))
- (define-global-primitives
- SCODE-EVAL FORCE
- SET-INTERRUPT-ENABLES! WITH-INTERRUPTS-REDUCED
- WITH-INTERRUPT-MASK
- GET-FIXED-OBJECTS-VECTOR WITH-HISTORY-DISABLED
- PRIMITIVE-PROCEDURE-ARITY NOT FALSE?
- ;; Environment
- LEXICAL-REFERENCE LEXICAL-ASSIGNMENT LOCAL-ASSIGNMENT
- LEXICAL-UNASSIGNED? LEXICAL-UNBOUND? LEXICAL-UNREFERENCEABLE?
- ;; Pointers
- EQ?
- PRIMITIVE-SET-TYPE MAKE-NON-POINTER-OBJECT
- PRIMITIVE-TYPE? PRIMITIVE-TYPE PRIMITIVE-DATUM
-
- ;; List Operations
- ;; (these appear here for the time being because the compiler
- ;; couldn't handle the `in-package' required to put them in
- ;; `list.scm'. They should be moved back when that is fixed.
- CONS PAIR? NULL? LENGTH CAR CDR SET-CAR! SET-CDR!
- GENERAL-CAR-CDR MEMQ ASSQ
-
- ;; System Compound Datatypes
- MAKE-CELL CELL? CELL-CONTENTS SET-CELL-CONTENTS!
-
- SYSTEM-PAIR-CONS SYSTEM-PAIR?
- SYSTEM-PAIR-CAR SYSTEM-PAIR-SET-CAR!
- SYSTEM-PAIR-CDR SYSTEM-PAIR-SET-CDR!
-
- SYSTEM-HUNK3-CXR0 SYSTEM-HUNK3-SET-CXR0!
- SYSTEM-HUNK3-CXR1 SYSTEM-HUNK3-SET-CXR1!
- SYSTEM-HUNK3-CXR2 SYSTEM-HUNK3-SET-CXR2!
-
- SYSTEM-LIST-TO-VECTOR SYSTEM-SUBVECTOR-TO-LIST SYSTEM-VECTOR?
- SYSTEM-VECTOR-SIZE SYSTEM-VECTOR-REF SYSTEM-VECTOR-SET!
- )
-;;; end of DEFINE-GLOBAL-PRIMITIVES scope.
-)
-\f
-;;;; Potpourri
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boot.scm,v 14.1 1988/06/13 11:40:56 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
-(define *the-non-printing-object* '(*THE-NON-PRINTING-OBJECT*))
-(define (identity-procedure x) x)
-(define false #F)
-(define true #T)
+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.
-(define (null-procedure . args) args '()) ; args ignored
-(define (false-procedure . args) args #F) ; args ignored
-(define (true-procedure . args) args #T) ; args ignored
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
+
+;;;; Boot Time Definitions
+;;; package: ()
+
+(declare (usual-integrations))
+\f
+(define (unparser/standard-method name #!optional unparser)
+ (lambda (state object)
+ (if (not (unparser-state? state)) (error "Bad unparser state" state))
+ (let ((port (unparser-state/port state)))
+ (write-string "#[" port)
+ (if (string? name)
+ (write-string name port)
+ (unparse-object state name))
+ (write-char #\Space port)
+ (write-string (number->string (hash object)) port)
+ (if (and (not (default-object? unparser)) unparser)
+ (begin (write-char #\Space port)
+ (unparser state object)))
+ (write-char #\] port))))
+(define *the-non-printing-object*
+ (object-new-type (ucode-type true) 1))
+
+(define-integrable interrupt-bit/stack #x0001)
+(define-integrable interrupt-bit/global-gc #x0002)
+(define-integrable interrupt-bit/gc #x0004)
+(define-integrable interrupt-bit/global-1 #x0008)
+(define-integrable interrupt-bit/kbd #x0010)
+(define-integrable interrupt-bit/global-2 #x0020)
+(define-integrable interrupt-bit/timer #x0040)
+(define-integrable interrupt-bit/global-3 #x0080)
+(define-integrable interrupt-bit/suspend #x0100)
+
+;; GC & stack overflow only
+(define-integrable interrupt-mask/gc-ok #x0007)
+
+;; Absolutely everything off
+(define-integrable interrupt-mask/none #x0000)
+
+;; Normal: all enabled
+(define-integrable interrupt-mask/all #xFFFF)
+
+(define (with-absolutely-no-interrupts thunk)
+ (with-interrupt-mask interrupt-mask/none
+ (lambda (interrupt-mask)
+ interrupt-mask
+ (thunk))))
(define (without-interrupts thunk)
- (with-interrupts-reduced interrupt-mask-gc-ok
- (lambda (old-mask)
- old-mask ;; ignored
+ (with-interrupt-mask interrupt-mask/gc-ok
+ (lambda (interrupt-mask)
+ interrupt-mask
(thunk))))
-(define apply
- (let ((primitive (make-primitive-procedure 'APPLY)))
- (named-lambda (apply f . args)
- (primitive f
- (if (null? args)
- '()
- (let loop
- ((first-element (car args))
- (rest-elements (cdr args)))
- (if (null? rest-elements)
- first-element
- (cons first-element
- (loop (car rest-elements)
- (cdr rest-elements))))))))))
-
-(define system-hunk3-cons
- (let ((hunk3-cons (make-primitive-procedure 'HUNK3-CONS)))
- (named-lambda (system-hunk3-cons type cxr0 cxr1 cxr2)
- (primitive-set-type type (hunk3-cons cxr0 cxr1 cxr2)))))
-
-(define (symbol-hash symbol)
- (string-hash (symbol->string symbol)))
-
-(define (symbol-append . symbols)
- (string->symbol (apply string-append (map symbol->string symbols))))
-
-(define (boolean? object)
- (or (eq? object #F)
- (eq? object #T)))
-\f
-;;; This won't work until vector is loaded, but it has no better place to go.
-
-(let-syntax ((ucode-type (macro (name) (microcode-type name))))
-
-(define (copy-program exp)
- (if (not (primitive-type? (ucode-type COMPILED-ENTRY) exp))
- (error "copy-program: Can only copy compiled programs" exp))
- (let* ((original (compiled-code-address->block exp))
- (block (primitive-set-type
- (ucode-type COMPILED-CODE-BLOCK)
- (vector-copy
- (primitive-set-type (ucode-type VECTOR)
- original))))
- (end (system-vector-size block)))
-
- (define (map-entry entry)
- (with-interrupt-mask
- interrupt-mask-none
- (lambda (old)
- old ;; ignored
- (primitive-object-set-type
- (primitive-type entry)
- (+ (compiled-code-address->offset entry)
- (primitive-datum block))))))
-
- (let loop ((n (1+ (primitive-datum (system-vector-ref block 0)))))
- (cond ((>= n end)
- (map-entry exp))
- ((not (lambda? (system-vector-ref block n)))
- (loop (1+ n)))
- (else
- (lambda-components (system-vector-ref block n)
- (lambda (name req opt rest aux decl body)
- (if (and (primitive-type? (ucode-type COMPILED-ENTRY) body)
- (eq? original (compiled-code-address->block body)))
- (system-vector-set! block n
- (make-lambda name req opt rest aux decl
- (map-entry body))))
- (loop (1+ n)))))))))
-
-) ;; End of let-syntax
\ No newline at end of file
+(define-primitives
+ (object-pure? pure?)
+ (object-constant? constant?)
+ get-next-constant)
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/char.scm,v 13.43 1988/04/27 18:24:54 mhwu Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/char.scm,v 14.1 1988/06/13 11:41:03 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Character Abstraction
+;;; package: (runtime character)
(declare (usual-integrations))
\f
-(let-syntax ((define-primitives
- (macro names
- `(BEGIN ,@(map (lambda (name)
- `(LOCAL-ASSIGNMENT
- SYSTEM-GLOBAL-ENVIRONMENT
- ',name
- ,(make-primitive-procedure name)))
- names)))))
- (define-primitives
- make-char char-code char-bits char->integer integer->char char->ascii
- char-ascii? ascii->char char-upcase char-downcase))
-
-(define char-code-limit #x80)
-(define char-bits-limit #o20)
-(define char-integer-limit (* char-code-limit char-bits-limit))
-
-(define (chars->ascii chars)
+(define-primitives
+ make-char char-code char-bits char->integer integer->char char->ascii
+ char-ascii? ascii->char char-upcase char-downcase)
+
+(define-integrable (char? object)
+ (object-type? (ucode-type character) object))
+
+(define-integrable char-code-limit #x80)
+(define-integrable char-bits-limit #x20)
+(define-integrable char-integer-limit #x1000)
+
+(define-integrable (chars->ascii chars)
(map char->ascii chars))
-(define (code->char code)
+(define-integrable (code->char code)
(make-char code 0))
-(define (char=? x y)
+(define-integrable (char=? x y)
(= (char->integer x) (char->integer y)))
-(define (char<? x y)
+(define-integrable (char<? x y)
(< (char->integer x) (char->integer y)))
-(define (char<=? x y)
+(define-integrable (char<=? x y)
(<= (char->integer x) (char->integer y)))
-(define (char>? x y)
+(define-integrable (char>? x y)
(> (char->integer x) (char->integer y)))
-(define (char>=? x y)
+(define-integrable (char>=? x y)
(>= (char->integer x) (char->integer y)))
-(define (char-ci->integer char)
+(define-integrable (char-ci->integer char)
(char->integer (char-upcase char)))
-(define (char-ci=? x y)
+(define-integrable (char-ci=? x y)
(= (char-ci->integer x) (char-ci->integer y)))
-(define (char-ci<? x y)
+(define-integrable (char-ci<? x y)
(< (char-ci->integer x) (char-ci->integer y)))
-(define (char-ci<=? x y)
+(define-integrable (char-ci<=? x y)
(<= (char-ci->integer x) (char-ci->integer y)))
-(define (char-ci>? x y)
+(define-integrable (char-ci>? x y)
(> (char-ci->integer x) (char-ci->integer y)))
-(define (char-ci>=? x y)
+(define-integrable (char-ci>=? x y)
(>= (char-ci->integer x) (char-ci->integer y)))
\f
-(define char?)
-(define digit->char)
-(define char->digit)
-(define name->char)
-(define char->name)
-(let ()
-
-(define char-type
- (microcode-type 'CHARACTER))
-
-(define 0-code (char-code (ascii->char #x30)))
-(define upper-a-code (char-code (ascii->char #x41)))
-(define lower-a-code (char-code (ascii->char #x61)))
-(define space-char (ascii->char #x20))
-(define hyphen-char (ascii->char #x2D))
-(define backslash-char (ascii->char #x5C))
+(define 0-code)
+(define upper-a-code)
+(define lower-a-code)
+(define space-char)
+(define hyphen-char)
+(define backslash-char)
+
+(define (initialize-package!)
+ (set! 0-code (char-code (ascii->char #x30)))
+ (set! upper-a-code (char-code (ascii->char #x41)))
+ (set! lower-a-code (char-code (ascii->char #x61)))
+ (set! space-char (ascii->char #x20))
+ (set! hyphen-char (ascii->char #x2D))
+ (set! backslash-char (ascii->char #x5C)))
(define named-codes
- `(("Backspace" . #x08)
+ '(("Backspace" . #x08)
("Tab" . #x09)
("Linefeed" . #x0A)
- ("VT" . #x0B)
("Page" . #x0C)
("Return" . #x0D)
("Call" . #x1A)
("Backnext" . #x1F)
("Space" . #x20)
("Rubout" . #x7F)
- ;; ASCII codes
+
+ ;; ASCII codes. Some of these are aliases for previous
+ ;; definitions, and will not appear as output.
("NUL" . #x00)
("SOH" . #x01)
("STX" . #x02)
("ENQ" . #x05)
("ACK" . #x06)
("BEL" . #x07)
- ;; Skip
+ ("BS" . #x08)
+ ("HT" . #x09)
+ ("LF" . #x0A)
+ ("VT" . #x0B)
+ ("FF" . #x0C)
+ ("CR" . #x0D)
("SO" . #x0E)
("SI" . #x0F)
("DLE" . #x10)
("ETB" . #x17)
("CAN" . #x18)
("EM" . #x19)
- ;; Skip
+ ("SUB" . #x1A)
+ ("ESC" . #x1B)
("FS" . #x1C)
("GS" . #x1D)
("RS" . #x1E)
("US" . #x1F)
+ ("DEL" . #x7F)
))
(define named-bits
- `(("M" . #o01)
- ("Meta" . #o01)
- ("C" . #o02)
- ("Control" . #o02)
- ("S" . #o04)
- ("Super" . #o04)
- ("H" . #o10)
- ("Hyper" . #o10)
- ("T" . #o20)
- ("Top" . #o20)
+ '(("M" . #x01)
+ ("Meta" . #x01)
+ ("C" . #x02)
+ ("Control" . #x02)
+ ("S" . #x04)
+ ("Super" . #x04)
+ ("H" . #x08)
+ ("Hyper" . #x08)
+ ("T" . #x10)
+ ("Top" . #x10)
))
\f
(define (-map-> alist string start end)
(loop (cdr entries)))))
(loop alist))
-(set! char?
-(named-lambda (char? object)
- (primitive-type? char-type object)))
-
-(set! digit->char
-(named-lambda (digit->char digit #!optional radix)
- (cond ((unassigned? radix) (set! radix 10))
+(define (digit->char digit #!optional radix)
+ (cond ((default-object? radix) (set! radix 10))
((not (and (<= 2 radix) (<= radix 36)))
(error "DIGIT->CHAR: Bad radix" radix)))
(and (<= 0 digit) (< digit radix)
(code->char (if (< digit 10)
(+ digit 0-code)
- (+ (- digit 10) upper-a-code))))))
+ (+ (- digit 10) upper-a-code)))))
-(set! char->digit
-(named-lambda (char->digit char #!optional radix)
- (cond ((unassigned? radix) (set! radix 10))
+(define (char->digit char #!optional radix)
+ (cond ((default-object? radix) (set! radix 10))
((not (and (<= 2 radix) (<= radix 36)))
(error "CHAR->DIGIT: Bad radix" radix)))
(and (zero? (char-bits char))
n)))
(or (try 0 0-code)
(try 10 upper-a-code)
- (try 10 lower-a-code))))))
+ (try 10 lower-a-code)))))
\f
-(set! name->char
-(named-lambda (name->char string)
+(define (name->char string)
(let ((end (string-length string))
(bits '()))
(define (loop start)
(set! bits (cons bit bits)))
(loop (1+ hyphen)))))))))))
(let ((code (loop 0)))
- (make-char code (apply + bits))))))
+ (make-char code (apply + bits)))))
(define (name->code string start end)
(if (substring-ci=? string start end "Newline" 0 7)
(or (-map-> named-codes string start end)
(error "Unknown character name" (substring string start end)))))
\f
-(set! char->name
-(named-lambda (char->name char #!optional slashify?)
- (if (unassigned? slashify?) (set! slashify? false))
+(define (char->name char #!optional slashify?)
+ (if (default-object? slashify?) (set! slashify? false))
(define (loop weight bits)
(if (zero? bits)
(let ((code (char-code char)))
((and slashify?
(not (zero? (char-bits char)))
(or (char=? base-char backslash-char)
- (char-set-member? (access atom-delimiters
- parser-package)
+ (char-set-member? char-set/atom-delimiters
base-char)))
(string-append "\\" (char->string base-char)))
((char-graphic? base-char)
">"))
"-"
rest))))))
- (loop 1 (char-bits char))))
-
-)
-\f
-;;;; Character Sets
-
-(define (char-set? object)
- (and (string? object) (= (string-length object) 256)))
-
-(define (char-set . chars)
- (let ((char-set (string-allocate 256)))
- (vector-8b-fill! char-set 0 256 0)
- (for-each (lambda (char) (vector-8b-set! char-set (char->ascii char) 1))
- chars)
- char-set))
-
-(define (predicate->char-set predicate)
- (let ((char-set (string-allocate 256)))
- (define (loop code)
- (if (< code 256)
- (begin (vector-8b-set! char-set code
- (if (predicate (ascii->char code)) 1 0))
- (loop (1+ code)))))
- (loop 0)
- char-set))
-
-(define (char-set-members char-set)
- (define (loop code)
- (cond ((>= code 256) '())
- ((zero? (vector-8b-ref char-set code)) (loop (1+ code)))
- (else (cons (ascii->char code) (loop (1+ code))))))
- (loop 0))
-
-(define (char-set-member? char-set char)
- (let ((ascii (char-ascii? char)))
- (and ascii (not (zero? (vector-8b-ref char-set ascii))))))
-
-(define (char-set-invert char-set)
- (predicate->char-set
- (lambda (char) (not (char-set-member? char-set char)))))
-
-(define (char-set-union char-set-1 char-set-2)
- (predicate->char-set
- (lambda (char)
- (or (char-set-member? char-set-1 char)
- (char-set-member? char-set-2 char)))))
-
-(define (char-set-intersection char-set-1 char-set-2)
- (predicate->char-set
- (lambda (char)
- (and (char-set-member? char-set-1 char)
- (char-set-member? char-set-2 char)))))
-
-(define (char-set-difference char-set-1 char-set-2)
- (predicate->char-set
- (lambda (char)
- (and (char-set-member? char-set-1 char)
- (not (char-set-member? char-set-2 char))))))
-\f
-;;;; System Character Sets
-
-(define char-set:upper-case
- (predicate->char-set
- (let ((lower (ascii->char #x41))
- (upper (ascii->char #x5A)))
- (lambda (char)
- (and (char<=? lower char)
- (char<=? char upper))))))
-
-(define char-set:lower-case
- (predicate->char-set
- (let ((lower (ascii->char #x61))
- (upper (ascii->char #x7A)))
- (lambda (char)
- (and (char<=? lower char)
- (char<=? char upper))))))
-
-(define char-set:numeric
- (predicate->char-set
- (let ((lower (ascii->char #x30))
- (upper (ascii->char #x39)))
- (lambda (char)
- (and (char<=? lower char)
- (char<=? char upper))))))
-
-(define char-set:alphabetic
- (char-set-union char-set:upper-case char-set:lower-case))
-
-(define char-set:alphanumeric
- (char-set-union char-set:alphabetic char-set:numeric))
-
-(define char-set:graphic
- (predicate->char-set
- (let ((lower (ascii->char #x20))
- (upper (ascii->char #x7E)))
- (lambda (char)
- (and (char<=? lower char)
- (char<=? char upper))))))
-
-(define char-set:standard
- (char-set-union char-set:graphic (char-set (ascii->char #x0D))))
-
-(define char-set:whitespace
- (char-set (ascii->char #x09) ;Tab
- (ascii->char #x0A) ;Linefeed
- (ascii->char #x0C) ;Page
- (ascii->char #x0D) ;Return
- (ascii->char #x20) ;Space
- ))
-
-(define char-set:not-whitespace
- (char-set-invert char-set:whitespace))
-\f
-(define ((char-set-predicate char-set) char)
- (char-set-member? char-set char))
-
-(define char-upper-case? (char-set-predicate char-set:upper-case))
-(define char-lower-case? (char-set-predicate char-set:lower-case))
-(define char-numeric? (char-set-predicate char-set:numeric))
-(define char-alphabetic? (char-set-predicate char-set:alphabetic))
-(define char-alphanumeric? (char-set-predicate char-set:alphanumeric))
-(define char-graphic? (char-set-predicate char-set:graphic))
-(define char-standard? (char-set-predicate char-set:standard))
-(define char-whitespace? (char-set-predicate char-set:whitespace))
+ (loop 1 (char-bits char)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/chrset.scm,v 14.1 1988/05/20 00:53:47 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/chrset.scm,v 14.2 1988/06/13 11:41:14 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Character Sets
+;;; package: (runtime character-set)
(declare (usual-integrations))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/codwlk.scm,v 14.1 1988/05/20 00:54:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/codwlk.scm,v 14.2 1988/06/13 11:41:19 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; SCode Walker
-;;; scode-walker-package
+;;; package: (runtime scode-walker)
(declare (usual-integrations))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.1 1988/05/20 00:54:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/conpar.scm,v 14.2 1988/06/13 11:41:24 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Continuation Parser
-;;; package: continuation-parser-package
+;;; package: (runtime continuation-parser)
(declare (usual-integrations))
\f
(if (not (return-address? return-address))
(error "illegal return address" return-address))
(let ((code (return-address/code return-address)))
- (if (>= code (vector-length stack-frame-types))
- (error "return-code too large" code))
- (let ((type (vector-ref stack-frame-types code)))
+ (let ((type (microcode-return/code->type code)))
(if (not type)
(error "return-code has no type" code))
type))))
(parser false read-only true)
(unparser false read-only true))
+(define (microcode-return/code->type code)
+ (if (not (< code (vector-length stack-frame-types)))
+ (error "return-code too large" code))
+ (vector-ref stack-frame-types code))
+
(define (initialize-package!)
(set! stack-frame-types (make-stack-frame-types)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/contin.scm,v 14.1 1988/05/20 00:54:50 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/contin.scm,v 14.2 1988/06/13 11:42:51 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Continuations
-;;; package: continuation-package
+;;; package: (runtime continuation)
(declare (usual-integrations))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/cpoint.scm,v 14.1 1988/05/20 00:55:10 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/cpoint.scm,v 14.2 1988/06/13 11:42:56 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Control Points
-;;; package: control-point-package
+;;; package: (runtime control-point)
(declare (usual-integrations))
\f
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/datime.scm,v 13.41 1987/01/23 00:11:08 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
-;;;; Date and Time Routines
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/datime.scm,v 14.1 1988/06/13 11:43:00 cph Exp $
-(declare (usual-integrations))
-\f
-;;;; Date and Time
+Copyright (c) 1988 Massachusetts Institute of Technology
-(define date
- (let ((year (make-primitive-procedure 'CURRENT-YEAR))
- (month (make-primitive-procedure 'CURRENT-MONTH))
- (day (make-primitive-procedure 'CURRENT-DAY)))
- (named-lambda (date #!optional receiver)
- ((if (unassigned? receiver) list receiver)
- (year) (month) (day)))))
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
-(define time
- (let ((hour (make-primitive-procedure 'CURRENT-HOUR))
- (minute (make-primitive-procedure 'CURRENT-MINUTE))
- (second (make-primitive-procedure 'CURRENT-SECOND)))
- (named-lambda (time #!optional receiver)
- ((if (unassigned? receiver) list receiver)
- (hour) (minute) (second)))))
-\f
-(define date->string)
-(define time->string)
-(let ()
+1. Any copy made of this software must include this copyright notice
+in full.
-(set! date->string
-(named-lambda (date->string year month day)
- (if year
- (string-append
- (vector-ref days-of-the-week
- (let ((qr (integer-divide year 4)))
- (remainder (+ (* year 365)
- (if (and (zero? (integer-divide-remainder qr))
- (<= month 2))
- (integer-divide-quotient qr)
- (1+ (integer-divide-quotient qr)))
- (vector-ref days-through-month (-1+ month))
- day
- 6)
- 7)))
- " "
- (vector-ref months-of-the-year (-1+ month))
- " "
- (write-to-string day)
- ", 19"
- (write-to-string year))
- "Date primitives not installed")))
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
-(define months-of-the-year
- #("January" "February" "March" "April" "May" "June" "July"
- "August" "September" "October" "November" "December"))
+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.
-(define days-of-the-week
- #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
-(define days-through-month
- (let ()
- (define (month-loop months value)
- (if (null? months)
- '()
- (cons value
- (month-loop (cdr months) (+ value (car months))))))
- (list->vector (month-loop '(31 28 31 30 31 30 31 31 30 31 30 31) 0))))
+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 without prior written consent from
+MIT in each case. |#
-(set! time->string
-(named-lambda (time->string hour minute second)
- (if hour
- (string-append (write-to-string
- (cond ((zero? hour) 12)
- ((< hour 13) hour)
- (else (- hour 12))))
- (if (< minute 10) ":0" ":")
- (write-to-string minute)
- (if (< second 10) ":0" ":")
- (write-to-string second)
- " "
- (if (< hour 12) "AM" "PM"))
- "Time primitives not installed")))
+;;;; Date and Time Routines
+;;; package: (runtime date/time)
+
+(declare (usual-integrations))
+\f
+;;;; Decoded Time
+
+;;; Based on Common Lisp definition. Needs time zone stuff, and
+;;; handling of abbreviated year specifications.
+
+(define-structure (decoded-time (conc-name decoded-time/))
+ (second false read-only true)
+ (minute false read-only true)
+ (hour false read-only true)
+ (day false read-only true)
+ (month false read-only true)
+ (year false read-only true)
+ (day-of-week false read-only true))
+
+(define (get-decoded-time)
+ ;; Can return false, indicating that we don't know the time.
+ (let ((day ((ucode-primitive current-day)))
+ (month ((ucode-primitive current-month)))
+ (year ((ucode-primitive current-year))))
+ (and year
+ (let ((year (+ year 1900)))
+ (make-decoded-time
+ ((ucode-primitive current-second))
+ ((ucode-primitive current-minute))
+ ((ucode-primitive current-hour))
+ day
+ month
+ year
+ (zellers-congruence day month year))))))
+
+(define (zellers-congruence day month year)
+ (let ((qr (integer-divide year 100)))
+ (let ((month (modulo (- month 2) 12))
+ (year (integer-divide-remainder qr))
+ (century (integer-divide-quotient qr)))
+ (modulo (-1+ (- (+ day
+ (quotient (-1+ (* 13 month)) 5)
+ year
+ (quotient year 4)
+ (quotient century 4))
+ (+ (* 2 century)
+ (if (zero? (remainder year 4))
+ (* 2 (quotient month 11))
+ (quotient month 11)))))
+ 7))))
+\f
+(define (decoded-time/date-string time)
+ (string-append
+ (vector-ref '#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday"
+ "Saturday" "Sunday")
+ (decoded-time/day-of-week time))
+ " "
+ (vector-ref '#("January" "February" "March" "April" "May" "June"
+ "July" "August" "September" "October"
+ "November" "December")
+ (-1+ (decoded-time/month time)))
+ " "
+ (write-to-string (decoded-time/day time))
+ ", "
+ (write-to-string (decoded-time/year time))))
-)
+(define (decoded-time/time-string time)
+ (let ((second (decoded-time/second time))
+ (minute (decoded-time/minute time))
+ (hour (decoded-time/hour time)))
+ (string-append (write-to-string
+ (cond ((zero? hour) 12)
+ ((< hour 13) hour)
+ (else (- hour 12))))
+ (if (< minute 10) ":0" ":")
+ (write-to-string minute)
+ (if (< second 10) ":0" ":")
+ (write-to-string second)
+ " "
+ (if (< hour 12) "AM" "PM"))))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.1 1988/05/20 00:55:29 cph Exp $
-;;;
-;;; Copyright (c) 1988 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.2 1988/06/13 11:43:06 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Debugger Command Loop Support
-;;; package: debugger-command-loop-package
+;;; package: (runtime debugger-command-loop)
(declare (usual-integrations))
\f
(prompt (cdr (cmdl/state cmdl))))
(let loop ()
(let ((char (char-upcase (prompt-for-command-char prompt cmdl))))
- (let ((entry (assv char (cdr command-set))))
- (if entry
- ((cadr entry))
- (begin
- (let ((port (cmdl/output-port cmdl)))
- (beep port)
- (newline port)
- (write-string "Unknown command char: " port)
- (write char port))
- (loop)))))))
+ (with-output-to-port (cmdl/output-port cmdl)
+ (lambda ()
+ (let ((entry (assv char (cdr command-set))))
+ (if entry
+ ((cadr entry))
+ (begin
+ (beep)
+ (newline)
+ (write-string "Unknown command char: ")
+ (write char)
+ (loop)))))))))
(cmdl-message/null))
(define ((standard-help-command command-set))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgutl.scm,v 14.1 1988/05/20 00:55:52 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgutl.scm,v 14.2 1988/06/13 11:43:10 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Debugger Utilities
-;;; package: debugger-utilities-package
+;;; package: (runtime debugger-utilities)
(declare (usual-integrations))
\f
(string-append s
(write->string (cadr binding)
(max (- x-size (string-length s))
- 0)))))))))
\ No newline at end of file
+ 0)))))))))
+
+(define (debug/read-eval-print-1 environment)
+ (let ((value (debug/eval (prompt-for-expression "Eval--> ") environment)))
+ (newline)
+ (write value)))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 13.46 1987/12/09 22:11:26 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
-;;;; Debugger
-
-(in-package debugger-package
-(declare (usual-integrations))
-\f
-(define debug-package
- (make-environment
-
-(define current-continuation)
-(define previous-continuations)
-(define current-reduction-number)
-(define current-number-of-reductions)
-(define current-reduction)
-(define current-environment)
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.1 1988/06/13 11:43:15 cph Exp $
-(define command-set
- (make-command-set 'DEBUG-COMMANDS))
+Copyright (c) 1988 Massachusetts Institute of Technology
-(define reduction-wrap-around-tag
- 'WRAP-AROUND)
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
-(define print-user-friendly-name
- (access print-user-friendly-name env-package))
+1. Any copy made of this software must include this copyright notice
+in full.
-(define print-expression
- pp)
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
-(define student-walk?
- false)
+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.
-(define print-return-values?
- false)
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
-(define environment-arguments-truncation
- 68)
+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 without prior written consent from
+MIT in each case. |#
-(define (define-debug-command letter function help-text)
- (define-letter-command command-set letter function help-text))
+;;;; Debugger
+;;; package: (runtime debugger)
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (set! command-set
+ (make-command-set
+ 'DEBUG-COMMANDS
+ `((#\? ,standard-help-command
+ "Help, list command letters")
+ (#\A ,debug-compiled
+ "Invoke compiled code debugger on the current subproblem")
+ (#\B ,earlier-reduction-command
+ "Earlier reduction (Back in time)")
+ (#\C ,show-current-frame
+ "Show Bindings of identifiers in the current environment")
+ (#\D ,later-subproblem-command
+ "Move (Down) to the next (later) subproblem")
+ (#\E ,enter-read-eval-print-loop
+ "Enter a read-eval-print loop in the current environment")
+ (#\F ,later-reduction-command
+ "Later reduction (Forward in time)")
+ (#\G ,goto-command
+ "Go to a particular Subproblem/Reduction level")
+ (#\H ,summarize-history-command
+ "Prints a summary of the entire history")
+ (#\I ,error-info-command
+ "Redisplay the error message")
+ (#\L ,pretty-print-current-expression
+ "(list expression) Pretty-print the current expression")
+ (#\P ,pretty-print-reduction-function
+ "Pretty print current procedure")
+ (#\Q ,standard-exit-command
+ "Quit (exit DEBUG)")
+ (#\R ,reductions-command
+ "Print the reductions of the current subproblem level")
+ (#\S ,print-current-expression
+ "Print the current subproblem/reduction")
+ (#\U ,earlier-subproblem-command
+ "Move (Up) to the previous (earlier) subproblem")
+ (#\V ,eval-in-current-environment
+ "Evaluate expression in current environment")
+ (#\W ,enter-where-command
+ "Enter WHERE on the current environment")
+ (#\X ,internal-command
+ "Create a read eval print loop in the debugger environment")
+ (#\Z ,return-command
+ "Return (continue with) an expression after evaluating it")
+ ))))
+
+(define command-set)
+\f
;;; Basic Commands
-(define-debug-command #\? (standard-help-command command-set)
- "Help, list command letters")
+(define current-subproblem)
+(define previous-subproblems)
+(define current-subproblem-number)
+(define current-reduction-number)
+(define current-reductions)
+(define current-number-of-reductions)
+(define current-reduction)
+(define current-environment)
+(define current-expression)
-(define-debug-command #\Q standard-exit-command "Quit (exit DEBUG)")
+(define reduction-wrap-around-tag 'WRAP-AROUND)
+(define student-walk? false)
+(define print-return-values? false)
+(define environment-arguments-truncation 68)
-(define (debug #!optional the-continuation)
- (fluid-let ((current-continuation)
- (previous-continuations '())
+(define (debug #!optional object)
+ (fluid-let ((current-subproblem)
+ (previous-subproblems)
+ (current-subproblem-number)
(current-reduction-number)
+ (current-reductions)
(current-number-of-reductions)
- (current-reduction false)
- (current-environment '()))
- (debug-abstract-continuation
- (cond ((unassigned? the-continuation) (rep-continuation))
- ((raw-continuation? the-continuation); Must precede next test!
- (raw-continuation->continuation the-continuation))
- ((continuation? the-continuation) the-continuation)
- (else (error "DEBUG: Not a continuation" the-continuation))))))
-\f
-(define (debug-abstract-continuation continuation)
- (set-current-continuation! continuation initial-reduction-number)
- (letter-commands command-set
- (lambda ()
- (print-current-expression)
- ((standard-rep-message "Debugger")))
- "Debug-->"))
-
-(define (undefined-environment? environment)
- (or (continuation-undefined-environment? environment)
- (eq? environment system-global-environment)
- (and (environment? environment)
- ((access system-external-environment? environment-package)
- environment))))
-
-(define (print-undefined-environment)
- (format "~%Undefined environment at this subproblem/reduction level"))
-
-(define (with-rep-alternative env receiver)
- (if (undefined-environment? env)
- (begin
- (print-undefined-environment)
- (format "~%Using the read-eval-print environment instead!")
- (receiver (rep-environment)))
- (receiver env)))
-
-(define (if-valid-environment env receiver)
- (if (undefined-environment? env)
- (print-undefined-environment)
- (receiver env)))
-
-(define (current-expression)
- (if current-reduction
- (reduction-expression current-reduction)
- (let ((exp (continuation-expression current-continuation)))
- (if (or (not (continuation-undefined-expression? exp))
- (null? (continuation-annotation current-continuation)))
- exp
- (cons 'UNDEFINED-EXPRESSION
- (continuation-annotation current-continuation))))))
+ (current-reduction)
+ (current-environment)
+ (current-expression))
+ (set-current-subproblem!
+ (let ((object
+ (if (default-object? object)
+ (or (error-continuation)
+ (current-proceed-continuation))
+ object)))
+ (or (coerce-to-stack-frame object)
+ (error "DEBUG: null continuation" object)))
+ '()
+ (lambda () 0))
+ (letter-commands command-set
+ (cmdl-message/append
+ (cmdl-message/active print-current-expression)
+ (cmdl-message/standard "Debugger"))
+ "Debug-->")))
+
+(define (coerce-to-stack-frame object)
+ (cond ((stack-frame? object)
+ (stack-frame/skip-non-subproblems object))
+ ((continuation? object)
+ (coerce-to-stack-frame (continuation->stack-frame object)))
+ (else
+ (error "DEBUG: illegal argument" object))))
\f
;;;; Random display commands
(define (pretty-print-current-expression)
- (print-expression (current-expression)))
-
-(define-debug-command #\L pretty-print-current-expression
- "(list expression) Pretty-print the current expression")
+ (print-expression current-expression))
(define (pretty-print-reduction-function)
- (if-valid-environment (if current-reduction
- (reduction-environment current-reduction)
- current-environment)
- (lambda (env) (pp (environment-procedure env)))))
-
-(define-debug-command #\P pretty-print-reduction-function
- "Pretty print current procedure")
+ (if-valid-environment current-environment
+ (lambda (environment)
+ (pp (environment-procedure environment)))))
(define (print-current-expression)
- (define (print-current-reduction)
- (format "~2xReduction Number:~x~o~%Expression:" current-reduction-number)
- (print-expression (reduction-expression current-reduction)))
-
- (define (print-application-information env)
- (let ((do-it
- (lambda (return?)
- (if return? (newline))
- (write-string "within ")
- (print-user-friendly-name env)
- (if return? (newline))
- (write-string " applied to ")
- (write-string
- (cdr (write-to-string (environment-arguments env)
- environment-arguments-truncation))))))
- (let ((output (with-output-to-string (lambda () (do-it false)))))
- (if (< (string-length output)
- (access printer-width implementation-dependencies))
- (begin (newline) (write-string output))
- (do-it true)))))
-
(newline)
- (if (null-continuation? current-continuation)
- (write-string "Null continuation")
+ (write-string "Subproblem Level: ")
+ (write current-subproblem-number)
+ (if current-reduction
(begin
- (write-string "Subproblem Level: ")
- (write (length previous-continuations))
- (if current-reduction
- (print-current-reduction)
- (begin
- (newline)
- (write-string "Possibly Incomplete Expression:")
- (print-expression
- (continuation-expression current-continuation))))
- (if-valid-environment current-environment
- print-application-information))))
-
-(define-debug-command #\S print-current-expression
- "Print the current subproblem/reduction")
-\f
+ (write-string " Reduction Number: ")
+ (write current-reduction-number)
+ (newline)
+ (write-string "Expression:"))
+ (begin
+ (newline)
+ (write-string "Possibly Incomplete Expression:")))
+ (print-expression current-expression)
+ (if-valid-environment current-environment
+ (lambda (environment)
+ (let ((do-it
+ (lambda (return?)
+ (if return? (newline))
+ (write-string "within ")
+ (print-user-friendly-name environment)
+ (if return? (newline))
+ (write-string " applied to ")
+ (write-string
+ (cdr
+ (write-to-string (environment-arguments environment)
+ environment-arguments-truncation))))))
+ (let ((output (with-output-to-string (lambda () (do-it false)))))
+ (if (< (string-length output)
+ (output-port/x-size (current-output-port)))
+ (begin (newline) (write-string output))
+ (do-it true)))))))
+
(define (reductions-command)
- (if (null-continuation? current-continuation)
- (format "~%Null continuation")
- (let loop ((r (continuation-reductions current-continuation)))
- (cond ((pair? r)
- (print-expression (reduction-expression (car r)))
- (loop (cdr r)))
- ((wrap-around-in-reductions? r)
- (format "~%Wrap Around in the reductions at this level."))
- (else 'done)))))
-
-(define-debug-command #\R reductions-command
- "Print the reductions of the current subproblem level")
+ (let loop ((reductions current-reductions))
+ (cond ((pair? reductions)
+ (print-expression (reduction-expression (car reductions)))
+ (loop (cdr reductions)))
+ ((wrap-around-in-reductions? reductions)
+ (newline)
+ (write-string "Wrap Around in the reductions at this level.")))))
\f
;;;; Short history display
(define (summarize-history-command)
- (define (print-continuations cont level)
- (define (print-reductions reductions show-all?)
- (define (print-reduction red number)
- (terse-print-expression level
- (reduction-expression red)
- (reduction-environment red)))
-
- (let loop ((reductions reductions) (number 0))
- (if (pair? reductions)
- (begin
- (print-reduction (car reductions) number)
- (if show-all? (loop (cdr reductions) (1+ number)))))))
-
- (if (null-continuation? cont)
- *the-non-printing-object*
- (begin
- (let ((reductions (continuation-reductions cont)))
- (if (not (pair? reductions))
- (terse-print-expression level
- (continuation-expression cont)
- (continuation-environment cont))
- (print-reductions reductions (= level 0))))
- (print-continuations (continuation-next-continuation cont)
- (1+ level)))))
-
- (let ((top-continuation (if (null? previous-continuations)
- current-continuation
- (car (last-pair previous-continuations)))))
- (if (null-continuation? top-continuation)
- (format "~%No history available")
- (begin
- (format "~%Sub Prb. Procedure Name Expression~%")
- (print-continuations top-continuation 0)))))
+ (let ((top-subproblem
+ (if (null? previous-subproblems)
+ current-subproblem
+ (car (last-pair previous-subproblems)))))
+ (newline)
+ (write-string "Sub Prb. Procedure Name Expression")
+ (newline)
+ (let loop ((frame top-subproblem) (level 0))
+ (if frame
+ (begin
+ (let ((reductions (stack-frame/reductions frame)))
+ (if (pair? reductions)
+ (let ((print-reduction
+ (lambda (reduction)
+ (terse-print-expression
+ level
+ (reduction-expression reduction)
+ (reduction-environment reduction)))))
+ (print-reduction (car reductions))
+ (if (= level 0)
+ (for-each print-reduction (cdr reductions))))
+ (with-values
+ (lambda () (stack-frame/debugging-info frame))
+ (lambda (expression environment)
+ (terse-print-expression level
+ expression
+ environment)))))
+ (loop (stack-frame/next-subproblem frame) (1+ level)))))))
(define (terse-print-expression level expression environment)
- (format "~%~@3o~:20o~4x~@:52c"
- level
- ;; procedure name
- (if (or (undefined-environment? environment)
- (special-name? (environment-name environment)))
- *the-non-printing-object*
- (environment-name environment))
- expression))
-
-(define-debug-command #\H summarize-history-command
- "Prints a summary of the entire history")
+ (newline)
+ (write-string (string-pad-left (number->string level) 3))
+ (write-string " ")
+ ;;; procedure name
+ (write-string
+ (string-pad-right
+ (if (or (not (environment? environment))
+ (special-name? (environment-name environment)))
+ ""
+ (write-to-truncated-string (environment-name environment) 20))
+ 20))
+ (write-string " ")
+ (write-string (write-to-truncated-string (unsyntax expression) 50)))
+
+(define (write-to-truncated-string object n-columns)
+ (let ((result (write-to-string object n-columns)))
+ (if (car result)
+ (string-append (substring (cdr result) 0 (- n-columns 4)) " ...")
+ (cdr result))))
\f
;;;; Motion to earlier expressions
-(define (earlier-reduction)
- (define (up! message)
- (format "~%~s~%Going to the previous (earlier) continuation!" message)
- (earlier-continuation-command))
-
+(define (earlier-subproblem-command)
+ (if (stack-frame/next-subproblem current-subproblem)
+ (begin
+ (earlier-subproblem)
+ (print-current-expression))
+ (begin
+ (beep)
+ (newline)
+ (write-string "There are only ")
+ (write current-subproblem-number)
+ (write-string " subproblem levels; already at earliest level"))))
+
+(define (earlier-reduction-command)
(cond ((and student-walk?
- (> (length previous-continuations) 0)
+ (> current-subproblem-number 0)
(= current-reduction-number 0))
- (earlier-continuation-command))
+ (earlier-subproblem-command))
((< current-reduction-number (-1+ current-number-of-reductions))
(set-current-reduction! (1+ current-reduction-number))
(print-current-expression))
- ((wrap-around-in-reductions?
- (continuation-reductions current-continuation))
- (up! "Wrap around in reductions at this level!"))
- (else (up! "No more reductions at this level!"))))
-
-(define-debug-command #\B earlier-reduction "Earlier reduction (Back in time)")
+ (else
+ (newline)
+ (write-string
+ (if (wrap-around-in-reductions? current-reductions)
+ "Wrap around in reductions at this level!"
+ "No more reductions at this level!"))
+ (newline)
+ (write-string "Going to the previous (earlier) subproblem")
+ (earlier-subproblem-command))))
(define (earlier-subproblem)
- (let ((new (continuation-next-continuation current-continuation)))
- (set! previous-continuations
- (cons current-continuation previous-continuations))
- (set-current-continuation! new normal-reduction-number)))
-
-(define (earlier-continuation-command)
- (if (not (null-continuation? (continuation-next-continuation
- current-continuation)))
- (earlier-subproblem)
- (format "~%There are only ~o subproblem levels"
- (length previous-continuations)))
- (print-current-expression))
-
-(define-debug-command #\U earlier-continuation-command
- "Move (Up) to the previous (earlier) continuation")
+ ;; Assumption: (not (not (stack-frame/next-subproblem current-subproblem)))
+ (set-current-subproblem! (stack-frame/next-subproblem current-subproblem)
+ (cons current-subproblem previous-subproblems)
+ normal-reduction-number))
\f
;;;; Motion to later expressions
-(define (later-reduction)
- (cond ((> current-reduction-number 0)
- (set-current-reduction! (-1+ current-reduction-number))
- (print-current-expression))
- ((or (not student-walk?)
- (= (length previous-continuations) 1))
- (later-continuation-TO-LAST-REDUCTION))
- (else (later-continuation))))
-
-(define-debug-command #\F later-reduction "Later reduction (Forward in time)")
-
-(define (later-continuation)
- (if (null? previous-continuations)
- (format "~%Already at lowest subproblem level")
- (begin (later-subproblem) (print-current-expression))))
-
-(define (later-continuation-TO-LAST-REDUCTION)
- (define (later-subproblem-TO-LAST-REDUCTION)
- (set-current-continuation!
- (car (set! previous-continuations (cdr previous-continuations)))
- last-reduction-number))
-
- (if (null? previous-continuations)
- (format "~%Already at lowest subproblem level")
- (begin (later-subproblem-TO-LAST-REDUCTION)
- (print-current-expression))))
-
-(define (later-subproblem)
- (set-current-continuation!
- (car (set! previous-continuations (cdr previous-continuations)))
- normal-reduction-number))
-
-(define (later-continuation-command)
- (if (null? previous-continuations)
- (format "~%Already at oldest continuation")
- (begin (later-subproblem) (print-current-expression))))
-
-(define-debug-command #\D later-continuation-command
- "Move (Down) to the next (later) continuation")
+(define (later-subproblem-command)
+ (later-subproblem normal-reduction-number))
+
+(define (later-reduction-command)
+ (if (positive? current-reduction-number)
+ (begin
+ (set-current-reduction! (-1+ current-reduction-number))
+ (print-current-expression))
+ (later-subproblem
+ (if (or (not student-walk?)
+ (= current-subproblem-number 1))
+ last-reduction-number
+ normal-reduction-number))))
+
+(define (later-subproblem select-reduction-number)
+ (if (null? previous-subproblems)
+ (begin
+ (beep)
+ (newline)
+ (write-string "Already at latest subproblem level"))
+ (begin
+ (set-current-subproblem! (car previous-subproblems)
+ (cdr previous-subproblems)
+ select-reduction-number)
+ (print-current-expression))))
\f
;;;; General motion command
(define (goto-command)
- (define (get-reduction-number)
- (let ((red
- (prompt-for-expression
- (format false
- "Reduction Number (0 through ~o inclusive): "
- (-1+ current-number-of-reductions)))))
- (cond ((not (number? red))
- (beep)
- (format "~%Reduction number must be numeric!")
- (get-reduction-number))
- ((not (and (>= red 0)
- (< red current-number-of-reductions)))
- (format "~%Reduction number out of range.!")
- (get-reduction-number))
- (else (set-current-reduction! red)))))
-
- (define (choose-reduction)
- (cond ((> current-number-of-reductions 1) (get-reduction-number))
- ((= current-number-of-reductions 1)
- (format "~%There is only one reduction for this subproblem")
- (set-current-reduction! 0))
- (else (format "~%There are no reductions for this subproblem."))))
-
- (define (get-subproblem-number)
- (let ((len (length previous-continuations))
- (sub (prompt-for-expression "Subproblem number: ")))
- (cond ((not (number? sub))
+ (let loop ()
+ (let ((subproblem-number (prompt-for-expression "Subproblem number: ")))
+ (cond ((not (and (integer? subproblem-number)
+ (not (negative? subproblem-number))))
(beep)
- (format "~%Subproblem level must be numeric!")
- (get-subproblem-number))
- ((< sub len) (repeat later-subproblem (- len sub))
- (choose-reduction))
+ (newline)
+ (write-string "Subproblem level must be nonnegative integer!")
+ (loop))
+ ((< subproblem-number current-subproblem-number)
+ (repeat (lambda ()
+ (set-current-subproblem! (car previous-subproblems)
+ (cdr previous-subproblems)
+ normal-reduction-number))
+ (- current-subproblem-number subproblem-number)))
(else
- (let loop ((len len))
- (cond ((= sub len) (choose-reduction))
- ((null-continuation?
- (continuation-next-continuation current-continuation))
- (format "~%There is no such subproblem.")
- (format "~%Now at subproblem number: ~o"
- (length previous-continuations))
- (choose-reduction))
- (else (earlier-subproblem) (loop (1+ len)))))))))
-
- (get-subproblem-number)
+ (let loop ()
+ (if (< current-subproblem-number subproblem-number)
+ (if (stack-frame/next-subproblem current-subproblem)
+ (begin
+ (earlier-subproblem)
+ (loop))
+ (begin
+ (beep)
+ (newline)
+ (write-string "There is no such subproblem.")
+ (newline)
+ (write-string "Now at subproblem number: ~o")
+ (write current-subproblem-number)))))))))
+ (set-current-reduction!
+ (cond ((> current-number-of-reductions 1)
+ (let get-reduction-number ()
+ (let ((reduction-number
+ (prompt-for-expression
+ (string-append
+ "Reduction Number (0 through "
+ (number->string (-1+ current-number-of-reductions))
+ " inclusive): "))))
+ (cond ((not (and (integer? reduction-number)
+ (not (negative? reduction-number))))
+ (beep)
+ (newline)
+ (write-string
+ "Reduction number must be nonnegative integer!")
+ (get-reduction-number))
+ ((not (< reduction-number current-number-of-reductions))
+ (beep)
+ (newline)
+ (write-string "Reduction number too large!")
+ (get-reduction-number))
+ (else
+ reduction-number)))))
+ ((= current-number-of-reductions 1)
+ (newline)
+ (write-string "There is only one reduction for this subproblem")
+ 0)
+ (else
+ (newline)
+ (write-string "There are no reductions for this subproblem.")
+ -1)))
(print-current-expression))
-
-(define-debug-command #\G goto-command
- "Go to a particular Subproblem/Reduction level")
\f
;;;; Evaluation and frame display commands
(define (enter-read-eval-print-loop)
(with-rep-alternative current-environment
- (lambda (env)
- (debug/read-eval-print env
+ (lambda (environment)
+ (debug/read-eval-print environment
"You are now in the desired environment"
"Eval-in-env-->"))))
-(define-debug-command #\E enter-read-eval-print-loop
- "Enter a read-eval-print loop in the current environment")
-
(define (eval-in-current-environment)
- (with-rep-alternative current-environment
- (lambda (env)
- (environment-warning-hook env)
- (debug/eval (prompt-for-expression "Eval--> ") env))))
-
-(define-debug-command #\V eval-in-current-environment
- "Evaluate expression in current environment")
-
-(define show-current-frame
- (let ((show-frame (access show-frame env-package)))
- (named-lambda (show-current-frame)
- (if-valid-environment current-environment
- (lambda (env) (show-frame env -1))))))
+ (with-rep-alternative current-environment debug/read-eval-print-1))
-(define-debug-command #\C show-current-frame
- "Show Bindings of identifiers in the current environment")
+(define (show-current-frame)
+ (if-valid-environment current-environment
+ (lambda (environment)
+ (show-frame environment -1))))
(define (enter-where-command)
(with-rep-alternative current-environment debug/where))
-(define-debug-command #\W enter-where-command
- "Enter WHERE on the current environment")
-
(define (error-info-command)
- (format "~% Message: ~s~%Irritant: ~o" (error-message) (error-irritant)))
-
-(define-debug-command #\I error-info-command "Redisplay the error message")
+ (let ((message (error-message))
+ (irritants (error-irritants)))
+ (newline)
+ (write-string " Message: ")
+ (write-string message)
+ (newline)
+ (if (null? irritants)
+ (write-string " No irritants")
+ (begin
+ (write-string " Irritants: ")
+ (for-each
+ (let ((n (- (output-port/x-size (current-output-port)) 4)))
+ (lambda (irritant)
+ (newline)
+ (write-string " ")
+ (if (error-irritant/noise? irritant)
+ (begin
+ (write-string "noise: ")
+ (write (error-irritant/noise-value irritant)))
+ (write-string
+ (let ((result (write-to-string irritant n)))
+ (if (car result)
+ (substring-move-right! "..." 0 3
+ (cdr result) (- n 3)))
+ (cdr result))))))
+ irritants)))
+ (newline)
+ (write-string " Formatted output:")
+ (newline)
+ (format-error-message message irritants)))
\f
;;;; Advanced hacking commands
-(define (return-command) ;command Z
- (define (do-it environment next)
- (environment-warning-hook environment)
- (let ((value
- (debug/eval
- (let ((expression
- (prompt-for-expression
- "Expression to EVALUATE and CONTINUE with ($ to retry): "
- )))
- (if (eq? expression '$)
- (unsyntax (current-expression))
- expression))
- environment)))
- (if print-return-values?
- (begin
- (format "~%That evaluates to:~%~o" value)
- (if (prompt-for-confirmation "Confirm: ") (next value)))
- (next value))))
-
- (let ((next (continuation-next-continuation current-continuation)))
- (if (null-continuation? next)
- (begin (beep) (format "~%Can't continue!!!"))
+(define (return-command)
+ (let ((next (stack-frame/next-subproblem current-subproblem)))
+ (if next
(with-rep-alternative current-environment
- (lambda (env) (do-it env next))))))
-
-(define-debug-command #\Z return-command
- "Return (continue with) an expression after evaluating it")
-
-(define user-debug-environment (make-environment))
+ (lambda (environment)
+ (let ((value
+ (debug/eval
+ (let ((expression
+ (prompt-for-expression
+ "Expression to EVALUATE and CONTINUE with ($ to retry): ")))
+ (if (eq? expression '$)
+ (unsyntax current-expression)
+ expression))
+ environment)))
+ (if print-return-values?
+ (begin
+ (newline)
+ (write-string "That evaluates to:")
+ (newline)
+ (write value)
+ (if (prompt-for-confirmation "Confirm: ") (next value)))
+ (next value)))))
+ (begin
+ (beep)
+ (newline)
+ (write-string "Can't continue!!!")))))
(define (internal-command)
(debug/read-eval-print user-debug-environment
"You are now in the debugger environment"
"Debugger-->"))
-
-(define-debug-command #\X internal-command
- "Create a read eval print loop in the debugger environment")
-
-(define debug-compiled-continuation false)
+(define user-debug-environment
+ (let () (the-environment)))
(define (debug-compiled)
- (if debug-compiled-continuation
- (debug-compiled-continuation current-continuation)
- (begin (beep)
- (format "~%The compiled code debugger is not present in this system."))))
+ (if debug-compiled-subproblem
+ (debug-compiled-subproblem current-subproblem)
+ (begin
+ (beep)
+ (newline)
+ (write-string "The compiled code debugger is not installed"))))
-(define-debug-command #\A debug-compiled
- "Invoke the compiled code debugger on the current continuation")
+(define debug-compiled-subproblem false)
\f
-;;;; Reduction and continuation motion low-level
-
-(define reduction-expression car)
-(define reduction-environment cadr)
+;;;; Reduction and subproblem motion low-level
+
+(define (set-current-subproblem! stack-frame previous-frames
+ select-reduction-number)
+ (set! current-subproblem stack-frame)
+ (set! previous-subproblems previous-frames)
+ (set! current-subproblem-number (length previous-subproblems))
+ (set! current-reductions
+ (if stack-frame (stack-frame/reductions current-subproblem) '()))
+ (set! current-number-of-reductions (dotted-list-length current-reductions))
+ (set-current-reduction! (select-reduction-number)))
(define (last-reduction-number)
(-1+ current-number-of-reductions))
(define (normal-reduction-number)
(min (-1+ current-number-of-reductions) 0))
-(define (initial-reduction-number)
- (let ((environment (continuation-environment current-continuation)))
- (if (and (environment? environment)
- (let ((procedure (environment-procedure environment)))
- (or (eq? procedure error-procedure)
- (eq? procedure breakpoint-procedure))))
- 1
- 0)))
-
-(define (set-current-continuation! continuation hook)
- (set! current-continuation continuation)
- (set! current-number-of-reductions
- (if (null-continuation? continuation)
- 0
- (dotted-list-length
- (continuation-reductions current-continuation))))
- (set-current-reduction! (hook)))
-
(define (set-current-reduction! number)
(set! current-reduction-number number)
- (if (and (not (= current-number-of-reductions 0)) (>= number 0))
- (set! current-reduction
- (list-ref (continuation-reductions current-continuation) number))
- (set! current-reduction false))
- (set! current-environment
- (if current-reduction
- (reduction-environment current-reduction)
- (continuation-environment current-continuation))))
+ (set! current-reduction
+ (and (not (null? current-reductions))
+ (>= number 0)
+ (list-ref current-reductions number)))
+ (if current-reduction
+ (begin
+ (set! current-expression (reduction-expression current-reduction))
+ (set! current-environment (reduction-environment current-reduction)))
+ (with-values (lambda () (stack-frame/debugging-info current-subproblem))
+ (lambda (expression environment)
+ (set! current-expression expression)
+ (set! current-environment environment)))))
+\f
+;;;; Utilities
(define (repeat f n)
(if (> n 0)
(count (1+ n) (CDR L))
n)))
+(define-integrable (reduction-expression reduction)
+ (car reduction))
+
+(define-integrable (reduction-environment reduction)
+ (cadr reduction))
+
(define (wrap-around-in-reductions? reductions)
(eq? (list-tail reductions (dotted-list-length reductions))
reduction-wrap-around-tag))
-\f
-;;; end DEBUG-PACKAGE.
-))
-
-;;; end IN-PACKAGE DEBUGGER-PACKAGE.
-)
-
-(define debug
- (access debug debug-package debugger-package))
-
-(define special-name?
- (let ((the-special-names
- (list lambda-tag:unnamed
- (access internal-lambda-tag lambda-package)
- (access internal-lexpr-tag lambda-package)
- lambda-tag:let
- lambda-tag:shallow-fluid-let
- lambda-tag:deep-fluid-let
- lambda-tag:common-lisp-fluid-let
- lambda-tag:make-environment)))
- (named-lambda (special-name? symbol)
- (memq symbol the-special-names))))
\ No newline at end of file
+
+(define (with-rep-alternative environment receiver)
+ (if (debugging-info/undefined-environment? environment)
+ (begin
+ (print-undefined-environment)
+ (newline)
+ (write-string "Using the read-eval-print environment instead!")
+ (receiver (standard-repl-environment)))
+ (receiver environment)))
+
+(define (if-valid-environment environment receiver)
+ (cond ((debugging-info/undefined-environment? environment)
+ (print-undefined-environment))
+ ((eq? environment system-global-environment)
+ (newline)
+ (write-string
+ "System global environment at this subproblem/reduction level"))
+ (else
+ (receiver environment))))
+
+(define (print-undefined-environment)
+ (newline)
+ (write-string "Undefined environment at this subproblem/reduction level"))
+
+(define (print-expression expression)
+ (cond ((debugging-info/undefined-expression? expression)
+ (newline)
+ (write-string "<undefined-expression>"))
+ ((debugging-info/compiled-code? expression)
+ (newline)
+ (write-string "<compiled-code>"))
+ (else
+ (pp expression))))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/defstr.scm,v 1.7 1987/12/11 16:13:21 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/defstr.scm,v 14.1 1988/06/13 11:43:43 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Structure Definition Macro
+;;; package: (runtime defstruct)
(declare (usual-integrations))
\f
same order as specified in the definition of the structure. A keyword
constructor may be specified by giving the option KEYWORD-CONSTRUCTOR.
+* BOA constructors are described using Scheme lambda lists. Since
+there is nothing corresponding to &aux in Scheme lambda lists, this
+functionality is not implemented.
+
* By default, no COPIER procedure is generated.
* The side effect procedure corresponding to the accessor "foo" is
* The option values FALSE, NIL, TRUE, and T are treated as if the
appropriate boolean constant had been specified instead.
-* After evaluating the structure definition, the name of the structure
-is bound to a Scheme type object. This works somewhat differently
-from a Common Lisp type.
-
* The PRINT-FUNCTION option is named PRINT-PROCEDURE. Its argument is
-a procedure of one argument (the structure instance) rather than three
-as in Common Lisp.
+a procedure of two arguments (the unparser state and the structure
+instance) rather than three as in Common Lisp.
-* By default, named structures are tagged with the Scheme type object.
-In Common Lisp, the structures are tagged with symbols, but that
-depends on the Common Lisp package system to help generate unique
+* By default, named structures are tagged with a unique object of some
+kind. In Common Lisp, the structures are tagged with symbols, but
+that depends on the Common Lisp package system to help generate unique
tags; Scheme has no such way of generating unique symbols.
* The NAMED option may optionally take an argument, which should be
the name of a variable. If used, structure instances will be tagged
-with that variable's value rather than the Scheme type object. The
-variable must be defined when the defstruct is evaluated.
+with that variable's value. If the structure has a PRINT-PROCEDURE
+(the default) the variable must be defined when the defstruct is
+evaluated.
* The TYPE option is restricted to the values VECTOR and LIST.
* The INCLUDE option is not implemented.
-* BOA constructors are described using Scheme lambda lists. Since
-there is nothing corresponding to &aux in Scheme lambda lists, this
-functionality is not implemented.
-
|#
\f
-(define defstruct-package
- (make-environment
+(define (initialize-package!)
+ (set! structure (make-named-tag "DEFSTRUCT-DESCRIPTION"))
+ (set! slot-assoc (association-procedure eq? slot/name))
+ (syntax-table-define system-global-syntax-table 'DEFINE-STRUCTURE
+ transform/define-structure))
-(syntax-table-define system-global-syntax-table 'DEFINE-STRUCTURE
+(define transform/define-structure
(macro (name-and-options . slot-descriptions)
(let ((structure (parse/name-and-options name-and-options)))
(structure/set-slots! structure
(boa-constructors '())
(copier-name false)
(predicate-name (symbol-append name '?))
- (print-procedure false)
+ (print-procedure print-procedure/default)
(type-seen? false)
(type 'STRUCTURE)
(named-seen? false)
- (type-tagged? true)
(tag-name name)
(offset 0)
(include false))
((INITIAL-OFFSET)
(check-arguments 1 1)
(set! offset (car arguments)))
+ #|
((INCLUDE)
(check-arguments 1 1)
(set! include arguments))
+ |#
(else
(error "Unrecognized structure option" keyword)))))
\f
(parse/option (car option) (cdr option))
(parse/option option '())))
options)
- (vector name
+ (vector structure
+ name
conc-name
keyword-constructor?
(and (or constructor-seen?
boa-constructors
copier-name
predicate-name
- (or print-procedure
- (and (eq? tag-name name)
- `(ACCESS DEFAULT-UNPARSER
- DEFSTRUCT-PACKAGE
- ,system-global-environment)))
+ (if (eq? print-procedure print-procedure/default)
+ `(,(absolute 'UNPARSER/STANDARD-METHOD) ',name)
+ print-procedure)
type
(cond ((eq? type 'STRUCTURE) 'VECTOR)
((eq? type 'VECTOR) 'VECTOR)
offset
include
'())))
+
+(define print-procedure/default
+ "default")
\f
;;;; Parse Slot-Descriptions
(structure/offset structure))))
(define (parse/slot-description structure slot-description index)
+ structure
(let ((kernel
(lambda (name default options)
(let ((type #T)
(loop (cdr slots) (1+ n)))))
`(BEGIN ,@(loop slots reserved)))))
- (define-structure-refs structure 0
+ (define-structure-refs structure 1
name
conc-name
keyword-constructor?
type
read-only?))
-(define slot-assoc
- (association-procedure eq? slot/name))
+(define structure)
+(define slot-assoc)
+
+(define (structure? object)
+ (and (vector? object)
+ (not (zero? (vector-length object)))
+ (eq? structure (vector-ref object 0))))
+\f
+(define (tag->structure tag)
+ (if (structure? tag)
+ tag
+ (let ((tag (2d-get tag structure)))
+ (and (structure? tag)
+ tag))))
+
+(define (named-structure? object)
+ (cond ((vector? object)
+ (and (not (zero? (vector-length object)))
+ (tag->structure (vector-ref object 0))))
+ ((pair? object)
+ (tag->structure (car object)))
+ (else false)))
+
+(define (named-structure/description instance)
+ (let ((structure
+ (tag->structure
+ (cond ((vector? instance) (vector-ref instance 0))
+ ((pair? instance) (car instance))
+ (else (error "Illegal structure instance" instance))))))
+ (if (not structure)
+ (error "Illegal structure instance" instance))
+ (let ((scheme-type (structure/scheme-type structure)))
+ (if (not (case scheme-type
+ ((VECTOR) (vector? instance))
+ ((LIST) (list? instance))
+ (else (error "Illegal structure type" scheme-type))))
+ (error "Malformed structure instance" instance))
+ (let ((accessor
+ (case scheme-type
+ ((VECTOR) vector-ref)
+ ((LIST) list-ref))))
+ (map (lambda (slot)
+ `(,(slot/name slot) ,(accessor instance (slot/index slot))))
+ (structure/slots structure))))))
\f
;;;; Code Generation
+(define (absolute name)
+ `(ACCESS ,name #F))
+
(define (accessor-definitions structure)
(mapcan (lambda (slot)
(let ((accessor-name
(DECLARE (INTEGRATE STRUCTURE))
,(case (structure/scheme-type structure)
((VECTOR)
- `((ACCESS VECTOR-REF ,system-global-environment)
- STRUCTURE
- ,(slot/index slot)))
+ `(,(absolute 'VECTOR-REF) STRUCTURE ,(slot/index slot)))
((LIST)
- `((ACCESS LIST-REF ,system-global-environment)
- STRUCTURE
- ,(slot/index slot)))
+ `(,(absolute 'LIST-REF) STRUCTURE ,(slot/index slot)))
(else
(error "Unknown scheme type" structure)))))))
(structure/slots structure)))
(DECLARE (INTEGRATE STRUCTURE VALUE))
,(case (structure/scheme-type structure)
((VECTOR)
- `((ACCESS VECTOR-SET! ,system-global-environment)
- STRUCTURE
- ,(slot/index slot)
- VALUE))
+ `(,(absolute 'VECTOR-SET!) STRUCTURE
+ ,(slot/index slot)
+ VALUE))
((LIST)
- `((ACCESS SET-CAR! ,system-global-environment)
- ((ACCESS LIST-TAIL ,system-global-environment)
- STRUCTURE
- ,(slot/index slot))
+ `(,(absolute 'SET-CAR!)
+ (,(absolute 'LIST-TAIL) STRUCTURE
+ ,(slot/index slot))
VALUE))
(else
(error "Unknown scheme type" structure))))))))
(let ((slot-names (map slot/name (structure/slots structure))))
`(DEFINE (,name ,@slot-names)
;; *** Kludge -- SCHEME-TYPE happens to be same as constructor.
- ((ACCESS ,(structure/scheme-type structure) ,system-global-environment)
+ (,(absolute (structure/scheme-type structure))
,@(constructor-prefix-slots structure)
,@slot-names))))
(let ((keyword-list (string->uninterned-symbol "keyword-list")))
`(DEFINE (,name . ,keyword-list)
,(let ((list-cons
- `((ACCESS CONS* ,system-global-environment)
+ `(,(absolute 'CONS*)
,@(constructor-prefix-slots structure)
- ((ACCESS KEYWORD-PARSER
- DEFSTRUCT-PACKAGE
- ,system-global-environment)
+ (,(absolute 'DEFINE-STRUCTURE/KEYWORD-PARSER)
,keyword-list
- ((ACCESS LIST ,system-global-environment)
+ (,(absolute 'LIST)
,@(map (lambda (slot)
- `((ACCESS CONS ,system-global-environment)
- ',(slot/name slot)
- ,(slot/default slot)))
+ `(,(absolute 'CONS) ',(slot/name slot)
+ ,(slot/default slot)))
(structure/slots structure)))))))
(case (structure/scheme-type structure)
((VECTOR)
- `((ACCESS LIST->VECTOR ,system-global-environment) ,list-cons))
+ `(,(absolute 'LIST->VECTOR) ,list-cons))
((LIST)
list-cons)
(else
(define (constructor-definition/boa structure name lambda-list)
`(DEFINE (,name . ,lambda-list)
;; *** Kludge -- SCHEME-TYPE happens to be same as constructor.
- ((ACCESS ,(structure/scheme-type structure) ,system-global-environment)
+ (,(absolute (structure/scheme-type structure))
,@(constructor-prefix-slots structure)
- ,@((access parse-lambda-list syntaxer-package)
- lambda-list
- (lambda (required optional rest)
- (let ((name->slot
- (lambda (name)
- (or (slot-assoc name (structure/slots structure))
- (error "Not a defined structure slot" name)))))
- (let ((required (map name->slot required))
- (optional (map name->slot optional))
- (rest (and rest (name->slot rest))))
- (map (lambda (slot)
- (cond ((or (memq slot required)
- (eq? slot rest))
- (slot/name slot))
- ((memq slot optional)
- `(IF (UNASSIGNED? ,(slot/name slot))
- ,(slot/default slot)
- ,(slot/name slot)))
- (else
- (slot/default slot))))
- (structure/slots structure)))))))))
+ ,@(parse-lambda-list lambda-list
+ (lambda (required optional rest)
+ (let ((name->slot
+ (lambda (name)
+ (or (slot-assoc name (structure/slots structure))
+ (error "Not a defined structure slot" name)))))
+ (let ((required (map name->slot required))
+ (optional (map name->slot optional))
+ (rest (and rest (name->slot rest))))
+ (map (lambda (slot)
+ (cond ((or (memq slot required)
+ (eq? slot rest))
+ (slot/name slot))
+ ((memq slot optional)
+ `(IF (DEFAULT-OBJECT? ,(slot/name slot))
+ ,(slot/default slot)
+ ,(slot/name slot)))
+ (else
+ (slot/default slot))))
+ (structure/slots structure)))))))))
(define (constructor-prefix-slots structure)
(let ((offsets (make-list (structure/offset structure) false)))
(cons (structure/tag-name structure) offsets)
offsets)))
\f
-(define (type-definitions structure)
- (if (structure/named? structure)
- `((DEFINE ,(structure/name structure)
- ((ACCESS MAKE-STRUCTURE-TYPE
- DEFSTRUCT-PACKAGE
- ,system-global-environment)
- ',structure
- ,(and (not (eq? (structure/tag-name structure)
- (structure/name structure)))
- (structure/tag-name structure)))))
- '()))
+(define (type-definitions *structure)
+ (cond ((not (structure/named? *structure))
+ '())
+ ((eq? (structure/tag-name *structure) (structure/name *structure))
+ `((DEFINE ,(structure/name *structure)
+ ',*structure)))
+ (else
+ `((2D-PUT! ,(structure/tag-name *structure)
+ ',structure
+ ',*structure)))))
(define (predicate-definitions structure)
(if (and (structure/predicate-name structure)
(structure/named? structure))
- `((DEFINE ,(structure/predicate-name structure)
- ((ACCESS TYPE-OBJECT-PREDICATE ,system-global-environment)
- ,(structure/name structure))))
+ (case (structure/scheme-type structure)
+ ((VECTOR)
+ `((DEFINE (,(structure/predicate-name structure) OBJECT)
+ (AND (,(absolute 'VECTOR?) OBJECT)
+ (,(absolute 'NOT)
+ (,(absolute 'ZERO?) (,(absolute 'VECTOR-LENGTH) OBJECT)))
+ (,(absolute 'EQ?) (,(absolute 'VECTOR-REF) OBJECT 0)
+ ,(structure/tag-name structure))))))
+ ((LIST)
+ `((DEFINE (,(structure/predicate-name structure) OBJECT)
+ (AND (,(absolute 'PAIR?) OBJECT)
+ (,(absolute 'EQ?) (,(absolute 'CAR) OBJECT)
+ ,(structure/tag-name structure))))))
+ (else
+ (error "Unknown scheme type" structure)))
'()))
-
+\f
(define (copier-definitions structure)
- (if (structure/copier-name structure)
- `((DEFINE ,(structure/copier-name structure)
+ (let ((copier-name (structure/copier-name structure)))
+ (if copier-name
+ `((DECLARE (INTEGRATE-OPERATOR ,copier-name))
,(case (structure/scheme-type structure)
- ((vector) `(ACCESS VECTOR-COPY ,system-global-environment))
- ((list) `(ACCESS LIST-COPY ,system-global-environment))
- (else (error "Unknown scheme type" structure)))))
- '()))
+ ((VECTOR)
+ `(DEFINE (,copier-name OBJECT)
+ (DECLARE (INTEGRATE OBJECT))
+ (,(absolute 'VECTOR-COPY) OBJECT)))
+ ((LIST)
+ `(DEFINE (,copier-name OBJECT)
+ (DECLARE (INTEGRATE OBJECT))
+ (,(absolute 'LIST-COPY) OBJECT)))
+ (else
+ (error "Unknown scheme type" structure))))
+ '())))
(define (print-procedure-definitions structure)
(if (and (structure/print-procedure structure)
(structure/named? structure))
- `(((ACCESS ,(case (structure/scheme-type structure)
- ((VECTOR) 'ADD-UNPARSER-SPECIAL-OBJECT!)
- ((LIST) 'ADD-UNPARSER-SPECIAL-PAIR!)
- (else (error "Unknown scheme type" structure)))
- UNPARSER-PACKAGE
- ,system-global-environment)
+ `((,(absolute (case (structure/scheme-type structure)
+ ((VECTOR) 'UNPARSER/SET-TAGGED-VECTOR-METHOD!)
+ ((LIST) 'UNPARSER/SET-TAGGED-PAIR-METHOD!)
+ (else (error "Unknown scheme type" structure))))
,(structure/tag-name structure)
,(structure/print-procedure structure)))
- '()))
-\f
-;;;; Runtime Support
-
-(define (keyword-parser argument-list default-alist)
- (if (null? argument-list)
- (map cdr default-alist)
- (let ((alist
- (map (lambda (entry) (cons (car entry) (cdr entry)))
- default-alist)))
- (define (loop arguments)
- (if (not (null? arguments))
- (begin
- (if (null? (cdr arguments))
- (error "Keyword list does not have even length"
- argument-list))
- (set-cdr! (or (assq (car arguments) alist)
- (error "Unknown keyword" (car arguments)))
- (cadr arguments))
- (loop (cddr arguments)))))
- (loop argument-list)
- (map cdr alist))))
-
-(define (default-unparser structure-instance)
- ((access unparse-with-brackets unparser-package)
- (lambda ()
- (write
- (structure/name
- (or (structure-instance->description structure-instance)
- (error "Not a named structure"))))
- (write-char #\Space)
- (write (hash structure-instance)))))
-\f
-(define (make-structure-type structure tag)
- (let ((type
- (case (structure/scheme-type structure)
- ((VECTOR)
- (make-sub-type
- (structure/name structure)
- (microcode-type-object 'VECTOR)
- (lambda (vector)
- (and (not (zero? (vector-length vector)))
- (eq? (vector-ref vector 0) tag)))))
- ((LIST)
- (make-sub-type
- (structure/name structure)
- (microcode-type-object 'PAIR)
- (lambda (pair)
- (eq? (car pair) tag))))
- (else
- (error "Unknown scheme type" structure)))))
- ;; Note side effects needed here, because of predicates
- ;; that are closed in this environment.
- (if (not tag) (set! tag type))
- (2d-put! tag tag->structure structure)
- (set! structure false)
- type))
-
-(define (structure-instance->description structure)
- (2d-get (cond ((and (vector? structure)
- (not (zero? (vector-length structure))))
- (vector-ref structure 0))
- ((pair? structure) (car structure))
- (else false))
- tag->structure))
-
-(define tag->structure
- "tag->structure")
-
-;;; end DEFSTRUCT-PACKAGE
-))
\ No newline at end of file
+ '()))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 13.50 1987/12/05 16:38:53 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.1 1988/06/13 11:43:56 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; GNU Emacs/Scheme Modeline Interface
+;;; package: (runtime emacs-interface)
(declare (usual-integrations))
\f
-(define emacs-interface-package
- (make-environment
+(define-primitives
+ tty-read-char-ready?
+ tty-read-char-immediate
+ (under-emacs? 0))
(define (transmit-signal type)
(write-char #\Altmode console-output-port)
(write-char type console-output-port))
(define (transmit-signal-without-gc type)
- (with-interrupts-reduced interrupt-mask-none
- (lambda (old-mask)
- (transmit-signal type))))
-
-(define (emacs-read-start)
- (transmit-signal-without-gc #\s))
-
-(define (emacs-read-finish)
- (transmit-signal-without-gc #\f))
-
-(define (emacs-start-gc)
- (transmit-signal #\b))
-
-(define (emacs-finish-gc state)
- (transmit-signal #\e))
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (transmit-signal type))))
(define (transmit-signal-with-argument type string)
- (with-interrupts-reduced interrupt-mask-none
- (lambda (old-mask)
- (transmit-signal type)
- (write-string string console-output-port)
- (write-char #\Altmode console-output-port))))
-
-(define (emacs-rep-message string)
- (transmit-signal-with-argument #\m string))
-
-(define (emacs-rep-value object)
- (transmit-signal-with-argument #\v (object->string object)))
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (transmit-signal type)
+ (write-string string console-output-port)
+ (write-char #\Altmode console-output-port))))
(define (object->string object)
(with-output-to-string
(lambda ()
(write object))))
+
+(define (emacs/read-start)
+ (transmit-signal-without-gc #\s))
+
+(define (emacs/read-finish)
+ (transmit-signal-without-gc #\f))
+
+(define (emacs/gc-start)
+ (transmit-signal #\b)
+ (normal/gc-start))
+
+(define (emacs/gc-finish start-value space-remaining)
+ (transmit-signal #\e)
+ (normal/gc-finish start-value space-remaining))
\f
-(define paranoid-error-hook?
- false)
+(define (emacs/repl-read repl)
+ (if (cmdl/io-to-console? repl)
+ (begin
+ (transmit-signal-without-gc #\R)
+ (let ((s-expression (read console-input-port)))
+ (repl-history/record! (repl/reader-history repl) s-expression)
+ s-expression))
+ (normal/repl-read repl)))
-(define (emacs-error-hook)
- (transmit-signal-without-gc #\z)
- (beep)
- (if paranoid-error-hook?
+(define (emacs/repl-write repl object)
+ (if (cmdl/io-to-console? repl)
(begin
- (transmit-signal-with-argument #\P
-"Error! Type ctl-E to enter error loop, anything else to return to top level.")
- (if (not (char-ci=? (emacs-read-char-immediate) #\C-E))
- (abort-to-previous-driver "Quit!")))))
+ (repl-history/record! (repl/printer-history repl) object)
+ (transmit-signal-with-argument #\v
+ (if (undefined-value? object)
+ ""
+ (object->string object))))
+ (normal/repl-write repl object)))
+
+(define (emacs/cmdl-message cmdl string)
+ (if (cmdl/io-to-console? cmdl)
+ (transmit-signal-with-argument #\m string)
+ (normal/cmdl-message cmdl string)))
-(define (emacs-rep-prompt level string)
+(define (emacs/cmdl-prompt cmdl prompt)
(transmit-signal-with-argument
#\p
- (string-append (object->string level)
+ (string-append (object->string (cmdl/level cmdl))
" "
- (let ((entry (assoc string emacs-rep-prompt-alist)))
+ (let ((entry (assoc prompt cmdl-prompt-alist)))
(if entry
(cdr entry)
- string)))))
+ prompt)))))
-(define emacs-rep-prompt-alist
+(define cmdl-prompt-alist
'(("]=>" . "[Normal REPL]")
("==>" . "[Normal REPL]")
("Eval-in-env-->" . "[Normal REPL]")
("Bkpt->" . "[Breakpoint REPL]")
("Error->" . "[Error REPL]")
- ("Debug-->" . "[Debugger]")
("Debugger-->" . "[Debugger REPL]")
("Visiting->" . "[Visiting environment]")
+ ("Debug-->" . "[Debugger]")
("Where-->" . "[Environment Inspector]")
("Which-->" . "[Task Inspector]")))
-
-(define (emacs-read-char-immediate)
- (define (loop)
- (let ((char (primitive-read-char-immediate)))
- (if (char=? char char:newline)
- (loop)
- (begin (emacs-read-finish)
- char))))
- (emacs-read-start)
- (if (not (primitive-read-char-ready? 0))
- (transmit-signal-without-gc #\c))
- (loop))
-
-(define primitive-read-char-ready?
- (make-primitive-procedure 'TTY-READ-CHAR-READY?))
-
-(define primitive-read-char-immediate
- (make-primitive-procedure 'TTY-READ-CHAR-IMMEDIATE))
\f
-(define (emacs/prompt-for-command-char prompt)
- (emacs-rep-prompt (rep-level) prompt)
- (transmit-signal-with-argument
- #\D
- (cond ((string=? "Debug-->" prompt) "Scheme-debug")
- ((string=? "Where-->" prompt) "Scheme-where")
- (else "Scheme")))
- (transmit-signal-without-gc #\o)
- (emacs/read-char-internal))
-
-(define (emacs/prompt-for-confirmation prompt)
- (transmit-signal-with-argument #\n prompt)
- (emacs/read-char-internal))
-
-(define (emacs/read-char-internal)
- (emacs-read-start)
- (let ((char (primitive-read-char-immediate)))
- (emacs-read-finish)
+(define (emacs/error-decision)
+ (transmit-signal-without-gc #\z)
+ (beep console-output-port)
+ (if paranoid-error-decision?
+ (begin
+ (transmit-signal-with-argument #\P
+"Error! Type ctl-E to enter error loop, anything else to return to top level.")
+ (if (not (char-ci=? (emacs/read-char-immediate) #\C-E))
+ (abort-to-previous-driver "Quit!")))))
+
+(define paranoid-error-decision?
+ false)
+
+(define (emacs/^G-interrupt interrupt-enables)
+ (transmit-signal #\g)
+ (normal/^G-interrupt interrupt-enables))
+
+(define (emacs/read-char-immediate)
+ (emacs/read-start)
+ (let ((char (tty-read-char-immediate)))
+ (emacs/read-finish)
char))
-(define (emacs/prompt-for-expression prompt)
- (transmit-signal-with-argument #\i prompt)
- (read))
+(define (emacs/read-command-char cmdl prompt)
+ (if (cmdl/io-to-console? cmdl)
+ (begin
+ (transmit-signal-with-argument
+ #\D
+ (cond ((string=? "Debug-->" prompt) "Scheme-debug")
+ ((string=? "Where-->" prompt) "Scheme-where")
+ ((string=? "Which-->" prompt) "Scheme-which")
+ (else "Scheme")))
+ (transmit-signal-without-gc #\o)
+ (read-char-internal))
+ (normal/read-command-char cmdl prompt)))
-(define (emacs/rep-read-hook)
- (transmit-signal-without-gc #\R)
- (read))
-\f
-(define normal-start-gc (access gc-start-hook gc-statistics-package))
-(define normal-finish-gc (access gc-finish-hook gc-statistics-package))
-(define normal-rep-message rep-message-hook)
-(define normal-rep-prompt rep-prompt-hook)
-(define normal-rep-value rep-value-hook)
-(define normal-read-start (access read-start-hook console-input-port))
-(define normal-read-finish (access read-finish-hook console-input-port))
-(define normal-read-char-immediate
- (access tty-read-char-immediate console-input-port))
-(define normal-error-hook (access *error-decision-hook* error-system))
-(define normal/rep-read-hook rep-read-hook)
-(define normal/prompt-for-command-char
- (access prompt-for-command-char debugger-package))
-(define normal/prompt-for-confirmation
- (access prompt-for-confirmation debugger-package))
-(define normal/prompt-for-expression
- (access prompt-for-expression debugger-package))
+(define (emacs/prompt-for-confirmation cmdl prompt)
+ (if (cmdl/io-to-console? cmdl)
+ (begin
+ (transmit-signal-with-argument #\n prompt)
+ (char=? #\y (read-char-internal)))
+ (normal/prompt-for-confirmation cmdl prompt)))
-(define (install-emacs-hooks!)
- (set! (access gc-start-hook gc-statistics-package) emacs-start-gc)
- (set! (access gc-finish-hook gc-statistics-package) emacs-finish-gc)
- (set! rep-message-hook emacs-rep-message)
- (set! rep-prompt-hook emacs-rep-prompt)
- (set! rep-value-hook emacs-rep-value)
- (set! (access read-start-hook console-input-port) emacs-read-start)
- (set! (access read-finish-hook console-input-port) emacs-read-finish)
- (set! (access tty-read-char-immediate console-input-port)
- emacs-read-char-immediate)
- (set! (access *error-decision-hook* error-system) emacs-error-hook)
- (set! rep-read-hook emacs/rep-read-hook)
- (set! (access prompt-for-command-char debugger-package)
- emacs/prompt-for-command-char)
- (set! (access prompt-for-confirmation debugger-package)
- emacs/prompt-for-confirmation)
- (set! (access prompt-for-expression debugger-package)
- emacs/prompt-for-expression))
+(define (emacs/prompt-for-expression cmdl prompt)
+ (if (cmdl/io-to-console? cmdl)
+ (begin
+ (transmit-signal-with-argument #\i prompt)
+ (read console-input-port))
+ (normal/prompt-for-expression cmdl prompt)))
-(define (install-normal-hooks!)
- (set! (access gc-start-hook gc-statistics-package) normal-start-gc)
- (set! (access gc-finish-hook gc-statistics-package) normal-finish-gc)
- (set! rep-message-hook normal-rep-message)
- (set! rep-prompt-hook normal-rep-prompt)
- (set! rep-value-hook normal-rep-value)
- (set! (access read-start-hook console-input-port) normal-read-start)
- (set! (access read-finish-hook console-input-port) normal-read-finish)
- (set! (access tty-read-char-immediate console-input-port)
- normal-read-char-immediate)
- (set! (access *error-decision-hook* error-system) normal-error-hook)
- (set! rep-read-hook normal/rep-read-hook)
- (set! (access prompt-for-command-char debugger-package)
- normal/prompt-for-command-char)
- (set! (access prompt-for-confirmation debugger-package)
- normal/prompt-for-confirmation)
- (set! (access prompt-for-expression debugger-package)
- normal/prompt-for-expression))
-
-(define under-emacs?
- (make-primitive-procedure 'UNDER-EMACS? 0))
+(define (read-char-internal)
+ (let ((char (emacs/read-char-immediate)))
+ (if (char=? char char:newline)
+ (read-char-internal)
+ char)))
+(define (cmdl/io-to-console? cmdl)
+ (and (eq? console-input-port (cmdl/input-port cmdl))
+ (eq? console-output-port (cmdl/output-port cmdl))))
+
+(define (emacs/set-working-directory-pathname! pathname)
+ (transmit-signal-with-argument #\w (pathname->string pathname)))
+\f
+(define normal/gc-start)
+(define normal/gc-finish)
+(define normal/cmdl-message)
+(define normal/cmdl-prompt)
+(define normal/repl-write)
+(define normal/repl-read)
+(define normal/read-char-immediate)
+(define normal/read-start)
+(define normal/read-finish)
+(define normal/error-decision)
+(define normal/read-command-char)
+(define normal/prompt-for-confirmation)
+(define normal/prompt-for-expression)
+(define normal/^G-interrupt)
+(define normal/set-working-directory-pathname!)
+
+(define (initialize-package!)
+ (set! normal/gc-start hook/gc-start)
+ (set! normal/gc-finish hook/gc-finish)
+ (set! normal/cmdl-message hook/cmdl-message)
+ (set! normal/cmdl-prompt hook/cmdl-prompt)
+ (set! normal/repl-write hook/repl-write)
+ (set! normal/repl-read hook/repl-read)
+ (set! normal/read-char-immediate hook/read-char-immediate)
+ (set! normal/read-start hook/read-start)
+ (set! normal/read-finish hook/read-finish)
+ (set! normal/error-decision hook/error-decision)
+ (set! normal/read-command-char hook/read-command-char)
+ (set! normal/prompt-for-confirmation hook/prompt-for-confirmation)
+ (set! normal/prompt-for-expression hook/prompt-for-expression)
+ (set! normal/^G-interrupt hook/^G-interrupt)
+ (set! normal/set-working-directory-pathname!
+ hook/set-working-directory-pathname!)
+ (add-event-receiver! event:after-restore install!)
+ (install!))
+\f
(define (install!)
((if (under-emacs?)
install-emacs-hooks!
install-normal-hooks!)))
-(add-event-receiver! event:after-restore install!)
-(install!)
+(define (install-emacs-hooks!)
+ (set! hook/gc-start emacs/gc-start)
+ (set! hook/gc-finish emacs/gc-finish)
+ (set! hook/cmdl-message emacs/cmdl-message)
+ (set! hook/cmdl-prompt emacs/cmdl-prompt)
+ (set! hook/repl-write emacs/repl-write)
+ (set! hook/repl-read emacs/repl-read)
+ (set! hook/read-char-immediate emacs/read-char-immediate)
+ (set! hook/read-start emacs/read-start)
+ (set! hook/read-finish emacs/read-finish)
+ (set! hook/error-decision emacs/error-decision)
+ (set! hook/read-command-char emacs/read-command-char)
+ (set! hook/prompt-for-confirmation emacs/prompt-for-confirmation)
+ (set! hook/prompt-for-expression emacs/prompt-for-expression)
+ (set! hook/^G-interrupt emacs/^G-interrupt)
+ (set! hook/set-working-directory-pathname!
+ emacs/set-working-directory-pathname!))
-;;; end EMACS-INTERFACE-PACKAGE
-))
\ No newline at end of file
+(define (install-normal-hooks!)
+ (set! hook/gc-start normal/gc-start)
+ (set! hook/gc-finish normal/gc-finish)
+ (set! hook/cmdl-message normal/cmdl-message)
+ (set! hook/cmdl-prompt normal/cmdl-prompt)
+ (set! hook/repl-write normal/repl-write)
+ (set! hook/repl-read normal/repl-read)
+ (set! hook/read-char-immediate normal/read-char-immediate)
+ (set! hook/read-start normal/read-start)
+ (set! hook/read-finish normal/read-finish)
+ (set! hook/error-decision normal/error-decision)
+ (set! hook/read-command-char normal/read-command-char)
+ (set! hook/prompt-for-confirmation normal/prompt-for-confirmation)
+ (set! hook/prompt-for-expression normal/prompt-for-expression)
+ (set! hook/^G-interrupt normal/^G-interrupt)
+ (set! hook/set-working-directory-pathname!
+ normal/set-working-directory-pathname!))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $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
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/equals.scm,v 14.1 1988/06/13 11:44:04 cph Rel $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Equality
+;;; package: ()
(declare (usual-integrations))
\f
-(let-syntax ((type?
- ;; Use PRIMITIVE-TYPE? for everything because the
- ;; compiler can optimize it well.
- (macro (name object)
- `(PRIMITIVE-TYPE? ,(microcode-type name) ,object))))
-
(define (eqv? x y)
;; EQV? is officially supposed to work on booleans, characters, and
;; numbers specially, but it turns out that EQ? does the right thing
;; for everything but numbers, so we take advantage of that.
(if (eq? x y)
true
- (and (primitive-type? (primitive-type x) y)
- (or (and (or (type? big-fixnum y)
- (type? big-flonum y))
+ (and (object-type? (object-type x) y)
+ (or (and (or (object-type? (ucode-type big-fixnum) y)
+ (object-type? (ucode-type big-flonum) y))
(= x y))
- (and (type? vector y)
+ (and (object-type? (ucode-type vector) y)
(zero? (vector-length x))
(zero? (vector-length y)))))))
(define (equal? x y)
(if (eq? x y)
true
- (and (primitive-type? (primitive-type x) y)
- (cond ((or (type? big-fixnum y)
- (type? big-flonum y))
+ (and (object-type? (object-type x) y)
+ (cond ((or (object-type? (ucode-type big-fixnum) y)
+ (object-type? (ucode-type big-flonum) y))
(= x y))
- ((type? list y)
+ ((object-type? (ucode-type list) y)
(and (equal? (car x) (car y))
(equal? (cdr x) (cdr y))))
- ((type? vector y)
+ ((object-type? (ucode-type vector) y)
(let ((size (vector-length x)))
(define (loop index)
(if (= index size)
(vector-ref y index))
(loop (1+ index)))))
(and (= size (vector-length y))
- (loop 0))))
- ((type? cell y)
+ (loop 0)))) ((object-type? (ucode-type cell) y)
(equal? (cell-contents x) (cell-contents y)))
- ((type? character-string y)
+ ((object-type? (ucode-type character-string) y)
(string=? x y))
- ((type? vector-1b y)
+ ((object-type? (ucode-type vector-1b) y)
(bit-string=? x y))
- (else false)))))
-
-)
+ (else false)))))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 13.51 1988/05/03 19:04:42 jinx Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
-;;;; Error System
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.1 1988/06/13 11:44:09 cph Exp $
-(declare (usual-integrations)
- (integrate-primitive-procedures set-fixed-objects-vector!))
-\f
-(define error-procedure
- (make-primitive-procedure 'ERROR-PROCEDURE 3))
+Copyright (c) 1988 Massachusetts Institute of Technology
-(define (error-from-compiled-code message . irritant-info)
- (error-procedure message
- (cond ((null? irritant-info) *the-non-printing-object*)
- ((null? (cdr irritant-info)) (car irritant-info))
- (else irritant-info))
- (rep-environment)))
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
-(define (error-message)
- (access error-message error-system))
+1. Any copy made of this software must include this copyright notice
+in full.
-(define (error-irritant)
- (access error-irritant error-system))
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
-(define error-prompt
- "Error->")
+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.
-(define error-system
- (make-environment
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
-(define *error-code*)
-(define *error-hook*)
-(define *error-decision-hook* false)
+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 without prior written consent from
+MIT in each case. |#
-(define error-message
- "")
+;;;; Error System
+;;; package: (runtime error-handler)
-(define error-irritant
- *the-non-printing-object*)
+(declare (usual-integrations))
\f
-;;;; REP Interface
-
-(define (error-procedure-handler message irritant environment)
- (with-proceed-point
- proceed-value-filter
- (lambda ()
- (fluid-let ((error-message message)
- (error-irritant irritant))
- (*error-hook* environment message irritant false)))))
-
-(define ((error-handler-wrapper handler) error-code interrupt-enables)
- (with-interrupts-reduced interrupt-mask-gc-ok
- (lambda (old-mask)
- (fluid-let ((*error-code* error-code))
- (with-proceed-point
- proceed-value-filter
- (lambda ()
- (set-interrupt-enables! interrupt-enables)
- (handler error-code
- (continuation-expression (rep-continuation)))))))))
-
-(define (wrapped-error-handler wrapper)
- (access handler (procedure-environment wrapper)))
+(define (initialize-package!)
+ (set! next-condition-type-index 0)
+ (set! handler-frames false)
+ (set! condition-type:error
+ (let ((dependencies (list false)))
+ (let ((result (%make-condition-type dependencies true false)))
+ (set-car! dependencies result)
+ result)))
+ (set! error-type:vanilla
+ (make-condition-type (list condition-type:error) "Anonymous error"))
+ (set! hook/error-handler default/error-handler)
+ (set! hook/error-decision default/error-decision)
+ (let ((fixed-objects (get-fixed-objects-vector)))
+ (vector-set! fixed-objects
+ (fixed-objects-vector-slot 'ERROR-PROCEDURE)
+ error-procedure-handler)
+ (vector-set! fixed-objects
+ (fixed-objects-vector-slot 'COMPILER-ERROR-PROCEDURE)
+ error-from-compiled-code)
+ ((ucode-primitive set-fixed-objects-vector!) fixed-objects)))
+
+(define (error-procedure-handler message irritants environment)
+ (with-proceed-point proceed-value-filter
+ (lambda ()
+ (simple-error
+ environment
+ message
+ ;; Kludge to support minimal upwards compatibility with `error'
+ ;; forms syntaxed by older syntaxer. Should be flushed after
+ ;; new runtime system has been in use for a while.
+ (cond ((eq? irritants *the-non-printing-object*) '())
+ ((or (null? irritants) (pair? irritants)) irritants)
+ (else (list irritants)))))))
+
+(define (error-from-compiled-code message . irritants)
+ (with-proceed-point proceed-value-filter
+ (lambda ()
+ (simple-error repl-environment message irritants))))
;;; (PROCEED) means retry error expression, (PROCEED value) means
;;; return VALUE as the value of the error subproblem.
-(define (proceed-value-filter value)
- (let ((continuation (rep-continuation)))
- (if (or (null? value) (null-continuation? continuation))
- (continuation '())
- ((continuation-next-continuation continuation) (car value)))))
-\f
-(define (start-error-rep message irritant)
- (fluid-let ((error-message message)
- (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)))))
-
-(define (standard-error-hook environment message irritant
- substitute-environment?)
- (push-rep environment
- (let ((message (make-error-message message irritant)))
- (if substitute-environment?
- (lambda ()
- (message)
- (write-string "
-There is no environment available;
-using the current read-eval-print environment."))
- message))
- (standard-rep-prompt error-prompt)))
-
-(define ((make-error-message message irritant))
- (newline)
- (write-string message)
- (if (not (eq? irritant *the-non-printing-object*))
- (let ((out (write-to-string irritant 40)))
- (write-char #\Space)
- (write-string (cdr out))
- (if (car out) (write-string "..."))))
- (if *error-decision-hook* (*error-decision-hook*)))
-\f
-;;;; Error Handlers
-
-;;; All error handlers have the following form:
-
-(define ((make-error-handler direction-alist operator-alist
- default-handler default-combination-handler)
- error-code expression)
- ((let direction-loop ((alist direction-alist))
- (cond ((null? alist)
- (cond ((combination? expression)
- (let ((operator (combination-operator* expression)))
- (let operator-loop ((alist operator-alist))
- (cond ((null? alist) default-combination-handler)
- ((memq operator (caar alist)) (cdar alist))
- (else (operator-loop (cdr alist)))))))
- (else default-handler)))
- (((caar alist) expression) (cdar alist))
- (else (direction-loop (cdr alist)))))
- expression))
-
-;;; Then there are several methods for modifying the behavior of a
-;;; given error handler.
-
-(define expression-specific-adder)
-(define operation-specific-adder)
-
-(let ()
- (define (((alist-adder name) error-handler) filter receiver)
- (let ((environment
- (procedure-environment (wrapped-error-handler error-handler))))
- (lexical-assignment environment
- name
- (cons (cons filter receiver)
- (lexical-reference environment name)))))
-
- (set! expression-specific-adder
- (alist-adder 'DIRECTION-ALIST))
- (set! operation-specific-adder
- (alist-adder 'OPERATOR-ALIST)))
-
-(define default-expression-setter)
-(define default-combination-setter)
-
-(let ()
- (define (((set-default name) error-handler) receiver)
- (lexical-assignment
- (procedure-environment (wrapped-error-handler error-handler))
- name
- receiver))
-
- (set! default-expression-setter
- (set-default 'DEFAULT-HANDLER))
- (set! default-combination-setter
- (set-default 'DEFAULT-COMBINATION-HANDLER)))
-\f
-;;;; Error Vector
-
-;;; Initialize the error vector to the default state:
-
-(define (error-code-or-name code)
- (let ((v (vector-ref (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'MICROCODE-ERRORS-VECTOR))))
- (if (or (>= code (vector-length v))
- (null? (vector-ref v code)))
- code
- (vector-ref v code))))
-
-(define (default-error-handler expression)
- (start-error-rep "Anomalous error -- get a wizard"
- (error-code-or-name *error-code*)))
-
-(define system-error-vector
- (make-initialized-vector number-of-microcode-errors
- (lambda (error-code)
- (error-handler-wrapper
- (make-error-handler '()
- '()
- default-error-handler
- default-error-handler)))))
-
-;;; Use this procedure to displace the default handler completely.
-
-(define (define-total-error-handler error-name handler)
- (vector-set! system-error-vector
- (microcode-error error-name)
- (error-handler-wrapper handler)))
-
-;;; It will be installed later.
-
-(define (install)
- (set! *error-hook* standard-error-hook)
- (vector-set! (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'SYSTEM-ERROR-VECTOR)
- system-error-vector)
- (vector-set! (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'ERROR-PROCEDURE)
- error-procedure-handler)
- (vector-set! (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'COMPILER-ERROR-PROCEDURE)
- error-from-compiled-code)
- (set-fixed-objects-vector! (get-fixed-objects-vector)))
-\f
-;;;; Error Definers
-
-(define ((define-definer type definer) error-name . args)
- (apply definer
- (type (vector-ref system-error-vector (microcode-error error-name)))
- args))
-
-(define ((define-specific-error error-name message) filter selector)
- ((cond ((pair? filter) define-operation-specific-error)
- (else define-expression-specific-error))
- error-name filter message selector))
-
-(define define-expression-specific-error
- (define-definer expression-specific-adder
- (lambda (adder filter message selector)
- (adder filter (expression-error-rep message selector)))))
-
-(define define-operation-specific-error
- (define-definer operation-specific-adder
- (lambda (adder filter message selector)
- (adder filter (combination-error-rep message selector)))))
-
-(define define-operand-error
- (define-definer default-combination-setter
- (lambda (setter message selector)
- (setter (combination-error-rep message selector)))))
-
-(define define-operator-error
- (define-definer default-combination-setter
- (lambda (setter message)
- (setter (expression-error-rep message combination-operator*)))))
-
-(define define-combination-error
- (define-definer default-combination-setter
- (lambda (setter message selector)
- (setter (expression-error-rep message selector)))))
-
-(define define-default-error
- (define-definer default-expression-setter
- (lambda (setter message selector)
- (setter (expression-error-rep message selector)))))
-
-(define ((expression-error-rep message selector) expression)
- (start-error-rep message (selector expression)))
-
-(define ((combination-error-rep message selector) combination)
- (start-error-rep
- (string-append message " "
- (let ((out (write-to-string (selector combination) 40)))
- (if (car out)
- (string-append (cdr out) "...")
- (cdr out)))
- "\nwithin procedure")
- (combination-operator* combination)))
+(define (proceed-value-filter continuation values)
+ (let ((next-subproblem
+ (and (not (null? values))
+ (continuation/first-subproblem continuation))))
+ (if next-subproblem
+ ((stack-frame->continuation next-subproblem) (car values))
+ (continuation *the-non-printing-object*))))
\f
-;;;; Combination Operations
-
-;;; Combinations coming out of the continuation parser are either all
-;;; unevaluated, or all evaluated, or all operands evaluated and the
-;;; operator undefined. Thus we must be careful about unwrapping
-;;; the components when necessary. In practice, it turns out that
-;;; all but one of the interesting errors happen at the application
-;;; point, at which all of the combination's components are evaluated.
-
-(define (combination-operator* combination)
- (unwrap-evaluated-object (combination-operator combination)))
-
-(define ((combination-operand selector) combination)
- (unwrap-evaluated-object (selector (combination-operands combination))))
-
-(define combination-first-operand (combination-operand first))
-(define combination-second-operand (combination-operand second))
-(define combination-third-operand (combination-operand third))
-
-(define (combination-operands* combination)
- (map unwrap-evaluated-object (combination-operands combination)))
-
-(define (unwrap-evaluated-object object)
- (if (continuation-evaluated-object? object)
- (continuation-evaluated-object-value object)
- (error "Not evaluated -- get a wizard" unwrap-evaluated-object object)))
-
-(define (combination-operator? expression)
- (and (combination? expression)
- (variable? (combination-operator expression))))
-
-(define (combination-operator-name combination)
- (variable-name (combination-operator combination)))
+(define (simple-error environment message irritants)
+ (signal-error
+ (if (condition-type? message)
+ (make-error-condition message irritants environment)
+ ;; This handles old and "vanilla" errors.
+ (let ((condition
+ (make-error-condition error-type:vanilla
+ irritants
+ environment)))
+ (1d-table/put! (condition/properties condition) message-tag message)
+ condition))))
+
+(define (make-error-condition condition-type irritants environment)
+ ;; Microcode errors also use this.
+ (let ((condition
+ (make-condition condition-type
+ irritants
+ (current-proceed-continuation))))
+ (1d-table/put! (condition/properties condition)
+ environment-tag
+ (if (eq? environment repl-environment)
+ (cons (standard-repl-environment) true)
+ (cons environment false)))
+ condition))
+
+(define message-tag
+ "message-tag")
+
+(define environment-tag
+ "environment-tag")
+
+(define repl-environment
+ "repl-environment")
+
+(define error-type:vanilla)
+
+(define (condition/message condition)
+ (let ((condition-type (condition/type condition)))
+ (or (and (eq? condition-type error-type:vanilla)
+ (1d-table/get (condition/properties condition) message-tag false))
+ (condition-type/message condition-type))))
+
+(define-integrable (condition/environment condition)
+ (car (1d-table/get (condition/properties condition) environment-tag false)))
+
+(define-integrable (condition/substitute-environment? condition)
+ (cdr (1d-table/get (condition/properties condition) environment-tag false)))
\f
-;;;; Environment Operation Errors
-
-(define define-unbound-variable-error
- (define-specific-error 'UNBOUND-VARIABLE
- "Unbound Variable"))
-
-(define-unbound-variable-error variable? variable-name)
-(define-unbound-variable-error access? access-name)
-(define-unbound-variable-error assignment? assignment-name)
-(define-unbound-variable-error combination-operator? combination-operator-name)
-(define-unbound-variable-error
- (list (make-primitive-procedure 'LEXICAL-REFERENCE 2)
- (make-primitive-procedure 'LEXICAL-ASSIGNMENT 3))
- combination-second-operand)
-
-(define-unbound-variable-error
- (list (make-primitive-procedure 'ENVIRONMENT-LINK-NAME 3))
- combination-third-operand)
-
-(define-unbound-variable-error
- (list (make-primitive-procedure 'ADD-FLUID-BINDING! 3))
- (lambda (obj)
- (let ((object (combination-second-operand obj)))
- (cond ((variable? object) (variable-name object))
- ((symbol? object) object)
- (else (error "Handler has bad object -- GET-A-WIZARD" object))))))
-
-(define define-unassigned-variable-error
- (define-specific-error 'UNASSIGNED-VARIABLE
- "Unassigned Variable"))
-
-(define-unassigned-variable-error variable? variable-name)
-(define-unassigned-variable-error access? access-name)
-(define-unassigned-variable-error combination-operator?
- combination-operator-name)
-(define-unassigned-variable-error
- (list (make-primitive-procedure 'LEXICAL-REFERENCE 2))
- combination-second-operand)
-
-(define define-bad-frame-error
- (define-specific-error 'BAD-FRAME
- "Illegal Environment Frame"))
-
-(define-bad-frame-error access? access-environment)
-(define-bad-frame-error in-package? in-package-environment)
+;;;; Standard Error Handler
+
+(define (standard-error-handler condition)
+ (fluid-let ((*error-condition* condition))
+ (hook/error-handler condition)))
+
+(define hook/error-handler)
+(define (default/error-handler condition)
+ (push-repl (condition/environment condition)
+ (let ((message
+ (cmdl-message/append
+ (apply cmdl-message/error
+ (condition/message condition)
+ (condition/irritants condition))
+ (cmdl-message/active hook/error-decision))))
+ (if (condition/substitute-environment? condition)
+ (cmdl-message/append
+ message
+ (cmdl-message/strings
+ ""
+ "There is no environment available;"
+ "using the current REPL environment"))
+ message))
+ "Error->"))
+
+(define hook/error-decision)
+(define (default/error-decision)
+ false)
+
+(define *error-condition* false)
+
+(define-integrable (error-condition)
+ *error-condition*)
+
+(define (error-continuation)
+ (let ((condition (error-condition)))
+ (and condition
+ (condition/continuation condition))))
+
+(define-integrable (error-message)
+ (condition/message (error-condition)))
+
+(define-integrable (error-irritants)
+ (condition/irritants (error-condition)))
\f
-;;;; Application Errors
-
-(define-operator-error 'UNDEFINED-PROCEDURE
- "Application of Non-Procedure Object")
-
-(define-operator-error 'UNDEFINED-PRIMITIVE-OPERATION
- "Undefined Primitive Procedure")
-
-(define-operator-error 'UNIMPLEMENTED-PRIMITIVE
- "Unimplemented Primitive Procedure")
-
-(define-operand-error 'WRONG-NUMBER-OF-ARGUMENTS
- "Wrong Number of Arguments"
- (lambda (combination)
- (length (combination-operands* combination))))
-
-(let ((make
- (lambda (wta-error-code bra-error-code position-string
- position-selector)
- (let ((ap-string (string-append position-string " argument position"))
- (selector (combination-operand position-selector)))
- (define-operand-error wta-error-code
- (string-append "Illegal datum in " ap-string)
- selector)
- (define-operand-error bra-error-code
- (string-append "Datum out of range in " ap-string)
- selector)))))
- (make 'WRONG-TYPE-ARGUMENT-0 'BAD-RANGE-ARGUMENT-0 "first" first)
- (make 'WRONG-TYPE-ARGUMENT-1 'BAD-RANGE-ARGUMENT-1 "second" second)
- (make 'WRONG-TYPE-ARGUMENT-2 'BAD-RANGE-ARGUMENT-2 "third" third)
- (make 'WRONG-TYPE-ARGUMENT-3 'BAD-RANGE-ARGUMENT-3 "fourth" fourth)
- (make 'WRONG-TYPE-ARGUMENT-4 'BAD-RANGE-ARGUMENT-4 "fifth" fifth)
- (make 'WRONG-TYPE-ARGUMENT-5 'BAD-RANGE-ARGUMENT-5 "sixth" sixth)
- (make 'WRONG-TYPE-ARGUMENT-6 'BAD-RANGE-ARGUMENT-6 "seventh" seventh)
- (make 'WRONG-TYPE-ARGUMENT-7 'BAD-RANGE-ARGUMENT-7 "eighth" eighth)
- (make 'WRONG-TYPE-ARGUMENT-8 'BAD-RANGE-ARGUMENT-8
- "ninth" (lambda (list) (general-car-cdr list #x1400)))
- (make 'WRONG-TYPE-ARGUMENT-9 'BAD-RANGE-ARGUMENT-9
- "tenth" (lambda (list) (general-car-cdr list #x3000))))
-
-(define-operand-error 'FAILED-ARG-1-COERCION
- "Argument 1 cannot be coerced to floating point"
- combination-first-operand)
-
-(define-operand-error 'FAILED-ARG-2-COERCION
- "Argument 2 cannot be coerced to floating point"
- combination-second-operand)
+;;;; Error Messages
+
+(define (warn string . irritants)
+ (with-output-to-port (cmdl/output-port (nearest-cmdl))
+ (lambda ()
+ (newline)
+ (write-string "Warning: ")
+ (format-error-message string irritants))))
+
+(define-integrable (error-irritants/sans-noise)
+ (list-transform-negative (error-irritants)
+ error-irritant/noise?))
+
+(define (error-irritant)
+ (let ((irritants (error-irritants/sans-noise)))
+ (cond ((null? irritants) *the-non-printing-object*)
+ ((null? (cdr irritants)) (car irritants))
+ (else irritants))))
+
+(define (cmdl-message/error string . irritants)
+ (cmdl-message/strings
+ (if (null? irritants)
+ string
+ (with-output-to-string
+ (lambda ()
+ (format-error-message string irritants))))))
+
+(define (format-error-message message irritants)
+ (fluid-let ((*unparser-list-depth-limit* 2)
+ (*unparser-list-breadth-limit* 5))
+ (for-each (lambda (irritant)
+ (if (error-irritant/noise? irritant)
+ (display (error-irritant/noise-value irritant))
+ (begin
+ (write-char #\Space)
+ (write irritant))))
+ (cons (if (string? message)
+ (error-irritant/noise message)
+ message)
+ irritants))))
+
+(define-integrable (error-irritant/noise noise)
+ (cons error-irritant/noise-tag noise))
+
+(define (error-irritant/noise? irritant)
+ (and (pair? irritant)
+ (eq? (car irritant) error-irritant/noise-tag)))
+
+(define-integrable (error-irritant/noise-value irritant)
+ (cdr irritant))
+
+(define error-irritant/noise-tag
+ "error-irritant/noise")
\f
-;;;; Primitive Operator Errors
-
-(let ((fasload (make-primitive-procedure 'BINARY-FASLOAD 1))
- (fasdump (make-primitive-procedure 'PRIMITIVE-FASDUMP 3))
- (load-band (make-primitive-procedure 'LOAD-BAND 1)))
-
- (define-operation-specific-error 'FASL-FILE-TOO-BIG
- (list fasload load-band)
- "FASLOAD: Not enough room"
- combination-first-operand)
-
- (define-operation-specific-error 'FASL-FILE-BAD-DATA
- (list fasload load-band)
- "FASLOAD: Bad binary file"
- combination-first-operand)
-
- ;; This one will never be reported by load-band.
- ;; It is too late to run the old image.
- (define-operation-specific-error 'WRONG-ARITY-PRIMITIVES
- (list fasload load-band)
- "FASLOAD: Primitives in binary file have the wrong arity"
- combination-first-operand)
-
- (define-operation-specific-error 'IO-ERROR
- (list fasload load-band)
- "FASLOAD: I/O error"
- combination-first-operand)
-
- (define-operation-specific-error 'FASLOAD-COMPILED-MISMATCH
- (list fasload load-band)
- "FASLOAD: Binary file contains compiled code for a different microcode"
- combination-first-operand)
-
- (define-operation-specific-error 'FASLOAD-BAND
- (list fasload)
- "FASLOAD: Binary file contains a scheme image (band), not an object"
- combination-first-operand)
-
- (define-operation-specific-error 'IO-ERROR
- (list fasdump)
- "FASDUMP: I/O error"
- combination-second-operand)
-
- (define-operation-specific-error 'FASDUMP-ENVIRONMENT
- (list fasdump)
- "FASDUMP: Object to dump is or points to environment objects"
- combination-first-operand)
- )
+;;;; Condition Types
+
+(define-structure (condition-type
+ (constructor %make-condition-type
+ (dependencies error? message))
+ (conc-name condition-type/))
+ ;; `dependencies' is sorted in decreasing `index' order.
+ (dependencies false read-only true)
+ (error? false read-only true)
+ (message false read-only true)
+ (index (allocate-condition-type-index!) read-only true)
+ (properties (make-1d-table) read-only true))
+
+(define (make-condition-type dependencies message)
+ (for-each guarantee-condition-type dependencies)
+ (let ((dependencies
+ (cons false
+ (reduce dependencies/union
+ '()
+ (map condition-type/dependencies dependencies)))))
+ (let ((result
+ (%make-condition-type dependencies
+ (if (memq condition-type:error dependencies)
+ true
+ false)
+ message)))
+ (set-car! dependencies result)
+ result)))
+
+(define (allocate-condition-type-index!)
+ (let ((index next-condition-type-index))
+ (set! next-condition-type-index (1+ index))
+ index))
+
+(define next-condition-type-index)
+
+(define (guarantee-condition-type object)
+ (if (not (condition-type? object)) (error "Illegal condition-type" object))
+ object)
+
+(define-integrable (condition-type<? x y)
+ (< (condition-type/index x) (condition-type/index y)))
\f
-;;; This will trap any external-primitive errors that
-;;; aren't caught by special handlers.
-
-(define-operator-error 'EXTERNAL-RETURN
- "Error during External Application")
-
-(define-operation-specific-error 'EXTERNAL-RETURN
- (list (make-primitive-procedure 'FILE-OPEN-CHANNEL 2))
- "Unable to open file"
- combination-first-operand)
-
-(define-operation-specific-error 'OUT-OF-FILE-HANDLES
- (list (make-primitive-procedure 'FILE-OPEN-CHANNEL 2))
- "Too many open files"
- combination-first-operand)
-
-(define-operation-specific-error 'BAD-ASSIGNMENT
- (list (make-primitive-procedure 'ENVIRONMENT-LINK-NAME 3))
- "Bound variable"
- combination-third-operand)
-
-;;; SCODE Syntax Errors
-
-;;; This error gets an unevaluated combination, but it doesn't ever
-;;; look at the components, so it doesn't matter.
-
-(define define-broken-variable-error
- (define-specific-error 'BROKEN-CVARIABLE
- "Broken Compiled Variable -- get a wizard"))
-
-(define-broken-variable-error variable? variable-name)
-(define-broken-variable-error assignment? assignment-name)
+(define (dependencies/union x y)
+ ;; This takes advantage of (and preserves) the dependency ordering.
+ (cond ((null? x) y)
+ ((null? y) x)
+ ((eq? (car x) (car y))
+ (cons (car x) (dependencies/union (cdr x) (cdr y))))
+ ((condition-type<? (car x) (car y))
+ (cons (car y) (dependencies/union x (cdr y))))
+ (else
+ (cons (car x) (dependencies/union (cdr x) y)))))
+
+(define (dependencies/intersect? x y)
+ (cond ((or (null? x) (null? y)) false)
+ ((eq? (car x) (car y)) true)
+ ((condition-type<? (car x) (car y))
+ (dependencies/intersect? x (cdr y)))
+ (else
+ (dependencies/intersect? (cdr x) y))))
+
+(define (make-error-type dependencies message)
+ (make-condition-type (if (there-exists? dependencies condition-type/error?)
+ dependencies
+ (cons condition-type:error dependencies))
+ message))
+
+(define (error-type? object)
+ (and (condition-type? object)
+ (condition-type/error? object)))
+
+(define condition-type:error)
\f
-;;;; System Errors
-
-(define-total-error-handler 'BAD-ERROR-CODE
- (lambda (error-code expression)
- (start-error-rep "Bad Error Code -- get a wizard"
- (error-code-or-name error-code))))
-
-(define-default-error 'BAD-INTERRUPT-CODE
- "Illegal Interrupt Code -- get a wizard"
- identity-procedure)
-
-(define-default-error 'EXECUTE-MANIFEST-VECTOR
- "Attempt to execute Manifest Vector -- get a wizard"
- identity-procedure)
-
-(define-default-error 'UNDEFINED-USER-TYPE
- "Undefined Type Code -- get a wizard"
- identity-procedure)
-
-(define-default-error 'INAPPLICABLE-CONTINUATION
- "Inapplicable continuation -- get a wizard"
- identity-procedure)
-
-(define-default-error 'COMPILED-CODE-ERROR
- "Compiled code error -- get a wizard"
- identity-procedure)
-
-(define-default-error 'ILLEGAL-REFERENCE-TRAP
- "Illegal reference trap -- get a wizard"
- identity-procedure)
-
-(define-default-error 'BROKEN-VARIABLE-CACHE
- "Broken variable value cell"
- identity-procedure)
+;;;; Condition Instances
+
+(define-structure (condition
+ (constructor %make-condition (type irritants continuation))
+ (conc-name condition/))
+ (type false read-only true)
+ (irritants false read-only true)
+ (continuation false read-only true)
+ (properties (make-1d-table) read-only true))
+
+(define (make-condition type irritants continuation)
+ (guarantee-condition-type type)
+ (if (not (list? irritants))
+ (error "Illegal condition irritants" irritants))
+ (guarantee-continuation continuation)
+ (%make-condition type irritants continuation))
+
+(define (guarantee-condition object)
+ (if (not (condition? object)) (error "Illegal condition" object))
+ object)
+
+(define-integrable (condition/dependencies condition)
+ (condition-type/dependencies (condition/type condition)))
+
+(define-integrable (condition/error? condition)
+ (condition-type/error? (condition/type condition)))
+
+(define (error? object)
+ (and (condition? object)
+ (condition/error? object)))
\f
-;;;; Harmless system errors
-
-(define-default-error 'FLOATING-OVERFLOW
- "Floating point overflow"
- identity-procedure)
-
-(define-total-error-handler 'WRITE-INTO-PURE-SPACE
- (lambda (error-code expression)
- (newline)
- (write-string "Automagically IMPURIFYing an object....")
- (impurify (combination-first-operand expression))))
-
-;;; end ERROR-SYSTEM package.
-))
\ No newline at end of file
+;;;; Condition Handling
+
+(define handler-frames)
+
+(define-structure (handler-frame (type structure)
+ (conc-name handler-frame/))
+ (condition-types false read-only true)
+ (handler false read-only true)
+ (next false read-only true))
+
+(define (bind-condition-handler condition-types handler thunk)
+ (for-each guarantee-condition-type condition-types)
+ (fluid-let ((handler-frames
+ (make-handler-frame condition-types
+ handler
+ handler-frames)))
+ (thunk)))
+
+(define-integrable (signal-error condition)
+ (signal-condition condition standard-error-handler))
+
+(define (signal-condition condition #!optional default-handler)
+ (guarantee-condition condition)
+ (let ((condition-type (condition/type condition)))
+ (let ((dependencies (condition-type/dependencies condition-type)))
+ (or (scan-handler-frames handler-frames dependencies
+ (lambda (frame)
+ (fluid-let ((handler-frames (handler-frame/next frame)))
+ ((handler-frame/handler frame) condition))))
+ (and (not (default-object? default-handler))
+ (fluid-let ((handler-frames false))
+ (default-handler condition)))))))
+
+(define (scan-handler-frames frames dependencies try-frame)
+ (let loop ((frame frames))
+ (and frame
+ (or (and (let ((condition-types
+ (handler-frame/condition-types frame)))
+ (or (null? condition-types)
+ (dependencies/intersect? dependencies
+ condition-types)))
+ (try-frame frame))
+ (loop (handler-frame/next frame))))))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $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
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/events.scm,v 14.1 1988/06/13 11:44:35 cph Rel $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Event Distribution
+;;; package: (runtime event-distributor)
(declare (usual-integrations))
\f
-(define make-event-distributor)
-(define event-distributor?)
-(define add-event-receiver!)
-(define remove-event-receiver!)
-
-(let ((:type (make-named-tag "EVENT-DISTRIBUTOR")))
- (set! make-event-distributor
- (named-lambda (make-event-distributor)
- (define receivers '())
- (define queue-head '())
- (define queue-tail '())
- (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))
- (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))))))
+(define (initialize-package!)
+ (set! add-event-receiver! (make-receiver-modifier 'ADD-RECEIVER))
+ (set! remove-event-receiver! (make-receiver-modifier 'REMOVE-RECEIVER)))
- (set! event-distributor?
- (named-lambda (event-distributor? object)
- (and (compound-procedure? object)
- (let ((e (procedure-environment object)))
- (and (not (lexical-unreferenceable? e ':TYPE))
- (eq? (access :type e) :type)
- e)))))
+(define (initialize-unparser!)
+ (unparser/set-tagged-vector-method!
+ event-distributor
+ (unparser/standard-method 'EVENT-DISTRIBUTOR)))
- (define ((make-receiver-modifier name operation)
- event-distributor event-receiver)
- (let ((e (event-distributor? event-distributor)))
- (if (not e)
- (error "Not an event distributor" name event-distributor))
- (without-interrupts
- (lambda ()
- (set! (access receivers e)
- (operation event-receiver (access receivers e)))))))
+(define-structure (event-distributor
+ (constructor make-event-distributor ())
+ (conc-name event-distributor/)
+ (print-procedure false))
+ (events (make-queue))
+ (lock false)
+ (receivers '()))
- (set! add-event-receiver!
- (make-receiver-modifier 'ADD-EVENT-RECEIVER!
- (lambda (receiver receivers)
- (append! receivers (list receiver)))))
+(define (event-distributor/invoke! event-distributor . arguments)
+ (enqueue! (event-distributor/events event-distributor)
+ (cons 'INVOKE-RECEIVERS arguments))
+ (process-events! event-distributor))
- (set! remove-event-receiver!
- (make-receiver-modifier 'REMOVE-EVENT-RECEIVER! delq!))
+(define (make-receiver-modifier keyword)
+ (lambda (event-distributor receiver)
+ (if (not (event-distributor? event-distributor))
+ (error "Not an event distributor" event-distributor))
+ (enqueue! (event-distributor/events event-distributor)
+ (cons keyword receiver))
+ (process-events! event-distributor)))
-)
\ No newline at end of file
+(define add-event-receiver!)
+(define remove-event-receiver!)
+\f
+(define (process-events! event-distributor)
+ (if (not
+ (without-interrupts
+ (lambda ()
+ (let ((lock (event-distributor/lock event-distributor)))
+ (set-event-distributor/lock! event-distributor true)
+ lock))))
+ (begin
+ (queue-map! (event-distributor/events event-distributor)
+ (lambda (event)
+ (case (car event)
+ ((INVOKE-RECEIVERS)
+ (let loop
+ ((receivers
+ (event-distributor/receivers event-distributor)))
+ (if (not (null? receivers))
+ (begin (apply (car receivers) (cdr event))
+ (loop (cdr receivers))))))
+ ((ADD-RECEIVER)
+ (set-event-distributor/receivers!
+ event-distributor
+ (append! (event-distributor/receivers event-distributor)
+ (list (cdr event)))))
+ ((REMOVE-RECEIVER)
+ (set-event-distributor/receivers!
+ event-distributor
+ (delv! (cdr event)
+ (event-distributor/receivers event-distributor))))
+ (else
+ (error "Illegal event" event)))))
+ (set-event-distributor/lock! event-distributor false))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.1 1988/05/20 00:57:08 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/framex.scm,v 14.2 1988/06/13 11:44:55 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Debugging Info
-;;; package: debugging-info-package
+;;; package: (runtime debugging-info)
(declare (usual-integrations))
\f
(for-each (lambda (entry)
(for-each (lambda (name)
(let ((type
- (or (vector-ref stack-frame-types
- (microcode-return name))
+ (or (microcode-return/code->type
+ (microcode-return name))
(error "Missing return type" name))))
(1d-table/put! (stack-frame-type/properties type)
method-tag
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 13.44 1988/05/05 08:39:12 cph Exp $
-;;;
-;;; Copyright (c) 1988 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 14.1 1988/06/13 11:45:00 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Garbage Collector
+;;; package: (runtime garbage-collector)
-(declare (usual-integrations)
- (integrate-primitive-procedures
- garbage-collect primitive-purify primitive-impurify primitive-fasdump
- set-interrupt-enables! enable-interrupts! primitive-gc-type pure?
- get-next-constant call-with-current-continuation hunk3-cons
- set-fixed-objects-vector! tty-write-char tty-write-string exit))
+(declare (usual-integrations))
\f
-(define add-gc-daemon!)
-(define gc-flip)
-(define purify)
-(define impurify)
-(define fasdump)
-(define suspend-world)
-(define set-default-gc-safety-margin!)
-
-(define garbage-collector-package
- (make-environment
-
-(define default-safety-margin 4500)
-
-;; SET-DEFAULT-GC-SAFETY-MARGIN! changes the amount of memory
-;; saved from the heap to allow the GC handler to run.
-
-(set! set-default-gc-safety-margin!
-(named-lambda (set-default-gc-safety-margin! #!optional margin)
- (if (or (unassigned? margin) (null? margin))
- default-safety-margin
- (begin (set! default-safety-margin margin)
- (gc-flip margin)))))
-
-;;;; Cold Load GC
-
-(define (reset)
- (enable-interrupts! interrupt-mask-none))
-
-;;; User call -- optionally overrides the default GC safety
-;;; margin for this flip only.
-
-(set! gc-flip
-(named-lambda (gc-flip #!optional new-safety-margin)
- (with-interrupts-reduced interrupt-mask-none
- (lambda (old-interrupt-mask)
- (garbage-collect
- (if (unassigned? new-safety-margin)
- default-safety-margin
- new-safety-margin))))))
-
-(vector-set! (vector-ref (get-fixed-objects-vector) 1)
- 2 ;Local Garbage Collection Interrupt
- (named-lambda (gc-interrupt interrupt-code interrupt-enables)
- (gc-flip Default-Safety-Margin)))
-
-(vector-set! (vector-ref (get-fixed-objects-vector) 1)
- 0 ;Local Stack Overflow Interrupt
- (named-lambda (stack-overflow-interrupt interrupt-code
- interrupt-enables)
- (stack-overflow)
- (set-interrupt-enables! interrupt-enables)))
+(define (initialize-package!)
+ (set! hook/gc-flip default/gc-flip)
+ (set! hook/purify default/purify)
+ (set! hook/stack-overflow default/stack-overflow)
+ (set! hook/hardware-trap default/hardware-trap)
+ (set! default-safety-margin 4500)
+ (set! pure-space-queue '())
+ (set! constant-space-queue '())
+ (set! hook/gc-start default/gc-start)
+ (set! hook/gc-finish default/gc-finish)
+ (let ((fixed-objects (get-fixed-objects-vector)))
+ (let ((interrupt-vector (vector-ref fixed-objects 1)))
+ (vector-set! interrupt-vector 0 condition-handler/stack-overflow)
+ (vector-set! interrupt-vector 2 condition-handler/gc))
+ (vector-set! fixed-objects #x0C condition-handler/hardware-trap)
+ ((ucode-primitive set-fixed-objects-vector!) fixed-objects)))
+
+(define (condition-handler/gc interrupt-code interrupt-enables)
+ interrupt-code interrupt-enables
+ (hook/gc-flip default-safety-margin))
+
+(define (condition-handler/stack-overflow interrupt-code interrupt-enables)
+ interrupt-code
+ (hook/stack-overflow)
+ (set-interrupt-enables! interrupt-enables))
+
+(define (condition-handler/hardware-trap escape-code)
+ escape-code
+ (hook/hardware-trap))
+
+(define hook/gc-flip)
+(define hook/purify)
+(define hook/stack-overflow)
+(define hook/hardware-trap)
+(define default-safety-margin)
\f
-;;; This variable is clobbered by GCSTAT.
-(define (stack-overflow)
- (tty-write-char char:newline)
- (tty-write-string "Stack overflow!")
- (tty-write-char char:newline)
- (exit))
-
-(vector-set! (get-fixed-objects-vector)
- #x0C
- (named-lambda (hardware-trap-handler escape-code)
- (hardware-trap)))
-
-;;; This is clobbered also by GCSTAT.
-(define (hardware-trap)
- (tty-write-char char:newline)
- (tty-write-string "Hardware trap")
- (tty-write-char char:newline)
- (exit))
-
-;;; The GC daemon is invoked by the microcode whenever there is a need.
-;;; All we provide here is a trivial extension mechanism.
-
-(vector-set! (get-fixed-objects-vector)
- #x0B
- (named-lambda (gc-daemon)
- (trigger-daemons gc-daemons)))
-
-(set-fixed-objects-vector! (get-fixed-objects-vector))
-
-(define (trigger-daemons daemons . extra-args)
- (let loop ((daemons daemons))
- (if (not (null? daemons))
- (begin (apply (car daemons) extra-args)
- (loop (cdr daemons))))))
-
-(define gc-daemons '())
-
-(set! add-gc-daemon!
-(named-lambda (add-gc-daemon! daemon)
- (if (not (memq daemon gc-daemons))
- (set! gc-daemons (cons daemon gc-daemons)))))
-
-(reset)
+(define (default/gc-flip safety-margin)
+ (cond ((not (null? pure-space-queue))
+ (let ((result (purify-internal pure-space-queue true safety-margin)))
+ (if (car result)
+ (set! pure-space-queue '())
+ (begin
+ (set! pure-space-queue (cdr pure-space-queue))
+ (queued-purification-failure)))
+ (cdr result)))
+ ((not (null? constant-space-queue))
+ (let ((result
+ (purify-internal constant-space-queue false safety-margin)))
+ (if (car result)
+ (set! constant-space-queue '())
+ (begin
+ (set! constant-space-queue (cdr constant-space-queue))
+ (queued-purification-failure)))
+ (cdr result)))
+ (else
+ (gc-flip-internal safety-margin))))
+
+(define (queued-purification-failure)
+ (warn "Unable to purify all queued items; dequeuing one"))
+
+(define (default/purify item pure-space? queue?)
+ (if (not (if pure-space? (object-pure? item) (object-constant? item)))
+ (cond ((not queue?)
+ (if (not (car (purify-internal item
+ pure-space?
+ default-safety-margin)))
+ (error "PURIFY: not enough room in constant space" item)))
+ (pure-space?
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (set! pure-space-queue (cons item pure-space-queue)))))
+ (else
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (set! constant-space-queue
+ (cons item constant-space-queue))))))))
+
+(define (default/stack-overflow)
+ (abort "maximum recursion depth exceeded"))
+
+(define (default/hardware-trap)
+ (abort "the hardware trapped"))
\f
-;;;; "GC-like" Primitives
-
-;; Purify an item -- move it into pure space and clean everything
-;; by doing a gc-flip
-
-(set! purify
-(named-lambda (purify item #!optional really-pure?)
- (if (not (car (primitive-purify item
- (if (unassigned? really-pure?)
- false
- really-pure?)
- default-safety-margin)))
- (error "Not enough room in constant space" purify item))
- item))
-
-(set! impurify
-(named-lambda (impurify object)
- (if (or (zero? (primitive-gc-type object))
- (not (pure? object)))
- object
- (primitive-impurify object))))
-
-(set! fasdump
-(named-lambda (fasdump object filename)
- (let ((filename (canonicalize-output-filename filename))
- (port (rep-output-port)))
- (newline port)
- (write-string "FASDumping " port)
- (write filename port)
- (if (not (primitive-fasdump object filename false))
- (error "Object is too large to be dumped" fasdump object))
- (write-string " -- done" port))
- object))
+(define pure-space-queue)
+(define constant-space-queue)
+(define hook/gc-start)
+(define hook/gc-finish)
+
+(define (gc-flip-internal safety-margin)
+ (let ((start-value (hook/gc-start)))
+ (let ((space-remaining ((ucode-primitive garbage-collect) safety-margin)))
+ (gc-abort-test space-remaining)
+ (hook/gc-finish start-value space-remaining)
+ space-remaining)))
+
+(define (purify-internal item pure-space? safety-margin)
+ (let ((start-value (hook/gc-start)))
+ (let ((result
+ ((ucode-primitive primitive-purify) item
+ pure-space?
+ safety-margin)))
+ (gc-abort-test (cdr result))
+ (hook/gc-finish start-value (cdr result))
+ result)))
+
+(define (default/gc-start)
+ false)
+
+(define (default/gc-finish start-value space-remaining)
+ start-value space-remaining
+ false)
+
+(define-integrable (gc-abort-test space-remaining)
+ (if (< space-remaining 4096)
+ (abort "out of memory")))
+
+(define (abort message)
+ (abort-to-nearest-driver (string-append "Aborting!: " message)))
\f
-(set! suspend-world
-(named-lambda (suspend-world suspender after-suspend after-restore)
- (with-interrupts-reduced interrupt-mask-gc-ok
- (lambda (ie)
- ((call-with-current-continuation
- (lambda (cont)
- (let ((fixed-objects-vector (get-fixed-objects-vector))
- (dynamic-state (current-dynamic-state)))
- (fluid-let ()
- (call-with-current-continuation
- (lambda (restart)
- (gc-flip)
- (suspender restart)
- (cont after-suspend)))
- (set-fixed-objects-vector! fixed-objects-vector)
- (set-current-dynamic-state! dynamic-state)
- (reset)
- ((access snarf-version microcode-system))
- (reset-keyboard-interrupt-dispatch-table!)
- (set! *rep-keyboard-map* (keyboard-interrupt-dispatch-table))
- ((access reset! primitive-io))
- ((access reset! working-directory-package))
- after-restore))))
- ie)))))
-
-;;; end GARBAGE-COLLECTOR-PACKAGE.
-))
\ No newline at end of file
+;;;; User Primitives
+
+(define (set-gc-safety-margin! #!optional safety-margin)
+ (if (not (or (default-object? safety-margin) (not safety-margin)))
+ (begin (set! default-safety-margin safety-margin)
+ (gc-flip safety-margin))) default-safety-margin)
+
+(define (gc-flip #!optional safety-margin)
+ ;; Optionally overrides the GC safety margin for this flip only.
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (hook/gc-flip (if (default-object? safety-margin)
+ default-safety-margin
+ safety-margin)))))
+(define (purify item #!optional pure-space? queue?)
+ ;; Purify an item -- move it into pure space and clean everything by
+ ;; doing a gc-flip.
+ (hook/purify item
+ (if (default-object? pure-space?) true pure-space?)
+ (if (default-object? queue?) true queue?))
+ item)
+
+(define (constant-space/in-use)
+ (- (get-next-constant) constant-space/base))
+
+;; This is set to the correct value during the cold load.
+(define constant-space/base)
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcdemn.scm,v 14.1 1988/05/20 00:57:31 cph Exp $
-;;;
-;;; Copyright (c) 1988 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcdemn.scm,v 14.2 1988/06/13 11:45:08 cph Rel $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Garbage Collector Daemons
-;;; package: gc-daemons
+;;; package: (runtime gc-daemons)
(declare (usual-integrations))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcnote.scm,v 14.1 1988/05/20 00:57:56 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcnote.scm,v 14.2 1988/06/13 11:45:12 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; GC Notification
-;;; package: gc-notification-package
+;;; package: (runtime gc-notification)
(declare (usual-integrations))
\f
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcstat.scm,v 13.44 1987/06/26 01:01:16 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcstat.scm,v 14.1 1988/06/13 11:45:17 cph Rel $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; GC Statistics
+;;; package: (runtime gc-statistics)
(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (set! hook/record-statistic! default/record-statistic!)
+ (set! history-modes
+ `((NONE . ,none:install-history!)
+ (BOUNDED . ,bounded:install-history!)
+ (UNBOUNDED . ,unbounded:install-history!)))
+ (set-history-mode! 'BOUNDED)
+ (statistics-reset!)
+ (add-event-receiver! event:after-restore statistics-reset!)
+ (set! hook/gc-start recorder/gc-start)
+ (set! hook/gc-finish recorder/gc-finish))
-(define gctime)
-(define gc-statistics)
-(define gc-history-mode)
+(define (recorder/gc-start)
+ (process-time-clock))
-(define gc-statistics-package
- (make-environment
+(define (recorder/gc-finish start-time space-remaining)
+ (let ((end-time (process-time-clock)))
+ (increment-non-runtime! (- end-time start-time))
+ (statistics-flip start-time end-time space-remaining)))
\f
-;;;; Statistics Hooks
-
-(define (gc-start-hook) 'DONE)
-(define (gc-finish-hook state) 'DONE)
-
-(define ((make-flip-hook old-flip) . More)
- (with-interrupts-reduced interrupt-mask-none
- (lambda (Old-Interrupt-Mask)
- (measure-interval
- 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))))
- (gc-finish-hook old-state)
- (if (< new-space-remaining 4096)
- (abort->nearest
- (standard-rep-message "Aborting: Out of memory!")))
- (lambda (end-time)
- (statistics-flip start-time
- end-time
- new-space-remaining)
- new-space-remaining))))))))
-\f
-;;;; Statistics Collector
-
(define meter)
(define total-gc-time)
(define last-gc-start)
(set! meter 1)
(set! total-gc-time 0)
(set! last-gc-start false)
- (set! last-gc-end (system-clock))
+ (set! last-gc-end (process-time-clock))
(reset-recorder! '()))
+(define-structure (gc-statistic (conc-name gc-statistic/))
+ (meter false read-only true)
+ (heap-left false read-only true)
+ (this-gc-start false read-only true)
+ (this-gc-end false read-only true)
+ (last-gc-start false read-only true)
+ (last-gc-end false read-only true))
+
(define (statistics-flip start-time end-time heap-left)
(let ((statistic
- (vector meter
- start-time end-time
- last-gc-start last-gc-end
- heap-left)))
+ (make-gc-statistic meter heap-left
+ start-time end-time
+ last-gc-start last-gc-end)))
(set! meter (1+ meter))
(set! total-gc-time (+ (- end-time start-time) total-gc-time))
(set! last-gc-start start-time)
(set! last-gc-end end-time)
- (record-statistic! statistic)))
+ (record-statistic! statistic)
+ (hook/record-statistic! statistic)))
-(set! gctime (named-lambda (gctime) total-gc-time))
+(define hook/record-statistic!)
+
+(define (default/record-statistic! statistic)
+ statistic
+ false)
+
+(define (gctime)
+ (internal-time/ticks->seconds total-gc-time))
\f
;;;; Statistics Recorder
(set! last-statistic statistic)
(record-in-history! statistic))
-(set! gc-statistics
- (named-lambda (gc-statistics)
- (let ((history (get-history)))
- (if (null? history)
- (if last-statistic
- (list last-statistic)
- '())
- history))))
+(define (gc-statistics)
+ (let ((history (get-history)))
+ (if (null? history)
+ (if last-statistic
+ (list last-statistic)
+ '())
+ history)))
\f
;;;; History Modes
(define get-history)
(define history-mode)
-(set! gc-history-mode
- (named-lambda (gc-history-mode #!optional new-mode)
- (let ((old-mode history-mode))
- (if (not (unassigned? new-mode))
- (let ((old-history (get-history)))
- (set-history-mode! new-mode)
- (reset-history! old-history)))
- old-mode)))
+(define (gc-history-mode #!optional new-mode)
+ (let ((old-mode history-mode))
+ (if (not (default-object? new-mode))
+ (let ((old-history (get-history)))
+ (set-history-mode! new-mode)
+ (reset-history! old-history)))
+ old-mode))
(define (set-history-mode! mode)
(let ((entry (assq mode history-modes)))
((cdr entry))
(set! history-mode (car entry))))
-(define history-modes
- `((NONE . ,(named-lambda (none:install-history!)
- (set! reset-history! none:reset-history!)
- (set! record-in-history! none:record-in-history!)
- (set! get-history none:get-history)))
- (BOUNDED . ,(named-lambda (bounded:install-history!)
- (set! reset-history! bounded:reset-history!)
- (set! record-in-history! bounded:record-in-history!)
- (set! get-history bounded:get-history)))
- (UNBOUNDED . ,(named-lambda (unbounded:install-history!)
- (set! reset-history! unbounded:reset-history!)
- (set! record-in-history! unbounded:record-in-history!)
- (set! get-history unbounded:get-history)))))
+(define history-modes)
\f
;;; NONE
+(define (none:install-history!)
+ (set! reset-history! none:reset-history!)
+ (set! record-in-history! none:record-in-history!)
+ (set! get-history none:get-history))
+
(define (none:reset-history! old)
+ old
(set! history '()))
(define (none:record-in-history! item)
+ item
'DONE)
(define (none:get-history)
'())
-
+\f
;;; BOUNDED
(define history-size 8)
(define (copy-to-size l size)
(let ((max (length l)))
(if (>= max size)
- (initial-segment l size)
- (append (initial-segment l max)
+ (list-head l size)
+ (append (list-head l max)
(make-list (- size max) '())))))
+(define (bounded:install-history!)
+ (set! reset-history! bounded:reset-history!)
+ (set! record-in-history! bounded:record-in-history!)
+ (set! get-history bounded:get-history))
+
(define (bounded:reset-history! old)
(set! history (apply circular-list (copy-to-size old history-size))))
(cond ((eq? scan history) '())
((null? (car scan)) (loop (cdr scan)))
(else (cons (car scan) (loop (cdr scan)))))))
-
+\f
;;; UNBOUNDED
+(define (unbounded:install-history!)
+ (set! reset-history! unbounded:reset-history!)
+ (set! record-in-history! unbounded:record-in-history!)
+ (set! get-history unbounded:get-history))
+
(define (unbounded:reset-history! old)
(set! history old))
(set! history (cons item history)))
(define (unbounded:get-history)
- (reverse history))
-\f
-;;;; Initialization
-
-(define (install!)
- (set-history-mode! 'BOUNDED)
- (statistics-reset!)
- (set! gc-flip (make-flip-hook gc-flip))
- (set! (access stack-overflow garbage-collector-package)
- (named-lambda (stack-overflow)
- (abort->nearest
- (standard-rep-message
- "Aborting: Maximum recursion depth exceeded!"))))
- (set! (access hardware-trap garbage-collector-package)
- (named-lambda (hardware-trap)
- (abort->nearest
- (standard-rep-message
- "Aborting: The hardware trapped!"))))
- (add-event-receiver! event:after-restore statistics-reset!))
-
-;;; end GC-STATISTICS-PACKAGE.
-))
-\f
-;;;; GC Notification
-
-(define toggle-gc-notification!)
-(define print-gc-statistics)
-(let ()
-
-(define normal-recorder '())
-
-(define (gc-notification statistic)
- (normal-recorder statistic)
- (with-output-to-port (rep-output-port)
- (lambda ()
- (print-statistic statistic))))
-
-(set! toggle-gc-notification!
- (named-lambda (toggle-gc-notification!)
- (if (null? normal-recorder)
- (begin (set! normal-recorder
- (access record-statistic! gc-statistics-package))
- (set! (access record-statistic! gc-statistics-package)
- gc-notification))
- (begin (set! (access record-statistic! gc-statistics-package)
- normal-recorder)
- (set! normal-recorder '())))
- *the-non-printing-object*))
-
-(set! print-gc-statistics
- (named-lambda (print-gc-statistics)
- (for-each print-statistic (gc-statistics))))
-
-(define (print-statistic statistic)
- (fluid-let ((*unparser-radix* 10))
- (apply (lambda (meter
- this-gc-start this-gc-end
- last-gc-start last-gc-end
- heap-left)
- (let ((delta-time (- this-gc-end this-gc-start)))
- (newline) (write-string "GC #") (write meter)
- (write-string " took: ") (write delta-time)
- (write-string " (")
- (write (round (* (/ delta-time (- this-gc-end last-gc-end))
- 100)))
- (write-string "%) free: ") (write heap-left)))
- (vector->list statistic))))
-
-)
\ No newline at end of file
+ (reverse history))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gdatab.scm,v 14.1 1988/05/20 00:58:20 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gdatab.scm,v 14.2 1988/06/13 11:45:24 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Global Databases
-;;; package: global-database-package
+;;; package: (runtime global-database)
(declare (usual-integrations))
\f
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gensym.scm,v 13.42 1987/11/21 18:06:02 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
-;;;; GENSYM
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gensym.scm,v 14.1 1988/06/13 11:45:28 cph Rel $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
+
+;;;; Symbol Generation
+;;; package: (runtime gensym)
(declare (usual-integrations))
\f
-(define (make-name-generator prefix)
- (let ((counter 0))
- (named-lambda (name-generator)
- (string->uninterned-symbol
- (string-append prefix
- (number->string
- (let ((n counter))
- (set! counter (1+ counter))
- n)))))))
+(define (generate-uninterned-symbol #!optional argument)
+ (if (not (default-object? argument))
+ (cond ((symbol? argument)
+ (set! name-prefix (symbol->string argument)))
+ ((and (integer? argument)
+ (not (negative? argument))) (set! name-counter argument))
+ (else
+ (error "GENERATE-UNINTERNED-SYMBOL: Bad argument" argument))))
+ (string->uninterned-symbol
+ (string-append name-prefix
+ (number->string
+ (let ((result name-counter))
+ (set! name-counter (1+ name-counter))
+ result)))))
+
+(define name-counter)
+(define name-prefix)
-(define generate-uninterned-symbol
- (let ((name-counter 0)
- (name-prefix "G"))
- (define (get-number)
- (let ((result name-counter))
- (set! name-counter (1+ name-counter))
- result))
- (named-lambda (generate-uninterned-symbol #!optional argument)
- (if (not (unassigned? argument))
- (cond ((symbol? argument)
- (set! name-prefix (symbol->string argument)))
- ((integer? argument)
- (set! name-counter argument))
- (else
- (error "Bad argument: GENERATE-UNINTERNED-SYMBOL"
- argument))))
- (string->uninterned-symbol
- (string-append name-prefix (number->string (get-number)))))))
+(define (initialize-package!)
+ (set! name-counter 0)
+ (set! name-prefix "G"))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.1 1988/05/20 00:58:36 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.2 1988/06/13 11:45:33 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Miscellaneous Global Definitions
+;;; package: ()
(declare (usual-integrations))
\f
(object-datum 1)
(object-type? 2)
(object-new-type object-set-type 2)
+ make-non-pointer-object
eq?
;; Cells
(not (object-non-pointer? object)))
(define (impurify object)
- (if (and (object-pointer? object) (pure? object))
+ (if (and (object-pointer? object) (object-pure? object))
((ucode-primitive primitive-impurify) object))
object)
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/hash.scm,v 13.46 1987/05/26 13:29:58 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/hash.scm,v 14.1 1988/06/13 11:45:38 cph Rel $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Object Hashing, populations, and 2D tables
+;;; package: (runtime hash)
+
+(declare (usual-integrations))
+\f
+;;;; Object hashing
;;; The hashing code, and the population code below, depend on weak
;;; conses supported by the microcode. In particular, both pieces of
;;; since two processors may be updating the data structures
;;; simultaneously.
-(declare (usual-integrations))
-
-(add-event-receiver! event:after-restore gc-flip)
-\f
-;;;; Object hashing
-
;;; How this works:
;;; There are two tables, the hash table and the unhash table:
;;; object-unhash's back. Then object-unhash does not need to be
;;; locked against garbage collection.
\f
+(define (initialize-package!)
+ (set! smallest-positive-bignum
+ (let loop ((x 1) (y 2))
+ (if (object-type? (object-type x) y)
+ (loop y (* y 2))
+ (* y 2))))
+ (set! next-hash-number 1)
+ (set! hash-table-size default/hash-table-size)
+ (set! unhash-table (make-vector hash-table-size '()))
+ (set! hash-table (make-vector (1+ hash-table-size) '()))
+ ;; Could use `primitive-object-set!' to clobber the manifest type
+ ;; code instead of allocating another word here.
+ (vector-set! hash-table 0
+ ((ucode-primitive primitive-object-set-type)
+ (ucode-type manifest-special-nm-vector)
+ (make-non-pointer-object hash-table-size)))
+ (let loop ((n 0))
+ (if (< n hash-table-size)
+ (begin (vector-set! unhash-table n (cons true '()))
+ (loop (1+ n)))))
+ (add-event-receiver! event:after-restore (lambda () (gc-flip)))
+ (add-gc-daemon! rehash-gc-daemon))
+
+(define default/hash-table-size 313)
+(define next-hash-number)
+(define hash-table-size)
+(define unhash-table)
+(define hash-table)
+(define smallest-positive-bignum)
+
(define (hash x)
(if (eq? x false)
0
(define (valid-hash-number? n)
(or (zero? n)
(object-unhash n)))
-
-(define object-hash)
-(define object-unhash)
-
-(let ((pair-type (microcode-type 'PAIR))
- (weak-cons-type (microcode-type 'WEAK-CONS))
- (snmv-type (microcode-type 'MANIFEST-SPECIAL-NM-VECTOR))
- (&make-object (make-primitive-procedure '&MAKE-OBJECT)))
- (declare (integrate-primitive-procedures &make-object))
-
-(define next-hash-number)
-(define hash-table-size)
-(define unhash-table)
-(define hash-table)
-
-(define (initialize-object-hash! size)
- (set! next-hash-number 1)
- (set! hash-table-size size)
- (set! unhash-table (vector-cons size '()))
- (set! hash-table (vector-cons (1+ size) '()))
- (vector-set! hash-table 0 (&make-object snmv-type size))
- (let initialize ((n 0))
- (if (< n size)
- (begin (vector-set! unhash-table n (cons true '()))
- (initialize (1+ n))))))
-
-;; Primitive-datum may return negative fixnums. Until fixed...
-
-(define safe-primitive-datum
- (let ((smallest-positive-bignum
- (let loop ((x 1) (y 2))
- (if (primitive-type? (primitive-type x) y)
- (loop y (* y 2))
- (* y 2)))))
- (named-lambda (safe-primitive-datum object)
- (let ((n (primitive-datum object)))
- (if (not (negative? n))
- n
- (+ smallest-positive-bignum n))))))
\f
;;; This is not dangerous because assq is a primitive and does not
;;; cause consing. The rest of the consing (including that by the
;;; interpreter) is a small bounded amount.
-(set! object-hash
-(named-lambda (object-hash object)
- (with-interrupt-mask interrupt-mask-none
- (lambda (ignore)
- (let* ((hash-index (1+ (modulo (safe-primitive-datum object) hash-table-size)))
+(define (object-hash object)
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let* ((hash-index (1+ (modulo (object-datum object) hash-table-size)))
(bucket (vector-ref hash-table hash-index))
(association (assq object bucket)))
(if association
(set! next-hash-number (1+ next-hash-number))
(vector-set! hash-table hash-index (cons pair bucket))
(set-cdr! unhash-bucket
- (cons (primitive-set-type weak-cons-type pair)
+ (cons (object-new-type (ucode-type weak-cons) pair)
(cdr unhash-bucket)))
- result)))))))
+ result))))))
;;; This is safe because it locks the garbage collector out only for a
;;; little time, enough to tag the bucket being searched, so that the
;;; daemon will not splice that bucket.
-(set! object-unhash
-(named-lambda (object-unhash number)
+(define (object-unhash number)
(let ((index (modulo number hash-table-size)))
- (with-interrupt-mask interrupt-mask-none
- (lambda (ignore)
+ (with-absolutely-no-interrupts
+ (lambda ()
(let ((bucket (vector-ref unhash-table index)))
(set-car! bucket false)
(let ((result
- (with-interrupt-mask interrupt-mask-gc-ok
- (lambda (ignore)
+ (without-interrupts
+ (lambda ()
(let loop ((l (cdr bucket)))
(cond ((null? l) false)
((= number (system-pair-cdr (car l)))
(system-pair-car (car l)))
(else (loop (cdr l)))))))))
(set-car! bucket true)
- result)))))))
+ result))))))
\f
;;;; Rehash daemon
;;; a primitive. See the installation code below.
#|
-(define (rehash weak-pair)
- (let ((index (1+ (modulo (safe-primitive-datum (system-pair-car weak-pair))
- hash-table-size))))
- (vector-set! hash-table
- index
- (cons (primitive-set-type pair-type weak-pair)
- (vector-ref hash-table index)))))
-
-(define (cleanup n)
- (if (zero? n)
- 'DONE
- (begin (vector-set! hash-table n '())
- (cleanup (-1+ n)))))
-
(define (rehash-gc-daemon)
- (cleanup hash-table-size)
+ (let cleanup ((n hash-table-size))
+ (if (not (zero? n))
+ (begin (vector-set! hash-table n '())
+ (cleanup (-1+ n)))))
(let outer ((n (-1+ hash-table-size)))
(if (negative? n)
true
(else (rehash (car l))
(inner2 (cdr l))))))))))
-(add-gc-daemon! rehash-gc-daemon)
+(define (rehash weak-pair)
+ (let ((index (1+ (modulo (object-datum (system-pair-car weak-pair))
+ hash-table-size))))
+ (vector-set! hash-table
+ index
+ (cons (object-new-type (ucode-type pair) weak-pair)
+ (vector-ref hash-table index)))))
|#
-\f
-(add-gc-daemon!
- (let ((primitive (make-primitive-procedure 'REHASH)))
- (lambda ()
- (primitive unhash-table hash-table))))
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/histry.scm,v 13.49 1987/10/12 20:59:10 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/histry.scm,v 14.1 1988/06/13 11:45:51 cph Rel $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; History Manipulation
+;;; package: (runtime history)
(declare (usual-integrations))
\f
-(define max-subproblems 10)
-(define max-reductions 5)
-(define with-new-history)
-
-(define history-package
- (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)))
- (hunk:make (make-primitive-procedure 'HUNK3-CONS))
- (type-code:unmarked-history (microcode-type 'unmarked-history))
- (type-code:marked-history (microcode-type 'marked-history))
-
- ;; VERTEBRA abstraction.
- (vertebra-rib system-hunk3-cxr0)
- (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.
- (reduction-expression system-hunk3-cxr0)
- (reduction-environment system-hunk3-cxr1)
- (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
- (hunk:make hunk3-cons)
- (vertebra-rib system-hunk3-cxr0)
- (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-expression system-hunk3-cxr0)
- (reduction-environment system-hunk3-cxr1)
- (set-reduction-expression! system-hunk3-set-cxr0!)
- (set-reduction-environment! system-hunk3-set-cxr1!)
- (set-next-reduction! system-hunk3-set-cxr2!))
-
- (integrate-operator history:mark history:unmark history:marked?))
-
-(define (history:unmark object)
- (declare (integrate object))
- (primitive-set-type type-code:unmarked-history object))
-
-(define (history:mark object)
- (declare (integrate object))
- (primitive-set-type type-code:marked-history object))
-
-(define (history:marked? object)
- (declare (integrate object))
- (primitive-type? type-code:marked-history object))
-\f
-;;; Vertebra operations
-
-(declare (integrate-operator make-vertebra same-vertebra?))
+;;; Vertebrae
-(define (make-vertebra rib deeper shallower)
- (declare (integrate rib deeper shallower))
- (history:unmark (hunk:make rib deeper shallower)))
+(define-integrable (make-vertebra rib deeper shallower)
+ (history:unmark (hunk3-cons rib deeper shallower)))
-(define (deeper-vertebra vertebra)
- (system-hunk3-cxr1 vertebra))
+(define-integrable vertebra-rib system-hunk3-cxr0)
+(define-integrable deeper-vertebra system-hunk3-cxr1)
+(define-integrable shallower-vertebra system-hunk3-cxr2)
+(define-integrable set-vertebra-rib! system-hunk3-set-cxr0!)
+(define-integrable set-deeper-vertebra! system-hunk3-set-cxr1!)
+(define-integrable set-shallower-vertebra! system-hunk3-set-cxr2!)
-(define (marked-vertebra? vertebra)
+(define-integrable (marked-vertebra? vertebra)
(history:marked? (system-hunk3-cxr1 vertebra)))
(define (mark-vertebra! vertebra)
- (system-hunk3-set-cxr1!
- vertebra
- (history:mark (system-hunk3-cxr1 vertebra))))
+ (system-hunk3-set-cxr1! vertebra
+ (history:mark (system-hunk3-cxr1 vertebra))))
(define (unmark-vertebra! vertebra)
(system-hunk3-set-cxr1! vertebra
(history:unmark (system-hunk3-cxr1 vertebra))))
-(define (same-vertebra? x y)
- (declare (integrate x y))
- (= (primitive-datum x) (primitive-datum y)))
+(define-integrable (same-vertebra? x y)
+ (= (object-datum x) (object-datum y)))
(define (link-vertebrae previous next)
(set-deeper-vertebra! previous next)
(set-shallower-vertebra! next previous))
\f
-;;; Reduction operations
+;;; Reductions
-(declare (integrate-operator make-reduction same-reduction?))
+(define-integrable (make-reduction expression environment next)
+ (history:unmark (hunk3-cons expression environment next)))
-(define (make-reduction expression environment next)
- (declare (integrate expression environment next))
- (history:unmark (hunk:make expression environment next)))
+(define-integrable reduction-expression system-hunk3-cxr0)
+(define-integrable reduction-environment system-hunk3-cxr1)
+(define-integrable next-reduction system-hunk3-cxr2)
+(define-integrable set-reduction-expression! system-hunk3-set-cxr0!)
+(define-integrable set-reduction-environment! system-hunk3-set-cxr1!)
+(define-integrable set-next-reduction! system-hunk3-set-cxr2!)
-(define (next-reduction reduction)
- (system-hunk3-cxr2 reduction))
-
-(define (marked-reduction? reduction)
+(define-integrable (marked-reduction? reduction)
(history:marked? (system-hunk3-cxr2 reduction)))
(define (mark-reduction! reduction)
- (system-hunk3-set-cxr2!
- reduction
- (history:mark (system-hunk3-cxr2 reduction))))
+ (system-hunk3-set-cxr2! reduction
+ (history:mark (system-hunk3-cxr2 reduction))))
(define (unmark-reduction! reduction)
(system-hunk3-set-cxr2! reduction
(history:unmark (system-hunk3-cxr2 reduction))))
-(define (same-reduction? x y)
- (declare (integrate x y))
- (= (primitive-datum x) (primitive-datum y)))
+(define-integrable (same-reduction? x y)
+ (= (object-datum x) (object-datum y)))
+\f
+;;; Marks
+
+(define-integrable (history:unmark object)
+ (object-new-type (ucode-type unmarked-history) object))
+
+(define-integrable (history:mark object)
+ (object-new-type (ucode-type marked-history) object))
+
+(define-integrable (history:marked? object)
+ (object-type? (ucode-type marked-history) object))
\f
;;;; History Initialization
(define (create-history depth width)
- (define (new-vertebra)
- (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-vertebra head '() '())))
-
- (cond ((or (not (integer? depth))
- (negative? depth))
- (error "Invalid Depth" 'CREATE-HISTORY depth))
- ((or (not (integer? width))
- (negative? width))
- (error "Invalid Width" 'CREATE-HISTORY width))
- (else
- (if (or (zero? depth) (zero? width))
- (begin (set! depth 1) (set! width 1)))
- (let ((head (new-vertebra)))
- (let subproblem-loop ((n (-1+ depth))
- (previous head))
- (if (zero? n)
- (link-vertebrae previous head)
- (let ((next (new-vertebra)))
- (link-vertebrae previous next)
- (subproblem-loop (-1+ n) next))))
- head))))
-\f
+ (let ((new-vertebra
+ (lambda ()
+ (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-vertebra head '() '())))))
+ (if (not (and (integer? depth) (positive? depth)))
+ (error "CREATE-HISTORY: invalid depth" depth))
+ (if (not (and (integer? width) (positive? width))) (error "CREATE-HISTORY: invalid width" width))
+ (let ((head (new-vertebra)))
+ (let subproblem-loop ((n (-1+ depth)) (previous head))
+ (if (zero? n)
+ (link-vertebrae previous head)
+ (let ((next (new-vertebra)))
+ (link-vertebrae previous next)
+ (subproblem-loop (-1+ n) next))))
+ head)))
+
;;; The PUSH-HISTORY! accounts for the pop which happens after
;;; 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 #F)
- system-global-environment)
- (push-history! history)))))
- (thunk)))
+(define (with-new-history thunk)
+ ((ucode-primitive 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
+ false
+ system-global-environment)
+ (push-history! history)))))
+ (thunk))
+(define max-subproblems 10)
+(define max-reductions 5)
+\f
;;;; Primitive History Operations
;;; These operations mimic the actions of the microcode.
;;; The history motion operations all return the new history.
(loop next)))))
'()))))
+(define the-empty-history)
+
(define (unfold-and-reverse-rib rib)
(let loop ((current (next-reduction rib)) (output 'WRAP-AROUND))
(let ((step
(define (dummy-compiler-reduction? reduction)
(and (null? (reduction-expression reduction))
- (eq? return-address-pop-from-compiled-code
+ (eq? (ucode-return-address pop-from-compiled-code)
(reduction-environment reduction))))
-(define the-empty-history
- (cons (vector-ref (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'DUMMY-HISTORY))
- '()))
-
(define (history-superproblem history)
(if (null? (cdr history))
history
'()
(force (cadr history))))
-(define (history-untransform history)
+(define-integrable (history-untransform history)
(car history))
-;;; end HISTORY-PACKAGE.
-(the-environment)))
\ No newline at end of file
+(define (initialize-package!)
+ (set! the-empty-history
+ (cons (vector-ref (get-fixed-objects-vector)
+ (fixed-objects-vector-slot 'DUMMY-HISTORY))
+ '())))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 13.52 1988/05/06 12:40:26 cph Exp $
-;;;
-;;; Copyright (c) 1988 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
-;;;; Input
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 14.1 1988/06/13 11:46:00 cph Exp $
-(declare (usual-integrations))
-\f
-;;;; Input Ports
+Copyright (c) 1988 Massachusetts Institute of Technology
-(define input-port-tag
- "Input Port")
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
-(define (input-port? object)
- (and (environment? object)
- (not (lexical-unreferenceable? object ':type))
- (eq? (access :type object) input-port-tag)))
+1. Any copy made of this software must include this copyright notice
+in full.
-(define eof-object
- "EOF Object")
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
-(define (eof-object? object)
- (eq? object eof-object))
+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.
-(define *current-input-port*)
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
-(define (current-input-port)
- *current-input-port*)
+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 without prior written consent from
+MIT in each case. |#
-(define (with-input-from-port port thunk)
- (if (not (input-port? port)) (error "Bad input port" port))
- (fluid-let ((*current-input-port* port))
- (thunk)))
-
-(define (with-input-from-file input-specifier thunk)
- (define new-port (open-input-file input-specifier))
- (define old-port)
- (dynamic-wind (lambda ()
- (set! old-port
- (set! *current-input-port*
- (set! new-port))))
- thunk
- (lambda ()
- (let ((port))
- ;; Only SET! is guaranteed to do the right thing with
- ;; an unassigned value. Binding may not work right.
- (set! port (set! *current-input-port* (set! old-port)))
- (if (not (unassigned? port))
- (close-input-port port))))))
-
-(define (call-with-input-file input-specifier receiver)
- (let ((port (open-input-file input-specifier)))
- (let ((value (receiver port)))
- (close-input-port port)
- value)))
+;;;; Input
+;;; package: (runtime input-port)
-(define (close-input-port port)
- ((access :close port)))
+(declare (usual-integrations))
\f
-;;;; Console Input Port
-
-(define console-input-port)
-(let ()
+;;;; Input Ports
-(define tty-read-char
- (make-primitive-procedure 'TTY-READ-CHAR))
+(define (initialize-package!)
+ (set! *current-input-port* console-input-port))
+
+(define (input-port/unparse state port)
+ ((unparser/standard-method 'INPUT-PORT
+ (input-port/custom-operation port 'PRINT-SELF))
+ state
+ port))
+
+(define-structure (input-port (conc-name input-port/)
+ (constructor %make-input-port)
+ (copier %input-port/copy)
+ (print-procedure input-port/unparse))
+ state
+ (operation/char-ready? false read-only true)
+ (operation/peek-char false read-only true)
+ (operation/read-char false read-only true)
+ (operation/peek-char-immediate false read-only true)
+ (operation/read-char-immediate false read-only true)
+ (operation/discard-char false read-only true)
+ (operation/read-string false read-only true)
+ (operation/discard-chars false read-only true)
+ (operation/read-start! false read-only true)
+ (operation/read-finish! false read-only true)
+ (custom-operations false read-only true))
+
+(define (guarantee-input-port port)
+ (if (not (input-port? port)) (error "Bad input port" port))
+ port)
-(define tty-read-char-immediate
- (make-primitive-procedure 'TTY-READ-CHAR-IMMEDIATE))
+(define (input-port/custom-operation port name)
+ (let ((entry (assq name (input-port/custom-operations port))))
+ (and entry
+ (cdr entry))))
-(define tty-read-char-ready?
- (make-primitive-procedure 'TTY-READ-CHAR-READY?))
+(define (input-port/copy port state)
+ (let ((result (%input-port/copy port)))
+ (set-input-port/state! result state)
+ result))
-(define tty-read-finish
- (make-primitive-procedure 'TTY-READ-FINISH))
+(define (input-port/char-ready? port interval)
+ ((input-port/operation/char-ready? port) port interval))
-(define (read-start-hook)
- 'DONE)
+(define (input-port/peek-char port)
+ ((input-port/operation/peek-char port) port))
-(define (read-finish-hook)
- 'DONE)
+(define (input-port/read-char port)
+ ((input-port/operation/read-char port) port))
-(set! console-input-port
- (make-environment
+(define (input-port/peek-char-immediate port)
+ ((input-port/operation/peek-char-immediate port) port))
-(define :type input-port-tag)
+(define (input-port/read-char-immediate port)
+ ((input-port/operation/read-char-immediate port) port))
-(define (:print-self)
- (unparse-with-brackets
- (lambda ()
- (write-string "Console input port"))))
+(define (input-port/discard-char port)
+ ((input-port/operation/discard-char port) port))
-(define (:close)
- 'DONE)
+(define (input-port/read-string port delimiters)
+ ((input-port/operation/read-string port) port delimiters))
-(define character-buffer
- false)
+(define (input-port/discard-chars port delimiters)
+ ((input-port/operation/discard-chars port) port delimiters))
-(define (:peek-char)
- (or character-buffer
- (begin (set! character-buffer (tty-read-char))
- character-buffer)))
+(define (input-port/read-start! port)
+ ((input-port/operation/read-start! port) port))
-(define (:discard-char)
- (set! character-buffer false))
+(define (input-port/read-finish! port)
+ ((input-port/operation/read-finish! port) port))
\f
-(define (:read-char)
- (if character-buffer
- (set! character-buffer false)
- (tty-read-char)))
-
-(define (:read-string delimiters)
- (define (loop)
- (if (char-set-member? delimiters (:peek-char))
- '()
- (let ((char (:read-char)))
- (cons char (loop)))))
- (list->string (loop)))
-
-(define (:discard-chars delimiters)
- (define (loop)
- (if (not (char-set-member? delimiters (:peek-char)))
- (begin (:discard-char)
- (loop))))
- (loop))
-
-(define (:peek-char-immediate)
- (or character-buffer
- (begin (set! character-buffer (tty-read-char-immediate))
- character-buffer)))
-
-(define (:read-char-immediate)
- (if character-buffer
- (set! character-buffer false)
- (tty-read-char-immediate)))
-
-(define (:char-ready? delay)
- (or character-buffer (tty-read-char-ready? delay)))
-
-(define (:read-start!)
- (read-start-hook))
-
-(define :read-finish!
- (let ()
- (define (read-finish-loop)
- (if (and (:char-ready? 0)
- (char-whitespace? (:peek-char)))
- (begin (:discard-char)
- (read-finish-loop))))
- (lambda ()
- (tty-read-finish)
- (read-finish-loop)
- (read-finish-hook))))
-
-;;; end CONSOLE-INPUT-PORT.
-))
-
-)
-
-(set! *current-input-port* console-input-port)
+(define (make-input-port operations state)
+ (let ((operations
+ (map (lambda (entry)
+ (cons (car entry) (cadr entry)))
+ operations)))
+ (let ((operation
+ (lambda (name default)
+ (let ((entry (assq name operations)))
+ (if entry
+ (begin (set! operations (delq! entry operations))
+ (cdr entry))
+ (or default
+ (error "MAKE-INPUT-PORT: missing operation" name)))))))
+ (let ((char-ready? (operation 'CHAR-READY? false))
+ (peek-char (operation 'PEEK-CHAR false))
+ (read-char (operation 'READ-CHAR false))
+ (read-string
+ (operation 'READ-STRING default-operation/read-string))
+ (discard-chars
+ (operation 'DISCARD-CHARS default-operation/discard-chars))
+ (read-start!
+ (operation 'READ-START! default-operation/read-start!))
+ (read-finish!
+ (operation 'READ-FINISH! default-operation/read-finish!)))
+ (let ((peek-char-immediate (operation 'PEEK-CHAR-IMMEDIATE peek-char))
+ (read-char-immediate (operation 'READ-CHAR-IMMEDIATE read-char))
+ (discard-char (operation 'DISCARD-CHAR read-char)))
+ (%make-input-port state
+ char-ready?
+ peek-char
+ read-char
+ peek-char-immediate
+ read-char-immediate
+ discard-char
+ read-string
+ discard-chars
+ read-start!
+ read-finish!
+ operations))))))
\f
-;;;; File Input Ports
-
-(define open-input-file)
-(let ()
-
-(define file-fill-input-buffer
- (make-primitive-procedure 'FILE-FILL-INPUT-BUFFER))
-
-(define file-length
- (make-primitive-procedure 'FILE-LENGTH))
-
-(define file-port-buffer-size
- 512)
-
-(set! open-input-file
-(named-lambda (open-input-file filename)
- (let ((file-channel ((access open-input-channel primitive-io)
- (canonicalize-input-filename filename))))
-
-(define :type input-port-tag)
-
-(define (:print-self)
- (unparse-with-brackets
- (lambda ()
- (write-string "Buffered input port for file: ")
- (write ((access channel-name primitive-io) file-channel)))))
-
-(define (:pathname)
- (->pathname filename))
-
-(define (:truename)
- (->pathname ((access channel-name primitive-io) file-channel)))
+(define (default-operation/read-string port delimiters)
+ (list->string
+ (let ((peek-char (input-port/operation/peek-char port))
+ (read-char (input-port/operation/read-char port)))
+ (let loop ()
+ (if (char-set-member? delimiters (peek-char port))
+ '()
+ (let ((char (read-char port)))
+ (cons char (loop))))))))
+
+(define (default-operation/discard-chars port delimiters)
+ (let ((peek-char (input-port/operation/peek-char port))
+ (discard-char (input-port/operation/discard-char port)))
+ (let loop ()
+ (if (not (char-set-member? delimiters (peek-char port)))
+ (begin (discard-char port)
+ (loop))))))
+
+(define (default-operation/read-start! port)
+ port
+ false)
-(define (:length)
- (file-length file-channel))
-\f
-(define buffer false)
-(define start-index 0)
-(define end-index -1)
-
-(define (refill-buffer!)
- (if (not buffer) (set! buffer (string-allocate file-port-buffer-size)))
- (set! start-index 0)
- (set! end-index (file-fill-input-buffer file-channel buffer))
- (zero? end-index))
-
-(declare (integrate buffer-ready?))
-
-(define (buffer-ready?)
- (and (not (zero? end-index))
- (not (refill-buffer!))))
-
-(define (:char-ready? delay)
- (or (< start-index end-index)
- (buffer-ready?)))
-
-(define (:close)
- (set! end-index 0)
- (set! buffer false)
- ((access close-physical-channel primitive-io) file-channel))
-
-(define (:peek-char)
- (if (< start-index end-index)
- (string-ref buffer start-index)
- (and (buffer-ready?)
- (string-ref buffer 0))))
-
-(define (:discard-char)
- (set! start-index (1+ start-index)))
-
-(define (:read-char)
- (if (< start-index end-index)
- (string-ref buffer (set! start-index (1+ start-index)))
- (and (buffer-ready?)
- (begin (set! start-index 1)
- (string-ref buffer 0)))))
-\f
-(define (:read-string delimiters)
- (define (loop)
- (let ((index
- (substring-find-next-char-in-set buffer start-index end-index
- delimiters)))
- (if index
- (substring buffer (set! start-index index) index)
- (let ((head (substring buffer start-index end-index)))
- (if (refill-buffer!)
- head
- (let ((tail (loop))
- (head-length (string-length head)))
- (let ((result (string-allocate (+ head-length
- (string-length tail)))))
- (substring-move-right! head 0 head-length
- result 0)
- (substring-move-right! tail 0 (string-length tail)
- result head-length)
- result)))))))
- (and (or (< start-index end-index)
- (buffer-ready?))
- (loop)))
-
-(define (:discard-chars delimiters)
- (define (loop)
- (let ((index
- (substring-find-next-char-in-set buffer start-index end-index
- delimiters)))
- (cond (index (set! start-index index))
- ((not (refill-buffer!)) (loop)))))
- (if (or (< start-index end-index)
- (buffer-ready?))
- (loop)))
-\f
-(define (:rest->string)
- (define (read-rest)
- (set! end-index 0)
- (loop))
-
- (define (loop)
- (let ((buffer (string-allocate file-port-buffer-size)))
- (let ((n (file-fill-input-buffer file-channel buffer)))
- (cond ((zero? n) '())
- ((< n file-port-buffer-size)
- (set-string-length! buffer n)
- (list buffer))
- (else (cons buffer (loop)))))))
-
- (if (zero? end-index)
- (error "End of file -- :REST->STRING"))
- (cond ((= -1 end-index)
- (let ((l (:length)))
- (if l
- (let ((buffer (string-allocate l)))
- (set! end-index 0)
- (file-fill-input-buffer file-channel buffer)
- buffer)
- (apply string-append (read-rest)))))
- ((< start-index end-index)
- (let ((first (substring buffer start-index end-index)))
- (apply string-append
- (cons first
- (read-rest)))))
- (else
- (apply string-append (read-rest)))))
-
-(the-environment))))
-
-)
+(define (default-operation/read-finish! port)
+ port
+ false)
\f
-;;;; String Input Ports
-
-(define (with-input-from-string string thunk)
- (fluid-let ((*current-input-port* (string->input-port string)))
- (thunk)))
-
-(define (string->input-port string #!optional start end)
- (cond ((unassigned? start)
- (set! start 0)
- (set! end (string-length string)))
- ((unassigned? end)
- (set! end (string-length string))))
-
-(define :type input-port-tag)
-
-(define (:print-self)
- (unparse-with-brackets
- (lambda ()
- (write-string "Input port for string"))))
-
-(define (:char-ready? delay)
- (< start end))
+(define eof-object
+ "EOF Object")
-(define (:close) 'DONE)
+(define (eof-object? object)
+ (eq? object eof-object))
-(define (:peek-char)
- (and (< start end)
- (string-ref string start)))
+(define (make-eof-object port)
+ port
+ eof-object)
-(define (:discard-char)
- (set! start (1+ start)))
+(define *current-input-port*)
-(define (:read-char)
- (and (< start end)
- (string-ref string (set! start (1+ start)))))
+(define-integrable (current-input-port)
+ *current-input-port*)
-(define (:read-string delimiters)
- (and (< start end)
- (let ((index
- (or (substring-find-next-char-in-set string start end delimiters)
- end)))
- (substring string (set! start index) index))))
+(define (with-input-from-port port thunk)
+ (if (not (input-port? port)) (error "Bad input port" port))
+ (fluid-let ((*current-input-port* port))
+ (thunk)))
-(define (:discard-chars delimiters)
- (if (< start end)
- (set! start
- (or (substring-find-next-char-in-set string start end delimiters)
- end))))
+(define (with-input-from-file input-specifier thunk)
+ (let ((new-port (open-input-file input-specifier))
+ (old-port false))
+ (dynamic-wind (lambda ()
+ (set! old-port *current-input-port*)
+ (set! *current-input-port* new-port)
+ (set! new-port false))
+ thunk
+ (lambda ()
+ (if *current-input-port*
+ (close-input-port *current-input-port*))
+ (set! *current-input-port* old-port)
+ (set! old-port false)))))
-;;; end STRING->INPUT-PORT.
-(the-environment))
+(define (call-with-input-file input-specifier receiver)
+ (let ((port (open-input-file input-specifier)))
+ (let ((value (receiver port)))
+ (close-input-port port)
+ value)))
\f
;;;; Input Procedures
+;;; **** The INTERVAL option for this operation works only for the
+;;; console port. Only Edwin uses this option.
+
+(define (char-ready? #!optional port interval)
+ (let ((port
+ (if (default-object? port)
+ (current-input-port)
+ (guarantee-input-port port))))
+ (if (not (and (integer? interval) (>= interval 0)))
+ (error "Bad interval" interval))
+ (input-port/char-ready? port interval)))
+
(define (peek-char #!optional port)
- (cond ((unassigned? port) (set! port *current-input-port*))
- ((not (input-port? port)) (error "Bad input port" port)))
- (or ((if (lexical-unreferenceable? port ':peek-char-immediate)
- (access :peek-char port)
- (access :peek-char-immediate port)))
- eof-object))
+ (let ((port
+ (if (default-object? port)
+ (current-input-port)
+ (guarantee-input-port port))))
+ (or (input-port/peek-char-immediate port)
+ eof-object)))
(define (read-char #!optional port)
- (cond ((unassigned? port) (set! port *current-input-port*))
- ((not (input-port? port)) (error "Bad input port" port)))
- (or ((if (lexical-unreferenceable? port ':read-char-immediate)
- (access :read-char port)
- (access :read-char-immediate port)))
- eof-object))
+ (let ((port
+ (if (default-object? port)
+ (current-input-port)
+ (guarantee-input-port port))))
+ (or (input-port/read-char-immediate port)
+ eof-object)))
+
+(define (read-char-no-hang #!optional port)
+ (let ((port
+ (if (default-object? port)
+ (current-input-port)
+ (guarantee-input-port port))))
+ (and (input-port/char-ready? port 0)
+ (or (input-port/read-char-immediate port)
+ eof-object))))
(define (read-string delimiters #!optional port)
- (cond ((unassigned? port) (set! port *current-input-port*))
- ((not (input-port? port)) (error "Bad input port" port)))
- (or ((access :read-string port) delimiters)
- eof-object))
-
-(define (read #!optional port)
- (cond ((unassigned? port) (set! port *current-input-port*))
- ((not (input-port? port)) (error "Bad input port" port)))
- (if (not (lexical-unreferenceable? port ':read-start!))
- ((access :read-start! port)))
- (let ((object ((access *parse-object parser-package) port)))
- (if (not (lexical-unreferenceable? port ':read-finish!))
- ((access :read-finish! port)))
- object))
-
-;;; **** The DELAY option for this operation works only for the
-;;; console port. Since it is a kludge, it is probably OK.
-
-(define (char-ready? #!optional port delay)
- (cond ((unassigned? port) (set! port *current-input-port*))
- ((not (input-port? port)) (error "Bad input port" port)))
- (cond ((unassigned? delay) (set! delay 0))
- ((not (and (integer? delay) (>= delay 0))) (error "Bad delay" delay)))
- ((access :char-ready? port) delay))
+ (let ((port
+ (if (default-object? port)
+ (current-input-port)
+ (guarantee-input-port port))))
+ (or (input-port/read-string port delimiters)
+ eof-object)))
+
+(define (read #!optional port parser-table)
+ (let ((port
+ (if (default-object? port)
+ (current-input-port)
+ (guarantee-input-port port)))
+ (parser-table
+ (if (default-object? parser-table)
+ (current-parser-table)
+ (guarantee-parser-table parser-table))))
+ (input-port/read-start! port)
+ (let ((object (parse-object/internal port parser-table)))
+ (input-port/read-finish! port)
+ object)))
-(define (read-char-no-hang #!optional port)
- (cond ((unassigned? port) (set! port *current-input-port*))
- ((not (input-port? port)) (error "Bad input port" port)))
- (and ((access :char-ready? port) 0)
- (read-char port)))
-\f
-(define load/default-types '("bin" "scm"))
-(define load-noisily? false)
-
-(define (load-noisily filename #!optional environment)
- (let ((environment
- (if (unassigned? environment) (rep-environment) environment)))
- (fluid-let ((load-noisily? true))
- (load filename environment))))
-
-(define read-file)
-(define load)
-(let ()
-
-(set! read-file
- (named-lambda (read-file filename)
- (call-with-input-file
- (pathname-default-version (->pathname filename) 'NEWEST)
- (access *parse-objects-until-eof parser-package))))
-
-;;; This crufty piece of code, once it decides which file to load,
-;;; does `file-exists?' on that file at least three times!!
-
-(set! load
- (named-lambda (load filename/s #!optional environment)
- (let ((environment
- (if (unassigned? environment) (rep-environment) environment)))
- (let ((kernel
- (lambda (filename last-file?)
- (let ((value
- (load/internal (find-true-filename (->pathname filename)
- load/default-types)
- environment
- load-noisily?)))
- (cond (last-file? value)
- (load-noisily? (rep-value value)))))))
- (if (pair? filename/s)
- (let loop ((filenames filename/s))
- (if (null? (cdr filenames))
- (kernel (car filenames) true)
- (begin (kernel (car filenames) false)
- (loop (cdr filenames)))))
- (kernel filename/s true))))))
-\f
-(define (load/internal true-filename environment load-noisily?)
- (let ((port (open-input-file true-filename)))
- (if (= 250 (char->ascii (peek-char port)))
- (begin (close-input-port port)
- (scode-eval (fasload true-filename) environment))
- (let ((syntax-table (rep-syntax-table))
- (no-value "no value"))
- (let load-loop ((value no-value))
- (let ((s-expression (read port)))
- (if (eof-object? s-expression)
- (begin (close-input-port port)
- value)
- (begin (if (and load-noisily? (not (eq? no-value value)))
- (rep-value value))
- (load-loop (rep-eval-hook s-expression
- environment
- syntax-table))))))))))
-
-(define (find-true-filename pathname default-types)
- (pathname->string
- (or (let ((try
- (lambda (pathname)
- (pathname->input-truename
- (pathname-default-version pathname 'NEWEST)))))
- (if (pathname-type pathname)
- (try pathname)
- (or (pathname->input-truename pathname)
- (let loop ((types default-types))
- (and (not (null? types))
- (or (try (pathname-new-type pathname (car types)))
- (loop (cdr types))))))))
- (error "No such file" pathname))))
-
-(define (pathname-default-version pathname version)
- (if (pathname-version pathname)
- pathname
- (pathname-new-version pathname version)))
-
-)
-\f
-(define (stickify-input-filenames filename/s default-pathname)
- (map (if default-pathname
- (lambda (filename)
- (merge-pathnames (->pathname filename) default-pathname))
- ->pathname)
- (if (pair? filename/s)
- filename/s
- (list filename/s))))
-
-#|(define (stickify-input-filenames filename/s default-pathname)
- (let loop
- ((filenames
- (if (pair? filename/s)
- filename/s
- (list filename/s)))
- (default-pathname default-pathname))
- (let ((pathname
- (let ((pathname (->pathname (car filenames))))
- (if default-pathname
- (merge-pathnames pathname default-pathname)
- pathname))))
- (cons pathname
- (if (pair? (cdr filenames))
- (loop (cdr filenames) pathname)
- '())))))|#
-\f
-(define fasload)
-(let ()
-
-(define default-pathname
- (make-pathname false false false "bin" 'NEWEST))
-
-(define binary-fasload
- (make-primitive-procedure 'BINARY-FASLOAD))
-
-(set! fasload
-(named-lambda (fasload filename)
- (let ((port (rep-output-port))
- (filename (canonicalize-input-filename
- (merge-pathnames (->pathname filename)
- default-pathname))))
- (newline port)
- (write-string "FASLoading " port)
- (write filename port)
- (let ((value (binary-fasload filename)))
- (write-string " -- done" port)
- value))))
-
-)
-
-(define transcript-on
- (let ((photo-open (make-primitive-procedure 'PHOTO-OPEN)))
- (named-lambda (transcript-on filename)
- (if (not (photo-open (canonicalize-output-filename filename)))
- (error "Transcript file already open: TRANSCRIPT-ON" filename))
- *the-non-printing-object*)))
-
-(define transcript-off
- (let ((photo-close (make-primitive-procedure 'PHOTO-CLOSE)))
- (named-lambda (transcript-off)
- (if (not (photo-close))
- (error "Transcript file already closed: TRANSCRIPT-OFF"))
- *the-non-printing-object*)))
\ No newline at end of file
+(define (close-input-port port)
+ (let ((operation (input-port/custom-operation port 'CLOSE)))
+ (if operation
+ (operation port))))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 13.48 1988/02/21 18:14:55 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 14.1 1988/06/13 11:46:23 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Interrupt System
+;;; package: (runtime interrupt-handler)
-(declare (usual-integrations)
- (integrate-primitive-procedures set-fixed-objects-vector!))
+(declare (usual-integrations))
\f
-(define with-external-interrupts-handler)
-
-(define timer-interrupt
- (let ((setup-timer-interrupt
- (make-primitive-procedure 'SETUP-TIMER-INTERRUPT 2)))
- (named-lambda (timer-interrupt)
- (setup-timer-interrupt '() '())
- (error "Unhandled Timer interrupt received"))))
-
-(define interrupt-system
- (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 '()))
+(define (initialize-package!)
+ (set! index:interrupt-vector
+ (fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR))
+ (set! index:termination-vector
+ (fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-PROCEDURES))
+ (set! timer-interrupt default/timer-interrupt)
+ (set! external-interrupt default/external-interrupt)
+ (set! keyboard-interrupts
+ (let ((table (make-vector 256 losing-keyboard-interrupt)))
+ (for-each (lambda (entry)
+ (vector-set! table
+ (char->ascii (car entry))
+ (cadr entry)))
+ `((#\B ,(keep-typeahead ^B-interrupt-handler))
+ (#\G ,(flush-typeahead ^G-interrupt-handler))
+ (#\U ,(flush-typeahead ^U-interrupt-handler))
+ (#\X ,(flush-typeahead ^X-interrupt-handler))
+ ;; (#\S ,(keep-typeahead ^S-interrupt-handler))
+ ;; (#\Q ,(keep-typeahead ^Q-interrupt-handler))
+ ;; (#\P ,(flush-typeahead ^P-interrupt-handler))
+ ;; (#\Z ,(flush-typeahead ^Z-interrupt-handler))
+ ))
+ table))
+ (set! hook/^B-interrupt default/^B-interrupt)
+ (set! hook/^G-interrupt default/^G-interrupt)
+ (set! hook/^U-interrupt default/^U-interrupt)
+ (set! hook/^X-interrupt default/^X-interrupt)
+ (set! hook/^S-interrupt default/^S-interrupt)
+ (set! hook/^Q-interrupt default/^Q-interrupt)
+ (set! hook/^P-interrupt default/^P-interrupt)
+ (set! hook/^Z-interrupt default/^Z-interrupt)
+ (install))
+
+(define-primitives
+ (setup-timer-interrupt 2)
+ get-next-interrupt-character
+ check-and-clean-up-input-channel
+ set-fixed-objects-vector!)
+
+(define-integrable stack-overflow-slot 0)
+(define-integrable gc-slot 2)
+(define-integrable character-slot 4)
+(define-integrable timer-slot 6)
+(define-integrable suspend-slot 8)
+(define-integrable illegal-interrupt-slot 9)
+
+(define index:interrupt-vector)
+(define index:termination-vector)
\f
-;;;; Soft interrupts
+;;;; Miscellaneous Interrupts
(define (timer-interrupt-handler interrupt-code interrupt-enables)
+ interrupt-code interrupt-enables
(timer-interrupt))
+(define timer-interrupt)
+(define (default/timer-interrupt)
+ (setup-timer-interrupt '() '())
+ (error "Unhandled Timer interrupt received"))
+
(define (suspend-interrupt-handler interrupt-code interrupt-enables)
- (fluid-let (((access *error-hook* error-system)
- (lambda (environment message irritant substitute-environment?)
- (%exit))))
- (if (not (disk-save (merge-pathnames (string->pathname "scheme_suspend")
- (home-directory-pathname))
- true))
- (%exit))))
+ interrupt-code interrupt-enables
+ (bind-condition-handler '() (lambda (condition) condition (%exit))
+ (lambda ()
+ (if (not (disk-save (merge-pathnames (string->pathname "scheme_suspend")
+ (home-directory-pathname))
+ true))
+ (%exit)))))
-;;; Keyboard Interrupts
+(define (gc-out-of-space-handler . args)
+ args
+ (abort-to-nearest-driver "Aborting! Out of memory"))
+
+(define (illegal-interrupt-handler interrupt-code interrupt-enables)
+ (error "Illegal interrupt" interrupt-code interrupt-enables))
+
+(define (default-interrupt-handler interrupt-code interrupt-enables)
+ (error "Anomalous interrupt" interrupt-code interrupt-enables))
+\f
+;;;; Keyboard Interrupts
(define (external-interrupt-handler interrupt-code interrupt-enables)
- (let ((interrupt-character (get-next-interrupt-character)))
- ((vector-ref keyboard-interrupts interrupt-character) interrupt-character
- interrupt-enables)))
+ interrupt-code
+ (external-interrupt (get-next-interrupt-character) interrupt-enables))
-(define (losing-keyboard-interrupt interrupt-character interrupt-enables)
- (error "Bad interrupt character" interrupt-character))
+(define (with-external-interrupts-handler handler thunk)
+ (fluid-let ((external-interrupt (flush-typeahead handler)))
+ (thunk)))
-(define keyboard-interrupts
- (vector-cons 256 losing-keyboard-interrupt))
+(define external-interrupt)
+(define (default/external-interrupt character interrupt-enables)
+ ((vector-ref keyboard-interrupts character) character interrupt-enables))
-(define (install-keyboard-interrupt! interrupt-char handler)
- (vector-set! keyboard-interrupts
- (char->ascii interrupt-char)
- handler))
+(define (losing-keyboard-interrupt character interrupt-enables)
+ interrupt-enables
+ (error "Bad interrupt character" character))
-(define (remove-keyboard-interrupt! interrupt-char)
- (vector-set! keyboard-interrupts
- (char->ascii interrupt-char)
- losing-keyboard-interrupt))
+(define keyboard-interrupts)
-(define until-most-recent-interrupt-character 0) ;for Pascal, ugh!
+;;; The following definitions must match the microcode.
+(define until-most-recent-interrupt-character 0)
(define multiple-copies-only 1)
-(define ((flush-typeahead kernel) interrupt-character interrupt-enables)
+(define ((flush-typeahead kernel) character interrupt-enables)
(if (check-and-clean-up-input-channel until-most-recent-interrupt-character
- interrupt-character)
- (kernel interrupt-character interrupt-enables)))
+ character)
+ (kernel character interrupt-enables)))
-(define ((keep-typeahead kernel) interrupt-character interrupt-enables)
- (if (check-and-clean-up-input-channel multiple-copies-only
- interrupt-character)
- (kernel interrupt-character interrupt-enables)))
+(define ((keep-typeahead kernel) character interrupt-enables)
+ (if (check-and-clean-up-input-channel multiple-copies-only character)
+ (kernel character interrupt-enables)))
\f
-(define ^B-interrupt-handler
- (keep-typeahead
- (lambda (interrupt-character interrupt-enables)
- (with-standard-proceed-point
- (lambda ()
- (breakpoint "^B interrupt" (rep-environment)))))))
-
-(define ^G-interrupt-handler
- (flush-typeahead
- (lambda (interrupt-character interrupt-enables)
- (if ((access under-emacs? emacs-interface-package))
- ((access transmit-signal emacs-interface-package) #\g))
- (abort-to-top-level-driver "Quit!"))))
-
-(define ^U-interrupt-handler
- (flush-typeahead
- (lambda (interrupt-character interrupt-enables)
- (abort-to-previous-driver "Up!"))))
-
-(define ^X-interrupt-handler
- (flush-typeahead
- (lambda (interrupt-character interrupt-enables)
- (abort-to-nearest-driver "Abort!"))))
+(define (^B-interrupt-handler character interrupt-enables)
+ character
+ (hook/^B-interrupt interrupt-enables))
-(define (gc-out-of-space-handler . args)
- (abort-to-nearest-driver "Aborting! Out of memory"))
-\f
-#|
-(define ^S-interrupt-handler
- (keep-typeahead
- (lambda (interrupt-character interrupt-enables)
- (if (null? ^Q-Hook)
- (begin
- (set-interrupt-enables! interrupt-enables)
- (beep)
- (call-with-current-continuation
- (lambda (stop-^S-wait)
- (fluid-let ((^Q-Hook Stop-^S-Wait))
- (let busy-wait () (busy-wait))))))))))
-
-(define ^Q-interrupt-handler
- (keep-typeahead
- (lambda (interrupt-character interrupt-enables)
- (if (not (null? ^Q-Hook))
- (begin
- (set-interrupt-enables! interrupt-enables)
- (^Q-Hook 'GO-ON))))))
-
-(define ^P-interrupt-handler
- (flush-typeahead
- (lambda (interrupt-character interrupt-enables)
- (set-interrupt-enables! interrupt-enables)
- (proceed))))
-
-(define ^Z-interrupt-handler
- (flush-typeahead
- (lambda (interrupt-character interrupt-enables)
- (set-interrupt-enables! interrupt-enables)
- (edit))))
-|#
+(define (^G-interrupt-handler character interrupt-enables)
+ character
+ (hook/^G-interrupt interrupt-enables))
+
+(define (^U-interrupt-handler character interrupt-enables)
+ character
+ (hook/^U-interrupt interrupt-enables))
+
+(define (^X-interrupt-handler character interrupt-enables)
+ character
+ (hook/^X-interrupt interrupt-enables))
+
+(define (^S-interrupt-handler character interrupt-enables)
+ character
+ (hook/^S-interrupt interrupt-enables))
+
+(define (^Q-interrupt-handler character interrupt-enables)
+ character
+ (hook/^Q-interrupt interrupt-enables))
+
+(define (^P-interrupt-handler character interrupt-enables)
+ character
+ (hook/^P-interrupt interrupt-enables))
+
+(define (^Z-interrupt-handler character interrupt-enables)
+ character
+ (hook/^Z-interrupt interrupt-enables))
+
+(define hook/^B-interrupt)
+(define hook/^G-interrupt)
+(define hook/^U-interrupt)
+(define hook/^X-interrupt)
+(define hook/^S-interrupt)
+(define hook/^Q-interrupt)
+(define hook/^P-interrupt)
+(define hook/^Z-interrupt)
\f
-(install-keyboard-interrupt! #\G ^G-interrupt-handler)
-(install-keyboard-interrupt! #\B ^B-interrupt-handler)
-; (install-keyboard-interrupt! #\P ^P-interrupt-handler)
-(install-keyboard-interrupt! #\U ^U-interrupt-handler)
-(install-keyboard-interrupt! #\X ^X-interrupt-handler)
-; (install-keyboard-interrupt! #\Z ^Z-interrupt-handler)
-; (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 suspend-slot 8)
-(define illegal-interrupt-slot 9)
+(define (default/^B-interrupt interrupt-enables)
+ interrupt-enables
+ (cmdl-interrupt/breakpoint))
-(define (illegal-interrupt-handler interrupt-code interrupt-enables)
- (error "Illegal interrupt" interrupt-code interrupt-enables))
+(define (default/^G-interrupt interrupt-enables)
+ interrupt-enables
+ (cmdl-interrupt/abort-top-level))
-(define (default-interrupt-handler interrupt-code interrupt-enables)
- (error "Anomalous interrupt" interrupt-code interrupt-enables))
+(define (default/^U-interrupt interrupt-enables)
+ interrupt-enables
+ (cmdl-interrupt/abort-previous))
+
+(define (default/^X-interrupt interrupt-enables)
+ interrupt-enables
+ (cmdl-interrupt/abort-nearest))
+
+(define (default/^S-interrupt interrupt-enables)
+ (if (not busy-wait-continuation)
+ (begin
+ (set-interrupt-enables! interrupt-enables)
+ (beep console-output-port)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (fluid-let ((busy-wait-continuation continuation))
+ (let busy-wait () (busy-wait))))))))
+
+(define (default/^Q-interrupt interrupt-enables)
+ (if busy-wait-continuation
+ (begin (set-interrupt-enables! interrupt-enables)
+ (busy-wait-continuation false))))
+
+(define busy-wait-continuation
+ false)
+
+(define (default/^P-interrupt interrupt-enables)
+ (set-interrupt-enables! interrupt-enables)
+ (proceed))
+
+(define (default/^Z-interrupt interrupt-enables)
+ (set-interrupt-enables! interrupt-enables)
+ (edit))
\f
(define (install)
- (with-interrupts-reduced interrupt-mask-gc-ok
- (lambda (old-mask)
+ (without-interrupts
+ (lambda ()
(let ((old-system-interrupt-vector
(vector-ref (get-fixed-objects-vector) index:interrupt-vector))
(old-termination-vector
(previous-stack-interrupt
(vector-ref old-system-interrupt-vector stack-overflow-slot))
(system-interrupt-vector
- (vector-cons (vector-length old-system-interrupt-vector)
+ (make-vector (vector-length old-system-interrupt-vector)
default-interrupt-handler))
(termination-vector
- (if old-termination-vector
- (if (> number-of-microcode-terminations
- (vector-length old-termination-vector))
- (vector-grow old-termination-vector
- number-of-microcode-terminations)
- old-termination-vector)
- (vector-cons number-of-microcode-terminations false))))
+ (let ((length (microcode-termination/code-limit)))
+ (if old-termination-vector
+ (if (> length (vector-length old-termination-vector))
+ (vector-grow old-termination-vector length)
+ old-termination-vector)
+ (make-vector length false)))))
(vector-set! system-interrupt-vector gc-slot previous-gc-interrupt)
(vector-set! system-interrupt-vector stack-overflow-slot
index:termination-vector
termination-vector)
- (set-fixed-objects-vector! (get-fixed-objects-vector)))))))
-\f
-(set! with-external-interrupts-handler
-(named-lambda (with-external-interrupts-handler handler code)
- (define (interrupt-routine interrupt-code interrupt-enables)
- (let ((character (get-next-interrupt-character)))
- (check-and-clean-up-input-channel
- until-most-recent-interrupt-character
- character)
- (handler character interrupt-enables)))
-
- (define old-handler interrupt-routine)
-
- (define interrupt-vector
- (vector-ref (get-fixed-objects-vector) index:interrupt-vector))
-
- (dynamic-wind
- (lambda ()
- (set! old-handler
- (vector-set! interrupt-vector character-slot old-handler)))
- code
- (lambda ()
- (vector-set! interrupt-vector character-slot
- (set! old-handler
- (vector-ref interrupt-vector character-slot)))))))
-
-;;; end INTERRUPT-SYSTEM package.
-(the-environment)))
\ No newline at end of file
+ (set-fixed-objects-vector! (get-fixed-objects-vector)))))))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 13.45 1987/04/13 18:43:17 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.1 1988/06/13 11:46:32 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Input/output utilities
+;;; package: (runtime primitive-io)
(declare (usual-integrations))
\f
-(define close-all-open-files)
+(define (initialize-package!)
+ (set! open-input-channel (open-channel-wrapper false))
+ (set! open-output-channel (open-channel-wrapper true))
+ (set! close-all-open-files (close-files file-close-channel))
+ (set! primitive-io/reset! (close-files (lambda (ignore) ignore)))
+ (set! open-files-list (list 'OPEN-FILES-LIST))
+ (set! traversing? false)
+ (add-gc-daemon! close-lost-open-files-daemon)
+ (add-event-receiver! event:after-restore primitive-io/reset!))
+
+(define-integrable (make-physical-channel descriptor channel direction)
+ (hunk3-cons descriptor channel direction))
+
+(define-integrable (channel-descriptor channel)
+ (system-hunk3-cxr0 channel))
+
+(define-integrable (set-channel-descriptor! channel descriptor)
+ (system-hunk3-set-cxr0! channel descriptor))
-(define primitive-io
- (let ((open-file-list-tag '*ALL-THE-OPEN-FILES*)
+(define-integrable (channel-name channel)
+ (system-hunk3-cxr1 channel))
- (weak-cons-type (microcode-type 'WEAK-CONS))
+(define-integrable (channel-direction channel)
+ (system-hunk3-cxr2 channel))
- (make-physical-channel (make-primitive-procedure 'HUNK3-CONS))
- (channel-descriptor system-hunk3-cxr0)
- (set-channel-descriptor! system-hunk3-set-cxr0!)
- (channel-name system-hunk3-cxr1)
- (channel-direction system-hunk3-cxr2)
- (set-channel-direction! system-hunk3-set-cxr2!)
+(define-integrable (set-channel-direction! channel direction)
+ (system-hunk3-set-cxr2! channel direction))
- (closed-direction 0)
- (closed-descriptor false))
+(define-primitives
+ file-open-channel
+ file-close-channel
+ close-lost-open-files)
- (make-environment
-
-(declare (integrate-primitive-procedures
- (make-physical-channel hunk3-cons)
- (channel-descriptor system-hunk3-cxr0)
- (set-channel-descriptor! system-hunk3-set-cxr0!)
- (channel-name system-hunk3-cxr1)
- (channel-direction system-hunk3-cxr2)
- (set-channel-direction! system-hunk3-set-cxr2!)))
+(define-integrable closed-direction 0)
+(define-integrable closed-descriptor false)
(define open-files-list)
(define traversing?)
-
-(define (initialize)
- (set! open-files-list (list open-file-list-tag))
- (set! traversing? false)
- true)
\f
;;;; Open/Close Files
;;; - false: input channel
;;; - 0: closed channel
-(define open-channel-wrapper
- (let ((open-channel (make-primitive-procedure 'FILE-OPEN-CHANNEL)))
- (named-lambda ((open-channel-wrapper direction) filename)
- (without-interrupts
- (lambda ()
- (let ((channel
- (make-physical-channel (open-channel filename direction)
- filename
- direction)))
- (with-interrupt-mask interrupt-mask-none ; Disallow gc
- (lambda (ie)
- (set-cdr! open-files-list
- (cons (system-pair-cons weak-cons-type
- channel
- (channel-descriptor channel))
- (cdr open-files-list)))))
- channel))))))
-
-(define open-input-channel (open-channel-wrapper false))
-(define open-output-channel (open-channel-wrapper true))
+(define ((open-channel-wrapper direction) filename)
+ (without-interrupts
+ (lambda ()
+ (let ((channel
+ (make-physical-channel
+ (file-open-channel filename direction)
+ filename
+ direction)))
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (set-cdr! open-files-list
+ (cons (system-pair-cons (ucode-type weak-cons)
+ channel
+ (channel-descriptor channel))
+ (cdr open-files-list)))))
+ channel))))
+
+(define open-input-channel)
+(define open-output-channel)
\f
-;; This is locked from interrupts, but GC can occur since the
-;; procedure itself hangs on to the channel until the last moment,
-;; when it returns the channel's name. The list will not be spliced
-;; by the daemon behind its back because of the traversing? flag.
-
-(define close-physical-channel
- (let ((primitive (make-primitive-procedure 'FILE-CLOSE-CHANNEL)))
- (named-lambda (close-physical-channel channel)
- (fluid-let ((traversing? true))
- (without-interrupts
- (lambda ()
- (if (eq? closed-direction
- (set-channel-direction! channel closed-direction))
- true ;Already closed!
- (begin
- (primitive (set-channel-descriptor! channel
- closed-descriptor))
- (let loop
- ((l1 open-files-list)
- (l2 (cdr open-files-list)))
- (cond ((null? l2)
- (set! traversing? false)
- (error "CLOSE-PHYSICAL-CHANNEL: lost channel"
- channel))
- ((eq? channel (system-pair-car (car l2)))
- (set-cdr! l1 (cdr l2))
- (channel-name channel))
- (else
- (loop l2 (cdr l2)))))))))))))
+;;; This is locked from interrupts, but GC can occur since the
+;;; procedure itself hangs on to the channel until the last moment,
+;;; when it returns the channel's name. The list will not be spliced
+;;; by the daemon behind its back because of the traversing? flag.
+
+(define (close-physical-channel channel)
+ (fluid-let ((traversing? true))
+ (without-interrupts
+ (lambda ()
+ (if (eq? closed-direction
+ (set-channel-direction! channel closed-direction))
+ true ;Already closed!
+ (begin
+ (file-close-channel
+ (set-channel-descriptor! channel closed-descriptor)) (let loop
+ ((l1 open-files-list)
+ (l2 (cdr open-files-list)))
+ (cond ((null? l2)
+ (set! traversing? false)
+ (error "CLOSE-PHYSICAL-CHANNEL: lost channel" channel))
+ ((eq? channel (system-pair-car (car l2)))
+ (set-cdr! l1 (cdr l2))
+ (channel-name channel))
+ (else
+ (loop l2 (cdr l2)))))))))))
\f
;;;; Finalization and daemon.
(loop (cdr open-files-list))))))))))
;;; This is invoked before disk-restoring. It "cleans" the microcode.
-
-(set! close-all-open-files
- (close-files (make-primitive-procedure 'FILE-CLOSE-CHANNEL)))
+(define close-all-open-files)
;;; This is invoked after disk-restoring. It "cleans" the new runtime system.
-
-(define reset!
- (close-files (lambda (ignore) true)))
+(define primitive-io/reset!)
\f
-;; This is the daemon which closes files which no one points to.
-;; Runs with GC, and lower priority interrupts, disabled.
-;; It is unsafe because of the (unnecessary) consing by the
-;; interpreter while it executes the loop.
-
-;; Replaced by a primitive installed below.
+;;; This is the daemon which closes files which no one points to.
+;;; Runs with GC, and lower priority interrupts, disabled.
+;;; It is unsafe because of the (unnecessary) consing by the
+;;; interpreter while it executes the loop.
+;;; Replaced by a primitive installed below.
#|
-
-(define close-lost-open-files-daemon
- (let ((primitive (make-primitive-procedure 'FILE-CLOSE-CHANNEL)))
- (named-lambda (close-lost-open-files-daemon)
- (if (not traversing?)
- (let loop
- ((l1 open-files-list)
- (l2 (cdr open-files-list)))
- (cond ((null? l2)
- true)
- ((null? (system-pair-car (car l2)))
- (primitive (system-pair-cdr (car l2)))
- (set-cdr! l1 (cdr l2))
- (loop l1 (cdr l1)))
- (else
- (loop l2 (cdr l2)))))))))
-
+(define (close-lost-open-files-daemon)
+ (if (not traversing?)
+ (let loop ((l1 open-files-list) (l2 (cdr open-files-list)))
+ (cond ((null? l2)
+ true)
+ ((null? (system-pair-car (car l2)))
+ (file-close-channel (system-pair-cdr (car l2)))
+ (set-cdr! l1 (cdr l2))
+ (loop l1 (cdr l1)))
+ (else
+ (loop l2 (cdr l2)))))))
|#
-
-(define close-lost-open-files-daemon
- (let ((primitive (make-primitive-procedure 'CLOSE-LOST-OPEN-FILES)))
- (named-lambda (close-lost-open-files-daemon)
- (if (not traversing?)
- (primitive open-files-list)))))
-
-;;; End of PRIMITIVE-IO package.
-)))
-
-((access initialize primitive-io))
-(add-gc-daemon! (access close-lost-open-files-daemon primitive-io))
\ No newline at end of file
+(define (close-lost-open-files-daemon)
+ (if (not traversing?)
+ (close-lost-open-files open-files-list)))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $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
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 14.1 1988/06/13 11:46:39 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Lambda Abstraction
+;;; package: (runtime lambda-abstraction)
(declare (usual-integrations))
\f
-(define lambda?)
-(define make-lambda)
-(define lambda-components)
-(define lambda-body)
-(define set-lambda-body!)
-(define lambda-bound)
-
-(define lambda-package
- (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))
+(define (initialize-package!)
+ (set! lambda-tag:internal-lambda (make-named-tag "INTERNAL-LAMBDA"))
+ (set! lambda-tag:internal-lexpr (make-named-tag "INTERNAL-LEXPR"))
+ (set! block-declaration-tag (make-named-tag "Block Declaration"))
+ (unparser/set-tagged-vector-method! block-declaration-tag
+ (unparser/standard-method 'BLOCK-DECLARATION))
+ (lambda-body-procedures clambda/physical-body clambda/set-physical-body!
+ (lambda (wrap-body! wrapper-components unwrap-body!
+ unwrapped-body set-unwrapped-body!)
+ (set! clambda-wrap-body! wrap-body!)
+ (set! clambda-wrapper-components wrapper-components)
+ (set! clambda-unwrap-body! unwrap-body!)
+ (set! clambda-unwrapped-body unwrapped-body)
+ (set! set-clambda-unwrapped-body! set-unwrapped-body!)))
+ (lambda-body-procedures clexpr/physical-body clexpr/set-physical-body!
+ (lambda (wrap-body! wrapper-components unwrap-body!
+ unwrapped-body set-unwrapped-body!)
+ (set! clexpr-wrap-body! wrap-body!)
+ (set! clexpr-wrapper-components wrapper-components)
+ (set! clexpr-unwrap-body! unwrap-body!)
+ (set! clexpr-unwrapped-body unwrapped-body)
+ (set! set-clexpr-unwrapped-body! set-unwrapped-body!)))
+ (lambda-body-procedures &triple-first &triple-set-first!
+ (lambda (wrap-body! wrapper-components unwrap-body!
+ unwrapped-body set-unwrapped-body!)
+ (set! xlambda-wrap-body! wrap-body!)
+ (set! xlambda-wrapper-components wrapper-components)
+ (set! xlambda-unwrap-body! unwrap-body!)
+ (set! xlambda-unwrapped-body unwrapped-body)
+ (set! set-xlambda-unwrapped-body! set-unwrapped-body!)))
+ (set! &lambda-components
+ (dispatch-1 'LAMBDA-COMPONENTS
+ clambda-components
+ clexpr-components
+ xlambda-components))
+ (set! has-internal-lambda?
+ (dispatch-0 'HAS-INTERNAL-LAMBDA?
+ clambda-has-internal-lambda?
+ clexpr-has-internal-lambda?
+ xlambda-has-internal-lambda?))
+ (set! lambda-wrap-body!
+ (dispatch-1 'LAMBDA-WRAP-BODY!
+ clambda-wrap-body!
+ clexpr-wrap-body!
+ xlambda-wrap-body!))
+ (set! lambda-wrapper-components
+ (dispatch-1 'LAMBDA-WRAPPER-COMPONENTS
+ clambda-wrapper-components
+ clexpr-wrapper-components
+ xlambda-wrapper-components))
+ (set! lambda-unwrap-body!
+ (dispatch-0 'LAMBDA-UNWRAP-BODY!
+ clambda-unwrap-body!
+ clexpr-unwrap-body!
+ xlambda-unwrap-body!))
+ (set! lambda-body
+ (dispatch-0 'LAMBDA-BODY
+ clambda-unwrapped-body
+ clexpr-unwrapped-body
+ xlambda-unwrapped-body))
+ (set! set-lambda-body!
+ (dispatch-1 'SET-LAMBDA-BODY!
+ set-clambda-unwrapped-body!
+ set-clexpr-unwrapped-body!
+ set-xlambda-unwrapped-body!))
+ (set! lambda-bound
+ (dispatch-0 'LAMBDA-BOUND
+ clambda-bound
+ clexpr-bound
+ xlambda-bound)))
\f
;;;; Hairy Advice Wrappers
;;; but the original state will always remain.
;;; **** Note: this stuff was implemented for the advice package.
-;;; Please don't use it for anything else since it will just
-;;; confuse things.
-
-(define lambda-body-procedures
- (let ((wrapper-tag '(LAMBDA-WRAPPER))
- (wrapper-body comment-expression)
- (set-wrapper-body! set-comment-expression!))
-
- (define (make-wrapper original-body new-body state)
- (make-comment (vector wrapper-tag original-body state)
- new-body))
-
- (define (wrapper? object)
- (and (comment? object)
- (let ((text (comment-text object)))
- (and (vector? text)
- (not (zero? (vector-length text)))
- (eq? (vector-ref text 0) wrapper-tag)))))
-
- (define (wrapper-state wrapper)
- (vector-ref (comment-text wrapper) 2))
-
- (define (set-wrapper-state! wrapper new-state)
- (vector-set! (comment-text wrapper) 2 new-state))
-
- (define (wrapper-original-body wrapper)
- (vector-ref (comment-text wrapper) 1))
-
- (define (set-wrapper-original-body! wrapper new-body)
- (vector-set! (comment-text wrapper) 1 new-body))
+;;; Please don't use it for anything else.
+
+(define (lambda-body-procedures physical-body set-physical-body! receiver)
+ (receiver
+ (named-lambda (wrap-body! lambda transform)
+ (let ((physical-body (physical-body lambda)))
+ (if (wrapper? physical-body)
+ (transform (wrapper-body physical-body)
+ (wrapper-state physical-body)
+ (lambda (new-body new-state)
+ (set-wrapper-body! physical-body new-body)
+ (set-wrapper-state! physical-body new-state)))
+ (transform physical-body
+ '()
+ (lambda (new-body new-state)
+ (set-physical-body! lambda
+ (make-wrapper physical-body
+ new-body
+ new-state)))))))
+ (named-lambda (wrapper-components lambda receiver)
+ (let ((physical-body (physical-body lambda)))
+ (if (wrapper? physical-body)
+ (receiver (wrapper-original-body physical-body)
+ (wrapper-state physical-body))
+ (receiver physical-body '()))))
+ (named-lambda (unwrap-body! lambda)
+ (let ((physical-body (physical-body lambda)))
+ (if (wrapper? physical-body)
+ (set-physical-body! lambda
+ (wrapper-original-body physical-body)))))
+ (named-lambda (unwrapped-body lambda)
+ (let ((physical-body (physical-body lambda)))
+ (if (wrapper? physical-body)
+ (wrapper-original-body physical-body)
+ physical-body)))
+ (named-lambda (set-unwrapped-body! lambda new-body)
+ (if (wrapper? (physical-body lambda))
+ (set-wrapper-original-body! (physical-body lambda) new-body)
+ (set-physical-body! lambda new-body)))))
\f
- (named-lambda (lambda-body-procedures physical-body set-physical-body!
- receiver)
- (receiver
-
- (named-lambda (wrap-body! lambda transform)
- (let ((physical-body (physical-body lambda)))
- (if (wrapper? physical-body)
- (transform (wrapper-body physical-body)
- (wrapper-state physical-body)
- (lambda (new-body new-state)
- (set-wrapper-body! physical-body new-body)
- (set-wrapper-state! physical-body new-state)))
- (transform physical-body
- '()
- (lambda (new-body new-state)
- (set-physical-body! lambda
- (make-wrapper physical-body
- new-body
- new-state)))))))
-
- (named-lambda (wrapper-components lambda receiver)
- (let ((physical-body (physical-body lambda)))
- (if (wrapper? physical-body)
- (receiver (wrapper-original-body physical-body)
- (wrapper-state physical-body))
- (receiver physical-body
- '()))))
-
- (named-lambda (unwrap-body! lambda)
- (let ((physical-body (physical-body lambda)))
- (if (wrapper? physical-body)
- (set-physical-body! lambda
- (wrapper-original-body physical-body)))))
-
- (named-lambda (unwrapped-body lambda)
- (let ((physical-body (physical-body lambda)))
- (if (wrapper? physical-body)
- (wrapper-original-body physical-body)
- physical-body)))
-
- (named-lambda (set-unwrapped-body! lambda new-body)
- (if (wrapper? (physical-body lambda))
- (set-wrapper-original-body! (physical-body lambda) new-body)
- (set-physical-body! lambda new-body)))
-
- ))
- ))
+(define-integrable (make-wrapper original-body new-body state)
+ (make-comment (vector wrapper-tag original-body state) new-body))
+
+(define (wrapper? object)
+ (and (comment? object)
+ (let ((text (comment-text object)))
+ (and (vector? text)
+ (not (zero? (vector-length text)))
+ (eq? (vector-ref text 0) wrapper-tag)))))
+
+(define wrapper-tag
+ '(LAMBDA-WRAPPER))
+
+(define-integrable (wrapper-body wrapper)
+ (comment-expression wrapper))
+
+(define-integrable (set-wrapper-body! wrapper body)
+ (set-comment-expression! wrapper body))
+
+(define-integrable (wrapper-state wrapper)
+ (vector-ref (comment-text wrapper) 2))
+
+(define-integrable (set-wrapper-state! wrapper new-state)
+ (vector-set! (comment-text wrapper) 2 new-state))
+
+(define-integrable (wrapper-original-body wrapper)
+ (vector-ref (comment-text wrapper) 1))
+
+(define-integrable (set-wrapper-original-body! wrapper body)
+ (vector-set! (comment-text wrapper) 1 body))
\f
;;;; Compound Lambda
required
(if (null? auxiliary)
body
- (make-combination (make-slambda internal-lambda-tag
- auxiliary
- body)
- (map (lambda (auxiliary)
- (make-unassigned-object))
- auxiliary)))))
+ (make-combination (make-internal-lambda auxiliary body)
+ (make-unassigned auxiliary)))))
(define (clambda-components clambda receiver)
(slambda-components clambda
(lambda (name required body)
- (let ((unwrapped-body (clambda-unwrapped-body clambda)))
- (if (combination? body)
- (let ((operator (combination-operator body)))
- (if (is-internal-lambda? operator)
- (slambda-components operator
- (lambda (tag auxiliary body)
- (receiver name required '() '() auxiliary
- unwrapped-body)))
- (receiver name required '() '() '() unwrapped-body)))
- (receiver name required '() '() '() unwrapped-body))))))
+ (receiver name required '() '()
+ (if (combination? body)
+ (let ((operator (combination-operator body)))
+ (if (internal-lambda? operator)
+ (slambda-components operator
+ (lambda (tag auxiliary body)
+ tag body
+ auxiliary))
+ '()))
+ '())
+ (clambda-unwrapped-body clambda)))))
(define (clambda-bound clambda)
(slambda-components clambda
(lambda (name required body)
+ name
(if (combination? body)
(let ((operator (combination-operator body)))
- (if (is-internal-lambda? operator)
+ (if (internal-lambda? operator)
(slambda-components operator
(lambda (tag auxiliary body)
+ tag body
(append required auxiliary)))
required))
required))))
(let ((body (slambda-body clambda)))
(and (combination? body)
(let ((operator (combination-operator body)))
- (and (is-internal-lambda? operator)
+ (and (internal-lambda? operator)
operator)))))
-\f
+
(define clambda-wrap-body!)
(define clambda-wrapper-components)
(define clambda-unwrap-body!)
(define clambda-unwrapped-body)
(define set-clambda-unwrapped-body!)
-(lambda-body-procedures (lambda (clambda)
- (slambda-body
- (or (clambda-has-internal-lambda? clambda)
- clambda)))
- (lambda (clambda new-body)
- (set-slambda-body!
- (or (clambda-has-internal-lambda? clambda)
- clambda)
- new-body))
- (lambda (wrap-body! wrapper-components unwrap-body!
- unwrapped-body set-unwrapped-body!)
- (set! clambda-wrap-body! wrap-body!)
- (set! clambda-wrapper-components wrapper-components)
- (set! clambda-unwrap-body! unwrap-body!)
- (set! clambda-unwrapped-body unwrapped-body)
- (set! set-clambda-unwrapped-body! set-unwrapped-body!)))
+(define (clambda/physical-body clambda)
+ (slambda-body (or (clambda-has-internal-lambda? clambda) clambda)))
+
+(define (clambda/set-physical-body! clambda body)
+ (set-slambda-body! (or (clambda-has-internal-lambda? clambda) clambda) body))
\f
;;;; Compound Lexpr
(define (make-clexpr name required rest auxiliary body)
(make-slexpr name
required
- (make-combination (make-slambda internal-lexpr-tag
- (cons rest auxiliary)
- body)
- (cons (let ((e (make-the-environment)))
- (make-combination
- system-subvector-to-list
- (list e
- (+ (length required) 3)
- (make-combination
- system-vector-size
- (list e)))))
- (map (lambda (auxiliary)
- (make-unassigned-object))
- auxiliary)))))
+ (make-combination
+ (make-internal-lexpr (cons rest auxiliary) body)
+ (cons (let ((environment (make-the-environment)))
+ (make-combination
+ system-subvector->list
+ (list environment
+ (+ (length required) 3)
+ (make-combination system-vector-length
+ (list environment)))))
+ (make-unassigned auxiliary)))))
(define (clexpr-components clexpr receiver)
(slexpr-components clexpr
(lambda (name required body)
(slambda-components (combination-operator body)
(lambda (tag auxiliary body)
+ tag body
(receiver name
required
'()
(define (clexpr-bound clexpr)
(slexpr-components clexpr
(lambda (name required body)
+ name
(slambda-components (combination-operator body)
(lambda (tag auxiliary body)
+ tag body
(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!)
(define clexpr-unwrapped-body)
(define set-clexpr-unwrapped-body!)
-(lambda-body-procedures (lambda (clexpr)
- (slambda-body (clexpr-has-internal-lambda? clexpr)))
- (lambda (clexpr new-body)
- (set-slambda-body!
- (clexpr-has-internal-lambda? clexpr)
- new-body))
- (lambda (wrap-body! wrapper-components unwrap-body!
- unwrapped-body set-unwrapped-body!)
- (set! clexpr-wrap-body! wrap-body!)
- (set! clexpr-wrapper-components wrapper-components)
- (set! clexpr-unwrap-body! unwrap-body!)
- (set! clexpr-unwrapped-body unwrapped-body)
- (set! set-clexpr-unwrapped-body! set-unwrapped-body!)))
+(define (clexpr/physical-body clexpr)
+ (slambda-body (clexpr-has-internal-lambda? clexpr)))
+
+(define (clexpr/set-physical-body! clexpr body)
+ (set-slambda-body! (clexpr-has-internal-lambda? clexpr) body))
\f
;;;; Extended Lambda
+(define-integrable xlambda-type
+ (ucode-type extended-lambda))
+
(define (make-xlambda name required optional rest auxiliary body)
(&typed-triple-cons xlambda-type
body
(list->vector
- `(,name ,@required
- ,@optional
- ,@(if (null? rest)
- auxiliary
- (cons rest auxiliary))))
+ (cons name
+ (append required
+ optional
+ (if (null? rest)
+ auxiliary
+ (cons rest auxiliary)))))
(make-non-pointer-object
(+ (length optional)
(* 256
- (+ (length required)
- (if (null? rest) 0 256)))))))
+ (+ (length required) (if (null? rest) 0 256)))))))
+
+(define-integrable (xlambda? object)
+ (object-type? xlambda-type object))
(define (xlambda-components xlambda receiver)
- (let ((qr1 (integer-divide (primitive-datum (&triple-third xlambda)) 256)))
+ (let ((qr1 (integer-divide (object-datum (&triple-third xlambda)) 256)))
(let ((qr2 (integer-divide (car qr1) 256)))
(let ((ostart (1+ (cdr qr2))))
(let ((rstart (+ ostart (cdr qr1))))
(subvector->list names 1 (vector-length names))))
(define (xlambda-has-internal-lambda? xlambda)
+ xlambda
false)
-\f
+
(define xlambda-wrap-body!)
(define xlambda-wrapper-components)
(define xlambda-unwrap-body!)
(define xlambda-unwrapped-body)
(define set-xlambda-unwrapped-body!)
-
-(lambda-body-procedures &triple-first &triple-set-first!
- (lambda (wrap-body! wrapper-components unwrap-body!
- unwrapped-body set-unwrapped-body!)
- (set! xlambda-wrap-body! wrap-body!)
- (set! xlambda-wrapper-components wrapper-components)
- (set! xlambda-unwrap-body! 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)
- (primitive-type? slexpr-type object)
- (primitive-type? xlambda-type object))))
-
-(define (is-internal-lambda? lambda)
- (and (primitive-type? slambda-type lambda)
- (memq (slambda-name lambda) internal-lambda-tags)))
+(define (lambda? object)
+ (or (slambda? object)
+ (slexpr? object)
+ (xlambda? object)))
-(set! make-lambda
-(named-lambda (make-lambda name required optional rest auxiliary
- declarations body)
+(define (make-lambda name required optional rest auxiliary declarations body)
(let ((body* (if (null? declarations)
body
(make-sequence (list (make-block-declaration declarations)
((null? rest)
(make-clambda name required auxiliary body*))
(else
- (make-clexpr name required rest auxiliary body*))))))
+ (make-clexpr name required rest auxiliary body*)))))
-(set! lambda-components
-(named-lambda (lambda-components lambda receiver)
+(define (lambda-components lambda receiver)
(&lambda-components lambda
(lambda (name required optional rest auxiliary body)
(let ((actions (and (sequence? body)
(receiver name required optional rest auxiliary
(block-declaration-text (car actions))
(make-sequence (cdr actions)))
- (receiver name required optional rest auxiliary '() body)))))))
-
+ (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)
+ ((cond ((slambda? lambda) clambda-op)
+ ((slexpr? lambda) clexpr-op)
+ ((xlambda? 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)
- ((primitive-type? xlambda-type lambda) xlambda-op)
+ ((cond ((slambda? lambda) clambda-op)
+ ((slexpr? lambda) clexpr-op)
+ ((xlambda? lambda) xlambda-op)
(else (error "Not a lambda" op-name lambda)))
lambda arg))
-(define &lambda-components
- (dispatch-1 'LAMBDA-COMPONENTS
- clambda-components
- clexpr-components
- xlambda-components))
-
-(define has-internal-lambda?
- (dispatch-0 'HAS-INTERNAL-LAMBDA?
- clambda-has-internal-lambda?
- clexpr-has-internal-lambda?
- xlambda-has-internal-lambda?))
-
-(define lambda-wrap-body!
- (dispatch-1 'LAMBDA-WRAP-BODY!
- clambda-wrap-body!
- clexpr-wrap-body!
- xlambda-wrap-body!))
-
-(define lambda-wrapper-components
- (dispatch-1 'LAMBDA-WRAPPER-COMPONENTS
- clambda-wrapper-components
- clexpr-wrapper-components
- xlambda-wrapper-components))
-
-(define lambda-unwrap-body!
- (dispatch-0 'LAMBDA-UNWRAP-BODY!
- clambda-unwrap-body!
- clexpr-unwrap-body!
- xlambda-unwrap-body!))
-
-(set! lambda-body
- (dispatch-0 'LAMBDA-BODY
- clambda-unwrapped-body
- clexpr-unwrapped-body
- xlambda-unwrapped-body))
-
-(set! set-lambda-body!
- (dispatch-1 'SET-LAMBDA-BODY!
- set-clambda-unwrapped-body!
- set-clexpr-unwrapped-body!
- set-xlambda-unwrapped-body!))
-
-(set! lambda-bound
- (dispatch-0 'LAMBDA-BOUND
- clambda-bound
- clexpr-bound
- xlambda-bound))
+(define &lambda-components)
+(define has-internal-lambda?)
+(define lambda-wrap-body!)
+(define lambda-wrapper-components)
+(define lambda-unwrap-body!)
+(define lambda-body)
+(define set-lambda-body!)
+(define lambda-bound)
+
+(define-integrable (make-block-declaration text)
+ (vector block-declaration-tag text))
+
+(define (block-declaration? object)
+ (and (vector? object)
+ (not (zero? (vector-length object)))
+ (eq? (vector-ref object 0) block-declaration-tag)))
+
+(define-integrable (block-declaration-text block-declaration)
+ (vector-ref block-declaration 1))
+
+(define block-declaration-tag)
\f
;;;; Simple Lambda/Lexpr
-(define (make-slambda name required body)
+(define-integrable slambda-type
+ (ucode-type lambda))
+
+(define-integrable (make-slambda name required body)
(&typed-pair-cons slambda-type body (list->vector (cons name required))))
+(define-integrable (slambda? object)
+ (object-type? slambda-type object))
+
(define (slambda-components slambda receiver)
(let ((bound (&pair-cdr slambda)))
(receiver (vector-ref bound 0)
(subvector->list bound 1 (vector-length bound))
(&pair-car slambda))))
-(define (slambda-name slambda)
+(define-integrable (slambda-name slambda)
(vector-ref (&pair-cdr slambda) 0))
-(define slambda-body &pair-car)
-(define set-slambda-body! &pair-set-car!)
+(define-integrable (slambda-body slambda)
+ (&pair-car slambda))
-(define (make-slexpr name required body)
- (&typed-pair-cons slexpr-type body (list->vector (cons name required))))
+(define-integrable (set-slambda-body! slambda body)
+ (&pair-set-car! slambda body))
-(define slexpr-components slambda-components)
-(define slexpr-body slambda-body)
+(define-integrable slexpr-type
+ (ucode-type lexpr))
-;;; end LAMBDA-PACKAGE.
-(the-environment)))
-\f
-;;;; Alternative Component Views
-
-(define (make-lambda* name required optional rest body)
- (scan-defines body
- (lambda (auxiliary declarations body*)
- (make-lambda name required optional rest auxiliary declarations body*))))
+(define-integrable (make-slexpr name required body)
+ (&typed-pair-cons slexpr-type body (list->vector (cons name required))))
-(define (lambda-components* lambda receiver)
- (lambda-components lambda
- (lambda (name required optional rest auxiliary declarations body)
- (receiver name required optional rest
- (make-open-block auxiliary declarations body)))))
+(define-integrable (slexpr? object)
+ (object-type? slexpr-type object))
-(define (lambda-components** lambda receiver)
- (lambda-components* lambda
- (lambda (name required optional rest body)
- (receiver (vector name required optional rest)
- (append required optional (if (null? rest) '() (list rest)))
- body))))
+(define (slexpr-components slexpr receiver)
+ (let ((bound (&pair-cdr slexpr)))
+ (receiver (vector-ref bound 0)
+ (subvector->list bound 1 (vector-length bound))
+ (&pair-car slexpr))))
-(define (lambda-pattern/name pattern)
- (vector-ref pattern 0))
+(define-integrable (slexpr-body slexpr)
+ (&pair-car slexpr))
+\f
+;;;; Internal Lambda
-(define (lambda-pattern/required pattern)
- (vector-ref pattern 1))
+(define lambda-tag:internal-lambda)
+(define lambda-tag:internal-lexpr)
-(define (lambda-pattern/optional pattern)
- (vector-ref pattern 2))
+(define-integrable (make-internal-lambda names body)
+ (make-slambda lambda-tag:internal-lambda names body))
-(define (lambda-pattern/rest pattern)
- (vector-ref pattern 3))
+(define-integrable (make-internal-lexpr names body)
+ (make-slambda lambda-tag:internal-lexpr names body))
-(define (make-lambda** pattern bound body)
+(define (internal-lambda? lambda)
+ (and (slambda? lambda)
+ (or (eq? (slambda-name lambda) lambda-tag:internal-lambda)
+ (eq? (slambda-name lambda) lambda-tag:internal-lexpr))))
- (define (split pattern bound receiver)
- (cond ((null? pattern)
- (receiver '() bound))
- (else
- (split (cdr pattern) (cdr bound)
- (lambda (copy tail)
- (receiver (cons (car bound) copy)
- tail))))))
-
- (split (lambda-pattern/required pattern) bound
- (lambda (required tail)
- (split (lambda-pattern/optional pattern) tail
- (lambda (optional rest)
- (make-lambda* (lambda-pattern/name pattern)
- required
- optional
- (if (null? rest) rest (car rest))
- body))))))
\ No newline at end of file
+(define (make-unassigned auxiliary)
+ (map (lambda (auxiliary)
+ auxiliary
+ (make-unassigned-reference-trap))
+ auxiliary))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambdx.scm,v 14.1 1988/05/20 00:58:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambdx.scm,v 14.2 1988/06/13 11:47:06 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Alternative Components for Lambda
+;;; package: ()
(declare (usual-integrations))
\f
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/list.scm,v 13.43 1988/05/03 18:55:13 jinx Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/list.scm,v 14.1 1988/06/13 11:47:11 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; List Operations
+;;; package: (runtime list)
(declare (usual-integrations))
\f
-;;; This IN-PACKAGE is just a kludge to prevent the definitions of the
-;;; primitives from shadowing the USUAL-INTEGRATIONS declaration.
-#| Temporarily relocated to `boot.scm' to help compiler.
-(in-package system-global-environment
-(let-syntax ()
- (define-macro (define-primitives . names)
- `(BEGIN ,@(map (lambda (name)
- `(DEFINE ,name ,(make-primitive-procedure name)))
- names)))
- (define-primitives
- cons pair? null? length car cdr set-car! set-cdr!
- general-car-cdr memq assq)))|#
-
-(define (list . elements)
- elements)
-
-(define (list? frob)
- (cond ((pair? frob) (list? (cdr frob)))
- ((null? frob) true)
- (else false)))
+(define-primitives
+ cons pair? null? length car cdr set-car! set-cdr! general-car-cdr)
+
+(define (list . items)
+ items)
(define (cons* first-element . rest-elements)
- (define (loop this-element rest-elements)
+ (let loop ((this-element first-element) (rest-elements rest-elements))
(if (null? rest-elements)
this-element
(cons this-element
(loop (car rest-elements)
- (cdr rest-elements)))))
- (loop first-element rest-elements))
+ (cdr rest-elements))))))
+
+(define (make-list length #!optional value)
+ (if (not (and (integer? length) (not (negative? length))))
+ (error "MAKE-LIST: length must be nonnegative integer" length))
+ (let ((value (if (default-object? value) '() value)))
+ (let loop ((n length) (result '()))
+ (if (zero? n)
+ result
+ (loop (-1+ n) (cons value result))))))
+
+(define (circular-list . items)
+ (if (not (null? items))
+ (let loop ((l items))
+ (if (null? (cdr l))
+ (set-cdr! l items)
+ (loop (cdr l)))))
+ items)
+
+(define (make-circular-list length #!optional value)
+ (if (not (and (integer? length) (not (negative? length))))
+ (error "MAKE-CIRCULAR-LIST: length must be nonnegative integer" length))
+ (if (positive? length)
+ (let ((value (if (default-object? value) '() value)))
+ (let ((last (cons value '())))
+ (let loop ((n (-1+ length)) (result last))
+ (if (zero? n)
+ (begin
+ (set-cdr! last result)
+ result)
+ (loop (-1+ n) (cons value result))))))
+ '()))
+\f
+(define (list-ref list index)
+ (let ((tail (list-tail list index)))
+ (if (not (pair? tail))
+ (error "LIST-REF: index too large" index))
+ (car tail)))
+
+(define (list-tail list index)
+ (if (not (and (integer? index) (not (negative? index))))
+ (error "LIST-TAIL: index must be nonnegative integer" index))
+ (let loop ((list list) (index index))
+ (if (zero? index)
+ list
+ (begin (if (not (pair? list))
+ (error "LIST-TAIL: index too large" index))
+ (loop (cdr list) (-1+ index))))))
+
+(define (list-head list index)
+ (if (not (and (integer? index) (not (negative? index))))
+ (error "LIST-HEAD: index must be nonnegative integer" index))
+ (let loop ((list list) (index index))
+ (if (zero? index)
+ '()
+ (begin
+ (if (not (pair? list))
+ (error "LIST-HEAD: list has too few elements" list index))
+ (cons (car list) (loop (cdr list) (-1+ index)))))))
+
+(define (sublist list start end)
+ (list-head (list-tail list start) (- end start)))
+\f
+(define (list? object)
+ (let loop ((object object))
+ (if (null? object)
+ true
+ (and (pair? object)
+ (loop (cdr object))))))
+
+(define (alist? object)
+ (if (null? object)
+ true
+ (and (pair? object)
+ (pair? (car object))
+ (alist? (cdr object)))))
+
+(define (list-copy items)
+ (let loop ((items items))
+ (if (pair? items)
+ (cons (car items) (loop (cdr items)))
+ (begin (if (not (null? items))
+ (error "LIST-COPY: argument not proper list" items))
+ '()))))
+
+(define (alist-copy alist)
+ (if (pair? alist)
+ (begin (if (not (pair? (car alist)))
+ (error "ALIST-COPY: illegal alist element" (car alist)))
+ (cons (cons (caar alist) (cdar alist)) (alist-copy (cdr alist))))
+ (begin (if (not (null? alist))
+ (error "ALIST-COPY: illegal alist" alist))
+ '())))
+
+(define (tree-copy tree)
+ (let loop ((tree tree))
+ (if (pair? tree)
+ (cons (loop (car tree)) (loop (cdr tree)))
+ tree)))
+\f
+;;;; Weak Pairs
+
+(define-integrable (weak-cons car cdr)
+ (system-pair-cons (ucode-type weak-cons) (or car weak-pair/false) cdr))
-(define (make-list size #!optional value)
- (subvector->list (vector-cons size (if (unassigned? value) '() value))
- 0
- size))
+(define-integrable (weak-pair? object)
+ (object-type? (ucode-type weak-cons) object))
-(define (list-copy elements)
- (apply list elements))
+(define-integrable (weak-pair/car? weak-pair)
+ (system-pair-car weak-pair))
-(define (list-ref l n)
- (cond ((not (pair? l)) (error "LIST-REF: Bad argument" l n))
- ((zero? n) (car l))
- (else (list-ref (cdr l) (-1+ n)))))
+(define (weak-car weak-pair)
+ (let ((car (system-pair-car weak-pair)))
+ (and (not (eq? car weak-pair/false))
+ car)))
-(define (list-tail l n)
- (cond ((zero? n) l)
- ((pair? l) (list-tail (cdr l) (-1+ n)))
- (else (error "LIST-TAIL: Bad argument" l))))
+(define-integrable (weak-set-car! weak-pair object)
+ (system-pair-set-car! weak-pair (or object weak-pair/false)))
-(define the-empty-stream '())
-(define empty-stream? null?)
-(define head car)
+(define-integrable (weak-cdr weak-pair)
+ (system-pair-cdr weak-pair))
-(define (tail stream)
- (force (cdr stream)))
+(define-integrable (weak-set-cdr! weak-pair object)
+ (system-pair-set-cdr! weak-pair object))
+
+(define weak-pair/false
+ "weak-pair/false")
\f
;;;; Standard Selectors
-(define (cddr x) (general-car-cdr x #o4))
-(define (cdar x) (general-car-cdr x #o5))
-(define (cadr x) (general-car-cdr x #o6))
-(define (caar x) (general-car-cdr x #o7))
-
-(define (cdddr x) (general-car-cdr x #o10))
-(define (cddar x) (general-car-cdr x #o11))
-(define (cdadr x) (general-car-cdr x #o12))
-(define (cdaar x) (general-car-cdr x #o13))
-(define (caddr x) (general-car-cdr x #o14))
-(define (cadar x) (general-car-cdr x #o15))
-(define (caadr x) (general-car-cdr x #o16))
-(define (caaar x) (general-car-cdr x #o17))
-
-(define (cddddr x) (general-car-cdr x #o20))
-(define (cdddar x) (general-car-cdr x #o21))
-(define (cddadr x) (general-car-cdr x #o22))
-(define (cddaar x) (general-car-cdr x #o23))
-(define (cdaddr x) (general-car-cdr x #o24))
-(define (cdadar x) (general-car-cdr x #o25))
-(define (cdaadr x) (general-car-cdr x #o26))
-(define (cdaaar x) (general-car-cdr x #o27))
-(define (cadddr x) (general-car-cdr x #o30))
-(define (caddar x) (general-car-cdr x #o31))
-(define (cadadr x) (general-car-cdr x #o32))
-(define (cadaar x) (general-car-cdr x #o33))
-(define (caaddr x) (general-car-cdr x #o34))
-(define (caadar x) (general-car-cdr x #o35))
-(define (caaadr x) (general-car-cdr x #o36))
-(define (caaaar x) (general-car-cdr x #o37))
-
-(define first car)
-(define (second x) (general-car-cdr x #o6))
-(define (third x) (general-car-cdr x #o14))
-(define (fourth x) (general-car-cdr x #o30))
-(define (fifth x) (general-car-cdr x #o60))
-(define (sixth x) (general-car-cdr x #o140))
-(define (seventh x) (general-car-cdr x #o300))
-(define (eighth x) (general-car-cdr x #o600))
+(define-integrable (caar x) (car (car x)))
+(define-integrable (cadr x) (car (cdr x)))
+(define-integrable (cdar x) (cdr (car x)))
+(define-integrable (cddr x) (cdr (cdr x)))
+
+(define-integrable (caaar x) (car (car (car x))))
+(define-integrable (caadr x) (car (car (cdr x))))
+(define-integrable (cadar x) (car (cdr (car x))))
+(define-integrable (caddr x) (car (cdr (cdr x))))
+
+(define-integrable (cdaar x) (cdr (car (car x))))
+(define-integrable (cdadr x) (cdr (car (cdr x))))
+(define-integrable (cddar x) (cdr (cdr (car x))))
+(define-integrable (cdddr x) (cdr (cdr (cdr x))))
+
+(define-integrable (caaaar x) (car (car (car (car x)))))
+(define-integrable (caaadr x) (car (car (car (cdr x)))))
+(define-integrable (caadar x) (car (car (cdr (car x)))))
+(define-integrable (caaddr x) (car (car (cdr (cdr x)))))
+
+(define-integrable (cadaar x) (car (cdr (car (car x)))))
+(define-integrable (cadadr x) (car (cdr (car (cdr x)))))
+(define-integrable (caddar x) (car (cdr (cdr (car x)))))
+(define-integrable (cadddr x) (car (cdr (cdr (cdr x)))))
+
+(define-integrable (cdaaar x) (cdr (car (car (car x)))))
+(define-integrable (cdaadr x) (cdr (car (car (cdr x)))))
+(define-integrable (cdadar x) (cdr (car (cdr (car x)))))
+(define-integrable (cdaddr x) (cdr (car (cdr (cdr x)))))
+
+(define-integrable (cddaar x) (cdr (cdr (car (car x)))))
+(define-integrable (cddadr x) (cdr (cdr (car (cdr x)))))
+(define-integrable (cdddar x) (cdr (cdr (cdr (car x)))))
+(define-integrable (cddddr x) (cdr (cdr (cdr (cdr x)))))
+
+(define-integrable (first x) (car x))
+(define-integrable (second x) (car (cdr x)))
+(define-integrable (third x) (car (cdr (cdr x))))
+(define-integrable (fourth x) (car (cdr (cdr (cdr x)))))
+(define-integrable (fifth x) (car (cdr (cdr (cdr (cdr x))))))
+(define-integrable (sixth x) (car (cdr (cdr (cdr (cdr (cdr x)))))))
+(define-integrable (seventh x) (car (cdr (cdr (cdr (cdr (cdr (cdr x))))))))
+
+(define-integrable (eighth x)
+ (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr x)))))))))
+
+(define-integrable (ninth x)
+ (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr x))))))))))
+
+(define-integrable (tenth x)
+ (car (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr (cdr x)))))))))))
\f
;;;; Sequence Operations
(define (append . lists)
- (define (outer current remaining)
- (define (inner list)
- (cond ((pair? list) (cons (car list) (inner (cdr list))))
- ((null? list) (outer (car remaining) (cdr remaining)))
- (else (error "APPEND: Argument not a list" current))))
- (if (null? remaining)
- current
- (inner current)))
(if (null? lists)
'()
- (outer (car lists) (cdr lists))))
+ (let outer ((current (car lists)) (remaining (cdr lists)))
+ (if (null? remaining)
+ current
+ (let inner ((list current))
+ (if (pair? list)
+ (cons (car list) (inner (cdr list)))
+ (begin (if (not (null? list))
+ (error "APPEND: Argument not a list" current))
+ (outer (car remaining) (cdr remaining)))))))))
(define (append! . lists)
- (define (loop head tail)
- (cond ((null? tail) head)
- ((pair? head)
- (set-cdr! (last-pair head) (loop (car tail) (cdr tail)))
- head)
- ((null? head) (loop (car tail) (cdr tail)))
- (else (error "APPEND!: Argument not a list" head))))
(if (null? lists)
'()
- (loop (car lists) (cdr lists))))
+ (let loop ((head (car lists)) (tail (cdr lists)))
+ (cond ((null? tail)
+ head)
+ ((pair? head)
+ (set-cdr! (last-pair head) (loop (car tail) (cdr tail)))
+ head)
+ (else
+ (if (not (null? head))
+ (error "APPEND!: Argument not a list" head))
+ (loop (car tail) (cdr tail)))))))
(define (reverse l)
- (define (loop rest so-far)
- (cond ((pair? rest) (loop (cdr rest) (cons (car rest) so-far)))
- ((null? rest) so-far)
- (else (error "REVERSE: Argument not a list" l))))
- (loop l '()))
+ (let loop ((rest l) (so-far '()))
+ (if (pair? rest)
+ (loop (cdr rest) (cons (car rest) so-far))
+ (begin (if (not (null? rest))
+ (error "REVERSE: Argument not a list" l))
+ so-far))))
(define (reverse! l)
- (define (loop current new-cdr)
- (cond ((pair? current) (loop (set-cdr! current new-cdr) current))
- ((null? current) new-cdr)
- (else (error "REVERSE!: Argument not a list" l))))
- (loop l '()))
+ (let loop ((current l) (new-cdr '()))
+ (if (pair? current)
+ (loop (set-cdr! current new-cdr) current)
+ (begin (if (not (null? current))
+ (error "REVERSE!: Argument not a list" l))
+ new-cdr))))
\f
;;;; Mapping Procedures
(define (map f . lists)
- (cond ((null? lists)
- (error "MAP: Too few arguments" f))
- ((null? (cdr lists))
- (let 1-loop ((list (car lists)))
- (cond ((pair? list)
- (cons (f (car list))
- (1-loop (cdr list))))
- ((null? list)
- '())
- (else
- (error "MAP: Argument not a list" (car lists))))))
- (else
- (let n-loop ((lists lists))
- (let parse-cars
- ((lists lists)
- (receiver
- (lambda (cars cdrs)
- (cons (apply f cars)
- (n-loop cdrs)))))
- (cond ((null? lists)
- (receiver '() '()))
- ((null? (car lists))
- '())
- ((pair? (car lists))
- (parse-cars (cdr lists)
- (lambda (cars cdrs)
- (receiver (cons (car (car lists)) cars)
- (cons (cdr (car lists)) cdrs)))))
- (else
- (error "MAP: Argument not a list" (car lists)))))))))
-\f
+ ;; Compiler doesn't, but ought to, make this very fast.
+ (apply map* '() f lists))
+
(define (map* initial-value f . lists)
- (cond ((null? lists)
- (error "MAP*: Too few arguments" f))
- ((null? (cdr lists))
- (let 1-loop ((list (car lists)))
- (cond ((pair? list)
- (cons (f (car list))
- (1-loop (cdr list))))
- ((null? list)
- initial-value)
- (else
- (error "MAP*: Argument not a list" (car lists))))))
- (else
- (let n-loop ((lists lists))
- (let parse-cars
- ((lists lists)
- (receiver
- (lambda (cars cdrs)
- (cons (apply f cars)
- (n-loop cdrs)))))
- (cond ((null? lists)
- (receiver '() '()))
- ((null? (car lists))
- initial-value)
- ((pair? (car lists))
- (parse-cars (cdr lists)
- (lambda (cars cdrs)
- (receiver (cons (car (car lists)) cars)
- (cons (cdr (car lists)) cdrs)))))
- (else
- (error "MAP*: Argument not a list" (car lists)))))))))
-\f
-(define (for-each f . lists)
- (cond ((null? lists)
- (error "FOR-EACH: Too few arguments" f))
- ((null? (cdr lists))
- (let 1-loop ((list (car lists)))
- (cond ((pair? list)
- (f (car list))
+ (if (null? lists)
+ (error "MAP*: Too few arguments" f))
+ (if (null? (cdr lists))
+ (let 1-loop ((list (car lists)))
+ (if (pair? list)
+ (cons (f (car list))
(1-loop (cdr list)))
- ((null? list)
- *the-non-printing-object*)
- (else
- (error "FOR-EACH: Argument not a list" (car lists))))))
- (else
- (let n-loop ((lists lists))
- (let parse-cars
- ((lists lists)
- (receiver
- (lambda (cars cdrs)
- (apply f cars)
- (n-loop cdrs))))
- (cond ((null? lists)
- (receiver '() '()))
- ((null? (car lists))
- *the-non-printing-object*)
- ((pair? (car lists))
- (parse-cars (cdr lists)
- (lambda (cars cdrs)
- (receiver (cons (car (car lists)) cars)
- (cons (cdr (car lists)) cdrs)))))
- (else
- (error "FOR-EACH: Argument not a list" (car lists)))))))))
-
-(define mapcar map)
-(define mapcar* map*)
-(define mapc for-each)
-\f
+ (begin
+ (if (not (null? list))
+ (error "MAP*: Argument not a list" list))
+ initial-value)))
+ (let n-loop ((lists lists))
+ (let parse-cars
+ ((lists lists)
+ (receiver
+ (lambda (cars cdrs)
+ (cons (apply f cars)
+ (n-loop cdrs)))))
+ (cond ((null? lists)
+ (receiver '() '()))
+ ((pair? (car lists))
+ (parse-cars (cdr lists)
+ (lambda (cars cdrs)
+ (receiver (cons (car (car lists)) cars)
+ (cons (cdr (car lists)) cdrs)))))
+ (else
+ (if (not (null? (car lists)))
+ (error "MAP*: Argument not a list" (car lists)))
+ initial-value))))))
+
(define (reduce f initial list)
- (define (loop value l)
- (cond ((pair? l)
- (loop (f value (car l))
- (cdr l)))
- ((null? l)
- value)
- (else
- (error "REDUCE: Argument not a list" list))))
- (loop initial list))
-
-(define (there-exists? predicate)
- (define (loop objects)
- (and (pair? objects)
- (or (predicate (car objects))
- (loop (cdr objects)))))
- loop)
-
-(define (for-all? predicate)
- (define (loop objects)
- (if (pair? objects)
- (and (predicate (car objects))
- (loop (cdr objects)))
- true))
- loop)
+ (let loop ((value initial) (l list))
+ (cond ((pair? l) (loop (f value (car l)) (cdr l)))
+ ((null? l) value)
+ (else (error "REDUCE: Argument not a list" list)))))
\f
-;;;; Generalized List Operations
-
-(define (positive-list-searcher predicate if-win if-lose)
- (define (list-searcher-loop list)
- (if (pair? list)
- (if (predicate list)
- (if-win list)
- (list-searcher-loop (cdr list)))
- (and if-lose (if-lose))))
- list-searcher-loop)
-
-(define (negative-list-searcher predicate if-win if-lose)
- (define (list-searcher-loop list)
- (if (pair? list)
- (if (predicate list)
- (list-searcher-loop (cdr list))
- (if-win list))
- (and if-lose (if-lose))))
- list-searcher-loop)
-
-(define (positive-list-transformer predicate tail)
- (define (list-transform-loop list)
- (if (pair? list)
- (if (predicate (car list))
- (cons (car list)
- (list-transform-loop (cdr list)))
- (list-transform-loop (cdr list)))
- tail))
- list-transform-loop)
-
-(define (negative-list-transformer predicate tail)
- (define (list-transform-loop list)
- (if (pair? list)
- (if (predicate (car list))
- (list-transform-loop (cdr list))
- (cons (car list)
- (list-transform-loop (cdr list))))
- tail))
- list-transform-loop)
+(define (for-each f . lists)
+ (if (null? lists)
+ (error "FOR-EACH: Too few arguments" f))
+ (if (null? (cdr lists))
+ (let 1-loop ((list (car lists)))
+ (cond ((pair? list)
+ (f (car list))
+ (1-loop (cdr list)))
+ ((not (null? list))
+ (error "FOR-EACH: Argument not a list" list))))
+ (let n-loop ((lists lists))
+ (let parse-cars
+ ((lists lists)
+ (receiver
+ (lambda (cars cdrs)
+ (apply f cars)
+ (n-loop cdrs))))
+ (cond ((null? lists)
+ (receiver '() '()))
+ ((pair? (car lists))
+ (parse-cars (cdr lists)
+ (lambda (cars cdrs)
+ (receiver (cons (car (car lists)) cars)
+ (cons (cdr (car lists)) cdrs)))))
+ ((not (null? (car lists)))
+ (error "FOR-EACH: Argument not a list" (car lists)))))))
+ *the-non-printing-object*)
+
+(define (mapcan f . lists)
+ ;; Compiler doesn't, but ought to, make this very fast.
+ (apply mapcan* '() f lists))
+
+(define (mapcan* initial-value f . lists)
+ (if (null? lists)
+ (error "MAPCAN*: Too few arguments" f))
+ (let loop ((lists lists))
+ (let scan
+ ((lists lists)
+ (c (lambda (cars cdrs)
+ (append! (apply f cars) (loop cdrs)))))
+ (cond ((null? lists) (c '() '()))
+ ((null? (car lists)) initial-value)
+ (else
+ (scan (cdr lists)
+ (lambda (cars cdrs)
+ (c (cons (car (car lists)) cars)
+ (cons (cdr (car lists)) cdrs)))))))))
\f
-(define (list-deletor predicate)
- (define (list-deletor-loop list)
- (if (pair? list)
- (if (predicate (car list))
- (list-deletor-loop (cdr list))
- (cons (car list) (list-deletor-loop (cdr list))))
- '()))
- list-deletor-loop)
+;;;; Generalized List Operations
-(define (list-deletor! predicate)
- (define (trim-initial-segment list)
- (if (pair? list)
- (if (predicate (car list))
- (trim-initial-segment (cdr list))
- (begin (locate-initial-segment list (cdr list))
- list))
- list))
- (define (locate-initial-segment last this)
- (if (pair? this)
- (if (predicate (car this))
- (set-cdr! last (trim-initial-segment (cdr this)))
- (locate-initial-segment this (cdr this)))
- this))
- trim-initial-segment)
-
-(define (list-transform-positive list predicate)
- (let loop ((list list))
- (if (pair? list)
- (if (predicate (car list))
- (cons (car list) (loop (cdr list)))
- (loop (cdr list)))
+(define (list-transform-positive items predicate)
+ (let loop ((items items))
+ (if (pair? items)
+ (if (predicate (car items))
+ (cons (car items) (loop (cdr items)))
+ (loop (cdr items)))
'())))
-(define (list-transform-negative list predicate)
- (let loop ((list list))
- (if (pair? list)
- (if (predicate (car list))
- (loop (cdr list))
- (cons (car list) (loop (cdr list))))
+(define (list-transform-negative items predicate)
+ (let loop ((items items))
+ (if (pair? items)
+ (if (predicate (car items))
+ (loop (cdr items))
+ (cons (car items) (loop (cdr items))))
'())))
-(define (list-search-positive list predicate)
- (let loop ((list list))
- (and (pair? list)
- (if (predicate (car list))
- (car list)
- (loop (cdr list))))))
-
-(define (list-search-negative list predicate)
- (let loop ((list list))
- (and (pair? list)
- (if (predicate (car list))
- (loop (cdr list))
- (car list)))))
-\f
-;;;; Membership Lists
-
-(define (member-procedure predicate)
- (lambda (element list)
- (let loop ((list list))
- (and (pair? list)
- (if (predicate (car list) element)
- list
- (loop (cdr list)))))))
+(define (list-search-positive items predicate)
+ (let loop ((items items))
+ (and (pair? items)
+ (if (predicate (car items))
+ (car items)
+ (loop (cdr items))))))
-;(define memq (member-procedure eq?))
-(define memv (member-procedure eqv?))
-(define member (member-procedure equal?))
+(define (list-search-negative items predicate)
+ (let loop ((items items))
+ (and (pair? items)
+ (if (predicate (car items))
+ (loop (cdr items))
+ (car items)))))
-(define (delete-member-procedure deletor predicate)
- (lambda (element list)
- ((deletor (lambda (match)
- (predicate match element)))
- list)))
+(define ((list-deletor predicate) items)
+ (list-transform-negative items predicate))
-(define delq (delete-member-procedure list-deletor eq?))
-(define delv (delete-member-procedure list-deletor eqv?))
-(define delete (delete-member-procedure list-deletor equal?))
+(define (list-deletor! predicate)
+ (letrec ((trim-initial-segment
+ (lambda (items)
+ (if (pair? items)
+ (if (predicate (car items))
+ (trim-initial-segment (cdr items))
+ (begin (locate-initial-segment items (cdr items))
+ items))
+ items)))
+ (locate-initial-segment
+ (lambda (last this)
+ (if (pair? this)
+ (if (predicate (car this))
+ (set-cdr! last (trim-initial-segment (cdr this)))
+ (locate-initial-segment this (cdr this)))
+ this))))
+ trim-initial-segment))
+\f
+;;;; Membership/Association Lists
+
+(define (initialize-package!)
+ (set! memv (member-procedure eqv?))
+ (set! member (member-procedure equal?))
+ (set! delv (delete-member-procedure list-deletor eqv?))
+ (set! delete (delete-member-procedure list-deletor equal?))
+ (set! delv! (delete-member-procedure list-deletor! eqv?))
+ (set! delete! (delete-member-procedure list-deletor! equal?))
+ (set! assv (association-procedure eqv? car))
+ (set! assoc (association-procedure equal? car))
+ (set! del-assq (delete-association-procedure list-deletor eq? car))
+ (set! del-assv (delete-association-procedure list-deletor eqv? car))
+ (set! del-assoc (delete-association-procedure list-deletor equal? car))
+ (set! del-assq! (delete-association-procedure list-deletor! eq? car))
+ (set! del-assv! (delete-association-procedure list-deletor! eqv? car))
+ (set! del-assoc! (delete-association-procedure list-deletor! equal? car)))
+
+(define memv)
+(define member)
+(define delv)
+(define delete)
+(define delv!)
+(define delete!)
+(define assv)
+(define assoc)
+(define del-assq)
+(define del-assv)
+(define del-assoc)
+(define del-assq!)
+(define del-assv!)
+(define del-assoc!)
-(define delq! (delete-member-procedure list-deletor! eq?))
-(define delv! (delete-member-procedure list-deletor! eqv?))
-(define delete! (delete-member-procedure list-deletor! equal?))
+(define (member-procedure predicate)
+ (lambda (item items)
+ (let loop ((items items))
+ (and (pair? items)
+ (if (predicate (car items) item)
+ items
+ (loop (cdr items)))))))
-;;;; Association Lists
+(define ((delete-member-procedure deletor predicate) item items)
+ ((deletor (lambda (match) (predicate match item))) items))
(define (association-procedure predicate selector)
(lambda (key alist)
(car alist)
(loop (cdr alist)))))))
-;(define assq (association-procedure eq? car))
-(define assv (association-procedure eqv? car))
-(define assoc (association-procedure equal? car))
-
(define ((delete-association-procedure deletor predicate selector) key alist)
- ((deletor (lambda (association)
- (predicate (selector association) key)))
- alist))
-
-(define del-assq (delete-association-procedure list-deletor eq? car))
-(define del-assv (delete-association-procedure list-deletor eqv? car))
-(define del-assoc (delete-association-procedure list-deletor equal? car))
+ ((deletor (lambda (entry) (predicate (selector entry) key))) alist))
+\f
+;;; The following could be defined using the generic procedures above,
+;;; but the compiler produces better code for them this way. The only
+;;; reason to use these procedures is speed, so we crank them up.
+
+(define (memq item items)
+ (let loop ((items items))
+ (and (pair? items)
+ (if (eq? (car items) item)
+ items
+ (loop (cdr items))))))
+
+(define (assq key alist)
+ (let loop ((alist alist))
+ (and (pair? alist)
+ (if (eq? (caar alist) key)
+ (car alist)
+ (loop (cdr alist))))))
+
+(define (delq item items)
+ (let loop ((items items))
+ (if (pair? items)
+ (if (eq? item (car items))
+ (loop (cdr items))
+ (cons (car items) (loop (cdr items))))
+ '())))
-(define del-assq! (delete-association-procedure list-deletor! eq? car))
-(define del-assv! (delete-association-procedure list-deletor! eqv? car))
-(define del-assoc! (delete-association-procedure list-deletor! equal? car))
+(define (delq! item items)
+ (letrec ((trim-initial-segment
+ (lambda (items)
+ (if (pair? items)
+ (if (eq? item (car items))
+ (trim-initial-segment (cdr items))
+ (begin (locate-initial-segment items (cdr items))
+ items))
+ items)))
+ (locate-initial-segment
+ (lambda (last this)
+ (if (pair? this)
+ (if (eq? item (car this))
+ (set-cdr! last (trim-initial-segment (cdr this)))
+ (locate-initial-segment this (cdr this)))
+ this))))
+ (trim-initial-segment items)))
\f
-;;;; Lastness
-
-(define (last-pair l)
- (if (pair? l)
- (let loop ((l l))
- (if (pair? (cdr l))
- (loop (cdr l))
- l))
- (error "LAST-PAIR: Argument not a list" l)))
-
-(define (except-last-pair l)
- (if (pair? l)
- (let loop ((l l))
- (if (pair? (cdr l))
- (cons (car l)
- (loop (cdr l)))
- '()))
- (error "EXCEPT-LAST-PAIR: Argument not a list" l)))
-
-(define (except-last-pair! l)
- (if (pair? l)
- (if (pair? (cdr l))
- (begin (let loop ((l l))
- (if (pair? (cddr l))
- (loop (cdr l))
- (set-cdr! l '())))
- l)
- '())
- (error "EXCEPT-LAST-PAIR!: Argument not a list" l)))
\ No newline at end of file
+;;;; Lastness and Segments
+
+(define (last-pair list)
+ (if (not (pair? list))
+ (error "LAST-PAIR: Argument not a pair" list))
+ (let loop ((list list))
+ (if (pair? (cdr list))
+ (loop (cdr list))
+ list)))
+
+(define (except-last-pair list)
+ (if (not (pair? list))
+ (error "EXCEPT-LAST-PAIR: Argument not a pair" list))
+ (let loop ((list list))
+ (if (pair? (cdr list))
+ (cons (car list)
+ (loop (cdr list)))
+ '())))
+
+(define (except-last-pair! list)
+ (if (not (pair? list))
+ (error "EXCEPT-LAST-PAIR!: Argument not a pair" list))
+ (if (pair? (cdr list))
+ (begin (let loop ((list list))
+ (if (pair? (cddr list))
+ (loop (cdr list))
+ (set-cdr! list '())))
+ list)
+ '()))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.1 1988/05/20 00:59:11 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.2 1988/06/13 11:47:32 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Code Loader
-;;; package: load-package
+;;; package: (runtime load)
(declare (usual-integrations))
\f
(define fasload/default-types)
(define (read-file filename)
- (stream->list
- (call-with-input-file
- (pathname-default-version (->pathname filename) 'NEWEST)
- read-stream)))
+ (call-with-input-file
+ (pathname-default-version (->pathname filename) 'NEWEST)
+ (lambda (port)
+ (stream->list (read-stream port)))))
(define (fasload filename)
(fasload/internal
(write-string " -- done" port)
value)))
-(define (load-noisily filename #!optional environment)
+(define (load-noisily filename #!optional environment syntax-table purify?)
(fluid-let ((load-noisily? true))
(load filename
- (if (default-object? environment) default-object environment))))
+ ;; This defaulting is a kludge until we get the optional
+ ;; defaulting fixed. Right now it must match the defaulting
+ ;; of `load'.
+ (if (default-object? environment) default-object environment)
+ (if (default-object? syntax-table) default-object syntax-table)
+ (if (default-object? purify?) default-object purify?))))
(define (load-init-file)
(let ((truename (init-file-truename)))
;;; This is careful to do the minimum number of file existence probes
;;; before opening the input file.
-(define (load filename/s #!optional environment)
+(define (load filename/s #!optional environment syntax-table purify?)
(let ((environment
;; Kludge until optional defaulting fixed.
- (if (default-object? environment) default-object environment)))
+ (if (or (default-object? environment)
+ (eq? environment default-object))
+ default-object
+ (->environment environment)))
+ (syntax-table
+ ;; Kludge until optional defaulting fixed.
+ (if (or (default-object? syntax-table)
+ (eq? syntax-table default-object))
+ default-object
+ (guarantee-syntax-table syntax-table)))
+ (purify?
+ (if (or (default-object? purify?)
+ (eq? purify? default-object))
+ false
+ purify?)))
(let ((kernel
(lambda (filename last-file?)
(let ((value
(find-true-filename pathname
load/default-types)
environment
+ syntax-table
+ purify?
load-noisily?))))
(cond (last-file? value)
(load-noisily? (write-line value)))))))
(define default-object
"default-object")
-(define (load/internal pathname true-filename environment load-noisily?)
+(define (load/internal pathname true-filename environment syntax-table
+ purify? load-noisily?)
(let ((port (open-input-file/internal pathname true-filename)))
(if (= 250 (char->ascii (peek-char port)))
(begin (close-input-port port)
- (scode-eval (fasload/internal true-filename)
+ (scode-eval (let ((scode (fasload/internal true-filename)))
+ (if purify? (purify scode))
+ scode)
(if (eq? environment default-object)
(standard-repl-environment)
environment)))
- (write-stream (eval-stream (read-stream port) environment)
+ (write-stream (eval-stream (read-stream port) environment syntax-table)
(if load-noisily?
(lambda (value)
(hook/repl-write (nearest-repl) value))
- (lambda (value) value false))))))
+ (lambda (value) value false))))))\f
(define (find-true-filename pathname default-types)
(pathname->string
(or (let ((try
(or (try (pathname-new-type pathname (car types)))
(loop (cdr types))))))))
(error "No such file" pathname))))
-\f
+
(define (read-stream port)
(parse-objects port
(current-parser-table)
(begin (close-input-port port)
true)))))
-(define (eval-stream stream environment)
+(define (eval-stream stream environment syntax-table)
(stream-map stream
(lambda (s-expression)
- (hook/repl-eval (nearest-repl)
- s-expression
- (if (eq? environment default-object)
- (standard-repl-environment)
- environment)))))
+ (let ((repl (nearest-repl)))
+ (hook/repl-eval repl
+ s-expression
+ (if (eq? environment default-object)
+ (repl/environment repl)
+ environment)
+ (if (eq? syntax-table default-object)
+ (repl/syntax-table repl)
+ syntax-table))))))
(define (write-stream stream write)
(if (stream-pair? stream)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.1 1988/05/20 00:59:28 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.2 1988/06/13 11:47:44 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
\f
((ucode-primitive set-interrupt-enables!) 0)
(define system-global-environment (the-environment))
-(define system-packages (let () (the-environment)))
-(let ()
+(let ((environment-for-package (let () (the-environment))))
(define-primitives
(+ &+)
(file-exists? 1)
garbage-collect
get-fixed-objects-vector
+ get-next-constant
get-primitive-address
get-primitive-name
lexical-reference
substring=?
substring-move-right!
substring-upcase!
+ tty-beep
tty-flush-output
+ tty-read-char-immediate
tty-write-char
tty-write-string
vector-ref
(tty-write-char newline-char)
(tty-flush-output)
(exit))
+
+(define (prompt-for-confirmation prompt)
+ (let loop ()
+ (tty-write-char newline-char)
+ (tty-write-string prompt)
+ (tty-write-string "(y or n) ")
+ (tty-flush-output)
+ (let ((char (tty-read-char-immediate)))
+ (cond ((or (eq? #\y char)
+ (eq? #\Y char))
+ (tty-write-string "Yes")
+ (tty-flush-output)
+ true)
+ ((or (eq? #\n char)
+ (eq? #\N char))
+ (tty-write-string "No")
+ (tty-flush-output)
+ false)
+ (else
+ (tty-beep)
+ (loop))))))
\f
;;;; GC, Interrupts, Errors
(define safety-margin 4500)
+(define constant-space/base (get-next-constant))
(let ((condition-handler/gc
(lambda (interrupt-code interrupt-enables)
(get-primitive-address (get-primitive-name (object-datum primitive)) false))
(define map-filename
- (if (implemented-primitive-procedure? file-exists?)
+ (if (and (implemented-primitive-procedure? file-exists?)
+ (not (prompt-for-confirmation "Load interpreted? ")))
(lambda (filename)
(let ((com-file (string-append filename ".com")))
(if (file-exists? com-file)
(define (package-initialize package-name procedure-name)
(tty-write-char newline-char)
- (tty-write-string "initialize:")
+ (tty-write-string "initialize: (")
(let loop ((name package-name))
(if (not (null? name))
- (begin (tty-write-string " ")
+ (begin (if (not (eq? name package-name))
+ (tty-write-string " "))
(tty-write-string (system-pair-car (car name)))
(loop (cdr name)))))
+ (tty-write-string ")")
+ (if (not (eq? procedure-name 'INITIALIZE-PACKAGE!))
+ (begin (tty-write-string " [")
+ (tty-write-string (system-pair-car procedure-name))
+ (tty-write-string "]")))
(tty-flush-output)
((lexical-reference (package-reference package-name) procedure-name)))
(define (package-reference name)
- (if (null? name)
- system-global-environment
- (let loop ((name name) (environment system-packages))
- (if (null? name)
- environment
- (loop (cdr name) (lexical-reference environment (car name)))))))
+ (package/environment (find-package name)))
(define (package-initialization-sequence packages)
(let loop ((packages packages))
(loop (cdr packages))))))
\f
;; Construct the package structure.
+;; Lotta hair here to load the package code before its package is built.
+(eval (cold-load/purify (fasload (map-filename "packag")))
+ environment-for-package)
+((access initialize-package! environment-for-package))
+(let loop ((names
+ '(FIND-PACKAGE
+ NAME->PACKAGE
+ PACKAGE/ADD-CHILD!
+ PACKAGE/CHILD
+ PACKAGE/CHILDREN
+ PACKAGE/ENVIRONMENT
+ PACKAGE/NAME
+ PACKAGE/PARENT
+ PACKAGE/REFERENCE
+ PACKAGE/SYSTEM-LOADER
+ PACKAGE?
+ SYSTEM-GLOBAL-PACKAGE)))
+ (if (not (null? names))
+ (begin (environment-link-name system-global-environment
+ environment-for-package
+ (car names))
+ (loop (cdr names)))))
+(package/add-child! system-global-package 'PACKAGE environment-for-package)
(eval (fasload "runtim.bcon") system-global-environment)
;; Global databases. Load, then initialize.
-
(let loop
((files
- '(("gcdemn" . (GC-DAEMONS))
- ("poplat" . (POPULATION))
- ("prop1d" . (1D-PROPERTY))
- ("events" . (EVENT-DISTRIBUTOR))
- ("gdatab" . (GLOBAL-DATABASE))
+ '(("gcdemn" . (RUNTIME GC-DAEMONS))
+ ("poplat" . (RUNTIME POPULATION))
+ ("prop1d" . (RUNTIME 1D-PROPERTY))
+ ("events" . (RUNTIME EVENT-DISTRIBUTOR))
+ ("gdatab" . (RUNTIME GLOBAL-DATABASE))
("boot" . ())
("queue" . ())
- ("gc" . (GARBAGE-COLLECTOR)))))
+ ("gc" . (RUNTIME GARBAGE-COLLECTOR)))))
(if (not (null? files))
(begin
(eval (cold-load/purify (fasload (map-filename (car (car files)))))
(package-reference (cdr (car files))))
(loop (cdr files)))))
-(package-initialize '(GC-DAEMONS) 'INITIALIZE-PACKAGE!)
-(package-initialize '(POPULATION) 'INITIALIZE-PACKAGE!)
-(package-initialize '(1D-PROPERTY) 'INITIALIZE-PACKAGE!)
-(package-initialize '(EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE!)
-(package-initialize '(GLOBAL-DATABASE) 'INITIALIZE-PACKAGE!)
-(package-initialize '(POPULATION) 'INITIALIZE-UNPARSER!)
-(package-initialize '(1D-PROPERTY) 'INITIALIZE-UNPARSER!)
-(package-initialize '(EVENT-DISTRIBUTOR) 'INITIALIZE-UNPARSER!)
-(package-initialize '(GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE!)
+(package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE!)
+(package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE!)
+(package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE!)
+(package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE!)
+(package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE!)
+(package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER!)
+(package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER!)
+(package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-UNPARSER!)
+(package-initialize '(PACKAGE) 'INITIALIZE-UNPARSER!)
+(package-initialize '(RUNTIME GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE!)
+(lexical-assignment (package-reference '(RUNTIME GARBAGE-COLLECTOR))
+ 'CONSTANT-SPACE/BASE
+ constant-space/base)
;; Load everything else.
((eval (fasload "runtim.bldr") system-global-environment)
(lambda (filename environment)
- (if (not (or (string=? filename "gcdemn")
+ (if (not (or (string=? filename "packag")
+ (string=? filename "gcdemn")
(string=? filename "poplat")
(string=? filename "prop1d")
(string=? filename "events")
(package-initialization-sequence
'(
;; Microcode interface
- (MICROCODE-TABLES)
- (PRIMITIVE-IO)
- (SAVE/RESTORE)
- (STATE-SPACE)
- (SYSTEM-CLOCK)
+ (RUNTIME MICROCODE-TABLES)
+ (RUNTIME PRIMITIVE-IO)
+ (RUNTIME SAVE/RESTORE)
+ (RUNTIME STATE-SPACE)
+ (RUNTIME SYSTEM-CLOCK)
;; Basic data structures
- (NUMBER)
- (LIST)
- (CHARACTER)
- (CHARACTER-SET)
- (GENSYM)
- (STREAM)
- (2D-PROPERTY)
- (HASH)
- (RANDOM-NUMBER)
+ (RUNTIME NUMBER)
+ (RUNTIME LIST)
+ (RUNTIME CHARACTER)
+ (RUNTIME CHARACTER-SET)
+ (RUNTIME GENSYM)
+ (RUNTIME STREAM)
+ (RUNTIME 2D-PROPERTY)
+ (RUNTIME HASH)
+ (RUNTIME RANDOM-NUMBER)
;; Microcode data structures
- (HISTORY)
- (LAMBDA-ABSTRACTION)
- (SCODE)
- (SCODE-COMBINATOR)
- (SCODE-SCAN)
- (SCODE-WALKER)
- (CONTINUATION-PARSER)
-
- ;; I/O ports
- (CONSOLE-INPUT)
- (CONSOLE-OUTPUT)
- (FILE-INPUT)
- (FILE-OUTPUT)
- (STRING-INPUT)
- (STRING-OUTPUT)
- (TRUNCATED-STRING-OUTPUT)
- (INPUT-PORT)
- (OUTPUT-PORT)
- (WORKING-DIRECTORY)
- (LOAD)
+ (RUNTIME HISTORY)
+ (RUNTIME LAMBDA-ABSTRACTION)
+ (RUNTIME SCODE)
+ (RUNTIME SCODE-COMBINATOR)
+ (RUNTIME SCODE-SCAN)
+ (RUNTIME SCODE-WALKER)
+ (RUNTIME CONTINUATION-PARSER)
+
+ ;; I/O
+ (RUNTIME CONSOLE-INPUT)
+ (RUNTIME CONSOLE-OUTPUT)
+ (RUNTIME FILE-INPUT)
+ (RUNTIME FILE-OUTPUT)
+ (RUNTIME STRING-INPUT)
+ (RUNTIME STRING-OUTPUT)
+ (RUNTIME TRUNCATED-STRING-OUTPUT)
+ (RUNTIME INPUT-PORT)
+ (RUNTIME OUTPUT-PORT)
+ (RUNTIME WORKING-DIRECTORY)
+ (RUNTIME DIRECTORY)
+ (RUNTIME LOAD)
;; Syntax
- (PARSER)
- (NUMBER-UNPARSER)
- (UNPARSER)
- (SYNTAXER)
- (MACROS)
- (SYSTEM-MACROS)
- (DEFSTRUCT)
- (UNSYNTAXER)
- (PRETTY-PRINTER)
-
+ (RUNTIME PARSER)
+ (RUNTIME NUMBER-UNPARSER) (RUNTIME UNPARSER)
+ (RUNTIME SYNTAXER)
+ (RUNTIME MACROS)
+ (RUNTIME SYSTEM-MACROS)
+ (RUNTIME DEFSTRUCT)
+ (RUNTIME UNSYNTAXER)
+ (RUNTIME PRETTY-PRINTER)
;; REP Loops
- (ERROR-HANDLER)
- (MICROCODE-ERRORS)
- (INTERRUPT-HANDLER)
- (GC-STATISTICS)
- (REP)
+ (RUNTIME ERROR-HANDLER)
+ (RUNTIME MICROCODE-ERRORS)
+ (RUNTIME INTERRUPT-HANDLER)
+ (RUNTIME GC-STATISTICS)
+ (RUNTIME REP)
;; Debugging
- (ADVICE)
- (DEBUGGER-COMMAND-LOOP)
- (DEBUGGER-UTILITIES)
- (ENVIRONMENT-INSPECTOR)
- (DEBUGGING-INFO)
- (DEBUGGER)
-
+ (RUNTIME ADVICE)
+ (RUNTIME DEBUGGER-COMMAND-LOOP)
+ (RUNTIME DEBUGGER-UTILITIES)
+ (RUNTIME ENVIRONMENT-INSPECTOR)
+ (RUNTIME DEBUGGING-INFO)
+ (RUNTIME DEBUGGER)
+
+ (RUNTIME)
;; Emacs -- last because it grabs the kitchen sink.
- (EMACS-INTERFACE)
+ (RUNTIME EMACS-INTERFACE)
))
-\f
+
)
-(add-system! (make-system "Microcode"
- microcode-id/version
- microcode-id/modification
- '()))
-(add-system! (make-system "Runtime" 14 0 '()))
-(remove-environment-parent! system-packages)
(initial-top-level-repl)
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/msort.scm,v 13.42 1987/11/21 18:06:51 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/msort.scm,v 14.1 1988/06/13 11:47:52 cph Rel $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Merge Sort
+;;; package: ()
(declare (usual-integrations))
\f
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/numpar.scm,v 13.43 1987/08/25 20:49:23 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/numpar.scm,v 14.1 1988/06/13 11:48:26 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Number Parser
+;;; package: (runtime number-parser)
(declare (usual-integrations))
\f
-(define string->number)
-
-(define number-parser-package
- (make-environment
-
;;; These are not supported right now.
-(define ->exact identity-procedure)
-(define ->inexact identity-procedure)
-(define ->long-flonum identity-procedure)
-(define ->short-flonum identity-procedure)
+(define-integrable (->exact number) number)
+(define-integrable (->inexact number) number)
+(define-integrable (->long-flonum number) number)
+(define-integrable (->short-flonum number) number)
(define *radix*)
-(set! string->number
- (named-lambda (string->number string #!optional exactness radix)
- ((cond ((or (unassigned? exactness) (not exactness)) identity-procedure)
- ((eq? exactness 'E) ->exact)
- ((eq? exactness 'I) ->inexact)
- (else (error "Illegal exactness argument" exactness)))
- (fluid-let ((*radix*
- (cond ((unassigned? radix) *parser-radix*)
- ((memv radix '(2 8 10 16)) radix)
- ((eq? radix 'B) 2)
- ((eq? radix 'O) 8)
- ((eq? radix 'D) 10)
- ((eq? radix 'X) 16)
- (else (error "Illegal radix argument" radix)))))
- (parse-number (string->list string))))))
+(define (string->number string #!optional exactness radix)
+ ((cond ((or (default-object? exactness) (not exactness)) identity-procedure)
+ ((eq? exactness 'E) ->exact)
+ ((eq? exactness 'I) ->inexact)
+ (else (error "Illegal exactness argument" exactness)))
+ (fluid-let ((*radix*
+ (cond ((default-object? radix) *parser-radix*)
+ ((memv radix '(2 8 10 16)) radix)
+ ((eq? radix 'B) 2)
+ ((eq? radix 'O) 8)
+ ((eq? radix 'D) 10)
+ ((eq? radix 'X) 16)
+ (else (error "Illegal radix argument" radix)))))
+ (parse-number (string->list string)))))
(define (parse-number chars)
(parse-real chars
(define (loop chars integer place-value)
(parse-digit/sharp chars
(lambda (chars count)
+ count
(finish chars (->inexact integer) place-value))
(lambda (chars digit)
(loop chars
(let ((digit (char->digit (car chars) *radix*)))
(if digit
(if-digit (cdr chars) digit)
- (otherwise chars))))))
-
-;;; end NUMBER-PARSER-PACKAGE
-))
\ No newline at end of file
+ (otherwise chars))))))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 13.46 1987/06/17 21:03:20 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
-;;;; Output
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 14.1 1988/06/13 11:48:42 cph Exp $
-(declare (usual-integrations))
-\f
-;;;; Output Ports
+Copyright (c) 1988 Massachusetts Institute of Technology
-(define output-port-tag
- "Output Port")
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
-(define (output-port? object)
- (and (environment? object)
- (not (lexical-unreferenceable? object ':TYPE))
- (eq? (access :type object) output-port-tag)))
+1. Any copy made of this software must include this copyright notice
+in full.
-(define *current-output-port*)
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
-(define (current-output-port)
- *current-output-port*)
+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.
-(define (with-output-to-port port thunk)
- (if (not (output-port? port)) (error "Bad output port" port))
- (fluid-let ((*current-output-port* port))
- (thunk)))
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
-(define (with-output-to-file output-specifier thunk)
- (define new-port (open-output-file output-specifier))
- (define old-port)
- (dynamic-wind (lambda ()
- (set! old-port
- (set! *current-output-port*
- (set! new-port))))
- thunk
- (lambda ()
- (let ((port))
- ;; Only SET! is guaranteed to do the right thing with
- ;; an unassigned value. Binding may not work right.
- (set! port (set! *current-output-port* (set! old-port)))
- (if (not (unassigned? port))
- (close-output-port port))))))
+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 without prior written consent from
+MIT in each case. |#
-(define (call-with-output-file output-specifier receiver)
- (let ((port (open-output-file output-specifier)))
- (let ((value (receiver port)))
- (close-output-port port)
- value)))
+;;;; Output
+;;; package: (runtime output-port)
-(define (close-output-port port)
- ((access :close port)))
+(declare (usual-integrations))
\f
-;;;; Console Output Port
-
-(define beep
- (make-primitive-procedure 'TTY-BEEP))
-
-(define (screen-clear)
- ((access :clear-screen console-output-port))
- ((access :flush-output console-output-port)))
-
-(define console-output-port)
-(let ()
-
-(define tty-write-char
- (make-primitive-procedure 'TTY-WRITE-CHAR))
-
-(define tty-write-string
- (make-primitive-procedure 'TTY-WRITE-STRING))
-
-(define tty-flush-output
- (make-primitive-procedure 'TTY-FLUSH-OUTPUT))
-
-(define tty-clear
- (make-primitive-procedure 'TTY-CLEAR))
-
-(set! console-output-port
- (make-environment
-
-(define :type output-port-tag)
+;;;; Output Ports
-(define (:print-self)
- (unparse-with-brackets
- (lambda ()
- (write-string "Console output port"))))
+(define (initialize-package!)
+ (set! *current-output-port* console-output-port)
+ (set! beep (wrap-custom-operation-0 'BEEP))
+ (set! clear (wrap-custom-operation-0 'CLEAR)))
+
+(define (output-port/unparse state port)
+ ((unparser/standard-method 'OUTPUT-PORT
+ (output-port/custom-operation port 'PRINT-SELF))
+ state
+ port))
+
+(define-structure (output-port (conc-name output-port/)
+ (constructor %make-output-port)
+ (copier %output-port/copy)
+ (print-procedure output-port/unparse))
+ state
+ (operation/write-char false read-only true)
+ (operation/write-string false read-only true)
+ (operation/flush-output false read-only true)
+ (custom-operations false read-only true))
+
+(define (guarantee-output-port port)
+ (if (not (output-port? port)) (error "Bad output port" port))
+ port)
-(define (:close) 'DONE)
-(define :write-char tty-write-char)
-(define :write-string tty-write-string)
-(define :flush-output tty-flush-output)
-(define :clear-screen tty-clear)
+(define (output-port/custom-operation port name)
+ (let ((entry (assq name (output-port/custom-operations port))))
+ (and entry
+ (cdr entry))))
-(define (:x-size)
- (access printer-width implementation-dependencies))
+(define (output-port/copy port state)
+ (let ((result (%output-port/copy port)))
+ (set-output-port/state! result state)
+ result))
-(define (:y-size)
- (access printer-length implementation-dependencies))
+(define (output-port/write-char port char)
+ ((output-port/operation/write-char port) port char))
-;;; end CONSOLE-OUTPUT-PORT.
-))
+(define (output-port/write-string port string)
+ ((output-port/operation/write-string port) port string))
-)
+(define (output-port/flush-output port)
+ ((output-port/operation/flush-output port) port))
-(set! *current-output-port* console-output-port)
+(define (output-port/x-size port)
+ (or (let ((operation (output-port/custom-operation port 'X-SIZE)))
+ (and operation
+ (operation port)))
+ 79))
\f
-;;; File Output Ports
-
-(define open-output-file)
-(let ()
-#|
-(declare (integrate-primitive-procedures file-write-char file-write-string))
-|#
-(define file-write-char
- (make-primitive-procedure 'FILE-WRITE-CHAR))
-
-(define file-write-string
- (make-primitive-procedure 'FILE-WRITE-STRING))
-
-(set! open-output-file
-(named-lambda (open-output-file filename)
- (make-file-output-port
- ((access open-output-channel primitive-io)
- (canonicalize-output-filename filename)))))
-
-(define (make-file-output-port file-channel)
-
-(define :type output-port-tag)
-
-(define (:print-self)
- (unparse-with-brackets
- (lambda ()
- (write-string "Output port for file: ")
- (write ((access channel-name primitive-io) file-channel)))))
-
-(define (:close)
- ((access close-physical-channel primitive-io) file-channel))
-
-(define (:write-char char)
- (file-write-char char file-channel))
-
-(define (:write-string string)
- (file-write-string string file-channel))
-
-(define (:flush-output) 'DONE)
-(define (:x-size) false)
-(define (:y-size) false)
-
-;;; end MAKE-FILE-OUTPUT-PORT.
-(the-environment))
-
-)
+(define (make-output-port operations state)
+ (let ((operations
+ (map (lambda (entry)
+ (cons (car entry) (cadr entry)))
+ operations)))
+ (let ((operation
+ (lambda (name default)
+ (let ((entry (assq name operations)))
+ (if entry
+ (begin (set! operations (delq! entry operations))
+ (cdr entry))
+ (or default
+ (error "MAKE-OUTPUT-PORT: missing operation" name)))))))
+ (let ((write-char (operation 'WRITE-CHAR false))
+ (write-string
+ (operation 'WRITE-STRING default-operation/write-string))
+ (flush-output
+ (operation 'FLUSH-OUTPUT default-operation/flush-output)))
+ (%make-output-port state
+ write-char
+ write-string
+ flush-output
+ operations)))))
+
+(define (default-operation/write-string port string)
+ (let ((write-char (output-port/operation/write-char port))
+ (end (string-length string)))
+ (let loop ((index 0))
+ (if (< index end)
+ (begin (write-char port (string-ref string index))
+ (loop (1+ index)))))))
+
+(define (default-operation/flush-output port)
+ port
+ false)
\f
-;;;; String Output Ports
-
-(define (write-to-string object #!optional max)
- (if (unassigned? max) (set! max false))
- (if (not max)
- (with-output-to-string
- (lambda ()
- (write object)))
- (with-output-to-truncated-string max
- (lambda ()
- (write object)))))
-
-(define (with-output-to-string thunk)
- (let ((port (string-output-port)))
- (fluid-let ((*current-output-port* port))
- (thunk))
- ((access :value port))))
-
-(define (string-output-port)
-
-(define :type output-port-tag)
-
-(define (:print-self)
- (unparse-with-brackets
- (lambda ()
- (write-string "Output port to string"))))
-
-(define accumulator '())
-
-(define (:value)
- (let ((string (apply string-append (reverse! accumulator))))
- (set! accumulator (list string))
- string))
+(define *current-output-port*)
-(define (:write-char char)
- (set! accumulator (cons (char->string char) accumulator)))
+(define-integrable (current-output-port)
+ *current-output-port*)
-(define (:write-string string)
- (set! accumulator (cons string accumulator)))
+(define (with-output-to-port port thunk)
+ (cond ((eq? port *current-output-port*) (thunk))
+ ((not (output-port? port)) (error "Bad output port" port))
+ (else (fluid-let ((*current-output-port* port)) (thunk)))))
-(define (:close) 'DONE)
-(define (:flush-output) 'DONE)
-(define (:x-size) false)
-(define (:y-size) false)
+(define (with-output-to-file output-specifier thunk)
+ (let ((new-port (open-output-file output-specifier))
+ (old-port false))
+ (dynamic-wind (lambda ()
+ (set! old-port *current-output-port*)
+ (set! *current-output-port* new-port)
+ (set! new-port false))
+ thunk
+ (lambda ()
+ (if *current-output-port*
+ (close-output-port *current-output-port*))
+ (set! *current-output-port* old-port)
+ (set! old-port false)))))
-;;; end STRING-OUTPUT-PORT.
-(the-environment))
-\f
-(define (with-output-to-truncated-string maxsize thunk)
- (call-with-current-continuation
- (lambda (return)
-
-(define :type output-port-tag)
-
-(define (:print-self)
- (unparse-with-brackets
- (lambda ()
- (write-string "Output port to truncated string"))))
-
-(define accumulator '())
-(define counter maxsize)
-
-(define (:write-char char)
- (:write-string (char->string char)))
-
-(define (:write-string string)
- (set! accumulator (cons string accumulator))
- (set! counter (- counter (string-length string)))
- (if (negative? counter)
- (return (cons true
- (substring (apply string-append (reverse! accumulator))
- 0 maxsize)))))
-
-(define (:close) 'DONE)
-(define (:flush-output) 'DONE)
-(define (:x-size) false)
-(define (:y-size) false)
-
-(fluid-let ((*current-output-port* (the-environment)))
- (thunk))
-(cons false (apply string-append (reverse! accumulator)))
-
-;;; end WITH-OUTPUT-TO-TRUNCATED-STRING.
-)))
+(define (call-with-output-file output-specifier receiver)
+ (let ((port (open-output-file output-specifier)))
+ (let ((value (receiver port)))
+ (close-output-port port)
+ value)))
\f
;;;; Output Procedures
(define (newline #!optional port)
- (cond ((unassigned? port) (set! port *current-output-port*))
- ((not (output-port? port)) (error "Bad output port" port)))
- ((access :write-char port) char:newline)
- ((access :flush-output port))
+ (let ((port
+ (if (default-object? port)
+ (current-output-port)
+ (guarantee-output-port port))))
+ (output-port/write-char port #\Newline)
+ (output-port/flush-output port))
*the-non-printing-object*)
(define (write-char char #!optional port)
- (cond ((unassigned? port) (set! port *current-output-port*))
- ((not (output-port? port)) (error "Bad output port" port)))
- ((access :write-char port) char)
- ((access :flush-output port))
+ (let ((port
+ (if (default-object? port)
+ (current-output-port)
+ (guarantee-output-port port))))
+ (output-port/write-char port char)
+ (output-port/flush-output port))
*the-non-printing-object*)
(define (write-string string #!optional port)
- (cond ((unassigned? port) (set! port *current-output-port*))
- ((not (output-port? port)) (error "Bad output port" port)))
- ((access :write-string port) string)
- ((access :flush-output port))
+ (let ((port
+ (if (default-object? port)
+ (current-output-port)
+ (guarantee-output-port port))))
+ (output-port/write-string port string)
+ (output-port/flush-output port))
+ *the-non-printing-object*)
+
+(define (close-output-port port)
+ (let ((operation (output-port/custom-operation port 'CLOSE)))
+ (if operation
+ (operation port)))
*the-non-printing-object*)
-(define (unparse-with-brackets thunk)
- ((access unparse-with-brackets unparser-package) thunk))
+(define (wrap-custom-operation-0 operation-name)
+ (lambda (#!optional port)
+ (let ((port
+ (if (default-object? port)
+ (current-output-port)
+ (guarantee-output-port port))))
+ (let ((operation (output-port/custom-operation port operation-name)))
+ (if operation
+ (begin
+ (operation port)
+ (output-port/flush-output port)))))
+ *the-non-printing-object*))
+
+(define beep)
+(define clear)
\f
-(define non-printing-object?
- (let ((objects
- (list *the-non-printing-object*
- undefined-conditional-branch
- (vector-ref (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'NON-OBJECT)))))
- (named-lambda (non-printing-object? object)
- (and (not (future? object))
- (memq object objects)))))
-
-(define display)
-(define write)
-(define write-line)
-
-(let ((make-unparser
- (lambda (handler)
- (lambda (object #!optional port)
- (if (not (non-printing-object? object))
- (if (unassigned? port)
- (handler object *current-output-port*)
- (with-output-to-port port
- (lambda ()
- (handler object port)))))
- *the-non-printing-object*))))
- (set! display
- (make-unparser
- (lambda (object port)
- (if (and (not (future? object))
- (string? object))
- ((access :write-string port) object)
- ((access unparse-object unparser-package) object port false))
- ((access :flush-output port)))))
- (set! write
- (make-unparser
- (lambda (object port)
- ((access unparse-object unparser-package) object port true)
- ((access :flush-output port)))))
- (set! write-line
- (make-unparser
- (lambda (object port)
- ((access :write-char port) char:newline)
- ((access unparse-object unparser-package) object port true)
- ((access :flush-output port))))))
\ No newline at end of file
+(define (display object #!optional port unparser-table)
+ (let ((port
+ (if (default-object? port)
+ (current-output-port)
+ (guarantee-output-port port)))
+ (unparser-table
+ (if (default-object? unparser-table)
+ (current-unparser-table)
+ (guarantee-unparser-table unparser-table))))
+ (if (string? object)
+ (output-port/write-string port object)
+ (unparse-object/internal object port 0 false unparser-table))
+ (output-port/flush-output port))
+ *the-non-printing-object*)
+
+(define (write object #!optional port unparser-table)
+ (let ((port
+ (if (default-object? port)
+ (current-output-port)
+ (guarantee-output-port port)))
+ (unparser-table
+ (if (default-object? unparser-table)
+ (current-unparser-table)
+ (guarantee-unparser-table unparser-table))))
+ (unparse-object/internal object port 0 true unparser-table)
+ (output-port/flush-output port))
+ *the-non-printing-object*)
+
+(define (write-line object #!optional port unparser-table)
+ (let ((port
+ (if (default-object? port)
+ (current-output-port)
+ (guarantee-output-port port)))
+ (unparser-table
+ (if (default-object? unparser-table)
+ (current-unparser-table)
+ (guarantee-unparser-table unparser-table))))
+ (output-port/write-char port #\Newline)
+ (unparse-object/internal object port 0 true unparser-table)
+ (output-port/flush-output port))
+ *the-non-printing-object*)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/packag.scm,v 14.1 1988/06/13 10:49:50 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/packag.scm,v 14.2 1988/06/13 11:48:57 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Simple Package Namespace
+;;; package: (package)
(declare (usual-integrations))
\f
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 13.44 1988/03/05 00:20:30 cph Rel $
-;;;
-;;; Copyright (c) 1988 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 14.1 1988/06/13 11:49:02 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Scheme Parser
+;;; package: (runtime parser)
(declare (usual-integrations))
\f
-(define *parser-radix* #d10)
-(define *parser-table*)
+(define (initialize-package!)
+ (set! char-set/undefined-atom-delimiters (char-set #\[ #\] #\{ #\} #\|))
+ (set! char-set/whitespace
+ (char-set #\Tab #\Linefeed #\Page #\Return #\Space))
+ (set! char-set/non-whitespace (char-set-invert char-set/whitespace))
+ (set! char-set/comment-delimiters (char-set #\Newline))
+ (set! char-set/special-comment-leaders (char-set #\# #\|))
+ (set! char-set/string-delimiters (char-set #\" #\\))
+ (set! char-set/atom-delimiters
+ (char-set-union char-set/whitespace
+ (char-set-union char-set/undefined-atom-delimiters
+ (char-set #\( #\) #\; #\" #\' #\`))))
+ (set! char-set/atom-constituents (char-set-invert char-set/atom-delimiters))
+ (set! char-set/char-delimiters
+ (char-set-union (char-set #\- #\\) char-set/atom-delimiters))
+ (set! char-set/symbol-leaders
+ (char-set-difference char-set/atom-constituents
+ (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
+ #\+ #\- #\. #\#)))
+
+ (set! lambda-optional-tag (intern "#!optional"))
+ (set! lambda-rest-tag (intern "#!rest"))
+ (set! dot-symbol (intern "."))
+ (set! named-objects
+ `((NULL . ,(list))
+ (FALSE . ,false)
+ (TRUE . ,true)
+ (OPTIONAL . ,lambda-optional-tag)
+ (REST . ,lambda-rest-tag)))
+
+ (set! *parser-radix* 10)
+ (set! system-global-parser-table (make-system-global-parser-table))
+ (set-current-parser-table! system-global-parser-table))
+
+(define char-set/undefined-atom-delimiters)
+(define char-set/whitespace)
+(define char-set/non-whitespace)
+(define char-set/comment-delimiters)
+(define char-set/special-comment-leaders)
+(define char-set/string-delimiters)
+(define char-set/atom-delimiters)
+(define char-set/atom-constituents)
+(define char-set/char-delimiters)
+(define char-set/symbol-leaders)
+
+(define lambda-optional-tag)
+(define lambda-rest-tag)
+(define *parser-radix*)
+(define system-global-parser-table)
+\f
+(define (make-system-global-parser-table)
+ (let ((table
+ (make-parser-table parse-object/atom
+ (collect-list-wrapper parse-object/atom)
+ parse-object/special-undefined
+ collect-list/special-undefined)))
+ (for-each (lambda (entry)
+ (parser-table/set-entry!
+ table
+ (car entry)
+ (cadr entry)
+ (if (null? (cddr entry))
+ (collect-list-wrapper (cadr entry))
+ (caddr entry))))
+ `(("#" ,parse-object/special ,collect-list/special)
+ (,char-set/symbol-leaders ,parse-object/symbol)
+ (("#b" "#B") ,parse-object/numeric-prefix)
+ (("#o" "#O") ,parse-object/numeric-prefix)
+ (("#d" "#D") ,parse-object/numeric-prefix)
+ (("#x" "#X") ,parse-object/numeric-prefix)
+ (("#i" "#I") ,parse-object/numeric-prefix)
+ (("#e" "#E") ,parse-object/numeric-prefix)
+ (("#s" "#S") ,parse-object/numeric-prefix)
+ (("#l" "#L") ,parse-object/numeric-prefix)
+ ("#*" ,parse-object/bit-string)
+ ("(" ,parse-object/list-open)
+ ("#(" ,parse-object/vector-open)
+ (")" ,parse-object/list-close ,collect-list/list-close)
+ (,char-set/whitespace
+ ,parse-object/whitespace
+ ,collect-list/whitespace)
+ (,char-set/undefined-atom-delimiters
+ ,parse-object/undefined-atom-delimiter
+ ,collect-list/undefined-atom-delimiter)
+ (";" ,parse-object/comment ,collect-list/comment)
+ ("#|"
+ ,parse-object/special-comment
+ ,collect-list/special-comment)
+ ("'" ,parse-object/quote)
+ ("`" ,parse-object/quasiquote)
+ ("," ,parse-object/unquote)
+ ("\"" ,parse-object/string-quote)
+ ("#\\" ,parse-object/char-quote)
+ (("#f" "#F") ,parse-object/false)
+ (("#t" "#T") ,parse-object/true)
+ ("#!" ,parse-object/named-constant)))
+ table))
+\f
+;;;; Top Level
-(define parser-package
- (make-environment
+(define (parse-object port parser-table)
+ (if (not (parser-table? parser-table))
+ (error "Not a valid parser table" parser-table))
+ (parse-object/internal port parser-table))
-(define *parser-parse-object-table*)
-(define *parser-collect-list-table*)
-(define *parser-parse-object-special-table*)
-(define *parser-collect-list-special-table*)
-(define *parser-peek-char*)
-(define *parser-discard-char*)
-(define *parser-read-char*)
-(define *parser-read-string*)
-(define *parser-discard-chars*)
-(define *parser-input-port*)
+(define (parse-objects port parser-table last-object?)
+ (if (not (parser-table? parser-table))
+ (error "Not a valid parser table" parser-table))
+ (parse-objects/internal port parser-table last-object?))
+
+(define (parse-object/internal port parser-table)
+ (within-parser port parser-table parse-object/dispatch))
-(define (*parse-object port)
- (fluid-let ((*parser-input-port* port)
- (*parser-parse-object-table* (caar *parser-table*))
- (*parser-collect-list-table* (cdar *parser-table*))
- (*parser-parse-object-special-table* (cadr *parser-table*))
- (*parser-collect-list-special-table* (cddr *parser-table*))
- (*parser-peek-char* (access :peek-char port))
- (*parser-discard-char* (access :discard-char port))
- (*parser-read-char* (access :read-char port))
- (*parser-read-string* (access :read-string port))
- (*parser-discard-chars* (access :discard-chars port)))
- (parse-object)))
-
-(define (*parse-objects-until-eof port)
- (fluid-let ((*parser-input-port* port)
- (*parser-parse-object-table* (caar *parser-table*))
- (*parser-collect-list-table* (cdar *parser-table*))
- (*parser-parse-object-special-table* (cadr *parser-table*))
- (*parser-collect-list-special-table* (cddr *parser-table*))
- (*parser-peek-char* (access :peek-char port))
- (*parser-discard-char* (access :discard-char port))
- (*parser-read-char* (access :read-char port))
- (*parser-read-string* (access :read-string port))
- (*parser-discard-chars* (access :discard-chars port)))
- (define (loop object)
- (if (eof-object? object)
+(define (parse-objects/internal port parser-table last-object?)
+ (let loop ()
+ (let ((object (parse-object/internal port parser-table)))
+ (if (last-object? object)
'()
- (cons object (loop (parse-object)))))
- (loop (parse-object))))
+ (cons-stream object (loop))))))
+
+(define (within-parser port parser-table thunk)
+ (fluid-let
+ ((*parser-input-port* port)
+ (*parser-peek-char* (input-port/operation/peek-char port))
+ (*parser-discard-char* (input-port/operation/discard-char port))
+ (*parser-read-char* (input-port/operation/read-char port))
+ (*parser-read-string* (input-port/operation/read-string port))
+ (*parser-discard-chars* (input-port/operation/discard-chars port))
+ (*parser-parse-object-table* (parser-table/parse-object parser-table))
+ (*parser-collect-list-table* (parser-table/collect-list parser-table))
+ (*parser-parse-object-special-table*
+ (parser-table/parse-object-special parser-table))
+ (*parser-collect-list-special-table*
+ (parser-table/collect-list-special parser-table)))
+ (thunk)))
\f
;;;; Character Operations
-(declare (integrate peek-char read-char discard-char
- read-string discard-chars))
+(define *parser-input-port*)
+(define *parser-peek-char*)
+(define *parser-discard-char*)
+(define *parser-read-char*)
+(define *parser-read-string*)
+(define *parser-discard-chars*)
-(define (peek-char)
- (or (*parser-peek-char*)
- (error "End of file within READ")))
+(define-integrable (peek-char)
+ (or (peek-char/eof-ok)
+ (parse-error/end-of-file)))
-(define (read-char)
- (or (*parser-read-char*)
- (error "End of file within READ")))
+(define-integrable (peek-char/eof-ok)
+ (*parser-peek-char* *parser-input-port*))
-(define (discard-char)
- (*parser-discard-char*))
+(define-integrable (read-char)
+ (or (read-char/eof-ok)
+ (parse-error/end-of-file)))
-(define (read-string delimiters)
- (declare (integrate delimiters))
- (*parser-read-string* delimiters))
+(define-integrable (read-char/eof-ok)
+ (*parser-read-char* *parser-input-port*))
-(define (discard-chars delimiters)
- (declare (integrate delimiters))
- (*parser-discard-chars* delimiters))
-\f
-;;; There are two major dispatch tables, one for parsing at top level,
-;;; the other for parsing the elements of a list. Most of the entries
-;;; for each table are have similar actions.
+(define-integrable (discard-char)
+ (*parser-discard-char* *parser-input-port*))
-;;; Default is atomic object. Parsing an atomic object does not
-;;; consume its terminator. Thus different terminators [such as open
-;;; paren, close paren, and whitespace], can have different effects on
-;;; parser.
+(define-integrable (read-string delimiters)
+ (*parser-read-string* *parser-input-port* delimiters))
-(define (parse-object:atom)
- (build-atom (read-atom)))
+(define-integrable (discard-chars delimiters)
+ (*parser-discard-chars* *parser-input-port* delimiters))
-(define ((collect-list-wrapper object-parser))
- (let ((first (object-parser))) ;forces order.
- (let ((rest (collect-list)))
- (if (and (pair? rest)
- (eq? dot-symbol (car rest)))
- (if (and (pair? (cdr rest))
- (null? (cddr rest)))
- (cons first (cadr rest))
- (error "PARSE-OBJECT: Improperly formed dotted list"
- (cons first rest)))
- (cons first rest)))))
+(define (parse-error/end-of-file)
+ (parse-error "end of file"))
-(define dot-symbol
- (string->symbol "."))
-
-(define (parse-undefined-special)
- (error "No such special reader macro" (peek-char)))
-
-(set! *parser-table*
- (cons (cons (vector-cons 256 parse-object:atom)
- (vector-cons 256 (collect-list-wrapper parse-object:atom)))
- (cons (vector-cons 256 parse-undefined-special)
- (vector-cons 256 parse-undefined-special))))
-
-(define ((parser-char-definer tables)
- char/chars procedure #!optional list-procedure)
- (if (unassigned? list-procedure)
- (set! list-procedure (collect-list-wrapper procedure)))
- (define (do-it char)
- (vector-set! (car tables) (char->ascii char) procedure)
- (vector-set! (cdr tables) (char->ascii char) list-procedure))
- (cond ((char? char/chars) (do-it char/chars))
- ((char-set? char/chars)
- (for-each do-it (char-set-members char/chars)))
- ((pair? char/chars) (for-each do-it char/chars))
- (else (error "Unknown character" char/chars))))
-
-(define define-char
- (parser-char-definer (car *parser-table*)))
-
-(define define-char-special
- (parser-char-definer (cdr *parser-table*)))
+(define (parse-error message #!optional irritant)
+ (error (string-append "PARSE-OBJECT: " message)
+ (if (default-object? irritant) *the-non-printing-object* irritant)))
\f
-(declare (integrate peek-ascii parse-object collect-list))
+;;;; Dispatch Points
-(define (peek-ascii)
- (or (char-ascii? (peek-char))
- (non-ascii-error)))
-
-(define (non-ascii-error)
- (error "Non-ASCII character encountered during parse" (read-char)))
+(define *parser-parse-object-table*)
+(define *parser-collect-list-table*)
+(define *parser-parse-object-special-table*)
+(define *parser-collect-list-special-table*)
-(define (parse-object)
- (let ((char (*parser-peek-char*)))
+(define-integrable (parse-object/dispatch)
+ (let ((char (peek-char/eof-ok)))
(if char
((vector-ref *parser-parse-object-table*
- (or (char-ascii? char)
- (non-ascii-error))))
- eof-object)))
+ (or (char-ascii? char) (parse-error/non-ascii))))
+ (make-eof-object *parser-input-port*))))
-(define (collect-list)
+(define-integrable (collect-list/dispatch)
((vector-ref *parser-collect-list-table* (peek-ascii))))
-(define-char #\#
- (lambda ()
- (discard-char)
- ((vector-ref *parser-parse-object-special-table* (peek-ascii))))
- (lambda ()
- (discard-char)
- ((vector-ref *parser-collect-list-special-table* (peek-ascii)))))
-
-(define numeric-leaders
- (char-set-union char-set:numeric
- (char-set #\+ #\- #\. #\#)))
+(define (parse-object/special)
+ (discard-char)
+ ((vector-ref *parser-parse-object-special-table* (peek-ascii))))
-(define undefined-atom-delimiters
- (char-set #\[ #\] #\{ #\} #\|))
+(define (collect-list/special)
+ (discard-char)
+ ((vector-ref *parser-collect-list-special-table* (peek-ascii))))
-(define atom-delimiters
- (char-set-union char-set:whitespace
- (char-set-union undefined-atom-delimiters
- (char-set #\( #\) #\; #\" #\' #\`))))
+(define-integrable (peek-ascii)
+ (or (char-ascii? (peek-char))
+ (parse-error/non-ascii)))
-(define atom-constituents
- (char-set-invert atom-delimiters))
+(define (parse-error/non-ascii)
+ (parse-error "Non-ASCII character encountered" (read-char)))
-(declare (integrate read-atom))
+(define (parse-object/special-undefined)
+ (parse-error "No such special reader macro" (peek-char))
+ (parse-object/dispatch))
-(define (read-atom)
- (read-string atom-delimiters))
+(define (collect-list/special-undefined)
+ (parse-error "No such special reader macro" (peek-char))
+ (collect-list/dispatch))
\f
+;;;; Symbols/Numbers
+
+(define (parse-object/atom)
+ (build-atom (read-atom)))
+
+(define-integrable (read-atom)
+ (read-string char-set/atom-delimiters))
+
(define (build-atom string)
(or (parse-number string)
(intern-string! string)))
-(declare (integrate parse-number))
-
-(define (parse-number string)
- (declare (integrate string))
+(define-integrable (parse-number string)
(string->number string false *parser-radix*))
(define (intern-string! string)
+ ;; Special version of `intern' to reduce consing and increase speed.
(substring-upcase! string 0 (string-length string))
(string->symbol string))
-(define-char (char-set-difference atom-constituents numeric-leaders)
- (lambda ()
- (intern-string! (read-atom))))
-
-(let ((numeric-prefix
- (lambda ()
- (let ((number
- (let ((char (read-char)))
- (string-append (char->string #\# char) (read-atom)))))
- (or (parse-number number)
- (error "READ: Bad number syntax" number))))))
- (define-char-special '(#\b #\B) numeric-prefix)
- (define-char-special '(#\o #\O) numeric-prefix)
- (define-char-special '(#\d #\D) numeric-prefix)
- (define-char-special '(#\x #\X) numeric-prefix)
- (define-char-special '(#\i #\I) numeric-prefix)
- (define-char-special '(#\e #\E) numeric-prefix)
- (define-char-special '(#\s #\S) numeric-prefix)
- (define-char-special '(#\l #\L) numeric-prefix))
-\f
-(define-char #\(
- (lambda ()
- (discard-char)
- (collect-list/top-level)))
+(define (parse-object/symbol)
+ (intern-string! (read-atom)))
+
+(define (parse-object/numeric-prefix)
+ (let ((number
+ (let ((char (read-char)))
+ (string-append (char->string #\# char) (read-atom)))))
+ (or (parse-number number)
+ (parse-error "Bad number syntax" number))))
-(define-char-special #\(
- (lambda ()
- (discard-char)
- (list->vector (collect-list/top-level))))
+(define (parse-object/bit-string)
+ (discard-char)
+ (let ((string (read-atom)))
+ (unsigned-integer->bit-string
+ (string-length string)
+ (or (string->number string false 2)
+ (error "READ: bad syntax for bit-string")))))\f
+;;;; Lists/Vectors
+
+(define (parse-object/list-open)
+ (discard-char)
+ (collect-list/top-level))
+
+(define (parse-object/vector-open)
+ (discard-char)
+ (list->vector (collect-list/top-level)))
+
+(define (parse-object/list-close)
+ (if (and ignore-extra-list-closes
+ (eq? console-input-port *parser-input-port*))
+ (discard-char)
+ (parse-error "Unmatched close paren" (read-char)))
+ (parse-object/dispatch))
+
+(define (collect-list/list-close)
+ (discard-char)
+ '())
+
+(define ignore-extra-list-closes
+ true)
(define (collect-list/top-level)
- (let ((value (collect-list)))
+ (let ((value (collect-list/dispatch)))
(if (and (pair? value)
(eq? dot-symbol (car value)))
- (error "PARSE-OBJECT: Improperly formed dotted list" value)
+ (parse-error "Improperly formed dotted list" value)
value)))
-(define ignore-extra-close-parens
- true)
+(define ((collect-list-wrapper parse-object))
+ (let ((first (parse-object))) ;forces order.
+ (let ((rest (collect-list/dispatch)))
+ (if (and (pair? rest)
+ (eq? dot-symbol (car rest)))
+ (if (and (pair? (cdr rest))
+ (null? (cddr rest)))
+ (cons first (cadr rest))
+ (parse-error "Improperly formed dotted list" (cons first rest)))
+ (cons first rest)))))
-(define-char #\)
- (lambda ()
- (if (and ignore-extra-close-parens
- (eq? console-input-port *parser-input-port*))
- (discard-char)
- (error "PARSE-OBJECT: Unmatched close paren" (read-char)))
- (parse-object))
- (lambda ()
- (discard-char)
- '()))
+(define dot-symbol)
\f
-(define-char undefined-atom-delimiters
- (lambda ()
- (error "PARSE-OBJECT: Undefined atom delimiter" (read-char))
- (parse-object))
- (lambda ()
- (error "PARSE-OBJECT: Undefined atom delimiter" (read-char))
- (collect-list)))
-
-(let ()
-
-(define-char char-set:whitespace
- (lambda ()
- (discard-whitespace)
- (parse-object))
- (lambda ()
- (discard-whitespace)
- (collect-list)))
+;;;; Whitespace/Comments
+
+(define (parse-object/whitespace)
+ (discard-whitespace)
+ (parse-object/dispatch))
+
+(define (collect-list/whitespace)
+ (discard-whitespace)
+ (collect-list/dispatch))
(define (discard-whitespace)
- (discard-chars non-whitespace))
+ (discard-chars char-set/non-whitespace))
-(define non-whitespace
- (char-set-invert char-set:whitespace))
+(define (parse-object/undefined-atom-delimiter)
+ (parse-error "Undefined atom delimiter" (read-char))
+ (parse-object/dispatch))
-)
-\f
-(let ()
+(define (collect-list/undefined-atom-delimiter)
+ (parse-error "Undefined atom delimiter" (read-char))
+ (collect-list/dispatch))
-(define-char #\;
- (lambda ()
- (discard-comment)
- (parse-object))
- (lambda ()
- (discard-comment)
- (collect-list)))
+(define (parse-object/comment)
+ (discard-comment)
+ (parse-object/dispatch))
+
+(define (collect-list/comment)
+ (discard-comment)
+ (collect-list/dispatch))
(define (discard-comment)
(discard-char)
- (discard-chars comment-delimiters)
+ (discard-chars char-set/comment-delimiters)
(discard-char))
-(define comment-delimiters
- (char-set char:newline))
-
-)
-
-(let ()
+(define (parse-object/special-comment)
+ (discard-special-comment)
+ (parse-object/dispatch))
-(define-char-special #\|
- (lambda ()
- (discard-char)
- (discard-special-comment)
- (parse-object))
- (lambda ()
- (discard-char)
- (discard-special-comment)
- (collect-list)))
+(define (collect-list/special-comment)
+ (discard-special-comment)
+ (collect-list/dispatch))
(define (discard-special-comment)
- (discard-chars special-comment-leaders)
- (if (char=? #\| (read-char))
- (if (char=? #\# (peek-char))
- (discard-char)
- (discard-special-comment))
- (begin (if (char=? #\| (peek-char))
- (begin (discard-char)
- (discard-special-comment)))
- (discard-special-comment))))
-
-(define special-comment-leaders
- (char-set #\# #\|))
-
-)
-\f
-(define-char #\'
- (lambda ()
- (discard-char)
- (list 'QUOTE (parse-object))))
-
-(define-char #\`
- (lambda ()
- (discard-char)
- (list 'QUASIQUOTE (parse-object))))
-
-(define-char #\,
- (lambda ()
- (discard-char)
- (if (char=? #\@ (peek-char))
- (begin (discard-char)
- (list 'UNQUOTE-SPLICING (parse-object)))
- (list 'UNQUOTE (parse-object)))))
-
-(define-char #\"
- (let ((delimiters (char-set #\" #\\)))
- (lambda ()
- (define (loop string)
- (if (char=? #\" (read-char))
- string
- (let ((char (read-char)))
- (string-append string
- (char->string
- (cond ((char-ci=? char #\t) #\Tab)
- ((char-ci=? char #\n) char:newline)
- ((char-ci=? char #\f) #\Page)
- (else char)))
- (loop (read-string delimiters))))))
- (discard-char)
- (loop (read-string delimiters)))))
+ (discard-char)
+ (let loop ()
+ (discard-chars char-set/special-comment-leaders)
+ (if (char=? #\| (read-char))
+ (if (char=? #\# (peek-char))
+ (discard-char)
+ (loop))
+ (begin (if (char=? #\| (peek-char))
+ (begin (discard-char)
+ (loop)))
+ (loop)))))
\f
-(define-char-special #\\
- (let ((delimiters (char-set-union (char-set #\- #\\) atom-delimiters)))
- (lambda ()
- (define (loop)
- (cond ((char=? #\\ (peek-char))
- (discard-char)
- (char->string (read-char)))
- ((char-set-member? delimiters (peek-char))
- (char->string (read-char)))
- (else
- (let ((string (read-string delimiters)))
- (if (let ((char (*parser-peek-char*)))
- (and char
- (char=? #\- char)))
- (begin (discard-char)
- (string-append string "-" (loop)))
- string)))))
- (discard-char)
- (if (char=? #\\ (peek-char))
- (read-char)
- (name->char (loop))))))
+;;;; Quoting
-(define ((fixed-object-parser object))
+(define (parse-object/quote)
(discard-char)
- object)
-
-(define-char-special '(#\f #\F) (fixed-object-parser false))
-(define-char-special '(#\t #\T) (fixed-object-parser true))
-
-(define-char-special #\!
- (lambda ()
- (discard-char)
- (let ((object-name (parse-object)))
- (cdr (or (assq object-name named-objects)
- (error "No object by this name" object-name))))))
-
-(define named-objects
- `((NULL . ,(list))
- (FALSE . ,(eq? 'TRUE 'FALSE))
- (TRUE . ,(eq? 'TRUE 'TRUE))
- (OPTIONAL . ,(access lambda-optional-tag lambda-package))
- (REST . ,(access lambda-rest-tag lambda-package))))
-
-;;; end PARSER-PACKAGE.
-))
-\f
-;;;; Parser Tables
-
-(define (parser-table-copy table)
- (cons (cons (vector-copy (caar table))
- (vector-copy (cdar table)))
- (cons (vector-copy (cadr table))
- (vector-copy (cddr table)))))
-
-(define parser-table-entry)
-(define set-parser-table-entry!)
-(let ()
-
-(define (decode-parser-char table char receiver)
- (cond ((char? char)
- (receiver (car table) (char->ascii char)))
- ((string? char)
- (cond ((= (string-length char) 1)
- (receiver (car table) (char->ascii (string-ref char 0))))
- ((and (= (string-length char) 2)
- (char=? #\# (string-ref char 0)))
- (receiver (cdr table) (char->ascii (string-ref char 1))))
- (else
- (error "Bad character" 'DECODE-PARSER-CHAR char))))
- (else
- (error "Bad character" 'DECODE-PARSER-CHAR char))))
+ (list 'QUOTE (parse-object/dispatch)))
-(define (ptable-ref table index)
- (cons (vector-ref (car table) index)
- (vector-ref (cdr table) index)))
+(define (parse-object/quasiquote)
+ (discard-char)
+ (list 'QUASIQUOTE (parse-object/dispatch)))
-(define (ptable-set! table index value)
- (vector-set! (car table) index (car value))
- (vector-set! (cdr table) index (cdr value)))
+(define (parse-object/unquote)
+ (discard-char)
+ (if (char=? #\@ (peek-char))
+ (begin (discard-char)
+ (list 'UNQUOTE-SPLICING (parse-object/dispatch)))
+ (list 'UNQUOTE (parse-object/dispatch))))
-(set! parser-table-entry
-(named-lambda (parser-table-entry table char)
- (decode-parser-char table char ptable-ref)))
+(define (parse-object/string-quote)
+ (discard-char)
+ (let loop ()
+ (let ((string (read-string char-set/string-delimiters)))
+ (if (char=? #\" (read-char))
+ string
+ (let ((char (read-char)))
+ (string-append string
+ (char->string
+ (cond ((char-ci=? char #\t) #\Tab)
+ ((char-ci=? char #\n) #\Newline)
+ ((char-ci=? char #\f) #\Page)
+ (else char)))
+ (loop)))))))
+
+(define (parse-object/char-quote)
+ (discard-char)
+ (if (char=? #\\ (peek-char))
+ (read-char)
+ (name->char
+ (let loop ()
+ (cond ((char=? #\\ (peek-char))
+ (discard-char)
+ (char->string (read-char)))
+ ((char-set-member? char-set/char-delimiters (peek-char))
+ (char->string (read-char)))
+ (else
+ (let ((string (read-string char-set/char-delimiters)))
+ (if (let ((char (peek-char/eof-ok)))
+ (and char
+ (char=? #\- char)))
+ (begin (discard-char)
+ (string-append string "-" (loop)))
+ string))))))))
+\f
+;;;; Constants
-(set! set-parser-table-entry!
-(named-lambda (set-parser-table-entry! table char entry)
- (decode-parser-char table char
- (lambda (sub-table index)
- (ptable-set! sub-table index entry)))))
+(define (parse-object/false)
+ (discard-char)
+ false)
-)
+(define (parse-object/true)
+ (discard-char)
+ true)
+
+(define (parse-object/named-constant)
+ (discard-char)
+ (let ((object-name (parse-object/dispatch)))
+ (cdr (or (assq object-name named-objects)
+ (parse-error "No object by this name" object-name)))))
+(define named-objects)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/partab.scm,v 14.1 1988/05/20 00:59:48 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/partab.scm,v 14.2 1988/06/13 11:49:18 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Parser Tables
-;;; package: parser-table-package
+;;; package: (runtime parser-table)
(declare (usual-integrations))
\f
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 13.44 1987/08/20 04:03:53 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.1 1988/06/13 11:49:23 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Pathnames
+;;; package: (runtime pathname)
(declare (usual-integrations))
\f#|
\f
;;;; Basic Pathnames
-;;; The following definition won't work because the type system isn't
-;;; defined when this file is loaded:
-
-;;; (define-structure pathname
-;;; (device false read-only true)
-;;; (directory false read-only true)
-;;; (name false read-only true)
-;;; (type false read-only true)
-;;; (version false read-only true))
-
-(define make-pathname)
-(define pathname?)
-(let ((pathname-tag "pathname"))
- (set! make-pathname
- (named-lambda (make-pathname device directory name type version)
- (vector pathname-tag device directory name type version)))
- (set! pathname?
- (named-lambda (pathname? object)
- (and (vector? object)
- (not (zero? (vector-length object)))
- (eq? pathname-tag (vector-ref object 0))))))
-
-(declare (integrate-operator pathname-device
- pathname-directory
- pathname-name
- pathname-type
- pathname-version))
-
-(define (pathname-device pathname)
- (declare (integrate pathname))
- (vector-ref pathname 1))
-
-(define (pathname-directory pathname)
- (declare (integrate pathname))
- (vector-ref pathname 2))
-
-(define (pathname-name pathname)
- (declare (integrate pathname))
- (vector-ref pathname 3))
-
-(define (pathname-type pathname)
- (declare (integrate pathname))
- (vector-ref pathname 4))
-
-(define (pathname-version pathname)
- (declare (integrate pathname))
- (vector-ref pathname 5))
-
-(declare (integrate copy-pathname))
-
-(define copy-pathname
- vector-copy)
-\f
+(define-structure (pathname
+ (copier pathname-copy)
+ (print-procedure
+ (unparser/standard-method 'PATHNAME
+ (lambda (state pathname)
+ (unparse-object state (pathname->string pathname))))))
+ (host false read-only true)
+ (device false read-only true)
+ (directory false read-only true)
+ (name false read-only true)
+ (type false read-only true)
+ (version false read-only true))
+
+(define (pathname-components pathname receiver)
+ (receiver (pathname-host pathname)
+ (pathname-device pathname)
+ (pathname-directory pathname)
+ (pathname-name pathname)
+ (pathname-type pathname)
+ (pathname-version pathname)))
+
(define (pathname-absolute? pathname)
(let ((directory (pathname-directory pathname)))
(and (pair? directory)
(eq? (car directory) 'ROOT))))
(define (pathname-directory-path pathname)
- (make-pathname (pathname-device pathname)
+ (make-pathname (pathname-host pathname)
+ (pathname-device pathname)
(pathname-directory pathname)
false
false
(define (pathname-name-path pathname)
(make-pathname false
+ false
false
(pathname-name pathname)
(pathname-type pathname)
(pathname-version pathname)))
+\f
+(define (pathname-new-host pathname host)
+ (make-pathname host
+ (pathname-device pathname)
+ (pathname-directory pathname)
+ (pathname-name pathname)
+ (pathname-type pathname)
+ (pathname-version pathname)))
(define (pathname-new-device pathname device)
- (make-pathname device
+ (make-pathname (pathname-host pathname)
+ device
(pathname-directory pathname)
(pathname-name pathname)
(pathname-type pathname)
(pathname-version pathname)))
(define (pathname-new-directory pathname directory)
- (make-pathname (pathname-device pathname)
+ (make-pathname (pathname-host pathname)
+ (pathname-device pathname)
directory
(pathname-name pathname)
(pathname-type pathname)
(pathname-version pathname)))
(define (pathname-new-name pathname name)
- (make-pathname (pathname-device pathname)
+ (make-pathname (pathname-host pathname)
+ (pathname-device pathname)
(pathname-directory pathname)
name
(pathname-type pathname)
(pathname-version pathname)))
(define (pathname-new-type pathname type)
- (make-pathname (pathname-device pathname)
+ (make-pathname (pathname-host pathname)
+ (pathname-device pathname)
(pathname-directory pathname)
(pathname-name pathname)
type
(pathname-version pathname)))
(define (pathname-new-version pathname version)
- (make-pathname (pathname-device pathname)
+ (make-pathname (pathname-host pathname)
+ (pathname-device pathname)
(pathname-directory pathname)
(pathname-name pathname)
(pathname-type pathname)
version))
\f
+(define (pathname-default-host pathname host)
+ (if (pathname-host pathname)
+ pathname
+ (pathname-new-host pathname host)))
+
+(define (pathname-default-device pathname device)
+ (if (pathname-device pathname)
+ pathname
+ (pathname-new-device pathname device)))
+
+(define (pathname-default-directory pathname directory)
+ (if (pathname-directory pathname)
+ pathname
+ (pathname-new-directory pathname directory)))
+
+(define (pathname-default-name pathname name)
+ (if (pathname-name pathname)
+ pathname
+ (pathname-new-name pathname name)))
+
+(define (pathname-default-type pathname type)
+ (if (pathname-type pathname)
+ pathname
+ (pathname-new-type pathname type)))
+
+(define (pathname-default-version pathname version)
+ (if (pathname-version pathname)
+ pathname
+ (pathname-new-version pathname version)))
+
+(define (pathname-default pathname host device directory name type version)
+ (make-pathname (or (pathname-host pathname) host)
+ (or (pathname-device pathname) device)
+ (or (pathname-directory pathname) directory)
+ (or (pathname-name pathname) name)
+ (or (pathname-type pathname) type)
+ (or (pathname-version pathname) version)))
+\f
;;;; Pathname Syntax
(define (->pathname object)
(parse-pathname string make-pathname))
(define (pathname->string pathname)
- (pathname-unparse (pathname-device pathname)
+ (pathname-unparse (pathname-host pathname)
+ (pathname-device pathname)
(pathname-directory pathname)
(pathname-name pathname)
(pathname-type pathname)
(pathname-version pathname)))
(define (pathname-directory-string pathname)
- (pathname-unparse (pathname-device pathname)
+ (pathname-unparse (pathname-host pathname)
+ (pathname-device pathname)
(pathname-directory pathname)
false
false
(define (pathname-name-string pathname)
(pathname-unparse false
+ false
false
(pathname-name pathname)
(pathname-type pathname)
(pathname-version pathname)))
\f
-(define (pathname-components pathname receiver)
- (receiver (pathname-device pathname)
- (pathname-directory pathname)
- (pathname-name pathname)
- (pathname-type pathname)
- (pathname-version pathname)))
-
-(define (pathname-extract pathname . fields)
- (make-pathname (and (memq 'DEVICE fields)
- (pathname-device pathname))
- (and (memq 'DIRECTORY fields)
- (pathname-directory pathname))
- (and (memq 'NAME fields)
- (pathname-name pathname))
- (and (memq 'TYPE fields)
- (pathname-type pathname))
- (and (memq 'VERSION fields)
- (pathname-version pathname))))
-
-(define (pathname-extract-string pathname . fields)
- (pathname-unparse (and (memq 'DEVICE fields)
- (pathname-device pathname))
- (and (memq 'DIRECTORY fields)
- (pathname-directory pathname))
- (and (memq 'NAME fields)
- (pathname-name pathname))
- (and (memq 'TYPE fields)
- (pathname-type pathname))
- (and (memq 'VERSION fields)
- (pathname-version pathname))))
-\f
;;;; Pathname Merging
(define (pathname->absolute-pathname pathname)
(define (merge-pathnames pathname default)
(make-pathname
+ (or (pathname-host pathname) (pathname-host default))
(or (pathname-device pathname) (pathname-device default))
(simplify-directory
(let ((directory (pathname-directory pathname))
(or (pathname-type pathname) (pathname-type default))
(or (pathname-version pathname) (pathname-version default))))
-(define simplify-directory)
-(let ()
-
-(set! simplify-directory
- (named-lambda (simplify-directory directory)
- (cond ((not (pair? directory)) directory)
- ((eq? (car directory) 'ROOT)
- (cons 'ROOT (simplify-tail (simplify-root-tail (cdr directory)))))
- (else (simplify-tail directory)))))
+(define (simplify-directory directory)
+ (if (or (null? directory)
+ (not (list? directory)))
+ directory
+ (let ((directory (delq 'SELF directory)))
+ (cond ((null? directory)
+ directory)
+ ((eq? (car directory) 'ROOT)
+ (cons 'ROOT
+ (simplify-tail (simplify-root-tail (cdr directory)))))
+ (else
+ (simplify-tail directory))))))
(define (simplify-root-tail directory)
- (if (and (pair? directory)
- (memq (car directory) '(SELF UP)))
+ (if (and (not (null? directory))
+ (eq? (car directory) 'UP))
(simplify-root-tail (cdr directory))
directory))
(define (simplify-tail directory)
- (cond ((not (pair? directory)) directory)
- ((eq? (car directory) 'SELF) (simplify-tail (cdr directory)))
- ((not (pair? (cdr directory))) directory)
- ((eq? (cadr directory) 'UP) (simplify-tail (cddr directory)))
- (else (cons (car directory) (simplify-tail (cdr directory))))))
-
-)
+ (reverse!
+ (let loop ((elements (reverse directory)))
+ (if (null? elements)
+ '()
+ (let ((head (car elements))
+ (tail (loop (cdr elements))))
+ (if (and (eq? head 'UP)
+ (not (null? tail))
+ (not (eq? (car tail) 'UP)))
+ (cdr tail)
+ (cons head tail)))))))
\f
;;;; Truenames
-(define pathname->input-truename
- (let ((truename-exists?
- (let ((file-exists? (make-primitive-procedure 'FILE-EXISTS?)))
- (lambda (pathname)
- (and (file-exists? (pathname->string pathname))
- pathname)))))
- (named-lambda (pathname->input-truename pathname)
- (let ((pathname (pathname->absolute-pathname pathname)))
- (cond ((not (eq? 'NEWEST (pathname-version pathname)))
- (truename-exists? pathname))
- ((not pathname-newest)
- (truename-exists? (pathname-new-version pathname false)))
- (else
- (pathname-newest pathname)))))))
+(define (pathname->input-truename pathname)
+ (let ((pathname (pathname->absolute-pathname pathname))
+ (truename-exists?
+ (lambda (pathname)
+ (and ((ucode-primitive file-exists?) (pathname->string pathname))
+ pathname))))
+ (cond ((not (eq? 'NEWEST (pathname-version pathname)))
+ (truename-exists? pathname))
+ ((not pathname-newest)
+ (truename-exists? (pathname-new-version pathname false)))
+ (else
+ (pathname-newest pathname)))))
(define (pathname->output-truename pathname)
(let ((pathname (pathname->absolute-pathname pathname)))
(pathname->string (pathname->output-truename (->pathname filename))))
(define (file-exists? filename)
- (pathname->input-truename (->pathname filename)))
\ No newline at end of file
+ (pathname->input-truename (->pathname filename)))
+
+(define (init-file-truename)
+ (let ((pathname (init-file-pathname)))
+ (and pathname
+ (or (pathname->input-truename
+ (merge-pathnames pathname (working-directory-pathname)))
+ (pathname->input-truename
+ (merge-pathnames pathname (home-directory-pathname)))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/poplat.scm,v 14.1 1988/05/20 01:00:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/poplat.scm,v 14.2 1988/06/13 11:49:48 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Populations
-;;; package: population-package
+;;; package: (runtime population)
(declare (usual-integrations))
\f
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 13.44 1987/06/26 04:31:51 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
-;;;; Pretty Printer
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.1 1988/06/13 11:49:53 cph Exp $
-(declare (usual-integrations))
-\f
-(define scheme-pretty-printer
- (make-environment
+Copyright (c) 1988 Massachusetts Institute of Technology
-(define *pp-primitives-by-name* true)
-(define *forced-x-size* false)
-(define *default-x-size* 80)
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
-(define x-size)
-(define next-coords)
-(define add-sc-entry!)
-(define sc-relink!)
-
-(declare (integrate *unparse-string *unparse-char))
+1. Any copy made of this software must include this copyright notice
+in full.
-(define (*unparse-string string)
- (declare (integrate string))
- ((access :write-string *current-output-port*) string))
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
-(define (*unparse-char char)
- (declare (integrate char))
- ((access :write-char *current-output-port*) char))
+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.
-(define (*unparse-open)
- (*unparse-char #\())
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
-(define (*unparse-close)
- (*unparse-char #\)))
+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 without prior written consent from
+MIT in each case. |#
-(define (*unparse-space)
- (*unparse-char #\Space))
+;;;; Pretty Printer
+;;; package: (runtime pretty-printer)
-(define (*unparse-newline)
- (*unparse-char char:newline))
+(declare (usual-integrations))
\f
-;;;; Top Level
-
-(define (pp expression as-code?)
- (fluid-let ((x-size (get-x-size)))
+(define (initialize-package!)
+ (set! forced-indentation (special-printer kernel/forced-indentation))
+ (set! pressured-indentation (special-printer kernel/pressured-indentation))
+ (set! print-procedure (special-printer kernel/print-procedure))
+ (set! print-let-expression (special-printer kernel/print-let-expression))
+ (set! dispatch-list
+ `((COND . ,forced-indentation)
+ (IF . ,forced-indentation)
+ (OR . ,forced-indentation)
+ (AND . ,forced-indentation)
+ (LET . ,print-let-expression)
+ (FLUID-LET . ,print-let-expression)
+ (DEFINE . ,print-procedure)
+ (LAMBDA . ,print-procedure)
+ (NAMED-LAMBDA . ,print-procedure)))
+ (set! walk-dispatcher default/walk-dispatcher))
+\f
+(define (pp scode . optionals)
+ (let ((kernel
+ (lambda (as-code?)
+ (let ((port (current-output-port)))
+ (if (and (not (compound-procedure? scode))
+ (scode-constant? scode))
+ (pp-top-level port scode as-code?)
+ (pp-top-level port
+ (let ((sexp (unsyntax scode)))
+ (if (and (pair? sexp)
+ (eq? (car sexp) 'NAMED-LAMBDA))
+ `(DEFINE ,@(cdr sexp))
+ sexp))
+ true)))))
+ (bad-arg
+ (lambda (argument)
+ (error "PP: Bad optional argument" argument))))
+ (cond ((null? optionals)
+ (kernel false))
+ ((null? (cdr optionals))
+ (cond ((eq? (car optionals) 'AS-CODE)
+ (kernel true))
+ ((output-port? (car optionals))
+ (with-output-to-port (car optionals)
+ (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)))
+ (bad-arg (cadr optionals))))
+ ((output-port? (car optionals))
+ (if (eq? (cadr optionals) 'AS-CODE)
+ (with-output-to-port (car optionals)
+ (lambda ()
+ (kernel true)))
+ (bad-arg (cadr optionals))))
+ (else
+ (bad-arg (car optionals)))))
+ (else
+ (error "PP: Too many optional arguments" optionals))))
+ *the-non-printing-object*)
+\f
+(define (pp-top-level port expression as-code?)
+ (fluid-let
+ ((x-size (get-x-size port))
+ (output-port port)
+ (operation/write-char (output-port/operation/write-char port))
+ (operation/write-string (output-port/operation/write-string port)))
(let ((node (numerical-walk expression)))
- (*unparse-newline)
- ((if as-code? print-node print-non-code-node) node 0 0)
- ((access :flush-output *current-output-port*)))))
+ (*unparse-newline) ((if as-code? print-node print-non-code-node) node 0 0)
+ (output-port/flush-output port))))
(define (stepper-pp expression port p-wrapper table nc relink! sc! offset)
- (fluid-let ((x-size (get-x-size))
+ (fluid-let ((x-size (get-x-size port))
+ (output-port port)
+ (operation/write-char (output-port/operation/write-char port))
+ (operation/write-string
+ (output-port/operation/write-string port))
(walk-dispatcher table)
(next-coords nc)
(sc-relink! relink!)
(print-node (p-wrapper print-node))
(print-guaranteed-node (p-wrapper print-guaranteed-node)))
(let ((node (numerical-walk expression)))
- (with-output-to-port port
- (lambda ()
- (print-node node (car offset) 0)
- ((access :flush-output *current-output-port*)))))))
+ (print-node node (car offset) 0)
+ (output-port/flush-output port))))
-(define (get-x-size)
+(define (get-x-size port)
(or *forced-x-size*
- ((access :x-size *current-output-port*))
- *default-x-size*))
+ (output-port/x-size port)))
+\f
+(define *pp-primitives-by-name* true)
+(define *forced-x-size* false)
+(define x-size)
+(define output-port)
+(define operation/write-char)
+(define operation/write-string)
+
+(define next-coords)
+(define add-sc-entry!)
+(define sc-relink!)
+
+(define-integrable (*unparse-char char)
+ (operation/write-char output-port char))
+
+(define-integrable (*unparse-string string)
+ (operation/write-string output-port string))
+
+(define-integrable (*unparse-open)
+ (*unparse-char #\())
+
+(define-integrable (*unparse-close)
+ (*unparse-char #\)))
+
+(define-integrable (*unparse-space)
+ (*unparse-char #\Space))
+
+(define-integrable (*unparse-newline)
+ (*unparse-char #\Newline))
+\f
(define (print-non-code-node node column depth)
(fluid-let ((dispatch-list '()))
(print-node node column depth)))
(print-column nodes column depth))))
(*unparse-close))
+(define dispatch-list)
+
(define ((special-printer procedure) nodes column depth)
(*unparse-open)
(*unparse-symbol (car nodes))
;;; Force the indentation to be an optimistic column.
-(define forced-indentation
- (special-printer
- (lambda (nodes optimistic pessimistic depth)
- (print-column nodes optimistic depth))))
+(define forced-indentation)
+(define (kernel/forced-indentation nodes optimistic pessimistic depth)
+ pessimistic
+ (print-column nodes optimistic depth))
;;; Pressure the indentation to be an optimistic column; no matter
;;; what happens, insist on a column, but accept a pessimistic one if
;;; necessary.
-(define pressured-indentation
- (special-printer
- (lambda (nodes optimistic pessimistic depth)
- (if (fits-as-column? nodes optimistic depth)
- (print-guaranteed-column nodes optimistic)
- (begin (tab-to pessimistic)
- (print-column nodes pessimistic depth))))))
+(define pressured-indentation)
+(define (kernel/pressured-indentation nodes optimistic pessimistic depth)
+ (if (fits-as-column? nodes optimistic depth)
+ (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
;;; order procedure patterns be printed more carefully.
-(define print-procedure
- (special-printer
- (lambda (nodes optimistic pessimistic depth)
- (print-node (car nodes) optimistic 0)
- (tab-to pessimistic)
- (print-column (cdr nodes) pessimistic depth))))
+(define print-procedure)
+(define (kernel/print-procedure nodes optimistic pessimistic depth)
+ (print-node (car nodes) optimistic 0)
+ (tab-to pessimistic)
+ (print-column (cdr nodes) pessimistic depth))
;;; 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
;;; start on that line if possible; otherwise they line up under the
;;; name. The body, of course, is always indented pessimistically.
-(define print-let-expression
- (special-printer
- (lambda (nodes optimistic pessimistic depth)
- (define (print-body nodes)
- (if (not (null? nodes))
- (begin (tab-to pessimistic)
- (print-column nodes pessimistic depth))))
- (cond ((null? (cdr nodes)) ;Screw case.
- (print-node (car nodes) optimistic depth))
- ((symbol? (car nodes)) ;Named LET.
- (*unparse-symbol (car nodes))
- (let ((new-optimistic
- (1+ (+ optimistic (symbol-length (car nodes))))))
- (cond ((fits-within? (cadr nodes) new-optimistic 0)
- (*unparse-space)
- (print-guaranteed-node (cadr nodes))
- (print-body (cddr nodes)))
- ((fits-as-column? (node-subnodes (cadr nodes))
- (+ new-optimistic 2)
- 0)
- (*unparse-space)
- (*unparse-open)
- (print-guaranteed-column (node-subnodes (cadr nodes))
- (1+ new-optimistic))
- (*unparse-close)
- (print-body (cddr nodes)))
- (else
- (tab-to optimistic)
- (print-node (cadr nodes) optimistic 0)
- (print-body (cddr nodes))))))
- (else ;Ordinary LET.
- (print-node (car nodes) optimistic 0)
- (print-body (cdr nodes)))))))
+(define print-let-expression)
+(define (kernel/print-let-expression nodes optimistic pessimistic depth)
+ (let ((print-body
+ (lambda (nodes)
+ (if (not (null? nodes))
+ (begin (tab-to pessimistic)
+ (print-column nodes pessimistic depth))))))
+ (cond ((null? (cdr nodes)) ;Screw case.
+ (print-node (car nodes) optimistic depth))
+ ((symbol? (car nodes)) ;Named LET.
+ (*unparse-symbol (car nodes))
+ (let ((new-optimistic
+ (1+ (+ optimistic (symbol-length (car nodes))))))
+ (cond ((fits-within? (cadr nodes) new-optimistic 0)
+ (*unparse-space)
+ (print-guaranteed-node (cadr nodes))
+ (print-body (cddr nodes)))
+ ((fits-as-column? (node-subnodes (cadr nodes))
+ (+ new-optimistic 2)
+ 0)
+ (*unparse-space)
+ (*unparse-open)
+ (print-guaranteed-column (node-subnodes (cadr nodes))
+ (1+ new-optimistic))
+ (*unparse-close)
+ (print-body (cddr nodes)))
+ (else
+ (tab-to optimistic)
+ (print-node (cadr nodes) optimistic 0)
+ (print-body (cddr nodes))))))
+ (else ;Ordinary LET.
+ (print-node (car nodes) optimistic 0)
+ (print-body (cdr nodes))))))
\f
-(define dispatch-list
- `((COND . ,forced-indentation)
- (IF . ,forced-indentation)
- (OR . ,forced-indentation)
- (AND . ,forced-indentation)
- (LET . ,print-let-expression)
- (FLUID-LET . ,print-let-expression)
- (DEFINE . ,print-procedure)
- (LAMBDA . ,print-procedure)
- (NAMED-LAMBDA . ,print-procedure)))
-
;;;; Alignment
-(declare (integrate fits-within?))
-
-(define (fits-within? node column depth)
- (declare (integrate node column depth))
+(define-integrable (fits-within? node column depth)
(> (- x-size depth)
(+ column (node-size node))))
(define (numerical-walk object)
((walk-dispatcher object) object))
-(define (walk-general object)
+(define walk-dispatcher)
+(define (default/walk-dispatcher x)
+ (cond ((object-type? (ucode-type interned-symbol) x) identity-procedure)
+ ((primitive-procedure? x) walk-primitive)
+ ((and (pair? x)
+ (not (unparse-list/unparser x)))
+ walk-pair)
+ ((and (vector? x)
+ (not (zero? (vector-length x)))
+ (not (unparse-vector/unparser x)))
+ walk-vector)
+ (else walk-general)))
+
+(define-integrable (walk-general object)
(write-to-string object))
(define (walk-primitive primitive)
(write-to-string primitive)))
(define (walk-pair pair)
- (if (and (eq? (car pair) 'QUOTE)
- (pair? (cdr pair))
- (null? (cddr pair)))
- (make-prefix-node "'" (numerical-walk (cadr pair)))
- (walk-unquoted-pair pair)))
-
-(define (walk-unquoted-pair pair)
- (cond (((access unparse-list/unparser unparser-package) pair)
- (walk-general pair))
- ((null? (cdr pair))
- (make-singleton-list-node (numerical-walk (car pair))))
- (else
- (make-list-node
- (numerical-walk (car pair))
- (if (and (pair? (cdr pair))
- (not
- ((access unparse-list/unparser unparser-package)
- (cdr pair))))
- (walk-unquoted-pair (cdr pair))
- (make-singleton-list-node
- (make-prefix-node ". " (numerical-walk (cdr pair)))))))))
+ (if (null? (cdr pair))
+ (make-singleton-list-node (numerical-walk (car pair)))
+ (make-list-node
+ (numerical-walk (car pair))
+ (if (and (pair? (cdr pair))
+ (not (unparse-list/unparser (cdr pair))))
+ (walk-pair (cdr pair))
+ (make-singleton-list-node
+ (make-prefix-node ". " (numerical-walk (cdr pair))))))))
(define (walk-vector vector)
- (if (zero? (vector-length vector))
- "#()"
- (make-prefix-node "#" (walk-unquoted-pair (vector->list vector)))))
-
-(define walk-dispatcher
- (make-type-dispatcher
- `((,symbol-type ,identity-procedure)
- (,primitive-procedure-type ,walk-primitive)
- (,(microcode-type-object 'PAIR) ,walk-pair)
- (,(microcode-type-object 'VECTOR) ,walk-vector)
- (,unparser-special-object-type ,walk-general))
- walk-general))
+ (make-prefix-node "#" (walk-pair (vector->list vector))))
\f
;;;; Node Model
;;; Carefully crafted to use the least amount of memory, while at the
;;; or the print-name of a symbol wasn't worth the speed that would
;;; be gained by keeping it around.
-(declare (integrate symbol-length))
-
-(define (symbol-length symbol)
- (declare (integrate symbol))
+(define-integrable (symbol-length symbol)
(string-length (symbol->string symbol)))
-(define (*unparse-symbol symbol)
+(define-integrable (*unparse-symbol symbol)
(*unparse-string (symbol->string symbol)))
(define (make-prefix-node prefix subnode)
(node-subnode subnode)))
(else (string-append prefix subnode))))
-(define prefix-node? vector?)
-(define prefix-node-size vector-first)
-(define node-prefix vector-second)
-(define node-subnode vector-third)
+(define-integrable (prefix-node? object)
+ (vector? object))
+
+(define-integrable (prefix-node-size node)
+ (vector-ref node 0))
+(define-integrable (node-prefix node)
+ (vector-ref node 1))
+
+(define-integrable (node-subnode node)
+ (vector-ref node 2))
+\f
(define (make-list-node car-node cdr-node)
(cons (1+ (+ (node-size car-node) (list-node-size cdr-node))) ;+1 space.
(cons car-node (node-subnodes cdr-node))))
(cons (+ 2 (node-size car-node)) ;+1 each parenthesis.
(list car-node)))
-(declare (integrate list-node? list-node-size node-subnodes))
+(define-integrable (list-node? object)
+ (pair? object))
+
+(define-integrable (list-node-size node)
+ (car node))
-(define list-node? pair?)
-(define list-node-size car)
-(define node-subnodes cdr)
+(define-integrable (node-subnodes node)
+ (cdr node))
(define (node-size node)
((cond ((list-node? node) list-node-size)
((symbol? node) symbol-length)
((prefix-node? node) prefix-node-size)
(else string-length))
- node))
-\f
-;;; end SCHEME-PRETTY-PRINTER package.
-))
-
-;;;; Exports
-
-(define pp
- (let ()
- (define (prepare scode)
- (let ((s-expression (unsyntax scode)))
- (if (and (pair? s-expression)
- (eq? (car s-expression) 'NAMED-LAMBDA))
- `(DEFINE ,@(cdr s-expression))
- s-expression)))
-
- (define (bad-arg argument)
- (error "Bad optional argument" 'PP argument))
-
- (lambda (scode . optionals)
- (define (kernel as-code?)
- (if (scode-constant? scode)
- ((access pp scheme-pretty-printer) scode as-code?)
- ((access pp scheme-pretty-printer) (prepare scode) true)))
-
- (cond ((null? optionals)
- (kernel false))
- ((null? (cdr optionals))
- (cond ((eq? (car optionals) 'AS-CODE)
- (kernel true))
- ((output-port? (car optionals))
- (with-output-to-port (car optionals)
- (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)))
- (bad-arg (cadr optionals))))
- ((output-port? (car optionals))
- (if (eq? (cadr optionals) 'AS-CODE)
- (with-output-to-port (car optionals)
- (lambda () (kernel true)))
- (bad-arg (cadr optionals))))
- (else
- (bad-arg (car optionals)))))
- (else
- (error "Too many optional arguments" 'PP optionals)))
- *the-non-printing-object*)))
-
-(define (pa procedure)
- (if (not (compound-procedure? procedure))
- (error "Must be a compound procedure" procedure))
- (pp (unsyntax-lambda-list (procedure-lambda procedure))))
\ No newline at end of file
+ node))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/prop1d.scm,v 14.1 1988/05/20 01:00:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/prop1d.scm,v 14.2 1988/06/13 11:50:11 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; One Dimensional Property Tables
-;;; package: 1d-property-package
+;;; package: (runtime 1d-property)
(declare (usual-integrations))
\f
(system-pair-cdr entry)
default)))
+(define (1d-table/lookup table key if-found if-not-found)
+ (let ((entry (weak-assq (or key false-key) table)))
+ (if entry
+ (if-found (system-pair-cdr entry))
+ (if-not-found))))
+
(define (1d-table/put! table key value)
(let ((key (or key false-key)))
(let ((entry (weak-assq key table)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/prop2d.scm,v 14.1 1988/05/20 01:00:38 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/prop2d.scm,v 14.2 1988/06/13 11:50:17 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Two Dimensional Property Tables
-;;; package: 2D-property-package
+;;; package: (runtime 2D-property)
(declare (usual-integrations))
\f
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/qsort.scm,v 13.41 1987/01/23 00:18:12 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/qsort.scm,v 14.1 1988/06/13 11:50:22 cph Rel $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Quick Sort
+;;; package: ()
(declare (usual-integrations))
\f
-(define (sort obj pred)
- (if (vector? obj)
- (sort! (vector-copy obj) pred)
- (vector->list (sort! (list->vector obj) pred))))
-
-(define sort!
- (let ()
-
- (define (exchange! vec i j)
- ;; Speedup hack uses value of VECTOR-SET!.
- (vector-set! vec j (vector-set! vec i (vector-ref vec j))))
-
- (named-lambda (sort! obj pred)
- (define (sort-internal! vec l r)
- (cond
- ((<= r l)
- vec)
- ((= r (1+ l))
- (if (pred (vector-ref vec r)
- (vector-ref vec l))
- (exchange! vec l r)
- vec))
- (else
- (quick-merge vec l r))))
-
- (define (quick-merge vec l r)
- (let ((first (vector-ref vec l)))
- (define (increase-i i)
- (if (or (> i r)
- (pred first (vector-ref vec i)))
- i
- (increase-i (1+ i))))
- (define (decrease-j j)
- (if (or (<= j l)
- (not (pred first (vector-ref vec j))))
- j
- (decrease-j (-1+ j))))
- (define (loop i j)
- (if (< i j) ;* used to be <=
- (begin (exchange! vec i j)
- (loop (increase-i (1+ i)) (decrease-j (-1+ j))))
- (begin (if (> j l)
- (exchange! vec j l))
- (sort-internal! vec (1+ j) r)
- (sort-internal! vec l (-1+ j)))))
- (loop (increase-i (1+ l))
- (decrease-j r))))
-
- (if (vector? obj)
- (begin (sort-internal! obj 0 (-1+ (vector-length obj)))
- obj)
- (error "SORT! works on vectors only" obj)))))
+(define (sort vector predicate)
+ (if (vector? vector)
+ (sort! (vector-copy vector) predicate)
+ (vector->list (sort! (list->vector vector) predicate))))
+
+(define (sort! vector predicate)
+
+ (define (outer-loop l r)
+ (if (> r l)
+ (if (= r (1+ l))
+ (if (predicate (vector-ref vector r)
+ (vector-ref vector l))
+ (exchange! l r))
+ (let ((lth-element (vector-ref vector l)))
+
+ (define (increase-i i)
+ (if (or (> i r)
+ (predicate lth-element (vector-ref vector i)))
+ i
+ (increase-i (1+ i))))
+
+ (define (decrease-j j)
+ (if (or (<= j l)
+ (not (predicate lth-element (vector-ref vector j))))
+ j
+ (decrease-j (-1+ j))))
+
+ (define (inner-loop i j)
+ (if (< i j) ;used to be <=
+ (begin (exchange! i j)
+ (inner-loop (increase-i (1+ i))
+ (decrease-j (-1+ j))))
+ (begin (if (> j l)
+ (exchange! j l))
+ (outer-loop (1+ j) r)
+ (outer-loop l (-1+ j)))))
+
+ (inner-loop (increase-i (1+ l))
+ (decrease-j r))))))
+
+ (define-integrable (exchange! i j)
+ (let ((ith-element (vector-ref vector i)))
+ (vector-set! vector i (vector-ref vector j))
+ (vector-set! vector j ith-element)))
+
+ (if (not (vector? vector))
+ (error "SORT! works on vectors only" vector))
+ (outer-loop 0 (-1+ (vector-length vector)))
+ vector)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/queue.scm,v 14.1 1988/05/20 01:00:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/queue.scm,v 14.2 1988/06/13 11:50:28 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Simple Queue Abstraction
+;;; package: ()
(declare (usual-integrations))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/random.scm,v 14.1 1988/05/20 01:01:13 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/random.scm,v 14.2 1988/06/13 11:50:32 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Random Number Generator
-;;; package: random-number-package
+;;; package: (runtime random-number)
(declare (usual-integrations))
\f
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 13.44 1988/04/26 19:41:15 cph Exp $
-;;;
-;;; Copyright (c) 1988 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.1 1988/06/13 11:50:36 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Read-Eval-Print Loop
+;;; package: (runtime rep)
(declare (usual-integrations))
\f
+(define (initialize-package!)
+ (set! *nearest-cmdl* false)
+ (set! hook/cmdl-prompt default/cmdl-prompt)
+ (set! hook/cmdl-message default/cmdl-message)
+ (set! cmdl-interrupt/breakpoint default/breakpoint)
+ (set! cmdl-interrupt/abort-top-level default/abort-top-level)
+ (set! cmdl-interrupt/abort-previous default/abort-previous)
+ (set! cmdl-interrupt/abort-nearest default/abort-nearest)
+ (set! hook/repl-environment default/repl-environment)
+ (set! hook/repl-read default/repl-read)
+ (set! hook/repl-write default/repl-write)
+ (set! hook/repl-eval default/repl-eval)
+ (set! hook/read-command-char default/read-command-char)
+ (set! hook/prompt-for-confirmation default/prompt-for-confirmation)
+ (set! hook/prompt-for-expression default/prompt-for-expression))
+
+(define (initial-top-level-repl)
+ (fluid-let ((user-repl-environment user-initial-environment)
+ (user-repl-syntax-table user-initial-syntax-table))
+ (let loop ((message "Cold load finished"))
+ (with-standard-proceed-point
+ (lambda ()
+ (make-repl false
+ user-repl-environment
+ user-repl-syntax-table
+ user-initial-prompt
+ console-input-port
+ console-output-port
+ (cmdl-message/standard message))))
+ (loop "Reset!"))))
+\f
;;;; Command Loops
-(define make-command-loop)
-(define push-command-loop)
-(define push-command-hook)
-(define with-rep-continuation)
-(define continue-rep)
-(define rep-continuation)
-(define rep-state)
-(define rep-level)
-(define abort->nearest)
-(define abort->previous)
-(define abort->top-level)
-(let ()
-
-(define top-level-driver-hook)
-(define previous-driver-hook)
-(define nearest-driver-hook)
-(define current-continuation)
-(define current-state)
-(define current-level 0)
-
-;; PUSH-COMMAND-HOOK is provided so that the Butterfly, in particular,
-;; can add its own little code just before creating a REP loop
-(set! push-command-hook
- (lambda (startup driver state continuation)
- (continuation startup driver state (lambda () 'ignore))))
-
-(set! make-command-loop
- (named-lambda (make-command-loop message driver)
- (define (driver-loop message)
- (driver-loop
- (with-rep-continuation
- (lambda (quit)
- (set! top-level-driver-hook quit)
- (set! nearest-driver-hook quit)
- (driver message)))))
- (set-interrupt-enables! interrupt-mask-gc-ok)
- (fluid-let ((top-level-driver-hook)
- (nearest-driver-hook))
- (driver-loop message))))
-\f
-(set! push-command-loop
-(named-lambda (push-command-loop startup-hook driver initial-state)
- (define (restart entry-hook each-time)
- (let ((reentry-hook
- (call-with-current-continuation
- (lambda (again)
- (set! nearest-driver-hook again)
- (set-interrupt-enables! interrupt-mask-all)
- (each-time)
- (entry-hook)
- (loop)))))
- (set-interrupt-enables! interrupt-mask-gc-ok)
- (restart reentry-hook each-time)))
-
- (define (loop)
- (set! current-state (driver current-state))
- (loop))
-
- (fluid-let ((current-level (1+ current-level))
- (previous-driver-hook nearest-driver-hook)
- (nearest-driver-hook)
- (current-state))
- (push-command-hook
- startup-hook driver initial-state
- (lambda (startup-hook driver initial-state each-time)
- (set! current-state initial-state)
- (restart startup-hook each-time))))))
+(define-structure (cmdl (conc-name cmdl/) (constructor %make-cmdl))
+ (parent false read-only true)
+ (level false read-only true)
+ (driver false read-only true)
+ (proceed-continuation false read-only true)
+ continuation
+ input-port
+ output-port
+ state)
+
+(define (make-cmdl parent input-port output-port driver state message)
+ (if (and parent (not (cmdl? parent)))
+ (error "MAKE-CMDL: illegal parent" parent))
+ (let ((cmdl
+ (%make-cmdl parent
+ (let loop ((parent parent))
+ (if parent
+ (1+ (loop (cmdl/parent parent)))
+ 1))
+ driver
+ (current-proceed-continuation)
+ false
+ input-port
+ output-port
+ state)))
+ (let loop ((message message))
+ (loop
+ (call-with-current-continuation
+ (lambda (continuation)
+ (set-cmdl/continuation! cmdl continuation)
+ (fluid-let
+ ((*nearest-cmdl* cmdl)
+ (cmdl-interrupt/abort-nearest default/abort-nearest)
+ (cmdl-interrupt/abort-previous default/abort-previous)
+ (cmdl-interrupt/abort-top-level default/abort-top-level)
+ (cmdl-interrupt/breakpoint default/breakpoint))
+ (with-interrupt-mask interrupt-mask/all
+ (lambda (interrupt-mask)
+ interrupt-mask
+ (message cmdl)
+ (driver cmdl))))))))))
+
+(define *nearest-cmdl*)
+
+(define (nearest-cmdl)
+ (if (not *nearest-cmdl*) (error "NEAREST-CMDL: no cmdl"))
+ *nearest-cmdl*)
+
+(define (push-cmdl driver state message)
+ (let ((cmdl (nearest-cmdl)))
+ (make-cmdl cmdl
+ (cmdl/input-port cmdl)
+ (cmdl/output-port cmdl)
+ driver
+ state
+ message)))
+
+(define (cmdl/base cmdl)
+ (let ((parent (cmdl/parent cmdl)))
+ (if parent
+ (cmdl/base parent)
+ cmdl)))
\f
-(set! with-rep-continuation
-(named-lambda (with-rep-continuation receiver)
- (call-with-current-continuation
- (lambda (raw-continuation)
- (let ((continuation (raw-continuation->continuation raw-continuation)))
- (fluid-let ((current-continuation continuation))
- (receiver continuation)))))))
-
-(set! continue-rep
-(named-lambda (continue-rep value)
- (current-continuation
- (if (eq? current-continuation top-level-driver-hook)
- (lambda ()
- (write-line value))
- value))))
+;;;; Messages
-(set! abort->nearest
-(named-lambda (abort->nearest message)
- (nearest-driver-hook message)))
+(define hook/cmdl-prompt)
-(set! abort->previous
-(named-lambda (abort->previous message)
- ((if (null? previous-driver-hook)
- nearest-driver-hook
- previous-driver-hook)
- message)))
+(define (default/cmdl-prompt cmdl prompt)
+ (write-string
+ (string-append "\n\n" (number->string (cmdl/level cmdl)) " " prompt " ")
+ (cmdl/output-port cmdl)))
-(set! abort->top-level
-(named-lambda (abort->top-level message)
- (top-level-driver-hook message)))
+(define ((cmdl-message/standard string) cmdl)
+ (hook/cmdl-message cmdl string))
-(set! rep-continuation
-(named-lambda (rep-continuation)
- current-continuation))
+(define hook/cmdl-message)
-(set! rep-state
-(named-lambda (rep-state)
- current-state))
+(define (default/cmdl-message cmdl string)
+ (write-string (string-append "\n" string) (cmdl/output-port cmdl)))
-(set! rep-level
-(named-lambda (rep-level)
- current-level))
+(define ((cmdl-message/strings . strings) cmdl)
+ (let ((port (cmdl/output-port cmdl)))
+ (for-each (lambda (string)
+ (write-string (string-append "\n" string) port))
+ strings)))
-) ; LET
-\f
-;;;; Read-Eval-Print Loops
-
-(define *rep-base-environment*)
-(define *rep-current-environment*)
-(define *rep-base-syntax-table*)
-(define *rep-current-syntax-table*)
-(define *rep-base-prompt*)
-(define *rep-current-prompt*)
-(define *rep-base-input-port*)
-(define *rep-current-input-port*)
-(define *rep-base-output-port*)
-(define *rep-current-output-port*)
-(define *rep-keyboard-map*)
-(define *rep-error-hook*)
-
-(define (rep-environment)
- *rep-current-environment*)
-
-(define (rep-base-environment)
- *rep-base-environment*)
-
-(define (set-rep-environment! environment)
- (set! *rep-current-environment* environment)
- (environment-warning-hook *rep-current-environment*))
-
-(define (set-rep-base-environment! environment)
- (set! *rep-base-environment* environment)
- (set! *rep-current-environment* environment)
- (environment-warning-hook *rep-current-environment*))
-
-(define (rep-syntax-table)
- *rep-current-syntax-table*)
-
-(define (rep-base-syntax-table)
- *rep-base-syntax-table*)
-
-(define (set-rep-syntax-table! syntax-table)
- (set! *rep-current-syntax-table* syntax-table))
-
-(define (set-rep-base-syntax-table! syntax-table)
- (set! *rep-base-syntax-table* syntax-table)
- (set! *rep-current-syntax-table* syntax-table))
+(define ((cmdl-message/null) cmdl)
+ cmdl
+ false)
+
+(define ((cmdl-message/active thunk) cmdl)
+ (with-output-to-port (cmdl/output-port cmdl)
+ thunk))
+
+(define ((cmdl-message/append . messages) cmdl)
+ (for-each (lambda (message) (message cmdl)) messages))
\f
-(define (rep-prompt)
- *rep-current-prompt*)
+;;;; Interrupts
-(define (set-rep-prompt! prompt)
- (set! *rep-current-prompt* prompt))
+(define cmdl-interrupt/abort-nearest)
+(define cmdl-interrupt/abort-previous)
+(define cmdl-interrupt/abort-top-level)
+(define cmdl-interrupt/breakpoint)
-(define (rep-base-prompt)
- *rep-base-prompt*)
+(define (default/abort-nearest)
+ (abort-to-nearest-driver "Abort!"))
-(define (set-rep-base-prompt! prompt)
- (set! *rep-base-prompt* prompt)
- (set! *rep-current-prompt* prompt))
+(define (abort-to-nearest-driver message)
+ (abort->nearest (cmdl-message/standard message)))
-(define (rep-input-port)
- *rep-current-input-port*)
+(define (abort->nearest message)
+ ((cmdl/continuation (nearest-cmdl)) message))
-(define (rep-output-port)
- *rep-current-output-port*)
+(define (default/abort-previous)
+ (abort-to-previous-driver "Up!"))
-(define environment-warning-hook
- identity-procedure)
+(define (abort-to-previous-driver message)
+ (abort->previous (cmdl-message/standard message)))
-(define rep-read-hook
- read)
+(define (abort->previous message)
+ ((cmdl/continuation
+ (let ((cmdl (nearest-cmdl)))
+ (or (cmdl/parent cmdl)
+ cmdl)))
+ message))
-(define rep-value-hook
- write-line)
+(define (default/abort-top-level)
+ (abort-to-top-level-driver "Quit!"))
-(define make-rep)
-(define push-rep)
-(define rep-eval-hook)
-(define rep-value)
-(define reader-history)
-(define printer-history)
-(let ()
-\f
-(set! make-rep
-(named-lambda (make-rep environment syntax-table prompt input-port output-port
- message)
- (fluid-let ((*rep-base-environment* environment)
- (*rep-base-syntax-table* syntax-table)
- (*rep-base-prompt* prompt)
- (*rep-base-input-port* input-port)
- (*rep-base-output-port* output-port)
- (*rep-keyboard-map* (keyboard-interrupt-dispatch-table))
- (*rep-error-hook* (access *error-hook* error-system)))
- (make-command-loop message rep-top-driver))))
-
-(define (rep-top-driver message)
- (push-rep *rep-base-environment* message *rep-base-prompt*))
-
-(set! push-rep
-(named-lambda (push-rep environment message prompt)
- (fluid-let ((*rep-current-environment* environment)
- (*rep-current-syntax-table* *rep-base-syntax-table*)
- (*rep-current-prompt* prompt)
- (*rep-current-input-port* *rep-base-input-port*)
- (*rep-current-output-port* *rep-base-output-port*)
- (*current-input-port* *rep-base-input-port*)
- (*current-output-port* *rep-base-output-port*)
- ((access *error-hook* error-system) *rep-error-hook*))
- (with-keyboard-interrupt-dispatch-table *rep-keyboard-map*
- (lambda ()
- (environment-warning-hook *rep-current-environment*)
- (push-command-loop message
- rep-driver
- (make-rep-state (make-history 5)
- (make-history 10))))))))
-
-(define (rep-driver state)
- (*rep-current-prompt*)
- (rep-value (rep-eval-hook (rep-read-hook)
- *rep-current-environment*
- *rep-current-syntax-table*))
- state)
+(define (abort-to-top-level-driver message)
+ (abort->top-level (cmdl-message/standard message)))
-(set! rep-eval-hook
- (named-lambda (rep-eval-hook s-expression environment syntax-table)
- (record-in-history! (rep-state-reader-history (rep-state)) s-expression)
- (with-new-history
- (let ((scode (syntax s-expression syntax-table)))
- (lambda () (scode-eval scode environment))))))
-
-(set! rep-value
- (named-lambda (rep-value object)
- (record-in-history! (rep-state-printer-history (rep-state)) object)
- (rep-value-hook object)))
-\f
-;;; History Manipulation
+(define (abort->top-level message)
+ ((let ((cmdl (cmdl/base (nearest-cmdl))))
+ (if cmdl-interrupt/abort-top-level/reset?
+ (cmdl/proceed-continuation cmdl)
+ (cmdl/continuation cmdl)))
+ message))
-(define (make-history size)
- (let ((list (make-list size '())))
- (append! list list)
- (vector history-tag size list)))
+;; User option variable
+(define cmdl-interrupt/abort-top-level/reset? false)
-(define history-tag
- '(REP-HISTORY))
+(define (default/breakpoint)
+ (with-standard-proceed-point
+ (lambda ()
+ (breakpoint (cmdl-message/standard "^B interrupt")
+ (standard-repl-environment)))))
+\f
+;;;; Proceed
-(define (record-in-history! history object)
- (if (not (null? (vector-ref history 2)))
- (begin (set-car! (vector-ref history 2) object)
- (vector-set! history 2 (cdr (vector-ref history 2))))))
+(define (with-proceed-point value-filter thunk)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (fluid-let ((proceed-continuation continuation)
+ (proceed-value-filter value-filter))
+ (thunk)))))
-(define (read-history history n)
- (if (not (and (integer? n)
- (not (negative? n))
- (< n (vector-ref history 1))))
- (error "Bad argument: READ-HISTORY" n))
- (list-ref (vector-ref history 2)
- (- (-1+ (vector-ref history 1)) n)))
+(define (current-proceed-continuation)
+ proceed-continuation)
-(define ((history-reader selector name) n)
- (let ((state (rep-state)))
- (if (rep-state? state)
- (read-history (selector state) n)
- (error "Not in REP loop" name))))
+(define (proceed . arguments)
+ (proceed-value-filter proceed-continuation arguments))
-(define rep-state-tag
- "REP State")
+(define proceed-continuation false)
+(define proceed-value-filter)
-(define (make-rep-state reader-history printer-history)
- (vector rep-state-tag reader-history printer-history))
+(define (with-standard-proceed-point thunk)
+ (with-proceed-point standard-value-filter thunk))
-(define (rep-state? object)
- (and (vector? object)
- (not (zero? (vector-length object)))
- (eq? (vector-ref object 0) rep-state-tag)))
+(define (standard-value-filter continuation arguments)
+ (continuation
+ (if (null? arguments)
+ *the-non-printing-object*
+ (car arguments))))
+\f
+;;;; REP Loops
+
+(define-structure (repl-state (conc-name repl-state/))
+ prompt
+ environment
+ syntax-table
+ reader-history
+ printer-history)
+
+(define (make-repl parent environment syntax-table prompt input-port
+ output-port message)
+ (make-cmdl parent
+ input-port
+ output-port
+ repl-driver
+ (make-repl-state prompt
+ environment
+ syntax-table
+ (make-repl-history reader-history-size)
+ (make-repl-history printer-history-size))
+ message))
+
+(define (repl-driver repl)
+ (fluid-let ((hook/error-handler default/error-handler))
+ (hook/cmdl-prompt repl (repl/prompt repl))
+ (let ((s-expression (hook/repl-read repl)))
+ (cmdl-message/value
+ (hook/repl-eval repl
+ s-expression
+ (repl/environment repl)
+ (repl/syntax-table repl))))))
+
+(define (repl? object)
+ (and (cmdl? object)
+ (repl-state? (cmdl/state object))))
+
+(define-integrable (repl/prompt repl)
+ (repl-state/prompt (cmdl/state repl)))
+
+(define-integrable (set-repl/prompt! repl prompt)
+ (set-repl-state/prompt! (cmdl/state repl) prompt))
+
+(define-integrable (repl/environment repl)
+ (repl-state/environment (cmdl/state repl)))
+
+(define-integrable (set-repl/environment! repl environment)
+ (set-repl-state/environment! (cmdl/state repl) environment))
+
+(define-integrable (repl/syntax-table repl)
+ (repl-state/syntax-table (cmdl/state repl)))
+
+(define-integrable (set-repl/syntax-table! repl syntax-table)
+ (set-repl-state/syntax-table! (cmdl/state repl) syntax-table))
+
+(define-integrable (repl/reader-history repl)
+ (repl-state/reader-history (cmdl/state repl)))
+
+(define-integrable (set-repl/reader-history! repl reader-history)
+ (set-repl-state/reader-history! (cmdl/state repl) reader-history))
+
+(define-integrable (repl/printer-history repl)
+ (repl-state/printer-history (cmdl/state repl)))
+
+(define-integrable (set-repl/printer-history! repl printer-history)
+ (set-repl-state/printer-history! (cmdl/state repl) printer-history))
+\f
+(define (repl/parent repl)
+ (skip-non-repls (cmdl/parent repl)))
+
+(define (nearest-repl)
+ (or (skip-non-repls (nearest-cmdl))
+ (error "NEAREST-REPL: no REPLs")))
+
+(define (skip-non-repls cmdl)
+ (and cmdl
+ (if (repl-state? (cmdl/state cmdl))
+ cmdl
+ (skip-non-repls (cmdl/parent cmdl)))))
+
+(define (repl/base repl)
+ (let ((parent (repl/parent repl)))
+ (if parent
+ (repl/base parent)
+ repl)))
+
+(define (standard-repl-environment)
+ (let ((repl (nearest-repl)))
+ (if repl
+ (repl/environment repl)
+ user-initial-environment)))
+
+(define (standard-repl-syntax-table)
+ (let ((repl (nearest-repl)))
+ (if repl
+ (repl/syntax-table repl)
+ user-initial-syntax-table)))
+
+(define (push-repl environment message prompt)
+ (let ((parent (nearest-cmdl)))
+ (make-repl parent
+ environment
+ (standard-repl-syntax-table)
+ prompt
+ (cmdl/input-port parent)
+ (cmdl/output-port parent)
+ message)))
+
+(define (read-eval-print environment message prompt)
+ (with-standard-proceed-point
+ (lambda ()
+ (push-repl environment message prompt))))
+
+(define (breakpoint message environment)
+ (push-repl environment message "Bkpt->"))
+
+(define (breakpoint-procedure environment message . irritants)
+ (with-history-disabled
+ (lambda ()
+ (with-standard-proceed-point
+ (lambda ()
+ (breakpoint (apply cmdl-message/error message irritants)
+ environment))))))
+\f
+;;;; Hooks
+
+(define hook/repl-environment)
+(define hook/repl-read)
+(define hook/repl-eval)
+(define hook/repl-write)
+
+(define (default/repl-environment repl environment)
+ repl environment
+ false)
+
+(define (default/repl-read repl)
+ (let ((s-expression (read (cmdl/input-port repl))))
+ (repl-history/record! (repl/reader-history repl) s-expression)
+ s-expression))
+
+(define (default/repl-eval repl s-expression environment syntax-table)
+ repl ;ignore
+ (let ((scode (syntax s-expression syntax-table)))
+ (with-new-history (lambda () (scode-eval scode environment)))))
+(define ((cmdl-message/value value) repl)
+ (hook/repl-write repl value))
+
+(define (default/repl-write repl object)
+ (repl-history/record! (repl/printer-history repl) object)
+ (let ((port (cmdl/output-port repl)))
+ (if (undefined-value? object)
+ (write-string "\n;No value" port)
+ (write-line object port))))
+\f
+;;;; History
-(define rep-state-reader-history vector-second)
-(define rep-state-printer-history vector-third)
+(define reader-history-size 5)
+(define printer-history-size 10)
-(set! reader-history
- (history-reader rep-state-reader-history 'READER-HISTORY))
+(define-structure (repl-history (constructor %make-repl-history)
+ (conc-name repl-history/))
+ (size false read-only true)
+ elements)
-(set! printer-history
- (history-reader rep-state-printer-history 'PRINTER-HISTORY))
+(define (make-repl-history size)
+ (%make-repl-history size (make-circular-list size '())))
-)
\ No newline at end of file
+(define (repl-history/record! history object)
+ (let ((elements (repl-history/elements history)))
+ (if (not (null? elements))
+ (begin (set-car! elements object)
+ (set-repl-history/elements! history (cdr elements))))))
+
+(define (repl-history/read history n)
+ (if (not (and (integer? n)
+ (not (negative? n)) (< n (repl-history/size history))))
+ (error "REPL-HISTORY/READ: Bad argument" n))
+ (list-ref (repl-history/elements history)
+ (- (-1+ (repl-history/size history)) n)))
+\f
+;;; User Interface Stuff
+
+(define user-repl-environment)
+(define user-repl-syntax-table)
+
+(define (ge environment)
+ (let ((repl (nearest-repl))
+ (environment (->environment environment)))
+ (set! user-repl-environment environment)
+ (set-repl-state/environment! (cmdl/state repl) environment)
+ (hook/repl-environment repl environment)
+ environment))
+
+(define (ve environment)
+ (let ((repl (nearest-repl))
+ (environment (->environment environment)))
+ (set-repl-state/environment! (cmdl/state repl) environment)
+ (set-repl-state/prompt! (cmdl/state repl) "Visiting->")
+ (hook/repl-environment repl environment)
+ environment))
+
+(define (->environment object)
+ (cond ((or (eq? object system-global-environment)
+ (environment? object))
+ object)
+ ((compound-procedure? object) (procedure-environment object))
+ ((promise? object)
+ (promise-environment object))
+ (else
+ (let ((package
+ (let ((package-name
+ (cond ((symbol? object) (list object))
+ ((list? object) object)
+ (else false))))
+ (and package-name
+ (name->package package-name)))))
+ (if (not package)
+ (error "->ENVIRONMENT: Not an environment" object))
+ (package/environment package)))))
+
+(define (gst syntax-table)
+ (guarantee-syntax-table syntax-table)
+ (set! user-repl-syntax-table syntax-table)
+ (set-repl-state/syntax-table! (cmdl/state (nearest-repl)) syntax-table)
+ *the-non-printing-object*)
+
+(define (vst syntax-table)
+ (guarantee-syntax-table syntax-table)
+ (set-repl-state/syntax-table! (cmdl/state (nearest-repl)) syntax-table)
+ *the-non-printing-object*)
+
+(define (re #!optional index)
+ (let ((repl (nearest-repl)))
+ (hook/repl-eval repl
+ (repl-history/read (repl/reader-history repl)
+ (if (default-object? index) 1 index))
+ (repl/environment repl)
+ (repl/syntax-table repl))))
+
+(define (in #!optional index)
+ (repl-history/read (repl/reader-history (nearest-repl))
+ (if (default-object? index) 1 index)))
+
+(define (out #!optional index)
+ (repl-history/read (repl/printer-history (nearest-repl))
+ (-1+ (if (default-object? index) 1 index))))
+
+;; Compatibility.
+(define %ge ge)
+(define %ve ve)
+(define %gst gst)
+(define %vst vst)
+(define %in in)
+(define %out out)
+\f
+;;;; Prompting
+
+(define (prompt-for-command-char prompt #!optional cmdl)
+ (let ((cmdl (if (default-object? cmdl) (nearest-cmdl) cmdl)))
+ (hook/cmdl-prompt cmdl prompt)
+ (hook/read-command-char cmdl prompt)))
+
+(define (prompt-for-confirmation prompt #!optional cmdl)
+ (hook/prompt-for-confirmation (if (default-object? cmdl) (nearest-cmdl) cmdl)
+ prompt))
+
+(define (prompt-for-expression prompt #!optional cmdl)
+ (hook/prompt-for-expression (if (default-object? cmdl) (nearest-cmdl) cmdl)
+ prompt))
+
+(define hook/read-command-char)
+(define hook/prompt-for-confirmation)
+(define hook/prompt-for-expression)
+
+(define (default/read-command-char cmdl prompt)
+ ;; Prompt argument is random. Emacs interface needs it right now.
+ prompt
+ (read-char-internal (cmdl/input-port cmdl)))
+
+(define (default/prompt-for-confirmation cmdl prompt)
+ (let ((input-port (cmdl/input-port cmdl))
+ (output-port (cmdl/output-port cmdl)))
+ (let loop ()
+ (newline output-port)
+ (write-string prompt output-port)
+ (write-string "(y or n) " output-port)
+ (let ((char (char-upcase (read-char-internal input-port))))
+ (cond ((or (char=? #\Y char)
+ (char=? #\Space char))
+ (write-string "Yes" output-port)
+ true)
+ ((or (char=? #\N char)
+ (char=? #\Rubout char))
+ (write-string "No" output-port)
+ false)
+ (else
+ (beep output-port)
+ (loop)))))))
+
+(define (default/prompt-for-expression cmdl prompt)
+ (let ((output-port (cmdl/output-port cmdl)))
+ (newline output-port)
+ (write-string prompt output-port) (read (cmdl/input-port cmdl))))
+
+(define (read-char-internal input-port)
+ (let loop ()
+ (let ((char (read-char input-port)))
+ (if (char=? char char:newline)
+ (loop)
+ char))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.1 1988/05/20 01:01:33 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.2 1988/06/13 11:50:50 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Save/Restore World
-;;; package: save/restore-package
+;;; package: (runtime save/restore)
(declare (usual-integrations))
\f
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scan.scm,v 13.42 1987/11/17 00:25:34 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scan.scm,v 14.1 1988/06/13 11:50:55 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Definition Scanner
+;;; package: (runtime scode-scan)
(declare (usual-integrations))
\f
;;; OPEN-BLOCK-COMPONENTS, will connect directly to SCAN-DEFINES and
;;; UNSCAN-DEFINES, respectively.
-(define scan-defines)
-(define unscan-defines)
-(define make-open-block)
-(define open-block?)
-(define open-block-components)
+(define (initialize-package!)
+ (set! open-block-tag (make-named-tag "OPEN-BLOCK")))
+
+(define open-block-tag)
-(let ((open-block-tag (make-named-tag "OPEN-BLOCK"))
- (sequence-2-type (microcode-type 'SEQUENCE-2))
- (sequence-3-type (microcode-type 'SEQUENCE-3))
- (null-sequence '(NULL-SEQUENCE)))
+(define-integrable sequence-2-type
+ (ucode-type sequence-2))
+
+(define-integrable sequence-3-type
+ (ucode-type sequence-3))
+
+(define null-sequence
+ '(NULL-SEQUENCE))
+
+(define (cons-sequence action sequence)
+ (cond ((object-type? sequence-2-type sequence)
+ (&typed-triple-cons sequence-3-type
+ action
+ (&pair-car sequence)
+ (&pair-cdr sequence)))
+ ((eq? sequence null-sequence)
+ action)
+ (else
+ (&typed-pair-cons sequence-2-type action sequence))))
\f
;;;; Scanning
;;; of auxiliaries will result in LAMBDA-COMPONENTS returning an
;;; EQUAL? list.
-(set! scan-defines
-(named-lambda (scan-defines expression receiver)
- ((scan-loop expression receiver) '() '() null-sequence)))
+(define (scan-defines expression receiver)
+ ((scan-loop expression receiver) '() '() null-sequence))
(define (scan-loop expression receiver)
- (cond ((primitive-type? sequence-2-type expression)
+ (cond ((object-type? sequence-2-type expression)
(scan-loop (&pair-cdr expression)
(scan-loop (&pair-car expression)
receiver)))
- ((primitive-type? sequence-3-type expression)
+ ((object-type? sequence-3-type expression)
(let ((first (&triple-first expression)))
(if (and (vector? first)
(not (zero? (vector-length first)))
declarations
(cons-sequence expression body))))))
\f
-(define (cons-sequence action sequence)
- (cond ((primitive-type? sequence-2-type sequence)
- (&typed-triple-cons sequence-3-type
- action
- (&pair-car sequence)
- (&pair-cdr sequence)))
- ((eq? sequence null-sequence)
- action)
- (else
- (&typed-pair-cons sequence-2-type action sequence))))
-\f
-(set! unscan-defines
-(named-lambda (unscan-defines names declarations body)
+(define (unscan-defines names declarations body)
(unscan-loop names body
(lambda (names* body*)
(if (not (null? names*))
body*
(&typed-pair-cons sequence-2-type
(make-block-declaration declarations)
- body*))))))
+ body*)))))
(define (unscan-loop names body receiver)
(cond ((null? names) (receiver '() body))
(make-definition name value))
(receiver names
body)))))
- ((primitive-type? sequence-2-type body)
+ ((object-type? sequence-2-type body)
(unscan-loop names (&pair-car body)
(lambda (names* body*)
(unscan-loop names* (&pair-cdr body)
(&typed-pair-cons sequence-2-type
body*
body**)))))))
- ((primitive-type? sequence-3-type body)
+ ((object-type? sequence-3-type body)
(unscan-loop names (&triple-first body)
(lambda (names* body*)
(unscan-loop names* (&triple-second body)
\f
;;;; Open Block
-(set! make-open-block
-(named-lambda (make-open-block names declarations body)
+(define (make-open-block names declarations body)
(if (and (null? names)
(null? declarations))
body
(vector open-block-tag names declarations)
(if (null? names)
'()
- (make-sequence
- (map (lambda (name)
- (make-definition name (make-unassigned-object)))
- names)))
- body))))
-
-
-(set! open-block?
-(named-lambda (open-block? object)
- (and (primitive-type? sequence-3-type object)
+ (make-sequence (map make-definition names)))
+ body)))
+
+(define (open-block? object)
+ (and (object-type? sequence-3-type object)
(vector? (&triple-first object))
- (eq? (vector-ref (&triple-first object) 0) open-block-tag))))
+ (eq? (vector-ref (&triple-first object) 0) open-block-tag)))
-(set! open-block-components
-(named-lambda (open-block-components open-block receiver)
+(define (open-block-components open-block receiver)
(receiver (vector-ref (&triple-first open-block) 1)
(vector-ref (&triple-first open-block) 2)
- (&triple-third open-block))))
-
-;;; end LET
-)
\ No newline at end of file
+ (&triple-third open-block)))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scode.scm,v 13.45 1987/10/09 17:13:54 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; SCODE Grab Bag
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scode.scm,v 14.1 1988/06/13 11:51:00 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Abstraction
+;;; package: (runtime scode)
(declare (usual-integrations))
\f
-;;;; Constants
+(define (initialize-package!)
+ (set! scode-constant/type-vector (make-scode-constant/type-vector))
+ (set! declaration-tag (make-named-tag "DECLARATION")))
-(define scode-constant?
- (let ((type-vector (make-vector number-of-microcode-types false)))
+;;;; Constant
+
+(define scode-constant/type-vector)
+
+(define (scode-constant? object)
+ (vector-ref scode-constant/type-vector (object-type object)))
+(define (make-scode-constant/type-vector)
+ (let ((type-vector (make-vector (microcode-type/code-limit) false)))
(for-each (lambda (name)
(vector-set! type-vector (microcode-type name) true))
- '(NULL TRUE UNASSIGNED
- FIXNUM BIGNUM FLONUM
- CHARACTER STRING UNINTERNED-SYMBOL INTERNED-SYMBOL
- NON-MARKED-VECTOR VECTOR-1B VECTOR-16B
- PAIR TRIPLE VECTOR QUOTATION PRIMITIVE))
- (named-lambda (scode-constant? object)
- (vector-ref type-vector (primitive-type object)))))
-
-(define make-null)
-(define make-false)
-(define make-true)
-
-(let ()
- (define (make-constant-maker name)
- (let ((type (microcode-type name)))
- (lambda ()
- (primitive-set-type type 0))))
- (set! make-null (make-constant-maker 'NULL))
- (set! make-false (make-constant-maker 'FALSE))
- (set! make-true (make-constant-maker 'TRUE)))
-
-(define undefined-conditional-branch
- (primitive-set-type (microcode-type 'TRUE) 1))
-
-;;;; QUOTATION
-
-(define quotation?)
-(define make-quotation)
-
-(let ((type (microcode-type 'QUOTATION)))
- (set! quotation?
- (named-lambda (quotation? object)
- (primitive-type? type object)))
- (set! make-quotation
- (named-lambda (make-quotation expression)
- (&typed-singleton-cons type expression))))
-
-(define quotation-expression &singleton-element)
+ '(BIGNUM
+ CHARACTER
+ COMPILED-CODE-BLOCK
+ CONTROL-POINT
+ DELAYED
+ ENTITY
+ ENVIRONMENT
+ EXTENDED-PROCEDURE
+ FIXNUM
+ FLONUM
+ HUNK3-A
+ INTERNED-SYMBOL
+ NON-MARKED-VECTOR
+ NULL
+ PAIR
+ PRIMITIVE
+ PROCEDURE
+ QUAD
+ RATNUM
+ RECNUM
+ REFERENCE-TRAP
+ RETURN-CODE
+ STRING
+ TRIPLE
+ TRUE
+ UNINTERNED-SYMBOL
+ VECTOR
+ VECTOR-16B
+ VECTOR-1B))
+ type-vector))
\f
-;;;; SYMBOL
+;;;; Quotation
-(define symbol?)
-(define string->uninterned-symbol)
-(let ()
+(define-integrable (make-quotation expression)
+ (&typed-singleton-cons (ucode-type quotation) expression))
-(define utype
- (microcode-type 'UNINTERNED-SYMBOL))
+(define-integrable (quotation? object)
+ (object-type? (ucode-type quotation) object))
-(define itype
- (microcode-type 'INTERNED-SYMBOL))
+(define-integrable (quotation-expression quotation)
+ (&singleton-element quotation))
-(set! symbol?
-(named-lambda (symbol? object)
- (or (primitive-type? itype object)
- (primitive-type? utype object))))
+;;;; Symbol
-(set! string->uninterned-symbol
-(named-lambda (string->uninterned-symbol string)
- (&typed-pair-cons utype
- string
- (make-unbound-object))))
+(define (symbol? object)
+ (or (object-type? (ucode-type interned-symbol) object)
+ (object-type? (ucode-type uninterned-symbol) object)))
-)
-
-(define string->symbol
- (make-primitive-procedure 'STRING->SYMBOL))
-
-(define (symbol->string symbol)
- (&pair-car symbol))
-
-(define make-symbol string->uninterned-symbol)
-(define make-interned-symbol string->symbol)
-(define symbol-print-name symbol->string)
-
-;; NOTE: Both of these assume that there are no reference traps.
-;; They can cause great harm if used indiscriminately.
+(define-integrable (string->uninterned-symbol string)
+ (&typed-pair-cons (ucode-type uninterned-symbol)
+ string
+ (make-unbound-reference-trap)))
-(define (symbol-global-value symbol)
- (&pair-cdr symbol))
+(define-integrable string->symbol
+ (ucode-primitive string->symbol))
-(define (set-symbol-global-value! symbol value)
- (&pair-set-cdr! symbol value))
+(define-integrable (symbol->string symbol)
+ (string-copy (system-pair-car symbol)))
(define (make-named-tag name)
(string->symbol (string-append "#[" name "]")))
-\f
-;;;; VARIABLE
-(define variable?)
-(define make-variable)
+(define-integrable (intern string)
+ (string->symbol (string-upcase string)))
-(let ((type (microcode-type 'VARIABLE)))
- (set! variable?
- (named-lambda (variable? object)
- (primitive-type? type object)))
- (set! make-variable
- (named-lambda (make-variable name)
- (system-hunk3-cons type name (make-true) (make-null)))))
+;;;; Variable
-(define variable-name system-hunk3-cxr0)
+(define-integrable (make-variable name)
+ (system-hunk3-cons (ucode-type variable) name true '()))
-(define (variable-components variable receiver)
+(define-integrable (variable? object)
+ (object-type? (ucode-type variable) object))
+
+(define-integrable (variable-name variable)
+ (system-hunk3-cxr0 variable))
+
+(define-integrable (variable-components variable receiver)
(receiver (variable-name variable)))
+\f
+;;;; Definition/Assignment
-;;;; DEFINITION
+(define (make-definition name #!optional value)
+ (&typed-pair-cons (ucode-type definition)
+ name
+ (if (default-object? value)
+ (make-unassigned-reference-trap)
+ value)))
-(define definition?)
-(define make-definition)
+(define-integrable (definition? object)
+ (object-type? (ucode-type definition) object))
-(let ((type (microcode-type 'DEFINITION)))
- (set! definition?
- (named-lambda (definition? object)
- (primitive-type? type object)))
- (set! make-definition
- (named-lambda (make-definition name value)
- (&typed-pair-cons type name value))))
+(define-integrable (definition-name definition)
+ (system-pair-car definition))
+
+(define-integrable (definition-value definition)
+ (&pair-cdr definition))
(define (definition-components definition receiver)
(receiver (definition-name definition)
(definition-value definition)))
-(define definition-name system-pair-car)
-(define set-definition-name! system-pair-set-car!)
-(define definition-value &pair-cdr)
-(define set-definition-value! &pair-set-cdr!)
-\f
-;;;; ASSIGNMENT
+(define-integrable (assignment? object)
+ (object-type? (ucode-type assignment) object))
-(define assignment?)
-(define make-assignment-from-variable)
+(define (make-assignment-from-variable variable #!optional value)
+ (&typed-pair-cons (ucode-type assignment)
+ variable
+ (if (default-object? value)
+ (make-unassigned-reference-trap)
+ value)))
-(let ((type (microcode-type 'ASSIGNMENT)))
- (set! assignment?
- (named-lambda (assignment? object)
- (primitive-type? type object)))
- (set! make-assignment-from-variable
- (named-lambda (make-assignment-from-variable variable value)
- (&typed-pair-cons type variable value))))
+(define-integrable (assignment-variable assignment)
+ (system-pair-car assignment))
+
+(define-integrable (assignment-value assignment)
+ (&pair-cdr assignment))
(define (assignment-components-with-variable assignment receiver)
(receiver (assignment-variable assignment)
(assignment-value assignment)))
-(define assignment-variable system-pair-car)
-(define set-assignment-variable! system-pair-set-car!)
-(define assignment-value &pair-cdr)
-(define set-assignment-value! &pair-set-cdr!)
+(define (make-assignment name #!optional value)
+ (make-assignment-from-variable (make-variable name)
+ (if (default-object? value)
+ (make-unassigned-reference-trap)
+ value)))
-(define (make-assignment name value)
- (make-assignment-from-variable (make-variable name) value))
+(define-integrable (assignment-name assignment)
+ (variable-name (assignment-variable assignment)))
(define (assignment-components assignment receiver)
- (assignment-components-with-variable assignment
- (lambda (variable value)
- (receiver (variable-name variable) value))))
-
-(define (assignment-name assignment)
- (variable-name (assignment-variable assignment)))
+ (receiver (assignment-name assignment)
+ (assignment-value assignment)))
\f
-;;;; COMMENT
+;;;; Comment
+
+(define-integrable (make-comment text expression)
+ (&typed-pair-cons (ucode-type comment) expression text))
-(define comment?)
-(define make-comment)
+(define-integrable (comment? object)
+ (object-type? (ucode-type comment) object))
-(let ((type (microcode-type 'COMMENT)))
- (set! comment?
- (named-lambda (comment? object)
- (primitive-type? type object)))
- (set! make-comment
- (named-lambda (make-comment text expression)
- (&typed-pair-cons type expression text))))
+(define-integrable (comment-text comment)
+ (system-pair-cdr comment))
+
+(define-integrable (set-comment-text! comment text)
+ (system-pair-set-cdr! comment text))
+
+(define-integrable (comment-expression comment)
+ (&pair-car comment))
+
+(define-integrable (set-comment-expression! comment expression)
+ (&pair-set-car! comment expression))
(define (comment-components comment receiver)
(receiver (comment-text comment)
(comment-expression comment)))
-(define comment-text &pair-cdr)
-(define set-comment-text! &pair-set-cdr!)
-(define comment-expression &pair-car)
-(define set-comment-expression! &pair-set-car!)
-\f
-;;;; DECLARATION
-
-(define declaration?)
-(define make-declaration)
-
-(let ((tag (make-named-tag "DECLARATION")))
- (set! declaration?
- (named-lambda (declaration? object)
- (and (comment? object)
- (let ((text (comment-text object)))
- (and (pair? text)
- (eq? (car text) tag))))))
- (set! make-declaration
- (named-lambda (make-declaration text expression)
- (make-comment (cons tag text) expression))))
-
-(define (declaration-components declaration receiver)
- (comment-components declaration
- (lambda (text expression)
- (receiver (cdr text) expression))))
+;;;; Declaration
-(define (declaration-text tagged-comment)
- (cdr (comment-text tagged-comment)))
+(define-integrable (make-declaration text expression)
+ (make-comment (cons declaration-tag text) expression))
-(define (set-declaration-text! tagged-comment new-text)
- (set-cdr! (comment-text tagged-comment) new-text))
+(define (declaration? object)
+ (and (comment? object)
+ (let ((text (comment-text object)))
+ (and (pair? text)
+ (eq? (car text) declaration-tag)))))
-(define declaration-expression
- comment-expression)
+(define declaration-tag)
-(define set-declaration-expression!
- set-comment-expression!)
+(define-integrable (declaration-text declaration)
+ (cdr (comment-text declaration)))
-(define make-block-declaration)
-(define block-declaration?)
-(let ()
+(define-integrable (set-declaration-text! declaration text)
+ (set-cdr! (comment-text declaration) text))
-(define tag
- (make-named-tag "Block Declaration"))
+(define-integrable (declaration-expression declaration)
+ (comment-expression declaration))
-(set! make-block-declaration
-(named-lambda (make-block-declaration text)
- (cons tag text)))
+(define-integrable (set-declaration-expression! declaration expression)
+ (set-comment-expression! declaration expression))
-(set! block-declaration?
-(named-lambda (block-declaration? object)
- (and (pair? object) (eq? (car object) tag))))
+(define (declaration-components declaration receiver)
+ (receiver (declaration-text declaration)
+ (declaration-expression declaration)))
+\f
+;;;; The-Environment
-)
+(define-integrable (make-the-environment)
+ (object-new-type (ucode-type the-environment) 0))
-(define block-declaration-text
- cdr)
-\f
-;;;; THE-ENVIRONMENT
+(define-integrable (the-environment? object)
+ (object-type? (ucode-type the-environment) object))
-(define the-environment?)
-(define make-the-environment)
+;;;; Access
-(let ((type (microcode-type 'THE-ENVIRONMENT)))
- (set! the-environment?
- (named-lambda (the-environment? object)
- (primitive-type? type object)))
- (set! make-the-environment
- (named-lambda (make-the-environment)
- (primitive-set-type type 0))))
+(define-integrable (make-access environment name)
+ (&typed-pair-cons (ucode-type access) environment name))
-;;;; ACCESS
+(define-integrable (access? object)
+ (object-type? (ucode-type access) object))
-(define access?)
-(define make-access)
+(define (access-environment expression)
+ (&pair-car expression))
-(let ((type (microcode-type 'ACCESS)))
- (set! access?
- (named-lambda (access? object)
- (primitive-type? type object)))
- (set! make-access
- (named-lambda (make-access environment name)
- (&typed-pair-cons type environment name))))
+(define-integrable (access-name expression)
+ (system-pair-cdr expression))
(define (access-components access receiver)
(receiver (access-environment access)
(access-name access)))
-(define access-environment &pair-car)
-(define access-name system-pair-cdr)
+;;;; Absolute Reference
+
+(define (make-absolute-reference name . rest)
+ (let loop ((reference (make-access system-global-environment name))
+ (rest rest))
+ (if (null? rest)
+ reference
+ (loop (make-access reference (car rest)) (cdr rest)))))
-;;;; IN-PACKAGE
+(define (absolute-reference? object)
+ (and (access? object)
+ (eq? (access-environment object) system-global-environment)))
-(define in-package?)
-(define make-in-package)
+(define-integrable (absolute-reference-name reference)
+ (access-name reference))
-(let ((type (microcode-type 'IN-PACKAGE)))
- (set! in-package?
- (named-lambda (in-package? object)
- (primitive-type? type object)))
- (set! make-in-package
- (named-lambda (make-in-package environment expression)
- (&typed-pair-cons type environment expression))))
+(define (absolute-reference-to? object name)
+ (and (absolute-reference? object)
+ (eq? (absolute-reference-name object) name)))
+\f
+;;;; In-Package
+
+(define-integrable (make-in-package environment expression)
+ (&typed-pair-cons (ucode-type in-package) environment expression))
+
+(define-integrable (in-package? object)
+ (object-type? (ucode-type in-package) object))
+
+(define-integrable (in-package-environment expression)
+ (&pair-car expression))
+
+(define-integrable (in-package-expression expression)
+ (&pair-cdr expression))
(define (in-package-components in-package receiver)
(receiver (in-package-environment in-package)
(in-package-expression in-package)))
-(define in-package-environment &pair-car)
-(define in-package-expression &pair-cdr)
-\f
-;;;; DELAY
+;;;; Delay
-(define delay?)
-(define make-delay)
+(define-integrable (make-delay expression)
+ (&typed-singleton-cons (ucode-type delay) expression))
-(let ((type (microcode-type 'DELAY)))
- (set! delay?
- (named-lambda (delay? object)
- (primitive-type? type object)))
- (set! make-delay
- (named-lambda (make-delay expression)
- (&typed-singleton-cons type expression))))
+(define-integrable (delay? object)
+ (object-type? (ucode-type delay) object))
-(define delay-expression &singleton-element)
+(define-integrable (delay-expression expression)
+ (&singleton-element expression))
-(define (delay-components delay receiver)
+(define-integrable (delay-components delay receiver)
(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.43 1987/08/17 18:16:27 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; SCODE Combinator Abstractions
+#| -*-Scheme-*-
-(declare (usual-integrations))
-\f
-;;;; SEQUENCE
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scomb.scm,v 14.1 1988/06/13 11:51:13 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
-(define sequence?)
-(define make-sequence)
-(define sequence-actions)
-(let ()
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
-(define type-2
- (microcode-type 'SEQUENCE-2))
+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.
-(define type-3
- (microcode-type 'SEQUENCE-3))
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Combinator Abstractions
+;;; package: (runtime scode-combinator)
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (set! combination/constant-folding-operators
+ (map make-primitive-procedure
+ '(PRIMITIVE-TYPE
+ &+ &- &* &/ INTEGER-DIVIDE 1+ -1+
+ TRUNCATE ROUND FLOOR CEILING
+ SQRT EXP LOG SIN COS &ATAN))))
-(set! sequence?
-(named-lambda (sequence? object)
- (or (primitive-type? type-2 object)
- (primitive-type? type-3 object))))
+;;;; Sequence
-(set! make-sequence
-(lambda (actions)
+(define (make-sequence actions)
(if (null? actions)
- (error "MAKE-SEQUENCE: No actions")
- (actions->sequence actions))))
-
-(define (actions->sequence actions)
- (cond ((null? (cdr actions))
- (car actions))
- ((null? (cddr actions))
- (&typed-pair-cons type-2
- (car actions)
- (cadr actions)))
- (else
- (&typed-triple-cons type-3
+ (error "MAKE-SEQUENCE: No actions"))
+ (let loop ((actions actions))
+ (cond ((null? (cdr actions))
+ (car actions))
+ ((null? (cddr actions))
+ (&typed-pair-cons (ucode-type sequence-2)
(car actions)
- (cadr actions)
- (actions->sequence (cddr actions))))))
-
-(set! sequence-actions
-(named-lambda (sequence-actions sequence)
- (cond ((primitive-type? type-2 sequence)
+ (cadr actions)))
+ (else
+ (&typed-triple-cons (ucode-type sequence-3)
+ (car actions)
+ (cadr actions)
+ (loop (cddr actions)))))))
+
+(define (sequence? object)
+ (or (object-type? (ucode-type sequence-2) object)
+ (object-type? (ucode-type sequence-3) object)))
+
+(define (sequence-actions sequence)
+ (cond ((object-type? (ucode-type sequence-2) sequence)
(append! (sequence-actions (&pair-car sequence))
(sequence-actions (&pair-cdr sequence))))
- ((primitive-type? type-3 sequence)
+ ((object-type? (ucode-type sequence-3) sequence)
(append! (sequence-actions (&triple-first sequence))
(sequence-actions (&triple-second sequence))
(sequence-actions (&triple-third sequence))))
(else
- (list sequence)))))
-
-)
+ (list sequence))))
-(define (sequence-components sequence receiver)
+(define-integrable (sequence-components sequence receiver)
(receiver (sequence-actions sequence)))
\f
-;;;; CONDITIONAL
-
-(define conditional?)
-(define make-conditional)
-(let ()
-
-(define type
- (microcode-type 'CONDITIONAL))
-
-(set! conditional?
-(named-lambda (conditional? object)
- (primitive-type? type object)))
-
-(set! make-conditional
-(named-lambda (make-conditional predicate consequent alternative)
- (if (combination? predicate)
- (combination-components predicate
- (lambda (operator operands)
- (if (eq? operator not)
- (make-conditional (first operands)
- alternative
- consequent)
- (&typed-triple-cons type
- predicate
- consequent
- alternative))))
- (&typed-triple-cons type predicate consequent alternative))))
-
-)
+;;;; Conditional
+
+(define (make-conditional predicate consequent #!optional alternative)
+ (let ((alternative
+ (if (default-object? alternative)
+ undefined-conditional-branch
+ alternative)))
+ (if (and (combination? predicate)
+ (eq? (combination-operator predicate) (ucode-primitive not)))
+ (make-conditional (car (combination-operands predicate))
+ alternative
+ consequent)
+ (&typed-triple-cons (ucode-type conditional)
+ predicate
+ consequent
+ alternative))))
+
+(define (conditional? object)
+ (object-type? (ucode-type conditional) object))
+
+(define undefined-conditional-branch
+ (object-new-type (ucode-type true) 1))
+
+(define-integrable (conditional-predicate conditional)
+ (&triple-first conditional))
+
+(define-integrable (conditional-consequent conditional)
+ (&triple-second conditional))
+
+(define-integrable (conditional-alternative conditional)
+ (&triple-third conditional))
(define (conditional-components conditional receiver)
(receiver (conditional-predicate conditional)
(conditional-consequent conditional)
(conditional-alternative conditional)))
-
-(define conditional-predicate &triple-first)
-(define conditional-consequent &triple-second)
-(define conditional-alternative &triple-third)
\f
-;;;; DISJUNCTION
-
-(define disjunction?)
-(define make-disjunction)
-(let ()
+;;;; Disjunction
-(define type
- (microcode-type 'DISJUNCTION))
+(define (make-disjunction predicate alternative)
+ (if (and (combination? predicate)
+ (eq? (combination-operator predicate) (ucode-primitive not)))
+ (make-conditional (car (combination-operands predicate))
+ alternative
+ true)
+ (&typed-pair-cons (ucode-type disjunction) predicate alternative)))
-(set! disjunction?
-(named-lambda (disjunction? object)
- (primitive-type? type object)))
+(define-integrable (disjunction? object)
+ (object-type? (ucode-type disjunction) object))
-(set! make-disjunction
-(named-lambda (make-disjunction predicate alternative)
- (if (combination? predicate)
- (combination-components predicate
- (lambda (operator operands)
- (if (eq? operator not)
- (make-conditional (first operands) alternative true)
- (&typed-pair-cons type predicate alternative))))
- (&typed-pair-cons type predicate alternative))))
+(define-integrable (disjunction-predicate disjunction)
+ (&pair-car disjunction))
-)
+(define-integrable (disjunction-alternative disjunction)
+ (&pair-cdr disjunction))
(define (disjunction-components disjunction receiver)
(receiver (disjunction-predicate disjunction)
(disjunction-alternative disjunction)))
-
-(define disjunction-predicate &pair-car)
-(define disjunction-alternative &pair-cdr)
-\f
-;;;; COMBINATION
-
-(define combination?)
-(define make-combination)
-(define combination-size)
-(define combination-components)
-(define combination-operator)
-(define combination-operands)
-(let ()
-
-(define type-1 (microcode-type 'COMBINATION-1))
-(define type-2 (microcode-type 'COMBINATION-2))
-(define type-N (microcode-type 'COMBINATION))
-(define p-type (microcode-type 'PRIMITIVE))
-(define p-type-0 (microcode-type 'PRIMITIVE-COMBINATION-0))
-(define p-type-1 (microcode-type 'PRIMITIVE-COMBINATION-1))
-(define p-type-2 (microcode-type 'PRIMITIVE-COMBINATION-2))
-(define p-type-3 (microcode-type 'PRIMITIVE-COMBINATION-3))
-
-(define (primitive-procedure? object)
- (primitive-type? p-type object))
-
-(set! combination?
-(named-lambda (combination? object)
- (or (primitive-type? type-1 object)
- (primitive-type? type-2 object)
- (primitive-type? type-N object)
- (primitive-type? p-type-0 object)
- (primitive-type? p-type-1 object)
- (primitive-type? p-type-2 object)
- (primitive-type? p-type-3 object))))
\f
-(set! make-combination
-(lambda (operator operands)
- (cond ((and (memq operator constant-folding-operators)
- (all-constants? operands))
+;;;; Combination
+
+(define (combination? object)
+ (or (object-type? (ucode-type combination) object)
+ (object-type? (ucode-type combination-1) object)
+ (object-type? (ucode-type combination-2) object)
+ (object-type? (ucode-type primitive-combination-0) object)
+ (object-type? (ucode-type primitive-combination-1) object)
+ (object-type? (ucode-type primitive-combination-2) object)
+ (object-type? (ucode-type primitive-combination-3) object)))
+
+(define (make-combination operator operands)
+ (cond ((and (memq operator combination/constant-folding-operators)
+ (let loop ((operands operands))
+ (or (null? operands)
+ (and (scode-constant? (car operands))
+ (loop (cdr operands))))))
(apply operator operands))
((null? operands)
(if (and (primitive-procedure? operator)
(= (primitive-procedure-arity operator) 0))
- (primitive-set-type p-type-0 operator)
- (&typed-vector-cons type-N (cons operator '()))))
+ (object-new-type (ucode-type primitive-combination-0) operator)
+ (&typed-vector-cons (ucode-type combination)
+ (cons operator '()))))
((null? (cdr operands))
(&typed-pair-cons
(if (and (primitive-procedure? operator)
(= (primitive-procedure-arity operator) 1))
- p-type-1
- type-1)
+ (ucode-type primitive-combination-1)
+ (ucode-type combination-1))
operator
(car operands)))
((null? (cddr operands))
(&typed-triple-cons
(if (and (primitive-procedure? operator)
(= (primitive-procedure-arity operator) 2))
- p-type-2
- type-2)
+ (ucode-type primitive-combination-2)
+ (ucode-type combination-2))
operator
(car operands)
(cadr operands)))
(if (and (null? (cdddr operands))
(primitive-procedure? operator)
(= (primitive-procedure-arity operator) 3))
- p-type-3
- type-N)
- (cons operator operands))))))
-
-(define constant-folding-operators
- (map make-primitive-procedure
- '(PRIMITIVE-TYPE
- &+ &- &* &/ INTEGER-DIVIDE 1+ -1+
- TRUNCATE ROUND FLOOR CEILING
- SQRT EXP LOG SIN COS &ATAN)))
-
-(define (all-constants? expressions)
- (or (null? expressions)
- (and (scode-constant? (car expressions))
- (all-constants? (cdr expressions)))))
-\f
-(set! combination-size
-(lambda (combination)
- (cond ((primitive-type? p-type-0 combination)
- 1)
- ((or (primitive-type? type-1 combination)
- (primitive-type? p-type-1 combination))
- 2)
- ((or (primitive-type? type-2 combination)
- (primitive-type? p-type-2 combination))
- 3)
- ((primitive-type? p-type-3 combination)
- 4)
- ((primitive-type? type-N combination)
- (&vector-size combination))
- (else
- (error "Not a combination -- COMBINATION-SIZE" combination)))))
-
-(set! combination-operator
-(lambda (combination)
- (cond ((primitive-type? p-type-0 combination)
- (primitive-set-type p-type combination))
- ((or (primitive-type? type-1 combination)
- (primitive-type? p-type-1 combination))
- (&pair-car combination))
- ((or (primitive-type? type-2 combination)
- (primitive-type? p-type-2 combination))
- (&triple-first combination))
- ((or (primitive-type? p-type-3 combination)
- (primitive-type? type-N combination))
- (&vector-ref combination 0))
- (else
- (error "Not a combination -- COMBINATION-OPERATOR"
- combination)))))
-
-(set! combination-operands
-(lambda (combination)
- (cond ((primitive-type? p-type-0 combination)
- '())
- ((or (primitive-type? type-1 combination)
- (primitive-type? p-type-1 combination))
- (list (&pair-cdr combination)))
- ((or (primitive-type? type-2 combination)
- (primitive-type? p-type-2 combination))
- (list (&triple-second combination)
- (&triple-third combination)))
- ((or (primitive-type? p-type-3 combination)
- (primitive-type? type-N combination))
- (&subvector-to-list combination 1 (&vector-size combination)))
- (else
- (error "Not a combination -- COMBINATION-OPERANDS"
- combination)))))
+ (ucode-type primitive-combination-3)
+ (ucode-type combination))
+ (cons operator operands)))))
+
+(define combination/constant-folding-operators)
\f
-(set! combination-components
-(lambda (combination receiver)
- (cond ((primitive-type? p-type-0 combination)
- (receiver (primitive-set-type p-type combination)
- '()))
- ((or (primitive-type? type-1 combination)
- (primitive-type? p-type-1 combination))
- (receiver (&pair-car combination)
- (list (&pair-cdr combination))))
- ((or (primitive-type? type-2 combination)
- (primitive-type? p-type-2 combination))
- (receiver (&triple-first combination)
- (list (&triple-second combination)
- (&triple-third combination))))
- ((or (primitive-type? p-type-3 combination)
- (primitive-type? type-N combination))
- (receiver (&vector-ref combination 0)
- (&subvector-to-list combination 1
- (&vector-size combination))))
- (else
- (error "Not a combination -- COMBINATION-COMPONENTS"
- combination)))))
+(let-syntax
+ ((combination-dispatch
+ (macro (name combination case-0 case-1 case-2 case-n)
+ `(COND ((OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-0)
+ ,combination)
+ ,case-0)
+ ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-1) ,combination)
+ (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-1)
+ ,combination))
+ ,case-1)
+ ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-2) ,combination)
+ (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-2)
+ ,combination))
+ ,case-2)
+ ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION) ,combination)
+ (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-3)
+ ,combination))
+ ,case-n)
+ (ELSE
+ (ERROR ,(string-append (symbol->string name)
+ ": Illegal combination")
+ ,combination))))))
+
+(define (combination-size combination)
+ (combination-dispatch combination-size combination
+ 1 2 3 (&vector-length combination)))
+
+(define (combination-operator combination)
+ (combination-dispatch combination-operator combination
+ (object-new-type (ucode-type primitive) combination)
+ (&pair-car combination)
+ (&triple-first combination)
+ (&vector-ref combination 0)))
+
+(define (combination-operands combination)
+ (combination-dispatch
+ combination-operands combination
+ '()
+ (list (&pair-cdr combination))
+ (list (&triple-second combination) (&triple-third combination))
+ (&subvector->list combination 1 (&vector-length combination))))
+
+(define (combination-components combination receiver)
+ (combination-dispatch
+ combination-components combination
+ (receiver (object-new-type (ucode-type primitive) combination) '())
+ (receiver (&pair-car combination) (list (&pair-cdr combination)))
+ (receiver (&triple-first combination)
+ (list (&triple-second combination) (&triple-third combination)))
+ (receiver (&vector-ref combination 0)
+ (&subvector->list combination 1 (&vector-length combination)))))
)
\f
-;;;; UNASSIGNED?
+;;;; Unassigned?
-(define unassigned??)
-(define make-unassigned?)
-(define unbound??)
-(define make-unbound?)
-(let ()
-
-(define ((envop-characteristic envop) object)
- (and (combination? object)
- (combination-components object
- (lambda (operator operands)
- (and (eq? operator envop)
- (the-environment? (first operands))
- (symbol? (second operands)))))))
-
-(define ((envop-maker envop) name)
- (make-combination envop
+(define (make-unassigned? name)
+ (make-combination (ucode-primitive lexical-unassigned?)
(list (make-the-environment) name)))
-(set! unassigned??
- (envop-characteristic lexical-unassigned?))
-
-(set! make-unassigned?
- (envop-maker lexical-unassigned?))
-
-(set! unbound??
- (envop-characteristic lexical-unbound?))
-
-(set! make-unbound?
- (envop-maker lexical-unbound?))
-
-)
-
-(define (unassigned?-name unassigned?)
- (second (combination-operands unassigned?)))
+(define (unassigned?? object)
+ (and (combination? object)
+ (eq? (combination-operator object)
+ (ucode-primitive lexical-unassigned?))
+ (let ((operands (combination-operands object)))
+ (and (the-environment? (car operands))
+ (symbol? (cadr operands))))))
-(define (unassigned?-components unassigned? receiver)
- (receiver (unassigned?-name unassigned?)))
+(define-integrable (unassigned?-name unassigned?)
+ (cadr (combination-operands unassigned?)))
-(define unbound?-name unassigned?-name)
-(define unbound?-components unassigned?-components)
\ No newline at end of file
+(define-integrable (unassigned?-components unassigned? receiver)
+ (receiver (unassigned?-name unassigned?)))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sdata.scm,v 13.43 1987/04/24 13:37:01 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sdata.scm,v 14.1 1988/06/13 11:51:27 cph Rel $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Abstract Data Field
+;;; package: (runtime scode-data)
(declare (usual-integrations))
\f
-(define unbound-object?)
-(define make-unbound-object)
-
-(define unassigned-object?)
-(define make-unassigned-object)
-
-(define &typed-singleton-cons)
-(define &singleton-element)
-(define &singleton-set-element!)
-
-(define &typed-pair-cons)
-(define &pair-car)
-(define &pair-set-car!)
-(define &pair-cdr)
-(define &pair-set-cdr!)
-
-(define &typed-triple-cons)
-(define &triple-first)
-(define &triple-set-first!)
-(define &triple-second)
-(define &triple-set-second!)
-(define &triple-third)
-(define &triple-set-third!)
-
-(define &typed-vector-cons)
-(define &list-to-vector)
-(define &vector-size)
-(define &vector-ref)
-(define &vector-to-list)
-(define &subvector-to-list)
-\f
-(let ((&unbound-object '(&UNBOUND-OBJECT))
- (&unbound-datum 2)
- (&unassigned-object '(&UNASSIGNED-OBJECT))
- (&unassigned-datum 0)
- (&unassigned-type (microcode-type 'UNASSIGNED))
- (&make-object (make-primitive-procedure '&MAKE-OBJECT))
- (hunk3-cons (make-primitive-procedure 'HUNK3-CONS)))
-
-(define (map-unassigned object)
- (cond ((eq? object &unbound-object)
- (&make-object &unassigned-type &unbound-datum))
- ((eq? object &unassigned-object)
- (&make-object &unassigned-type &unassigned-datum))
- (else object)))
-
-;;; This is no longer really right, given the other traps.
-(define (map-from-unassigned datum)
- (if (eq? datum &unassigned-datum) ;**** cheat for speed.
- &unassigned-object
- &unbound-object))
-
-(define (map-unassigned-list list)
- (if (null? list)
- '()
- (cons (map-unassigned (car list))
- (map-unassigned-list (cdr list)))))
-
-(set! make-unbound-object
- (lambda ()
- &unbound-object))
-
-(set! unbound-object?
- (lambda (object)
- (eq? object &unbound-object)))
-
-(set! make-unassigned-object
- (lambda ()
- &unassigned-object))
-
-(set! unassigned-object?
- (let ((microcode-unassigned-object
- (vector-ref (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'NON-OBJECT))))
- (lambda (object)
- (or (eq? object &unassigned-object)
- (eq? object microcode-unassigned-object)))))
-\f
-(set! &typed-singleton-cons
- (lambda (type element)
- (system-pair-cons type (map-unassigned element) '())))
-
-(set! &singleton-element
- (lambda (singleton)
- (if (primitive-type? &unassigned-type (system-pair-car singleton))
- (map-from-unassigned (primitive-datum (system-pair-car singleton)))
- (system-pair-car singleton))))
-
-(set! &singleton-set-element!
- (lambda (singleton new-element)
- (system-pair-set-car! singleton (map-unassigned new-element))))
-
-(set! &typed-pair-cons
- (lambda (type car cdr)
- (system-pair-cons type
- (map-unassigned car)
- (map-unassigned cdr))))
-
-(set! &pair-car
- (lambda (pair)
- (if (primitive-type? &unassigned-type (system-pair-car pair))
- (map-from-unassigned (primitive-datum (system-pair-car pair)))
- (system-pair-car pair))))
-
-(set! &pair-set-car!
- (lambda (pair new-car)
- (system-pair-set-car! pair (map-unassigned new-car))))
-
-(set! &pair-cdr
- (lambda (pair)
- (if (primitive-type? &unassigned-type (system-pair-cdr pair))
- (map-from-unassigned (primitive-datum (system-pair-cdr pair)))
- (system-pair-cdr pair))))
-
-(set! &pair-set-cdr!
- (lambda (pair new-cdr)
- (system-pair-set-cdr! pair (map-unassigned new-cdr))))
-\f
-(set! &typed-triple-cons
- (lambda (type first second third)
- (primitive-set-type type
- (hunk3-cons (map-unassigned first)
- (map-unassigned second)
- (map-unassigned third)))))
-
-(set! &triple-first
- (lambda (triple)
- (if (primitive-type? &unassigned-type (system-hunk3-cxr0 triple))
- (map-from-unassigned (primitive-datum (system-hunk3-cxr0 triple)))
- (system-hunk3-cxr0 triple))))
-
-(set! &triple-set-first!
- (lambda (triple new-first)
- (system-hunk3-set-cxr0! triple (map-unassigned new-first))))
-
-(set! &triple-second
- (lambda (triple)
- (if (primitive-type? &unassigned-type (system-hunk3-cxr1 triple))
- (map-from-unassigned (primitive-datum (system-hunk3-cxr1 triple)))
- (system-hunk3-cxr1 triple))))
-
-(set! &triple-set-second!
- (lambda (triple new-second)
- (system-hunk3-set-cxr0! triple (map-unassigned new-second))))
-
-(set! &triple-third
- (lambda (triple)
- (if (primitive-type? &unassigned-type (system-hunk3-cxr2 triple))
- (map-from-unassigned (primitive-datum (system-hunk3-cxr2 triple)))
- (system-hunk3-cxr2 triple))))
-
-(set! &triple-set-third!
- (lambda (triple new-third)
- (system-hunk3-set-cxr0! triple (map-unassigned new-third))))
+(define (&typed-singleton-cons type element)
+ (system-pair-cons type (unmap-reference-trap element) '()))
+
+(define (&singleton-element singleton)
+ (map-reference-trap (lambda () (system-pair-car singleton))))
+
+(define (&singleton-set-element! singleton new-element)
+ (system-pair-set-car! singleton (unmap-reference-trap new-element)))
+
+(define (&typed-pair-cons type car cdr)
+ (system-pair-cons type
+ (unmap-reference-trap car)
+ (unmap-reference-trap cdr)))
+
+(define (&pair-car pair)
+ (map-reference-trap (lambda () (system-pair-car pair))))
+
+(define (&pair-set-car! pair new-car)
+ (system-pair-set-car! pair (unmap-reference-trap new-car)))
+
+(define (&pair-cdr pair)
+ (map-reference-trap (lambda () (system-pair-cdr pair))))
+
+(define (&pair-set-cdr! pair new-cdr)
+ (system-pair-set-cdr! pair (unmap-reference-trap new-cdr)))
\f
-(set! &typed-vector-cons
- (lambda (type elements)
- (system-list-to-vector type (map-unassigned-list elements))))
-
-(set! &list-to-vector
- list->vector)
-
-(set! &vector-size
- system-vector-size)
-
-(set! &vector-ref
- (lambda (vector index)
- (if (primitive-type? &unassigned-type (system-vector-ref vector index))
- (map-from-unassigned
- (primitive-datum (system-vector-ref vector index)))
- (system-vector-ref vector index))))
-
-(set! &vector-to-list
- (lambda (vector)
- (&subvector-to-list vector 0 (system-vector-size vector))))
-
-(set! &subvector-to-list
- (lambda (vector start stop)
- (let loop ((sublist (system-subvector-to-list vector start stop)))
- (if (null? sublist)
- '()
- (cons (if (primitive-type? &unassigned-type (car sublist))
- (map-from-unassigned (primitive-datum (car sublist)))
- (car sublist))
- (loop (cdr sublist)))))))
-
-)
\ No newline at end of file
+(define (&typed-triple-cons type first second third)
+ (object-new-type type
+ (hunk3-cons (unmap-reference-trap first)
+ (unmap-reference-trap second)
+ (unmap-reference-trap third))))
+
+(define (&triple-first triple)
+ (map-reference-trap (lambda () (system-hunk3-cxr0 triple))))
+
+(define (&triple-set-first! triple new-first)
+ (system-hunk3-set-cxr0! triple (unmap-reference-trap new-first)))
+
+(define (&triple-second triple)
+ (map-reference-trap (lambda () (system-hunk3-cxr1 triple))))
+
+(define (&triple-set-second! triple new-second)
+ (system-hunk3-set-cxr0! triple (unmap-reference-trap new-second)))
+
+(define (&triple-third triple)
+ (map-reference-trap (lambda () (system-hunk3-cxr2 triple))))
+
+(define (&triple-set-third! triple new-third)
+ (system-hunk3-set-cxr0! triple (unmap-reference-trap new-third)))
+
+(define (&typed-vector-cons type elements)
+ (system-list->vector
+ type
+ (let loop ((elements elements))
+ (if (null? elements)
+ '()
+ (cons (unmap-reference-trap (car elements))
+ (loop (cdr elements)))))))
+
+(define (&vector-length vector)
+ (system-vector-length vector))
+
+(define (&vector-ref vector index)
+ (map-reference-trap (lambda () (system-vector-ref vector index))))
+
+(define (&subvector->list vector start stop)
+ (let loop ((sublist (system-subvector->list vector start stop)))
+ (if (null? sublist)
+ '()
+ (cons (map-reference-trap (lambda () (car sublist)))
+ (loop (cdr sublist))))))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sfile.scm,v 13.42 1987/08/20 03:06:21 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sfile.scm,v 14.1 1988/06/13 11:51:34 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Simple File Operations
+;;; package: ()
(declare (usual-integrations))
\f
-(define copy-file
- (let ((p-copy-file (make-primitive-procedure 'COPY-FILE)))
- (named-lambda (copy-file from to)
- (p-copy-file (canonicalize-input-filename from)
- (canonicalize-output-filename to)))))
-
-(define rename-file
- (let ((p-rename-file (make-primitive-procedure 'RENAME-FILE)))
- (named-lambda (rename-file from to)
- (p-rename-file (canonicalize-input-filename from)
- (canonicalize-output-filename to)))))
-
-(define delete-file
- (let ((p-delete-file (make-primitive-procedure 'REMOVE-FILE)))
- (named-lambda (delete-file name)
- (p-delete-file (canonicalize-input-filename name)))))
\ No newline at end of file
+(define (copy-file from to)
+ ((ucode-primitive copy-file) (canonicalize-input-filename from)
+ (canonicalize-output-filename to)))
+
+(define (rename-file from to)
+ ((ucode-primitive rename-file) (canonicalize-input-filename from)
+ (canonicalize-output-filename to)))
+
+(define (delete-file name)
+ ((ucode-primitive remove-file) (canonicalize-input-filename name)))
+
+(define (transcript-on filename)
+ (if (not ((ucode-primitive photo-open)
+ (canonicalize-output-filename filename)))
+ (error "TRANSCRIPT-ON: Transcript file already open" filename))
+ *the-non-printing-object*)
+
+(define (transcript-off)
+ (if (not ((ucode-primitive photo-close)))
+ (error "TRANSCRIPT-OFF: Transcript file already closed"))
+ *the-non-printing-object*)
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/stream.scm,v 13.41 1987/01/23 00:20:30 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Stream Utilities
+#| -*-Scheme-*-
-(declare (usual-integrations))
-\f
-;;;; General Streams
-
-(define (nth-stream n s)
- (cond ((empty-stream? s)
- (error "Empty stream -- NTH-STREAM" n))
- ((= n 0)
- (head s))
- (else
- (nth-stream (- n 1) (tail s)))))
-
-(define (accumulate combiner initial-value stream)
- (if (empty-stream? stream)
- initial-value
- (combiner (head stream)
- (accumulate combiner
- initial-value
- (tail stream)))))
-
-(define (filter pred stream)
- (cond ((empty-stream? stream)
- the-empty-stream)
- ((pred (head stream))
- (cons-stream (head stream)
- (filter pred (tail stream))))
- (else
- (filter pred (tail stream)))))
-
-(define (map-stream proc stream)
- (if (empty-stream? stream)
- the-empty-stream
- (cons-stream (proc (head stream))
- (map-stream proc (tail stream)))))
-
-(define (map-stream-2 proc s1 s2)
- (if (or (empty-stream? s1)
- (empty-stream? s2))
- the-empty-stream
- (cons-stream (proc (head s1) (head s2))
- (map-stream-2 proc (tail s1) (tail s2)))))
-
-(define (append-streams s1 s2)
- (if (empty-stream? s1)
- s2
- (cons-stream (head s1)
- (append-streams (tail s1) s2))))
-
-(define (enumerate-fringe tree)
- (if (pair? tree)
- (append-streams (enumerate-fringe (car tree))
- (enumerate-fringe (cdr tree)))
- (cons-stream tree the-empty-stream)))
-\f
-;;;; Numeric Streams
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/stream.scm,v 14.1 1988/06/13 11:51:38 cph Exp $
-(define (add-streams s1 s2)
- (cond ((empty-stream? s1) s2)
- ((empty-stream? s2) s1)
- (else
- (cons-stream (+ (head s1) (head s2))
- (add-streams (tail s1) (tail s2))))))
+Copyright (c) 1988 Massachusetts Institute of Technology
-(define (scale-stream c s)
- (map-stream (lambda (x) (* c x)) s))
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
-(define (enumerate-interval n1 n2)
- (if (> n1 n2)
- the-empty-stream
- (cons-stream n1 (enumerate-interval (1+ n1) n2))))
+1. Any copy made of this software must include this copyright notice
+in full.
-(define (integers-from n)
- (cons-stream n (integers-from (1+ n))))
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
-(define integers
- (integers-from 0))
-\f
-;;;; Some Hairier Stuff
-
-(define (merge s1 s2)
- (cond ((empty-stream? s1) s2)
- ((empty-stream? s2) s1)
- (else
- (let ((h1 (head s1))
- (h2 (head s2)))
- (cond ((< h1 h2)
- (cons-stream h1
- (merge (tail s1)
- s2)))
- ((> h1 h2)
- (cons-stream h2
- (merge s1
- (tail s2))))
- (else
- (cons-stream h1
- (merge (tail s1)
- (tail s2)))))))))
+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 operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
+
+;;;; Basic Stream Operations
+;;; package: (runtime stream)
+
+(declare (usual-integrations))
\f
-;;;; Printing
-
-(define print-stream
- (let ()
- (define (iter s)
- (if (empty-stream? s)
- (write-string "}")
- (begin (write-string " ")
- (write (head s))
- (iter (tail s)))))
- (lambda (s)
- (newline)
- (write-string "{")
- (if (empty-stream? s)
- (write-string "}")
- (begin (write (head s))
- (iter (tail s)))))))
+(define (stream-pair? stream)
+ (and (pair? stream)
+ (promise? (cdr stream))))
+
+(define-integrable (stream-null? stream)
+ (null? stream))
+
+(define-integrable (stream-car stream)
+ (car stream))
+
+(define-integrable (stream-cdr stream)
+ (force (cdr stream)))
+
+(define (stream . list)
+ (list->stream list))
+
+(define (list->stream list)
+ (if (pair? list)
+ (cons-stream (car list) (list->stream (cdr list)))
+ (begin (if (not (null? list))
+ (error "LIST->STREAM: not a proper list" list))
+ '())))
+
+(define (stream->list stream)
+ (if (stream-pair? stream)
+ (cons (stream-car stream) (stream->list (stream-cdr stream)))
+ (begin (guarantee-stream-null stream 'STREAM->LIST) '())))
+
+(define (stream-length stream)
+ (let loop ((stream stream) (length 0))
+ (if (stream-pair? stream)
+ (loop (stream-cdr stream) (1+ length))
+ (begin (guarantee-stream-null stream 'STREAM-LENGTH) length))))
+
+(define (stream-ref stream index)
+ (let ((tail (stream-tail stream index)))
+ (if (not (stream-pair? tail))
+ (error "STREAM-REF: index too large" index))
+ (stream-car tail)))
+
+(define (stream-tail stream index)
+ (if (not (and (integer? index) (not (negative? index))))
+ (error "STREAM-TAIL: index must be nonnegative integer" index)) (let loop ((stream stream) (index index))
+ (if (zero? index)
+ stream
+ (begin (if (not (stream-pair? stream))
+ (error "STREAM-TAIL: index too large" index))
+ (loop (stream-cdr stream) (-1+ index))))))
\f
-;;;; Support for COLLECT
-
-(define (flatmap f s)
- (flatten (map-stream f s)))
-
-(define (flatten stream)
- (accumulate-delayed interleave-delayed
- the-empty-stream
- stream))
-
-(define (accumulate-delayed combiner initial-value stream)
- (if (empty-stream? stream)
- initial-value
- (combiner (head stream)
- (delay (accumulate-delayed combiner
- initial-value
- (tail stream))))))
-
-(define (interleave-delayed s1 delayed-s2)
- (if (empty-stream? s1)
- (force delayed-s2)
- (cons-stream (head s1)
- (interleave-delayed (force delayed-s2)
- (delay (tail s1))))))
-
-(define ((spread-tuple procedure) tuple)
- (apply procedure tuple))
+(define (stream-map stream procedure)
+ (let loop ((stream stream))
+ (if (stream-pair? stream)
+ (cons-stream (procedure (stream-car stream))
+ (loop (stream-cdr stream)))
+ (begin (guarantee-stream-null stream 'STREAM-MAP) '()))))
+
+(define (guarantee-stream-null stream name)
+ (if (not (null? stream))
+ (error (string-append (symbol->string name) ": not a proper stream")
+ stream)))
+
+(define-integrable the-empty-stream
+ '())
+
+(define-integrable (empty-stream? stream)
+ (stream-null? stream))
+
+(define-integrable (head stream)
+ (stream-car stream))
+
+(define-integrable (tail stream)
+ (stream-cdr stream))
+
+(define prime-numbers-stream)
+
+(define (make-prime-numbers-stream)
+ (letrec ((primes
+ (cons-stream
+ (cons 2 4)
+ (let filter ((integer 3))
+ (if (let loop ((primes primes))
+ (let ((prime (stream-car primes)))
+ (or (> (cdr prime) integer)
+ (and (not (zero? (remainder integer
+ (car prime))))
+ (loop (stream-cdr primes))))))
+ (cons-stream (cons integer (* integer integer))
+ (filter (1+ integer)))
+ (filter (1+ integer)))))))
+ (let loop ((primes primes))
+ (cons-stream (car (stream-car primes))
+ (loop (stream-cdr primes))))))
+(define (initialize-package!)
+ (set! prime-numbers-stream (make-prime-numbers-stream)))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/string.scm,v 13.43 1987/12/17 20:32:25 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/string.scm,v 14.1 1988/06/13 11:51:44 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Character String Operations
+;;; package: ()
(declare (usual-integrations))
\f
;;;; Primitives
-(let-syntax ((define-primitives
- (macro names
- `(BEGIN ,@(map (lambda (name)
- `(LOCAL-ASSIGNMENT
- SYSTEM-GLOBAL-ENVIRONMENT
- ',name
- ,(make-primitive-procedure name)))
- names)))))
- (define-primitives
- string-allocate string? string-ref string-set!
- string-length string-maximum-length set-string-length!
- substring=? substring-ci=? substring<?
- substring-move-right! substring-move-left!
- substring-find-next-char-in-set
- substring-find-previous-char-in-set
- substring-match-forward substring-match-backward
- substring-match-forward-ci substring-match-backward-ci
- substring-upcase! substring-downcase! string-hash string-hash-mod
-
- vector-8b-ref vector-8b-set! vector-8b-fill!
- vector-8b-find-next-char vector-8b-find-previous-char
- vector-8b-find-next-char-ci vector-8b-find-previous-char-ci))
+(define-primitives
+ string-allocate string? string-ref string-set!
+ string-length string-maximum-length set-string-length!
+ substring=? substring-ci=? substring<?
+ substring-move-right! substring-move-left!
+ substring-find-next-char-in-set
+ substring-find-previous-char-in-set
+ substring-match-forward substring-match-backward
+ substring-match-forward-ci substring-match-backward-ci
+ substring-upcase! substring-downcase! string-hash string-hash-mod
+
+ vector-8b-ref vector-8b-set! vector-8b-fill!
+ vector-8b-find-next-char vector-8b-find-previous-char
+ vector-8b-find-next-char-ci vector-8b-find-previous-char-ci)
;;; Character Covers
-(define (substring-fill! string start end char)
+(define-integrable (substring-fill! string start end char)
(vector-8b-fill! string start end (char->ascii char)))
-(define (substring-find-next-char string start end char)
+(define-integrable (substring-find-next-char string start end char)
(vector-8b-find-next-char string start end (char->ascii char)))
-(define (substring-find-previous-char string start end char)
+(define-integrable (substring-find-previous-char string start end char)
(vector-8b-find-previous-char string start end (char->ascii char)))
-(define (substring-find-next-char-ci string start end char)
+(define-integrable (substring-find-next-char-ci string start end char)
(vector-8b-find-next-char-ci string start end (char->ascii char)))
-(define (substring-find-previous-char-ci string start end char)
+(define-integrable (substring-find-previous-char-ci string start end char)
(vector-8b-find-previous-char-ci string start end (char->ascii char)))
;;; Special, not implemented in microcode.
;;;; Basic Operations
(define (make-string length #!optional char)
- (if (unassigned? char)
+ (if (default-object? char)
(string-allocate length)
(let ((result (string-allocate length)))
(substring-fill! result 0 length char)
result)))
-(define (string-null? string)
+(define-integrable (string-null? string)
(zero? (string-length string)))
(define (substring string start end)
(substring-move-right! string start end result 0)
result))
+(define-integrable (string-head string end)
+ (substring string 0 end))
+
+(define (string-tail string start)
+ (substring string start (string-length string)))
+
(define (list->string chars)
(let ((result (string-allocate (length chars))))
(define (loop index chars)
string2 0 (string-length string2)))
(define (substring-prefix? string1 start1 end1 string2 start2 end2)
- (and (<= (- end1 start1) (- end2 start2))
- (= (substring-match-forward string1 start1 end1
- string2 start2 end2)
- end1)))
+ (let ((length (- end1 start1)))
+ (and (<= length (- end2 start2))
+ (= (substring-match-forward string1 start1 end1
+ string2 start2 end2)
+ length))))
+
+(define (string-suffix? string1 string2)
+ (substring-suffix? string1 0 (string-length string1)
+ string2 0 (string-length string2)))
+(define (substring-suffix? string1 start1 end1 string2 start2 end2)
+ (let ((length (- end1 start1)))
+ (and (<= length (- end2 start2))
+ (= (substring-match-backward string1 start1 end1
+ string2 start2 end2)
+ length))))
+\f
(define (string-compare-ci string1 string2 if= if< if>)
(let ((size1 (string-length string1))
(size2 (string-length string2)))
string2 0 (string-length string2)))
(define (substring-prefix-ci? string1 start1 end1 string2 start2 end2)
- (and (<= (- end1 start1) (- end2 start2))
- (= (substring-match-forward-ci string1 start1 end1
- string2 start2 end2)
- end1)))
+ (let ((length (- end1 start1)))
+ (and (<= length (- end2 start2))
+ (= (substring-match-forward-ci string1 start1 end1
+ string2 start2 end2)
+ length))))
+
+(define (string-suffix-ci? string1 string2)
+ (substring-suffix-ci? string1 0 (string-length string1)
+ string2 0 (string-length string2)))
+
+(define (substring-suffix-ci? string1 start1 end1 string2 start2 end2)
+ (let ((length (- end1 start1)))
+ (and (<= length (- end2 start2))
+ (= (substring-match-backward-ci string1 start1 end1
+ string2 start2 end2)
+ length))))
\f
;;;; Trim/Pad
(define (string-trim-left string #!optional char-set)
- (if (unassigned? char-set) (set! char-set char-set:not-whitespace))
+ (if (default-object? char-set) (set! char-set char-set:not-whitespace))
(let ((index (string-find-next-char-in-set string char-set))
(length (string-length string)))
(if (not index)
(substring string index length))))
(define (string-trim-right string #!optional char-set)
- (if (unassigned? char-set) (set! char-set char-set:not-whitespace))
+ (if (default-object? char-set) (set! char-set char-set:not-whitespace))
(let ((index (string-find-previous-char-in-set string char-set)))
(if (not index)
""
(substring string 0 (1+ index)))))
(define (string-trim string #!optional char-set)
- (if (unassigned? char-set) (set! char-set char-set:not-whitespace))
+ (if (default-object? char-set) (set! char-set char-set:not-whitespace))
(let ((index (string-find-next-char-in-set string char-set)))
(if (not index)
""
(1+ (string-find-previous-char-in-set string char-set))))))
(define (string-pad-right string n #!optional char)
- (if (unassigned? char) (set! char #\Space))
+ (if (default-object? char) (set! char #\Space))
(let ((length (string-length string)))
(if (= length n)
string
result))))
(define (string-pad-left string n #!optional char)
- (if (unassigned? char) (set! char #\Space))
+ (if (default-object? char) (set! char #\Space))
(let ((length (string-length string)))
(if (= length n)
string
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strnin.scm,v 14.1 1988/05/20 01:01:53 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strnin.scm,v 14.2 1988/06/13 11:51:51 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; String I/O Ports
-;;; package: string-io-package
+;;; package: (runtime string-input)
(declare (usual-integrations))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strott.scm,v 14.1 1988/05/20 01:02:10 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strott.scm,v 14.2 1988/06/13 11:51:56 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; String Output Ports (Truncated)
-;;; package: truncated-string-output-package
+;;; package: (runtime truncated-string-output)
(declare (usual-integrations))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strout.scm,v 14.1 1988/05/20 01:02:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strout.scm,v 14.2 1988/06/13 11:52:01 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; String Output Ports
-;;; package: string-output-package
+;;; package: (runtime string-output)
(declare (usual-integrations))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntab.scm,v 14.1 1988/05/20 01:02:42 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntab.scm,v 14.2 1988/06/13 11:52:05 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Syntax Table
-;;; package: syntax-table-package
+;;; package: (runtime syntax-table)
(declare (usual-integrations))
\f
(parent false read-only true))
(define (make-syntax-table #!optional parent)
- (if (default-object? parent)
- (set! parent false)
- (check-syntax-table parent 'MAKE-SYNTAX-TABLE))
- (%make-syntax-table '() parent))
+ (%make-syntax-table '()
+ (if (default-object? parent)
+ false
+ (guarantee-syntax-table parent))))
-(define (check-syntax-table table name)
- (if (not (syntax-table? table))
- (error "Not a syntax table" name table)))
+(define (guarantee-syntax-table table)
+ (if (not (syntax-table? table)) (error "Illegal syntax table" table))
+ table)
-(define (syntax-table-ref table name)
- (check-syntax-table table 'SYNTAX-TABLE-REF)
+(define (syntax-table/ref table name)
+ (guarantee-syntax-table table)
(let loop ((table table))
(and table
(let ((entry (assq name (syntax-table/alist table))))
(cdr entry)
(loop (syntax-table/parent table)))))))
-(define (syntax-table-define table name transform)
- (check-syntax-table table 'SYNTAX-TABLE-DEFINE)
+(define syntax-table-ref
+ syntax-table/ref)
+
+(define (syntax-table/define table name transform)
+ (guarantee-syntax-table table)
(let ((entry (assq name (syntax-table/alist table))))
(if entry
(set-cdr! entry transform)
(cons (cons name transform)
(syntax-table/alist table))))))
+(define syntax-table-define
+ syntax-table/define)
+
(define (syntax-table/copy table)
- (check-syntax-table table 'SYNTAX-TABLE/COPY)
+ (guarantee-syntax-table table)
(let loop ((table table))
(and table
(%make-syntax-table (alist-copy (syntax-table/alist table))
(loop (syntax-table/parent table))))))
(define (syntax-table/extend table alist)
- (check-syntax-table table 'SYNTAX-TABLE/EXTEND)
+ (guarantee-syntax-table table)
(%make-syntax-table (alist-copy alist) table))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 13.51 1987/11/17 20:11:13 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
-;;;; SYNTAX: S-Expressions -> SCODE
-
-(declare (usual-integrations))
-\f
-(define lambda-tag:unnamed
- (make-named-tag "UNNAMED-PROCEDURE"))
-
-(define *fluid-let-type*
- 'SHALLOW)
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 14.1 1988/06/13 11:54:32 cph Exp $
-(define lambda-tag:shallow-fluid-let
- (make-named-tag "SHALLOW-FLUID-LET-PROCEDURE"))
+Copyright (c) 1988 Massachusetts Institute of Technology
-(define lambda-tag:deep-fluid-let
- (make-named-tag "DEEP-FLUID-LET-PROCEDURE"))
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
-(define lambda-tag:common-lisp-fluid-let
- (make-named-tag "COMMON-LISP-FLUID-LET-PROCEDURE"))
+1. Any copy made of this software must include this copyright notice
+in full.
-(define lambda-tag:let
- (make-named-tag "LET-PROCEDURE"))
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
-(define lambda-tag:make-environment
- (make-named-tag "MAKE-ENVIRONMENT-PROCEDURE"))
+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.
-(define syntax)
-(define syntax*)
-(define macro-spreader)
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
-(define enable-scan-defines!)
-(define with-scan-defines-enabled)
-(define disable-scan-defines!)
-(define with-scan-defines-disabled)
+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 without prior written consent from
+MIT in each case. |#
-;; Enable shallow vs fluid binding for FLUID-LET
-(define shallow-fluid-let!)
-(define deep-fluid-let!)
-(define common-lisp-fluid-let!)
+;;;; SYNTAX: S-Expressions -> SCODE
+;;; package: (runtime syntaxer)
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (set-fluid-let-type! 'SHALLOW)
+ (enable-scan-defines!)
+ (set! lambda-tag:unnamed (make-named-tag "UNNAMED-PROCEDURE"))
+ (set! lambda-tag:let (make-named-tag "LET-PROCEDURE"))
+ (set! lambda-tag:fluid-let (make-named-tag "FLUID-LET-PROCEDURE"))
+ (set! lambda-tag:make-environment (make-named-tag "MAKE-ENVIRONMENT"))
+ (set! system-global-syntax-table (make-system-global-syntax-table))
+ (set! user-initial-syntax-table
+ (make-syntax-table system-global-syntax-table)))
+
+(define lambda-tag:unnamed)
+(define lambda-tag:let)
+(define lambda-tag:fluid-let)
+(define lambda-tag:make-environment)
(define system-global-syntax-table)
-(define syntax-table?)
-(define make-syntax-table)
-(define extend-syntax-table)
-(define copy-syntax-table)
-(define syntax-table-ref)
-(define syntax-table-define)
-(define syntax-table-shadow)
-(define syntax-table-undefine)
-
-(define syntaxer-package)
-(let ((external-make-sequence make-sequence)
- (external-make-lambda make-lambda))
-(set! syntaxer-package (the-environment))
+(define user-initial-syntax-table)
+
+(define (make-system-global-syntax-table)
+ (let ((table (make-syntax-table)))
+ (for-each (lambda (entry)
+ (syntax-table-define table (car entry)
+ (make-primitive-syntaxer (cadr entry))))
+ `(
+ ;; R*RS special forms
+ (BEGIN ,syntax/begin)
+ (COND ,syntax/cond)
+ (DEFINE ,syntax/define)
+ (DELAY ,syntax/delay)
+ (IF ,syntax/if)
+ (LAMBDA ,syntax/lambda)
+ (LET ,syntax/let)
+ (OR ,syntax/or)
+ (QUOTE ,syntax/quote)
+ (SET! ,syntax/set!)
+
+ ;; Syntax extensions
+ (DEFINE-SYNTAX ,syntax/define-syntax)
+ (DEFINE-MACRO ,syntax/define-macro)
+ (LET-SYNTAX ,syntax/let-syntax)
+ (MACRO ,syntax/lambda)
+ (USING-SYNTAX ,syntax/using-syntax)
+
+ ;; Environment extensions
+ (ACCESS ,syntax/access)
+ (IN-PACKAGE ,syntax/in-package)
+ (THE-ENVIRONMENT ,syntax/the-environment)
+ (UNASSIGNED? ,syntax/unassigned?)
+ ;; To facilitate upgrade to new option argument mechanism.
+ (DEFAULT-OBJECT? ,syntax/unassigned?)
+
+ ;; Miscellaneous extensions
+ (DECLARE ,syntax/declare)
+ (FLUID-LET ,syntax/fluid-let)
+ (LOCAL-DECLARE ,syntax/local-declare)
+ (NAMED-LAMBDA ,syntax/named-lambda)
+ (SCODE-QUOTE ,syntax/scode-quote)))
+ table))
\f
-;;;; Dispatch Point
+;;;; Top Level Syntaxers
+
+(define *syntax-table*)
+(define *current-keyword* false)
+
+(define (syntax expression #!optional table)
+ (cond ((default-object? table) (set! table *syntax-table*))
+ ((not (syntax-table? table))
+ (error "SYNTAX: not a syntax table" table)))
+ (syntax-top-level syntax-expression table expression))
+
+(define (syntax* expressions #!optional table)
+ (cond ((default-object? table) (set! table *syntax-table*))
+ ((not (syntax-table? table))
+ (error "SYNTAX: not a syntax table" table)))
+ (syntax-top-level syntax-sequence table expressions))
+
+(define (syntax-top-level syntax-expression table expression)
+ (fluid-let ((*syntax-table* table)
+ (*current-keyword* false))
+ (syntax-expression expression)))
(define (syntax-expression expression)
(cond ((pair? expression)
- (let ((quantum (syntax-table-ref syntax-table (car expression))))
- (if quantum
- (fluid-let ((saved-keyword (car expression)))
- (quantum expression))
+ (let ((transform (syntax-table-ref *syntax-table* (car expression))))
+ (if transform
+ (if (primitive-syntaxer? transform)
+ (transform-apply (primitive-syntaxer/transform transform)
+ expression)
+ (let ((result (transform-apply transform expression)))
+ (if (syntax-closure? result)
+ (syntax-closure/expression result)
+ (syntax-expression result))))
(make-combination (syntax-expression (car expression))
(syntax-expressions (cdr expression))))))
((symbol? expression)
(else
expression)))
-(define (syntax-expressions expressions)
- (if (null? expressions)
- '()
- (cons (syntax-expression (car expressions))
- (syntax-expressions (cdr expressions)))))
+;;; Two overlapping kludges here. This should go away and be replaced
+;;; by a true syntactic closure mechanism like that described by
+;;; Bawden and Rees.
-(define ((spread-arguments kernel) expression)
- (apply kernel (cdr expression)))
+(define-integrable (make-syntax-closure expression)
+ (cons syntax-closure-tag expression))
-(define saved-keyword
- (make-interned-symbol ""))
+(define (syntax-closure? expression)
+ (and (pair? expression)
+ (eq? (car expression) syntax-closure-tag)))
-(define (syntax-error message . irritant)
- (error (string-append message
- ": "
- (symbol->string saved-keyword)
- " SYNTAX")
- (cond ((null? irritant) *the-non-printing-object*)
- ((null? (cdr irritant)) (car irritant))
- (else irritant))))
+(define-integrable (syntax-closure/expression syntax-closure)
+ (cdr syntax-closure))
+
+(define syntax-closure-tag
+ "syntax-closure")
+
+(define-integrable (make-primitive-syntaxer expression)
+ (cons primitive-syntaxer-tag expression))
+
+(define (primitive-syntaxer? expression)
+ (and (pair? expression)
+ (eq? (car expression) primitive-syntaxer-tag)))
+
+(define-integrable (primitive-syntaxer/transform primitive-syntaxer)
+ (cdr primitive-syntaxer))
+
+(define primitive-syntaxer-tag
+ "primitive-syntaxer")
\f
-(define (syntax-sequence subexpressions)
- (if (null? subexpressions)
- (syntax-error "No subforms in sequence")
- (make-sequence (syntax-sequentially subexpressions))))
+(define (transform-apply transform expression)
+ (fluid-let ((*current-keyword* (car expression)))
+ (let ((n-arguments (length (cdr expression))))
+ (if (not (procedure-arity-valid? transform n-arguments))
+ (syntax-error "incorrect number of subforms" n-arguments)))
+ (apply transform (cdr expression))))
+
+(define (syntax-error message . irritants)
+ (error (string-append "SYNTAX: "
+ (if *current-keyword*
+ (string-append (symbol->string *current-keyword*)
+ ": "
+ message)
+ message))
+ (cond ((null? irritants) *the-non-printing-object*)
+ ((null? (cdr irritants)) (car irritants))
+ (else irritants))))
-(define (syntax-sequentially expressions)
+(define (syntax-expressions expressions)
(if (null? expressions)
'()
- ;; force eval order.
- (let ((first (syntax-expression (car expressions))))
- (cons first
- (syntax-sequentially (cdr expressions))))))
+ (cons (syntax-expression (car expressions))
+ (syntax-expressions (cdr expressions)))))
+
+(define (syntax-sequence expressions)
+ (if (null? expressions)
+ (syntax-error "No subforms in sequence")
+ (make-scode-sequence
+ (let loop ((expressions expressions))
+ (if (null? expressions)
+ '()
+ ;; Force eval order. This is required so that special
+ ;; forms such as `define-syntax' work correctly.
+ (let ((first (syntax-expression (car expressions))))
+ (cons first (loop (cdr expressions)))))))))
(define (syntax-bindings bindings receiver)
(cond ((null? bindings)
(syntax-error "Non-symbolic variable" (car chain))))
(define (expand-binding-value rest)
- (cond ((null? rest) unassigned-object)
+ (cond ((null? rest) (make-unassigned-reference-trap))
((null? (cdr rest)) (syntax-expression (car rest)))
(else (syntax-error "Too many forms in value" rest))))
-(define expand-conjunction
- (let ()
- (define (expander forms)
- (if (null? (cdr forms))
- (syntax-expression (car forms))
- (make-conjunction (syntax-expression (car forms))
- (expander (cdr forms)))))
- (named-lambda (expand-conjunction forms)
- (if (null? forms)
- true
- (expander forms)))))
-
-(define expand-disjunction
- (let ()
- (define (expander forms)
- (if (null? (cdr forms))
- (syntax-expression (car forms))
- (make-disjunction (syntax-expression (car forms))
- (expander (cdr forms)))))
- (named-lambda (expand-disjunction forms)
- (if (null? forms)
- false
- (expander forms)))))
+(define (expand-disjunction forms)
+ (if (null? forms)
+ false
+ (let loop ((forms forms))
+ (if (null? (cdr forms))
+ (syntax-expression (car forms))
+ (make-disjunction (syntax-expression (car forms))
+ (loop (cdr forms)))))))
(define (expand-lambda pattern actions receiver)
- (define (loop pattern body)
- (if (pair? (car pattern))
- (loop (car pattern)
- (make-lambda (cdr pattern) body))
- (receiver pattern body)))
- ((if (pair? pattern) loop receiver) pattern (syntax-lambda-body actions)))
+ ((if (pair? pattern)
+ (letrec ((loop
+ (lambda (pattern body)
+ (if (pair? (car pattern))
+ (loop (car pattern)
+ (make-simple-lambda (cdr pattern) body))
+ (receiver pattern body)))))
+ loop)
+ receiver)
+ pattern
+ (syntax-lambda-body actions)))
(define (syntax-lambda-body body)
(syntax-sequence
(cdr body) ;discard documentation string.
body)))
\f
-;;;; Quasiquote
-
-(define expand-quasiquote)
-(let ()
-
-(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 (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
- (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 (descend-quasiquote expression 0 finalize-quasiquote))))
-
-)
-\f
;;;; Basic Syntax
-(define syntax-SCODE-QUOTE-form
- (spread-arguments
- (lambda (expression)
- (make-quotation (syntax-expression expression)))))
-
-(define syntax-QUOTE-form
- (spread-arguments identity-procedure))
-
-(define syntax-THE-ENVIRONMENT-form
- (spread-arguments make-the-environment))
-
-(define syntax-UNASSIGNED?-form
- (spread-arguments make-unassigned?))
-
-(define syntax-UNBOUND?-form
- (spread-arguments make-unbound?))
-
-(define syntax-ACCESS-form
- (spread-arguments
- (lambda chain
- (expand-access chain make-access))))
-
-(define syntax-SET!-form
- (spread-arguments
- (lambda (name . rest)
- ((invert-expression (syntax-expression name))
- (expand-binding-value rest)))))
-
-(define syntax-DEFINE-form
- (spread-arguments
- (lambda (pattern . rest)
- (cond ((symbol? pattern)
- (make-definition pattern
- (expand-binding-value
- (if (and (= (length rest) 2)
- (string? (cadr rest)))
- (list (car rest))
- rest))))
- ((pair? pattern)
- (expand-lambda pattern rest
- (lambda (pattern body)
- (make-definition (car pattern)
- (make-named-lambda (car pattern) (cdr pattern)
- body)))))
- (else
- (syntax-error "Bad pattern" pattern))))))
-
-(define syntax-SEQUENCE-form
- (spread-arguments
- (lambda actions
- (syntax-sequence actions))))
-\f
-(define syntax-IN-PACKAGE-form
- (spread-arguments
- (lambda (environment . body)
- (make-in-package (syntax-expression environment)
- (syntax-sequence body)))))
-
-(define syntax-DELAY-form
- (spread-arguments
- (lambda (expression)
- (make-delay (syntax-expression expression)))))
-
-(define syntax-CONS-STREAM-form
- (spread-arguments
- (lambda (head tail)
- (make-combination* cons
- (syntax-expression head)
- (make-delay (syntax-expression tail))))))
+(define (syntax/scode-quote expression)
+ (make-quotation (syntax-expression expression)))
+
+(define (syntax/quote expression)
+ expression)
+
+(define (syntax/the-environment)
+ (make-the-environment))
+
+(define (syntax/unassigned? name)
+ (make-unassigned? name))
+
+(define (syntax/access . chain)
+ (expand-access chain make-access))
+
+(define (syntax/set! name . rest)
+ ((invert-expression (syntax-expression name)) (expand-binding-value rest)))
+
+(define (syntax/define pattern . rest)
+ (cond ((symbol? pattern)
+ (make-definition pattern
+ (expand-binding-value
+ (if (and (= (length rest) 2)
+ (string? (cadr rest)))
+ (list (car rest))
+ rest))))
+ ((pair? pattern)
+ (expand-lambda pattern rest
+ (lambda (pattern body)
+ (make-definition (car pattern)
+ (make-named-lambda (car pattern) (cdr pattern)
+ body)))))
+ (else
+ (syntax-error "Bad pattern" pattern))))
+
+(define (syntax/begin . actions)
+ (syntax-sequence actions))
+
+(define (syntax/in-package environment . body)
+ (make-in-package (syntax-expression environment)
+ (syntax-sequence body)))
+
+(define (syntax/delay expression)
+ (make-delay (syntax-expression expression)))
\f
;;;; Conditionals
-(define syntax-IF-form
- (spread-arguments
- (lambda (predicate consequent . rest)
- (make-conditional (syntax-expression predicate)
- (syntax-expression consequent)
- (cond ((null? rest) undefined-conditional-branch)
- ((null? (cdr rest))
- (syntax-expression (car rest)))
- (else
- (syntax-error "Too many forms" (cdr rest))))))))
-
-(define syntax-CONJUNCTION-form
- (spread-arguments
- (lambda forms
- (expand-conjunction forms))))
-
-(define syntax-DISJUNCTION-form
- (spread-arguments
- (lambda forms
- (expand-disjunction forms))))
-\f
-(define syntax-COND-form
- (let ()
- (define (process-cond-clauses clause rest)
- (cond ((eq? (car clause) 'ELSE)
- (if (null? rest)
- (syntax-sequence (cdr clause))
- (syntax-error "ELSE not last clause" rest)))
- ((null? (cdr clause))
- (make-disjunction (syntax-expression (car clause))
- (if (null? rest)
- undefined-conditional-branch
- (process-cond-clauses (car rest)
- (cdr rest)))))
- ((and (pair? (cdr clause))
- (eq? (cadr clause) '=>))
- (syntax-expression
- `((ACCESS COND-=>-HELPER SYNTAXER-PACKAGE '())
- ,(car clause)
- (LAMBDA () ,@(cddr clause))
- (LAMBDA ()
- ,(if (null? rest)
- undefined-conditional-branch
- `(COND ,@rest))))))
- (else
- (make-conditional (syntax-expression (car clause))
- (syntax-sequence (cdr clause))
- (if (null? rest)
- undefined-conditional-branch
- (process-cond-clauses (car rest)
- (cdr rest)))))))
- (spread-arguments
- (lambda (clause . rest)
- (process-cond-clauses clause rest)))))
-
-(define (cond-=>-helper form1-result thunk2 thunk3)
- (if form1-result
- ((thunk2) form1-result)
- (thunk3)))
+(define (syntax/if predicate consequent . rest)
+ (make-conditional (syntax-expression predicate)
+ (syntax-expression consequent)
+ (cond ((null? rest) undefined-conditional-branch)
+ ((null? (cdr rest))
+ (syntax-expression (car rest)))
+ (else
+ (syntax-error "Too many forms" (cdr rest))))))
+
+(define (syntax/or . expressions)
+ (expand-disjunction expressions))
+
+(define (syntax/cond clause . rest)
+ (let loop ((clause clause) (rest rest))
+ (cond ((eq? (car clause) 'ELSE)
+ (if (null? rest)
+ (syntax-sequence (cdr clause))
+ (syntax-error "ELSE not last clause" rest)))
+ ((null? (cdr clause))
+ (make-disjunction (syntax-expression (car clause))
+ (if (null? rest)
+ undefined-conditional-branch
+ (loop (car rest) (cdr rest)))))
+ ((and (pair? (cdr clause))
+ (eq? (cadr clause) '=>))
+ (syntax-expression
+ `((ACCESS SYNTAXER/COND-=>-HELPER '())
+ ,(car clause)
+ (LAMBDA () ,@(cddr clause))
+ (LAMBDA ()
+ ,(if (null? rest)
+ undefined-conditional-branch
+ `(COND ,@rest))))))
+ (else
+ (make-conditional (syntax-expression (car clause))
+ (syntax-sequence (cdr clause))
+ (if (null? rest)
+ undefined-conditional-branch
+ (loop (car rest) (cdr rest))))))))
\f
;;;; Procedures
-(define syntax-LAMBDA-form
- (spread-arguments
- (lambda (pattern . body)
- (make-lambda pattern (syntax-lambda-body body)))))
-
-(define syntax-NAMED-LAMBDA-form
- (spread-arguments
- (lambda (pattern . body)
- (expand-lambda pattern body
- (lambda (pattern body)
- (if (pair? pattern)
- (make-named-lambda (car pattern) (cdr pattern) body)
- (syntax-error "Illegal named-lambda list" pattern)))))))
-
-(define syntax-LET-form
- (spread-arguments
- (lambda (name-or-pattern pattern-or-first . rest)
- (if (symbol? name-or-pattern)
- (syntax-bindings pattern-or-first
- (lambda (names 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-ENVIRONMENT-form
- (spread-arguments
- (lambda body
- (make-closed-block
- lambda-tag:make-environment '() '()
- (if (null? body)
- the-environment-object
- (make-sequence* (syntax-sequence body) the-environment-object))))))
+(define (syntax/lambda pattern . body)
+ (make-simple-lambda pattern (syntax-lambda-body body)))
+
+(define (syntax/named-lambda pattern . body)
+ (expand-lambda pattern body
+ (lambda (pattern body)
+ (if (pair? pattern)
+ (make-named-lambda (car pattern) (cdr pattern) body)
+ (syntax-error "Illegal named-lambda list" pattern)))))
+
+(define (syntax/let name-or-pattern pattern-or-first . rest)
+ (if (symbol? name-or-pattern)
+ (syntax-bindings pattern-or-first
+ (lambda (names 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)))))))
\f
;;;; Syntax Extensions
-(define syntax-LET-SYNTAX-form
- (spread-arguments
- (lambda (bindings . body)
- (syntax-bindings bindings
- (lambda (names values)
- (fluid-let ((syntax-table
- (extend-syntax-table
- (map (lambda (name value)
- (cons name (syntax-eval value)))
- names
- values)
- syntax-table)))
- (syntax-sequence body)))))))
-
-(define syntax-USING-SYNTAX-form
- (spread-arguments
- (lambda (table . body)
- (let ((table* (syntax-eval (syntax-expression table))))
- (if (not (syntax-table? table*))
- (syntax-error "Not a syntax table" table))
- (fluid-let ((syntax-table table*))
- (syntax-sequence body))))))
-
-(define syntax-DEFINE-SYNTAX-form
- (spread-arguments
- (lambda (name value)
- (cond ((symbol? name)
- (syntax-table-define syntax-table name
- (syntax-eval (syntax-expression value)))
- name)
- ((and (pair? name) (symbol? (car name)))
- (syntax-table-define syntax-table (car name)
- (let ((transformer
- (syntax-eval (syntax-NAMED-LAMBDA-form
- `(NAMED-LAMBDA ,name ,value)))))
- (lambda (expression)
- (apply transformer (cdr expression)))))
- (car name))
- (else (syntax-error "Bad syntax description" name))))))
-
-(define (syntax-MACRO-form expression)
- (make-combination* (make-absolute-reference 'MACRO-SPREADER)
- (syntax-LAMBDA-form expression)))
-
-(define (syntax-DEFINE-MACRO-form expression)
- (syntax-table-define syntax-table (caadr expression)
- (macro-spreader (syntax-eval (syntax-NAMED-LAMBDA-form expression))))
- (caadr expression))
-
-(set! macro-spreader
- (named-lambda ((macro-spreader transformer) expression)
- (syntax-expression (apply transformer (cdr expression)))))
-\f
-;;;; Grab Bag
-
-(define (syntax-ERROR-LIKE-form procedure-name)
- (spread-arguments
- (lambda (message . rest)
- (make-combination* (make-absolute-reference procedure-name)
- (syntax-expression message)
- (cond ((null? rest)
- (make-absolute-reference
- '*THE-NON-PRINTING-OBJECT*))
- ((null? (cdr rest))
- (syntax-expression (car rest)))
- (else
- (make-combination
- (make-absolute-reference 'LIST)
- (syntax-expressions rest))))
- (make-the-environment)))))
-
-(define syntax-ERROR-form
- (syntax-ERROR-LIKE-form 'ERROR-PROCEDURE))
-
-(define syntax-BKPT-form
- (syntax-ERROR-LIKE-form 'BREAKPOINT-PROCEDURE))
-
-(define syntax-QUASIQUOTE-form
- (spread-arguments expand-quasiquote))
+(define (syntax/let-syntax bindings . body)
+ (syntax-bindings bindings
+ (lambda (names values)
+ (fluid-let ((*syntax-table*
+ (syntax-table/extend
+ *syntax-table*
+ (map (lambda (name value)
+ (cons name (syntax-eval value)))
+ names
+ values))))
+ (syntax-sequence body)))))
+
+(define (syntax/using-syntax table . body)
+ (let ((table* (syntax-eval (syntax-expression table))))
+ (if (not (syntax-table? table*))
+ (syntax-error "Not a syntax table" table))
+ (fluid-let ((*syntax-table* table*))
+ (syntax-sequence body))))
+
+(define (syntax/define-syntax name value)
+ (if (not (symbol? name))
+ (syntax-error "Illegal name" name))
+ (syntax-table-define *syntax-table* name
+ (syntax-eval (syntax-expression value)))
+ name)
+
+(define (syntax/define-macro pattern . body)
+ (let ((keyword (car pattern)))
+ (syntax-table-define *syntax-table* keyword
+ (syntax-eval (apply syntax/named-lambda pattern body)))
+ keyword))
+
+(define-integrable (syntax-eval scode)
+ (scode-eval scode syntaxer/default-environment))
\f
;;;; FLUID-LET
-(define syntax-FLUID-LET-form-shallow
- (let ()
-
- (define (syntax-fluid-bindings bindings receiver)
- (if (null? bindings)
- (receiver '() '() '() '())
- (syntax-fluid-bindings (cdr bindings)
- (lambda (names values transfers-in transfers-out)
- (let ((binding (car bindings)))
- (if (pair? binding)
- (let ((transfer
- (let ((reference (syntax-expression (car binding))))
- (let ((assignment (invert-expression reference)))
- (lambda (target source)
- (make-assignment
- target
- (assignment
- (make-assignment source
- unassigned-object)))))))
- (value (expand-binding-value (cdr binding)))
- (inside-name
- (string->uninterned-symbol "INSIDE-PLACEHOLDER"))
- (outside-name
- (string->uninterned-symbol "OUTSIDE-PLACEHOLDER")))
- (receiver (cons* inside-name outside-name names)
- (cons* value unassigned-object values)
- (cons (transfer outside-name inside-name)
- transfers-in)
- (cons (transfer inside-name outside-name)
- transfers-out)))
- (syntax-error "Binding not a pair" binding)))))))
-
- (spread-arguments
- (lambda (bindings . body)
- (if (null? bindings)
- (syntax-sequence body)
- (syntax-fluid-bindings bindings
- (lambda (names values transfers-in transfers-out)
- (make-closed-block
- lambda-tag:shallow-fluid-let names values
- (make-combination*
- (make-variable 'DYNAMIC-WIND)
- (make-thunk (make-sequence transfers-in))
- (make-thunk (syntax-sequence body))
- (make-thunk (make-sequence transfers-out)))))))))))
-\f
-(define syntax-FLUID-LET-form-deep)
-(define syntax-FLUID-LET-form-common-lisp)
-(let ()
-
-(define (make-fluid-let primitive procedure-tag)
- ;; (FLUID-LET ((<access-or-symbol> <value>) ...) . <body>) =>
- ;; (WITH-SAVED-FLUID-BINDINGS
- ;; (LAMBDA ()
- ;; (ADD-FLUID! (THE-ENVIRONMENT) <access-or-symbol> <value>)
- ;; ...
- ;; <body>))
- (let ((with-saved-fluid-bindings
- (make-primitive-procedure 'WITH-SAVED-FLUID-BINDINGS 1)))
- (spread-arguments
- (lambda (bindings . body)
- (syntax-fluid-bindings bindings
- (lambda (names values)
- (make-combination
- (internal-make-lambda procedure-tag '() '() '()
- (make-combination
- with-saved-fluid-bindings
- (list
- (make-thunk
- (make-sequence
- (map*
- (list (syntax-sequence body))
- (lambda (name-or-access value)
- (cond ((variable? name-or-access)
- (make-combination
- primitive
- (list the-environment-object
- (make-quotation name-or-access)
- value)))
- ((access? name-or-access)
- (access-components name-or-access
- (lambda (env name)
- (make-combination primitive
- (list env name value)))))
- (else
- (syntax-error
- "Target of FLUID-LET not a symbol or ACCESS form"
- name-or-access))))
- names values))))))
- '())))))))
+(define (syntax/fluid-let bindings . body)
+ (syntax/fluid-let/current bindings body))
+
+(define syntax/fluid-let/current)
+
+(define (set-fluid-let-type! type)
+ (set! syntax/fluid-let/current
+ (case type
+ ((SHALLOW) syntax/fluid-let/shallow)
+ ((DEEP) syntax/fluid-let/deep)
+ ((COMMON-LISP) syntax/fluid-let/common-lisp)
+ (else (error "SET-FLUID-LET-TYPE!: unknown type" type)))))
+
+(define (syntax/fluid-let/shallow bindings body)
+ (if (null? bindings)
+ (syntax-sequence body)
+ (syntax-fluid-bindings/shallow bindings
+ (lambda (names values transfers-in transfers-out)
+ (make-closed-block lambda-tag:fluid-let names values
+ (make-combination*
+ (make-absolute-reference 'DYNAMIC-WIND)
+ (make-thunk (make-scode-sequence transfers-in))
+ (make-thunk (syntax-sequence body))
+ (make-thunk (make-scode-sequence transfers-out))))))))
+
+(define (syntax/fluid-let/deep bindings body)
+ (syntax/fluid-let/deep* (ucode-primitive add-fluid-binding! 3)
+ bindings
+ body))
+
+(define (syntax/fluid-let/common-lisp bindings body)
+ (syntax/fluid-let/deep* (ucode-primitive make-fluid-binding! 3)
+ bindings
+ body))
+
+(define (syntax/fluid-let/deep* add-fluid-binding! bindings body)
+ (make-closed-block lambda-tag:fluid-let '() '()
+ (make-combination*
+ (ucode-primitive with-saved-fluid-bindings 1)
+ (make-thunk
+ (make-scode-sequence*
+ (make-scode-sequence
+ (syntax-fluid-bindings/deep add-fluid-binding! bindings))
+ (syntax-sequence body))))))
\f
-(define (syntax-fluid-bindings bindings receiver)
+(define (syntax-fluid-bindings/shallow bindings receiver)
(if (null? bindings)
- (receiver '() '())
- (syntax-fluid-bindings
- (cdr bindings)
- (lambda (names values)
- (let ((binding (car bindings)))
- (if (pair? binding)
- (receiver (cons (let ((name (syntax-expression (car binding))))
- (if (or (variable? name)
- (access? name))
- name
- (syntax-error "Binding name illegal"
- (car binding))))
- names)
- (cons (expand-binding-value (cdr binding)) values))
- (syntax-error "Binding not a pair" binding)))))))
-
-(set! syntax-FLUID-LET-form-deep
- (make-fluid-let (make-primitive-procedure 'ADD-FLUID-BINDING! 3)
- lambda-tag:deep-fluid-let))
-
-(set! syntax-FLUID-LET-form-common-lisp
- ;; This -- groan -- is for Common Lisp support
- (make-fluid-let (make-primitive-procedure 'MAKE-FLUID-BINDING! 3)
- lambda-tag:common-lisp-fluid-let))
-
-;;; end special FLUID-LETs.
-)
+ (receiver '() '() '() '())
+ (syntax-fluid-bindings/shallow (cdr bindings)
+ (lambda (names values transfers-in transfers-out)
+ (let ((binding (car bindings)))
+ (if (pair? binding)
+ (let ((transfer
+ (let ((reference (syntax-expression (car binding))))
+ (let ((assignment (invert-expression reference)))
+ (lambda (target source)
+ (make-assignment
+ target
+ (assignment (make-assignment source)))))))
+ (value (expand-binding-value (cdr binding)))
+ (inside-name
+ (string->uninterned-symbol "INSIDE-PLACEHOLDER"))
+ (outside-name
+ (string->uninterned-symbol "OUTSIDE-PLACEHOLDER")))
+ (receiver (cons* inside-name outside-name names)
+ (cons* value (make-unassigned-reference-trap)
+ values)
+ (cons (transfer outside-name inside-name)
+ transfers-in)
+ (cons (transfer inside-name outside-name)
+ transfers-out)))
+ (syntax-error "Binding not a pair" binding)))))))
+
+(define (syntax-fluid-bindings/deep add-fluid-binding! bindings)
+ (map (lambda (binding)
+ (syntax-fluid-binding/deep add-fluid-binding! binding))
+ bindings))
+
+(define (syntax-fluid-binding/deep add-fluid-binding! binding)
+ (if (pair? binding)
+ (let ((name (syntax-expression (car binding)))
+ (finish
+ (lambda (environment name)
+ (make-combination* add-fluid-binding!
+ environment
+ name
+ (expand-binding-value (cdr binding))))))
+ (cond ((variable? name)
+ (finish (make-the-environment) (make-quotation name)))
+ ((access? name)
+ (access-components name finish))
+ (else
+ (syntax-error "Binding name illegal" (car binding)))))
+ (syntax-error "Binding not a pair" binding)))
\f
;;;; Extended Assignment Syntax
;;; DECLARATION objects all contain lists of standard declarations.
;;; Each standard declaration is a proper list with symbolic keyword.
-(define syntax-LOCAL-DECLARE-form
- (spread-arguments
- (lambda (declarations . body)
- (make-declaration (process-declarations declarations)
- (syntax-sequence body)))))
+(define (syntax/declare . declarations)
+ (make-block-declaration (map process-declaration declarations)))
-(define syntax-DECLARE-form
- (spread-arguments
- (lambda declarations
- (make-block-declaration (map process-declaration declarations)))))
+(define (syntax/local-declare declarations . body)
+ (make-declaration (process-declarations declarations)
+ (syntax-sequence body)))
;;; These two procedures use `error' instead of `syntax-error' because
-;;; they are called when the syntaxer is not running.
+;;; they are also called when the syntaxer is not running.
(define (process-declarations declarations)
(if (list? declarations)
\f
;;;; SCODE Constructors
-(define unassigned-object
- (make-unassigned-object))
-
-(define the-environment-object
- (make-the-environment))
-
(define (make-conjunction first second)
(make-conditional first second false))
(define (make-combination* operator . operands)
(make-combination operator operands))
-(define (make-sequence* . operands)
- (make-sequence operands))
-
-(define (make-sequence operands)
- (internal-make-sequence operands))
+(define (make-scode-sequence* . operands)
+ (make-scode-sequence operands))
(define (make-absolute-reference name . rest)
- (let loop ((reference (make-access (make-null) name)) (rest rest))
+ (let loop ((reference (make-access false name)) (rest rest))
(if (null? rest)
reference
(loop (make-access reference (car rest)) (cdr rest)))))
(define (make-thunk body)
- (make-lambda '() body))
+ (make-simple-lambda '() body))
-(define (make-lambda pattern body)
+(define (make-simple-lambda pattern body)
(make-named-lambda lambda-tag:unnamed pattern body))
(define (make-named-lambda name pattern body)
(define (make-letrec names values body)
(make-closed-block lambda-tag:let '() '()
- (make-sequence (append! (map make-definition names values)
- (list body)))))
+ (make-scode-sequence
+ (append! (map make-definition names values)
+ (list body)))))
\f
;;;; Lambda List Parser
(define (parse-lambda-list lambda-list receiver)
(let ((required (list '()))
(optional (list '())))
- (define (parse-parameters cell)
- (define (loop pattern)
+ (define (parse-parameters cell pattern)
+ (let loop ((pattern pattern))
(cond ((null? pattern) (finish false))
((symbol? pattern) (finish pattern))
((not (pair? pattern)) (bad-lambda-list pattern))
- ((eq? (car pattern) (access lambda-rest-tag lambda-package))
+ ((eq? (car pattern) lambda-rest-tag)
(if (and (pair? (cdr pattern)) (null? (cddr pattern)))
(cond ((symbol? (cadr pattern)) (finish (cadr pattern)))
((and (pair? (cadr pattern))
(finish (caadr pattern)))
(else (bad-lambda-list (cdr pattern))))
(bad-lambda-list (cdr pattern))))
- ((eq? (car pattern) (access lambda-optional-tag lambda-package))
+ ((eq? (car pattern) lambda-optional-tag)
(if (eq? cell required)
- ((parse-parameters optional) (cdr pattern))
+ (parse-parameters optional (cdr pattern))
(bad-lambda-list pattern)))
((symbol? (car pattern))
(set-car! cell (cons (car pattern) (car cell)))
((and (pair? (car pattern)) (symbol? (caar pattern)))
(set-car! cell (cons (caar pattern) (car cell)))
(loop (cdr pattern)))
- (else (bad-lambda-list pattern))))
- loop)
+ (else (bad-lambda-list pattern)))))
(define (finish rest)
(receiver (reverse! (car required))
(define (bad-lambda-list pattern)
(syntax-error "Illegally-formed lambda-list" pattern))
- ((parse-parameters required) lambda-list)))
+ (parse-parameters required lambda-list)))
\f
;;;; Scan Defines
-(define no-scan-make-sequence
- external-make-sequence)
-
-(define (scanning-make-sequence actions)
- (scan-defines (external-make-sequence actions)
+(define (make-sequence/scan actions)
+ (scan-defines (make-sequence actions)
make-open-block))
-(define (no-scan-make-lambda name required optional rest body)
- (external-make-lambda name required optional rest '() '() body))
+(define (make-lambda/no-scan name required optional rest body)
+ (make-lambda name required optional rest '() '() body))
-(define scanning-make-lambda
- make-lambda*)
+(define (make-lambda/scan name required optional rest body)
+ (make-lambda* name required optional rest body))
-(define internal-make-sequence)
+(define make-scode-sequence)
(define internal-make-lambda)
-(set! enable-scan-defines!
- (named-lambda (enable-scan-defines!)
- (set! internal-make-sequence scanning-make-sequence)
- (set! internal-make-lambda scanning-make-lambda)))
-
-(set! with-scan-defines-enabled
- (named-lambda (with-scan-defines-enabled thunk)
- (fluid-let ((internal-make-sequence scanning-make-sequence)
- (internal-make-lambda scanning-make-lambda))
- (thunk))))
-
-(set! disable-scan-defines!
- (named-lambda (disable-scan-defines!)
- (set! internal-make-sequence no-scan-make-sequence)
- (set! internal-make-lambda no-scan-make-lambda)))
-
-(set! with-scan-defines-disabled
- (named-lambda (with-scan-defines-disabled thunk)
- (fluid-let ((internal-make-sequence no-scan-make-sequence)
- (internal-make-lambda no-scan-make-lambda))
- (thunk))))
-
-(define ((fluid-let-maker marker which-kind) #!optional name)
- (if (unassigned? name) (set! name 'FLUID-LET))
- (if (eq? name 'FLUID-LET) (set! *fluid-let-type* marker))
- (syntax-table-define system-global-syntax-table name which-kind))
-
-(set! shallow-fluid-let!
- (fluid-let-maker 'SHALLOW syntax-fluid-let-form-shallow))
-
-(set! deep-fluid-let!
- (fluid-let-maker 'DEEP syntax-fluid-let-form-deep))
-
-(set! common-lisp-fluid-let!
- (fluid-let-maker 'COMMON-LISP syntax-fluid-let-form-common-lisp))
-\f
-;;;; Top Level Syntaxers
-
-(define syntax-table)
+(define (enable-scan-defines!)
+ (set! make-scode-sequence make-sequence/scan)
+ (set! internal-make-lambda make-lambda/scan))
-(define syntax-environment
- (in-package system-global-environment
- (make-environment)))
-
-;;; The top level procedures, when not given an argument, use whatever
-;;; the current syntax table is. This is reasonable only while inside
-;;; a syntaxer quantum, since at other times there is current table.
-
-(define ((make-syntax-top-level syntaxer) expression #!optional table)
- (if (unassigned? table)
- (syntaxer expression)
- (begin (check-syntax-table table 'SYNTAX)
- (fluid-let ((syntax-table table))
- (syntaxer expression)))))
-
-(set! syntax
- (make-syntax-top-level syntax-expression))
-
-(set! syntax*
- (make-syntax-top-level syntax-sequence))
-
-(define (syntax-eval scode)
- (scode-eval scode syntax-environment))
-\f
-;;;; Syntax Table
-
-(define syntax-table-tag
- '(SYNTAX-TABLE))
-
-(set! syntax-table?
- (named-lambda (syntax-table? object)
- (and (pair? object)
- (eq? (car object) syntax-table-tag))))
-
-(define (check-syntax-table table name)
- (if (not (syntax-table? table))
- (error "Not a syntax table" name table)))
-
-(set! make-syntax-table
- (named-lambda (make-syntax-table #!optional parent)
- (cons syntax-table-tag
- (cons '()
- (if (unassigned? parent)
- '()
- (cdr parent))))))
-
-(set! extend-syntax-table
- (named-lambda (extend-syntax-table alist #!optional table)
- (if (unassigned? table) (set! table (current-syntax-table)))
- (check-syntax-table table 'EXTEND-SYNTAX-TABLE)
- (cons syntax-table-tag (cons alist (cdr table)))))
-
-(set! copy-syntax-table
- (named-lambda (copy-syntax-table #!optional table)
- (if (unassigned? table) (set! table (current-syntax-table)))
- (check-syntax-table table 'COPY-SYNTAX-TABLE)
- (cons syntax-table-tag
- (map (lambda (alist)
- (map (lambda (pair)
- (cons (car pair) (cdr pair)))
- alist))
- (cdr table)))))
-\f
-(set! syntax-table-ref
- (named-lambda (syntax-table-ref table name)
- (define (loop frames)
- (and (not (null? frames))
- (let ((entry (assq name (car frames))))
- (if entry
- (cdr entry)
- (loop (cdr frames))))))
- (check-syntax-table table 'SYNTAX-TABLE-REF)
- (loop (cdr table))))
-
-(set! syntax-table-define
- (named-lambda (syntax-table-define table name quantum)
- (check-syntax-table table 'SYNTAX-TABLE-DEFINE)
- (let ((entry (assq name (cadr table))))
- (if entry
- (set-cdr! entry quantum)
- (set-car! (cdr table)
- (cons (cons name quantum)
- (cadr table)))))))
-
-(set! syntax-table-shadow
- (named-lambda (syntax-table-shadow table name)
- (check-syntax-table table 'SYNTAX-TABLE-SHADOW)
- (let ((entry (assq name (cadr table))))
- (if entry
- (set-cdr! entry false)
- (set-car! (cdr table)
- (cons (cons name false)
- (cadr table)))))))
-
-(set! syntax-table-undefine
- (named-lambda (syntax-table-undefine table name)
- (check-syntax-table table 'SYNTAX-TABLE-UNDEFINE)
- (if (assq name (cadr table))
- (set-car! (cdr table)
- (del-assq! name (cadr table))))))
-\f
-;;;; Default Syntax
-
-(enable-scan-defines!)
-
-(set! system-global-syntax-table
- (cons syntax-table-tag
- `(((ACCESS . ,syntax-ACCESS-form)
- (AND . ,syntax-CONJUNCTION-form)
- (BEGIN . ,syntax-SEQUENCE-form)
- (BKPT . ,syntax-BKPT-form)
- (COND . ,syntax-COND-form)
- (CONS-STREAM . ,syntax-CONS-STREAM-form)
- (DECLARE . ,syntax-DECLARE-form)
- (DEFINE . ,syntax-DEFINE-form)
- (DEFINE-SYNTAX . ,syntax-DEFINE-SYNTAX-form)
- (DEFINE-MACRO . ,syntax-DEFINE-MACRO-form)
- (DELAY . ,syntax-DELAY-form)
- (ERROR . ,syntax-ERROR-form)
- (FLUID-LET . ,syntax-FLUID-LET-form-shallow)
- (IF . ,syntax-IF-form)
- (IN-PACKAGE . ,syntax-IN-PACKAGE-form)
- (LAMBDA . ,syntax-LAMBDA-form)
- (LET . ,syntax-LET-form)
- (LET-SYNTAX . ,syntax-LET-SYNTAX-form)
- (LOCAL-DECLARE . ,syntax-LOCAL-DECLARE-form)
- (MACRO . ,syntax-MACRO-form)
- (MAKE-ENVIRONMENT . ,syntax-MAKE-ENVIRONMENT-form)
- (NAMED-LAMBDA . ,syntax-NAMED-LAMBDA-form)
- (OR . ,syntax-DISJUNCTION-form)
- ;; The funniness here prevents QUASIQUOTE from being
- ;; seen as a nested backquote.
- (,'QUASIQUOTE . ,syntax-QUASIQUOTE-form)
- (QUOTE . ,syntax-QUOTE-form)
- (SCODE-QUOTE . ,syntax-SCODE-QUOTE-form)
- (SEQUENCE . ,syntax-SEQUENCE-form)
- (SET! . ,syntax-SET!-form)
- (THE-ENVIRONMENT . ,syntax-THE-ENVIRONMENT-form)
- (UNASSIGNED? . ,syntax-UNASSIGNED?-form)
- (UNBOUND? . ,syntax-UNBOUND?-form)
- (USING-SYNTAX . ,syntax-USING-SYNTAX-form)
- ))))
-
-;;; end SYNTAXER-PACKAGE
-)
\ No newline at end of file
+(define (disable-scan-defines!)
+ (set! make-scode-sequence make-sequence)
+ (set! internal-make-lambda make-lambda/no-scan))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sysclk.scm,v 13.42 1987/12/14 00:15:38 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
-;;;; System Clock
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sysclk.scm,v 14.1 1988/06/13 11:57:59 cph Rel $
-(declare (usual-integrations))
-\f
-(define process-time-clock
- (make-primitive-procedure 'SYSTEM-CLOCK 0))
+Copyright (c) 1988 Massachusetts Institute of Technology
-(define real-time-clock
- (make-primitive-procedure 'REAL-TIME-CLOCK 0))
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
-(define system-clock)
-(define runtime)
-(define measure-interval)
-(define wait-interval)
-(let ((offset-time) (non-runtime))
+1. Any copy made of this software must include this copyright notice
+in full.
-(define (clock)
- (- (process-time-clock) offset-time))
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
-(define (ticks->seconds ticks)
- (/ ticks 1000))
+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 operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
-(define (seconds->ticks seconds)
- (* seconds 1000))
+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 without prior written consent from
+MIT in each case. |#
+
+;;;; System Clock
+;;; package: (runtime system-clock)
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (reset-system-clock!)
+ (add-event-receiver! event:after-restore reset-system-clock!))
(define (reset-system-clock!)
(set! offset-time (process-time-clock))
(set! non-runtime 0))
-(reset-system-clock!)
-(add-event-receiver! event:after-restore reset-system-clock!)
-
-(set! system-clock
- (named-lambda (system-clock)
- (ticks->seconds (clock))))
-
-(set! runtime
- (named-lambda (runtime)
- (ticks->seconds (- (clock) non-runtime))))
-
-(set! measure-interval
- (named-lambda (measure-interval runtime? thunk)
- (let ((start (clock)))
- (let ((receiver (thunk (ticks->seconds start))))
- (let ((end (clock)))
- (if (not runtime?)
- (set! non-runtime (+ (- end start) non-runtime)))
- (receiver (ticks->seconds end)))))))
-
-(set! wait-interval
- (named-lambda (wait-interval number-of-seconds)
- (let ((end (+ (clock) (seconds->ticks number-of-seconds))))
- (let wait-loop ()
- (if (< (clock) end)
- (wait-loop))))))
-
-;;; end LET.
-)
\ No newline at end of file
+(define offset-time)
+(define non-runtime)
+
+(define-integrable process-time-clock
+ (ucode-primitive system-clock 0))
+
+(define-integrable real-time-clock
+ (ucode-primitive real-time-clock 0))
+
+(define (system-clock)
+ (process->system-time (process-time-clock)))
+
+(define (runtime)
+ (process->system-time (- (process-time-clock) non-runtime)))
+
+(define (increment-non-runtime! ticks)
+ (set! non-runtime (+ non-runtime ticks)))
+
+(define (measure-interval runtime? thunk)
+ (let ((start (process-time-clock)))
+ (let ((receiver (thunk (process->system-time start))))
+ (let ((end (process-time-clock)))
+ (if (not runtime?)
+ (increment-non-runtime! (- end start)))
+ (receiver (process->system-time end))))))
+
+(define-integrable (process->system-time ticks)
+ (internal-time/ticks->seconds (- ticks offset-time)))
+
+(define-integrable (internal-time/ticks->seconds ticks)
+ (/ ticks 1000))
+
+(define-integrable (internal-time/seconds->ticks seconds)
+ (* seconds 1000))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sysmac.scm,v 14.1 1988/05/20 01:03:06 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sysmac.scm,v 14.2 1988/06/13 11:58:05 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; System Internal Syntax
-;;; package: system-macros-package
+;;; package: (runtime system-macros)
(declare (usual-integrations))
\f
(let ((table (make-syntax-table system-global-syntax-table)))
(for-each (lambda (entry)
(syntax-table-define table (car entry) (cadr entry)))
- `((DEFINE-INTEGRABLE ,transform/define-integrable)
- (DEFINE-PRIMITIVES ,transform/define-primitives)
+ `((DEFINE-PRIMITIVES ,transform/define-primitives)
(UCODE-PRIMITIVE ,transform/ucode-primitive)
(UCODE-RETURN-ADDRESS ,transform/ucode-return-address)
(UCODE-TYPE ,transform/ucode-type)))
(define transform/ucode-return-address
(macro arguments
- (make-return-address (apply microcode-return arguments))))
-\f
-(define transform/define-integrable
- (macro (pattern . body)
- (parse-define-syntax pattern body
- (lambda (name body)
- `(BEGIN (DECLARE (INTEGRATE ,pattern))
- (DEFINE ,name ,@body)))
- (lambda (pattern body)
- `(BEGIN (DECLARE (INTEGRATE-OPERATOR ,(car pattern)))
- (DEFINE ,pattern
- ,@(if (list? (cdr pattern))
- `((DECLARE
- (INTEGRATE
- ,@(lambda-list->bound-names (cdr pattern)))))
- '())
- ,@body))))))
-
-(define (parse-define-syntax pattern body if-variable if-lambda)
- (cond ((pair? pattern)
- (let loop ((pattern pattern) (body body))
- (cond ((pair? (car pattern))
- (loop (car pattern) `((LAMBDA ,(cdr pattern) ,@body))))
- ((symbol? (car pattern))
- (if-lambda pattern body))
- (else
- (error "Illegal name" (car pattern))))))
- ((symbol? pattern)
- (if-variable pattern body))
- (else
- (error "Illegal name" pattern))))
-
-(define (lambda-list->bound-names lambda-list)
- (cond ((null? lambda-list)
- '())
- ((pair? lambda-list)
- (let ((lambda-list
- (if (eq? (car lambda-list) lambda-optional-tag)
- (begin (if (not (pair? (cdr lambda-list)))
- (error "Missing optional variable" lambda-list))
- (cdr lambda-list))
- lambda-list)))
- (cons (let ((parameter (car lambda-list)))
- (if (pair? parameter) (car parameter) parameter))
- (lambda-list->bound-names (cdr lambda-list)))))
- (else
- (if (not (symbol? lambda-list))
- (error "Illegal rest variable" lambda-list))
- (list lambda-list))))
\ No newline at end of file
+ (make-return-address (apply microcode-return arguments))))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 13.52 1988/02/21 18:13:33 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
-;;;; Systems
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 14.1 1988/06/13 11:58:10 cph Exp $
-(declare (usual-integrations))
-\f
-;;; (DISK-SAVE filename #!optional identify)
-;;; (DUMP-WORLD filename #!optional identify)
-;;; Saves a world image in FILENAME. IDENTIFY has the following meaning:
-;;;
-;;; [] Not supplied => ^G on restore (normal for saving band).
-;;; [] String => New world ID message, and ^G on restore.
-;;; [] Otherwise => Returns normally (very useful for saving bugs!).
-;;;
-;;; The image saved by DISK-SAVE does not include the "microcode", the
-;;; one saved by DUMP-WORLD does, and is an executable file.
+Copyright (c) 1988 Massachusetts Institute of Technology
-(define disk-save)
-(define dump-world)
-(define event:after-restore)
-(define event:after-restart)
-(define full-quit)
-(define identify-world)
-(define identify-system)
-(define add-system!)
-(define add-secondary-gc-daemon!)
-(let ()
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
-(define world-identification "Scheme")
-(define known-systems '())
-(define secondary-gc-daemons '())
-(define date-world-saved)
-(define time-world-saved)
+1. Any copy made of this software must include this copyright notice
+in full.
-(define (restart-world)
- (screen-clear)
- (abort->top-level
- (lambda ()
- (identify-world)
- (event:after-restart))))
-\f
-(define (setup-image save-image)
- (lambda (filename #!optional identify)
- (let ((d (date)) (t (time)))
- (gc-flip)
- ((access trigger-daemons garbage-collector-package) secondary-gc-daemons)
- (save-image filename
- (lambda (ie)
- (set-interrupt-enables! ie)
- (set! date-world-saved d)
- (set! time-world-saved t)
- false)
- (lambda (ie)
- (set-interrupt-enables! ie)
- (set! date-world-saved d)
- (set! time-world-saved t)
- (event:after-restore)
- (cond ((unassigned? identify)
- (restart-world))
- ((string? identify)
- (set! world-identification identify)
- (restart-world))
- (else
- true)))))))
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
-(set! disk-save
- (setup-image save-world))
+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.
-(set! dump-world
- (setup-image
- (let ((primitive (make-primitive-procedure 'DUMP-WORLD 1)))
- (lambda (filename after-dumping after-restoring)
- (let ((ie (set-interrupt-enables! interrupt-mask-none)))
- ((if (primitive filename)
- (lambda (ie)
- ((access reset! primitive-io))
- ((access reset! working-directory-package))
- (after-restoring ie))
- after-dumping)
- ie))))))
-\f
-(set! event:after-restore (make-event-distributor))
-(set! event:after-restart (make-event-distributor))
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
-(add-event-receiver! event:after-restart
- (lambda ()
- (if (not (unassigned? init-file-pathname))
- (let ((file
- (or (pathname->input-truename
- (merge-pathnames init-file-pathname
- (working-directory-pathname)))
- (pathname->input-truename
- (merge-pathnames init-file-pathname
- (home-directory-pathname))))))
- (if (not (null? file))
- (load file user-initial-environment))))))
+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 without prior written consent from
+MIT in each case. |#
-;; This is not the right place for this, but I don't know what is.
+;;;; Systems
+;;; package: (runtime system)
-(add-event-receiver!
- event:after-restore
- (lambda ()
- ((access reset! continuation-package))))
+(declare (usual-integrations))
\f
-(set! full-quit
- (named-lambda (full-quit)
- (quit)
- (restart-world)))
-
-(set! identify-world
- (named-lambda (identify-world)
- (newline)
- (write-string world-identification)
- (write-string " saved on ")
- (write-string (apply date->string date-world-saved))
- (write-string " at ")
- (write-string (apply time->string time-world-saved))
- (newline)
- (write-string " Release ")
- (write-string (access :release microcode-system))
- (for-each identify-system known-systems)))
+(define-structure (system
+ (constructor make-system
+ (name version modification files-lists))
+ (conc-name system/))
+ (name false read-only true)
+ (version false read-only true)
+ (modification false read-only true)
+ (files-lists false read-only true)
+ (files false))
-(set! identify-system
- (named-lambda (identify-system system)
- (newline)
- (write-string " ")
- (write-string (access :name system))
- (write-string " ")
- (write (access :version system))
- (let ((mod (access :modification system)))
- (if mod
- (begin (write-string ".")
- (write mod))))))
-
-(set! add-system!
- (named-lambda (add-system! system)
- (set! known-systems (append! known-systems (list system)))))
-
-(set! add-secondary-gc-daemon!
- (named-lambda (add-secondary-gc-daemon! daemon)
- (if (not (memq daemon secondary-gc-daemons))
- (set! secondary-gc-daemons (cons daemon secondary-gc-daemons)))))
+(define known-systems '())
-)
+(define (add-system! system)
+ (set! known-systems (append! known-systems (list system)))
+ *the-non-printing-object*)
+
+(define (for-each-system! procedure)
+ (for-each procedure known-systems))
+
+(define (system/identification-string system)
+ (string-append (system/name system)
+ " "
+ (number->string (system/version system))
+ (let ((modification (system/modification system)))
+ (if modification
+ (string-append "." (number->string modification))
+ ""))))
\f
-;;; Load the given system, which must have the following variables
-;;; defined:
-;;;
-;;; :FILES which will be assigned the list of filenames actually
+;;; Load the given system.
+
+;;; SYSTEM/FILES will be assigned the list of filenames actually
;;; loaded.
-;;;
-;;; :FILES-LISTS which should contain a list of pairs, the car of each
+
+;;; SYSTEM/FILES-LISTS should contain a list of pairs, the car of each
;;; pair being an environment, and the cdr a list of filenames. The
;;; files are loaded in the order specified, into the environments
;;; specified. COMPILED?, if false, means change all of the file
;;; types to "BIN".
-(define load-system!)
-(let ()
+(define (load-system! system #!optional compiled?)
+ (let ((files
+ (format-files-list (system/files-lists system)
+ (if (default-object? compiled?)
+ (prompt-for-confirmation "Load compiled? ") compiled?))))
+ (set-system/files! system
+ (map (lambda (file) (pathname->string (car file)))
+ files))
+ (for-each (lambda (file scode)
+ (newline) (write-string "Eval ")
+ (write (pathname->string (car file)))
+ (scode-eval scode (cdr file)))
+ files
+ (let loop ((files (map car files)))
+ (if (null? files)
+ '()
+ (split-list files 20
+ (lambda (head tail)
+ (let ((expressions (map fasload head)))
+ (newline)
+ (write-string "Purify")
+ (purify (list->vector expressions) true)
+ (append! expressions (loop tail))))))))
+ (newline)
+ (write-string "Done"))
+ (add-system! system)
+ *the-non-printing-object*)
-(set! load-system!
- (named-lambda (load-system! system #!optional compiled?)
- (if (unassigned? compiled?) (set! compiled? (query "Load compiled")))
- (define (loop files)
- (if (null? files)
- '()
- (split-list files 20
- (lambda (head tail)
- (let ((expressions (map fasload head)))
- (newline)
- (write-string "Purify")
- (purify (list->vector expressions) true)
- (append! expressions (loop tail)))))))
- (let ((files (format-files-list (access :files-lists system) compiled?)))
- (set! (access :files system)
- (map (lambda (file) (pathname->string (car file))) files))
- (for-each (lambda (file scode)
- (newline) (write-string "Eval ")
- (write (pathname->string (car file)))
- (scode-eval scode (cdr file)))
- files
- (loop (map car files)))
- (newline)
- (write-string "Done"))
- (add-system! system)
- *the-non-printing-object*))
-\f
(define (split-list list n receiver)
(if (or (not (pair? list)) (zero? n))
(receiver '() list)
(mapcan (lambda (files-list)
(map (lambda (filename)
(let ((pathname (->pathname filename)))
- (cons (if compiled?
- pathname
- (pathname-new-type pathname "bin"))
+ (cons (if (and (not compiled?)
+ (equal? "com" (pathname-type pathname)))
+ (pathname-new-type pathname "bin")
+ pathname)
(car files-list))))
(cdr files-list)))
- files-lists))
-
-(define (query prompt)
- (newline)
- (write-string prompt)
- (write-string " (Y or N)? ")
- (let ((char (char-upcase (read-char))))
- (cond ((char=? #\Y char)
- (write-string "Yes")
- true)
- ((char=? #\N char)
- (write-string "No")
- false)
- (else (beep) (query prompt)))))
-
-)
\ No newline at end of file
+ files-lists))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.1 1988/05/20 01:04:01 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/udata.scm,v 14.2 1988/06/13 11:58:26 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Simple Microcode Data Structures
+;;; package: ()
(declare (usual-integrations))
\f
(define-integrable (primitive-procedure? object)
(object-type? (ucode-type primitive) object))
+(define (guarantee-primitive-procedure object)
+ (if (not (primitive-procedure? object))
+ (error "Not a primitive procedure" object))
+ object)
+
(define (make-primitive-procedure name #!optional arity)
(let ((arity (if (default-object? arity) false arity)))
(let ((result ((ucode-primitive get-primitive-address) name arity)))
(eq? arity true)))
(if (false? result)
(error "MAKE-PRIMITIVE-PROCEDURE: unknown name" name)
- (error "MAKE-PRIMITIVE-PROCEDURE: inconsistent arity"
- name 'NEW: arity 'OLD: result)))
+ (error "MAKE-PRIMITIVE-PROCEDURE: inconsistent arity" name
+ (error-irritant/noise "new:") arity
+ (error-irritant/noise "old:") result)))
result)))
(define (implemented-primitive-procedure? object)
false))
(define (primitive-procedure-name primitive)
- (if (not (primitive-procedure? primitive))
- (error "PRIMITIVE-PROCEDURE-NAME: Not a primitive procedure" primitive))
- ((ucode-primitive get-primitive-name) (object-datum primitive)))
+ ((ucode-primitive get-primitive-name)
+ (object-datum (guarantee-primitive-procedure primitive))))
(define (compound-procedure? object)
(or (object-type? (ucode-type procedure) object)
(object-type? (ucode-type extended-procedure) object)))
+(define (guarantee-compound-procedure object)
+ (if (not (compound-procedure? object))
+ (error "Not a compound procedure" object))
+ object)
+
(define-integrable (compound-procedure-lambda procedure)
(system-pair-car procedure))
(primitive-procedure? object)
(compiled-procedure? object)))
-(define (procedure-lambda procedure)
- (if (not (compound-procedure? procedure))
- (error "PROCEDURE-LAMBDA: Not a compound procedure" procedure))
- (compound-procedure-lambda procedure))
+(define-integrable (procedure-lambda procedure)
+ (compound-procedure-lambda (guarantee-compound-procedure procedure)))
+
+(define-integrable (procedure-environment procedure)
+ (compound-procedure-environment (guarantee-compound-procedure procedure)))
-(define (procedure-environment procedure)
- (if (not (compound-procedure? procedure))
- (error "PROCEDURE-ENVIRONMENT: Not a compound procedure" procedure))
- (compound-procedure-environment procedure))
+(define (procedure-components procedure receiver)
+ (guarantee-compound-procedure procedure)
+ (receiver (compound-procedure-lambda procedure)
+ (compound-procedure-environment procedure)))
(define (procedure-arity procedure)
(cond ((primitive-procedure? procedure)
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.1 1988/05/20 01:04:16 cph Exp $
-;;;
-;;; Copyright (c) 1988 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.2 1988/06/13 11:58:33 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Microcode Environments
+;;; package: (runtime environment)
(declare (usual-integrations))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.1 1988/05/20 01:04:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.2 1988/06/13 11:58:37 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Microcode Errors
-;;; package: microcode-errors
+;;; package: (runtime microcode-errors)
(declare (usual-integrations))
\f
(define (make-error-translator alist error-type)
(lambda (error-code interrupt-enables)
+ error-code
(set-interrupt-enables! interrupt-enables)
(with-proceed-point proceed-value-filter
(lambda ()
- (signal-condition
+ (signal-error
(let ((frame
(continuation/first-subproblem
(current-proceed-continuation))))
(set-interrupt-enables! interrupt-enables)
(with-proceed-point proceed-value-filter
(lambda ()
- (signal-condition
+ (signal-error
(make-error-condition
error-type:anomalous
(list (or (microcode-error/code->name error-code) error-code))
(set-interrupt-enables! interrupt-enables)
(with-proceed-point proceed-value-filter
(lambda ()
- (signal-condition
+ (signal-error
(make-error-condition error-type:bad-error-code
(list error-code)
repl-environment)))))
" argument position")))
(define (make-wrong-type-type n)
- (make-condition-type (list error-type:bad-range-argument)
+ (make-condition-type (list error-type:wrong-type-argument)
(string-append "Illegal datum in "
(vector-ref nth-string n)
" argument position")))
internal-apply-frame/add-fluid-binding-name
(ucode-primitive add-fluid-binding! 3))
+ (define-internal-apply-handler 'UNBOUND-VARIABLE 0 2
+ (ucode-primitive environment-link-name))
+
+ (define-internal-apply-handler 'BAD-ASSIGNMENT 0 2
+ (ucode-primitive environment-link-name))
+
(define-standard-frame-handler 'UNASSIGNED-VARIABLE 'EVAL-ERROR
standard-frame/variable? variable-name)
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 13.54 1988/03/14 16:36:38 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 14.1 1988/06/13 11:58:58 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Unparser
+;;; package: (runtime unparser)
(declare (usual-integrations))
\f
-;;; Control Variables
+(define (initialize-package!)
+ (set! string-delimiters (char-set #\" #\\ #\Tab #\Newline #\Page))
+ (set! hook/interned-symbol unparse-symbol)
+ (set! *unparser-radix* 10)
+ (set! *unparser-list-breadth-limit* false)
+ (set! *unparser-list-depth-limit* false)
+ (set! system-global-unparser-table (make-system-global-unparser-table))
+ (set-current-unparser-table! system-global-unparser-table))
+
+(define *unparser-radix*)
+(define *unparser-list-breadth-limit*)
+(define *unparser-list-depth-limit*)
+(define system-global-unparser-table)
+(define *current-unparser-table*)
+
+(define (current-unparser-table)
+ *current-unparser-table*)
+
+(define (set-current-unparser-table! table)
+ (guarantee-unparser-table table)
+ (set! *current-unparser-table* table))
+
+(define (make-system-global-unparser-table)
+ (let ((table (make-unparser-table unparse/default)))
+ (for-each (lambda (entry)
+ (unparser-table/set-entry! table (car entry) (cadr entry)))
+ `((BIGNUM ,unparse/number)
+ (CHARACTER ,unparse/character)
+ (COMPILED-ENTRY ,unparse/compiled-entry)
+ (COMPLEX ,unparse/number)
+ (ENTITY ,unparse/entity)
+ (ENVIRONMENT ,unparse/environment)
+ (EXTENDED-PROCEDURE ,unparse/compound-procedure)
+ (FIXNUM ,unparse/number)
+ (FLONUM ,unparse/number)
+ (FUTURE ,unparse/future)
+ (INTERNED-SYMBOL ,unparse/interned-symbol)
+ (LIST ,unparse/pair)
+ (NULL ,unparse/null)
+ (PRIMITIVE ,unparse/primitive-procedure)
+ (PROCEDURE ,unparse/compound-procedure)
+ (RETURN-ADDRESS ,unparse/return-address)
+ (STRING ,unparse/string)
+ (TRUE ,unparse/true)
+ (UNINTERNED-SYMBOL ,unparse/uninterned-symbol)
+ (VARIABLE ,unparse/variable)
+ (VECTOR ,unparse/vector)
+ (VECTOR-1B ,unparse/bit-string)))
+ table))
+\f
+;;;; Unparser Table/State
-(define *unparser-radix* #d10)
-(define *unparser-list-breadth-limit* false)
-(define *unparser-list-depth-limit* false)
+(define-structure (unparser-table (constructor %make-unparser-table)
+ (conc-name unparser-table/))
+ (dispatch-vector false read-only true))
-(define unparser-package
- (make-environment
+(define (guarantee-unparser-table table)
+ (if (not (unparser-table? table)) (error "Bad unparser table" table))
+ table)
-(define *unparse-char)
-(define *unparse-string)
-(define *unparse-symbol)
-(define *unparser-list-depth*)
-(define *slashify*)
+(define (make-unparser-table default-method)
+ (%make-unparser-table
+ (make-vector (microcode-type/code-limit) default-method)))
-(define (unparse-with-brackets thunk)
- (*unparse-string "#[")
- (thunk)
- (*unparse-char #\]))
+(define (unparser-table/copy table)
+ (%make-unparser-table (unparser-table/dispatch-vector table)))
-(define (unparse-object object port slashify)
- (fluid-let ((*unparse-char (access :write-char port))
- (*unparse-string (access :write-string port))
- (*unparser-list-depth* 0)
- (*slashify* slashify)
- (*unparse-symbol (if (unassigned? *unparse-symbol)
- unparse-symbol
- *unparse-symbol)))
- (*unparse-object-or-future object)))
-
-(define (*unparse-object-or-future object)
- (if (future? object)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "FUTURE ")
- (unparse-datum object)))
- (*unparse-object object)))
+(define (unparser-table/entry table type-name)
+ (vector-ref (unparser-table/dispatch-vector table)
+ (microcode-type type-name)))
+
+(define (unparser-table/set-entry! table type-name method)
+ (vector-set! (unparser-table/dispatch-vector table)
+ (microcode-type type-name)
+ method))
+
+(define-structure (unparser-state (conc-name unparser-state/))
+ (port false read-only true)
+ (list-depth false read-only true)
+ (slashify? false read-only true)
+ (unparser-table false read-only true))
+
+(define (guarantee-unparser-state state)
+ (if (not (unparser-state? state)) (error "Bad unparser state" state))
+ state)
+\f
+;;;; Top Level
+
+(define (unparse-char state char)
+ (guarantee-unparser-state state)
+ (write-char char (unparser-state/port state)))
+
+(define (unparse-string state string)
+ (guarantee-unparser-state state)
+ (write-string string (unparser-state/port state)))
+
+(define (unparse-object state object)
+ (guarantee-unparser-state state)
+ (unparse-object/internal object
+ (unparser-state/port state)
+ (unparser-state/list-depth state)
+ (unparser-state/slashify? state)
+ (unparser-state/unparser-table state)))
+
+(define (unparse-object/internal object port list-depth slashify? table)
+ (fluid-let
+ ((*output-port* port)
+ (*unparse-char-operation* (output-port/operation/write-char port))
+ (*unparse-string-operation* (output-port/operation/write-string port))
+ (*list-depth* list-depth)
+ (*slashify?* slashify?)
+ (*unparser-table* table)
+ (*dispatch-vector* (unparser-table/dispatch-vector table)))
+ (*unparse-object object)))
+
+(define-integrable (invoke-user-method method object)
+ (method (make-unparser-state *output-port*
+ *list-depth*
+ *slashify?*
+ *unparser-table*)
+ object))
+
+(define *list-depth*)
+(define *slashify?*)
+(define *unparser-table*)
+(define *dispatch-vector*)
(define (*unparse-object object)
- ((vector-ref dispatch-vector (primitive-type object)) object))
+ ((vector-ref *dispatch-vector*
+ ((ucode-primitive primitive-object-type 1) object))
+ object))
+\f
+;;;; Low Level Operations
+
+(define *output-port*)
+(define *unparse-char-operation*)
+(define *unparse-string-operation*)
+
+(define-integrable (*unparse-char char)
+ (*unparse-char-operation* *output-port* char))
+
+(define-integrable (*unparse-string string)
+ (*unparse-string-operation* *output-port* string))
-(define (*unparse-substring string start end)
+(define-integrable (*unparse-substring string start end)
(*unparse-string (substring string start end)))
-(define (unparse-default object)
- (unparse-with-brackets
- (lambda ()
- (*unparse-object (or (object-type object)
- `(UNDEFINED-TYPE-CODE ,(primitive-type object))))
- (*unparse-char #\Space)
- (unparse-datum object))))
+(define-integrable (*unparse-datum object)
+ (*unparse-string (number->string (object-datum object) 16)))
-(define dispatch-vector
- (vector-cons number-of-microcode-types unparse-default))
+(define-integrable (*unparse-hash object)
+ (*unparse-string (number->string (hash object))))
-(define (define-type type dispatcher)
- (vector-set! dispatch-vector (microcode-type type) dispatcher))
+(define (*unparse-with-brackets name object thunk)
+ (*unparse-string "#[")
+ (if (string? name)
+ (*unparse-string name)
+ (*unparse-object name))
+ (if object
+ (begin (*unparse-char #\Space)
+ (*unparse-hash object)))
+ (if thunk
+ (begin (*unparse-char #\Space)
+ (thunk)))
+ (*unparse-char #\]))
\f
-(define-type 'NULL
- (lambda (x)
- (if (eq? x '())
- (*unparse-string "()")
- (unparse-default x))))
-
-(define-type 'TRUE
- (lambda (x)
- (if (eq? x true)
- (*unparse-string "#T")
- (unparse-default x))))
-
-(define-type 'RETURN-ADDRESS
- (lambda (return-address)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "RETURN-ADDRESS ")
- (*unparse-object (return-address-name return-address))))))
+;;;; Unparser Methods
+
+(define (unparse/default object)
+ (let ((type (user-object-type object)))
+ (if (zero? (object-gc-type object))
+ (*unparse-with-brackets type false
+ (lambda ()
+ (*unparse-datum object)))
+ (*unparse-with-brackets type object false))))
+
+(define (user-object-type object)
+ (let ((type-code (object-type object)))
+ (let ((type-name (microcode-type/code->name type-code)))
+ (if type-name
+ (let ((entry (assq type-name renamed-user-object-types)))
+ (if entry (cdr entry) type-name))
+ (intern
+ (string-append "undefined-type:" (number->string type-code)))))))
+
+(define renamed-user-object-types
+ '((FIXNUM . NUMBER)
+ (BIGNUM . NUMBER)
+ (FLONUM . NUMBER)
+ (COMPLEX . NUMBER)
+ (INTERNED-SYMBOL . SYMBOL)
+ (UNINTERNED-SYMBOL . SYMBOL)
+ (EXTENDED-PROCEDURE . PROCEDURE)
+ (PRIMITIVE . PRIMITIVE-PROCEDURE)
+ (LEXPR . LAMBDA)
+ (EXTENDED-LAMBDA . LAMBDA)
+ (COMBINATION-1 . COMBINATION)
+ (COMBINATION-2 . COMBINATION)
+ (PRIMITIVE-COMBINATION-0 . COMBINATION)
+ (PRIMITIVE-COMBINATION-1 . COMBINATION)
+ (PRIMITIVE-COMBINATION-2 . COMBINATION)
+ (PRIMITIVE-COMBINATION-3 . COMBINATION)
+ (SEQUENCE-2 . SEQUENCE)
+ (SEQUENCE-3 . SEQUENCE)))
+\f
+(define (unparse/null object)
+ (cond ((eq? object '()) (*unparse-string "()"))
+ ((eq? object #F) (*unparse-string "#F"))
+ (else (unparse/default object))))
+
+(define (unparse/true object)
+ (cond ((eq? object true) (*unparse-string "#T"))
+ ((undefined-value? object) (*unparse-string "#[undefined-value]"))
+ (else (unparse/default object))))
+
+(define (unparse/return-address return-address)
+ (*unparse-with-brackets 'RETURN-ADDRESS return-address
+ (lambda ()
+ (*unparse-object (return-address/name return-address)))))
+
+(define (unparse/interned-symbol symbol)
+ (hook/interned-symbol symbol))
+
+(define hook/interned-symbol)
+
+(define (unparse/uninterned-symbol symbol)
+ (*unparse-with-brackets 'UNINTERNED-SYMBOL
+ symbol
+ (lambda () (unparse-symbol symbol))))
(define (unparse-symbol symbol)
(*unparse-string (symbol->string symbol)))
-(define-type 'INTERNED-SYMBOL
- (lambda (symbol)
- (*unparse-symbol symbol)))
-
-(define-type 'UNINTERNED-SYMBOL
- (lambda (symbol)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "UNINTERNED ")
- (unparse-symbol symbol)
- (*unparse-char #\Space)
- (*unparse-object (object-hash symbol))))))
-
-(define-type 'CHARACTER
- (lambda (character)
- (if *slashify*
- (begin (*unparse-string "#\\")
- (*unparse-string (char->name character true)))
- (*unparse-char character))))
+(define (unparse/character character)
+ (if *slashify?*
+ (begin (*unparse-string "#\\")
+ (*unparse-string (char->name character true)))
+ (*unparse-char character)))
\f
-(define-type 'STRING
- (let ((delimiters (char-set #\" #\\ #\Tab char:newline #\Page)))
- (lambda (string)
- (if *slashify*
- (begin (*unparse-char #\")
- (let ((end (string-length string)))
- (define (loop start)
- (let ((index (substring-find-next-char-in-set
- string start end delimiters)))
- (if index
- (begin (*unparse-substring string start index)
- (*unparse-char #\\)
- (*unparse-char
- (let ((char (string-ref string index)))
- (cond ((char=? char #\Tab) #\t)
- ((char=? char char:newline) #\n)
- ((char=? char #\Page) #\f)
- (else char))))
- (loop (1+ index)))
- (*unparse-substring string start end))))
- (if (substring-find-next-char-in-set string 0 end
- delimiters)
- (loop 0)
- (*unparse-string string)))
- (*unparse-char #\"))
- (*unparse-string string)))))
+(define (unparse/string string)
+ (if *slashify?*
+ (begin (*unparse-char #\")
+ (let ((end (string-length string)))
+ (define (loop start)
+ (let ((index
+ (substring-find-next-char-in-set string start end
+ string-delimiters)))
+ (if index
+ (begin (*unparse-substring string start index)
+ (*unparse-char #\\)
+ (*unparse-char
+ (let ((char (string-ref string index)))
+ (cond ((char=? char #\Tab) #\t)
+ ((char=? char char:newline) #\n)
+ ((char=? char #\Page) #\f)
+ (else char))))
+ (loop (1+ index)))
+ (*unparse-substring string start end))))
+ (if (substring-find-next-char-in-set string 0 end
+ string-delimiters)
+ (loop 0)
+ (*unparse-string string)))
+ (*unparse-char #\"))
+ (*unparse-string string)))
+
+(define string-delimiters)
+
+(define (unparse/bit-string bit-string)
+ (*unparse-string "#*")
+ (let loop ((index (-1+ (bit-string-length bit-string))))
+ (if (not (negative? index))
+ (begin (*unparse-char (if (bit-string-ref bit-string index) #\1 #\0))
+ (loop (-1+ index))))))
\f
-(define-type 'VECTOR
- (let ((nmv-type (microcode-type 'manifest-nm-vector))
- (snmv-type (microcode-type 'manifest-special-nm-vector)))
- (lambda (vector)
- (limit-unparse-depth
+(define (unparse/vector vector)
+ ((or (unparse-vector/unparser vector) unparse-vector/normal) vector))
+
+(define (unparse-vector/unparser vector)
+ (and (not (zero? (vector-length vector)))
+ (let ((tag (safe-vector-ref vector 0)))
+ (and (not (future? tag))
+ (let ((method (unparser/tagged-vector-method tag)))
+ (and method
+ (lambda (object)
+ (invoke-user-method method object))))))))
+
+(define (unparse-vector/normal vector)
+ (limit-unparse-depth
+ (lambda ()
+ (let ((length (vector-length vector)))
+ (if (zero? length)
+ (*unparse-string "#()")
+ (begin
+ (*unparse-string "#(")
+ (*unparse-object (safe-vector-ref vector 0))
+ (let loop ((index 1))
+ (cond ((= index length)
+ (*unparse-char #\)))
+ ((and *unparser-list-breadth-limit*
+ (>= index *unparser-list-breadth-limit*))
+ (*unparse-string " ...)"))
+ (else
+ (*unparse-char #\Space)
+ (*unparse-object (safe-vector-ref vector index))
+ (loop (1+ index)))))))))))
+
+(define (safe-vector-ref vector index)
+ (if (with-absolutely-no-interrupts
(lambda ()
- (let ((length (vector-length vector))
- (element
- (lambda (index)
- (if (with-interrupt-mask interrupt-mask-none
- (lambda (ie)
- (or (primitive-type? nmv-type
- (vector-ref vector index))
- (primitive-type? snmv-type
- (vector-ref vector index)))))
- (error "Attempt to unparse partially marked vector" 0)
- (vector-ref vector index)))))
- (let ((normal
- (lambda ()
- (*unparse-string "#(")
- (*unparse-object-or-future (element 0))
- (let loop ((index 1))
- (cond ((= index length)
- (*unparse-char #\)))
- ((and *unparser-list-breadth-limit*
- (>= index *unparser-list-breadth-limit*))
- (*unparse-string " ...)"))
- (else
- (*unparse-char #\Space)
- (*unparse-object-or-future (element index))
- (loop (1+ index))))))))
- (cond ((zero? length)
- (*unparse-string "#()"))
- ((future? vector)
- (normal))
- (else
- (let ((entry
- (assq (element 0) *unparser-special-objects*)))
- (if entry
- ((cdr entry) vector)
- (normal))))))))))))
-
-(define *unparser-special-objects* '())
-
-(define (add-unparser-special-object! key unparser)
- (set! *unparser-special-objects*
- (cons (cons key unparser)
- *unparser-special-objects*))
- *the-non-printing-object*)
+ (or (object-type? (ucode-type manifest-nm-vector)
+ (vector-ref vector index))
+ (object-type? (ucode-type manifest-special-nm-vector)
+ (vector-ref vector index)))))
+ (error "Attempt to unparse partially marked vector" 0))
+ (vector-ref vector index))
\f
-(define-type 'LIST
- (lambda (object)
- ((or (unparse-list/unparser object) unparse-list) object)))
+(define (unparse/pair pair)
+ ((or (unparse-list/unparser pair) unparse-list) pair))
(define (unparse-list list)
(limit-unparse-depth
(lambda ()
(*unparse-char #\()
- (*unparse-object-or-future (car list))
+ (*unparse-object (car list))
(unparse-tail (cdr list) 2)
(*unparse-char #\)))))
(define (limit-unparse-depth kernel)
(if *unparser-list-depth-limit*
- (fluid-let ((*unparser-list-depth* (1+ *unparser-list-depth*)))
- (if (> *unparser-list-depth* *unparser-list-depth-limit*)
+ (fluid-let ((*list-depth* (1+ *list-depth*)))
+ (if (> *list-depth* *unparser-list-depth-limit*)
(*unparse-string "...")
(kernel)))
(kernel)))
(begin (*unparse-string " . ")
(unparser l))
(begin (*unparse-char #\Space)
- (*unparse-object-or-future (car l))
+ (*unparse-object (car l))
(if (and *unparser-list-breadth-limit*
(>= n *unparser-list-breadth-limit*)
(not (null? (cdr l))))
(unparse-tail (cdr l) (1+ n)))))))
((not (null? l))
(*unparse-string " . ")
- (*unparse-object-or-future l))))
+ (*unparse-object l))))
(define (unparse-list/unparser object)
- (cond ((future? (car object)) false)
- ((unassigned-object? object) unparse-unassigned)
- ((unbound-object? object) unparse-unbound)
- ((reference-trap? object) unparse-reference-trap)
- ((eq? (car object) 'QUOTE)
- (and (pair? (cdr object))
- (null? (cddr object))
- unparse-quote-form))
- (else
- (let ((entry (assq (car object) *unparser-special-pairs*)))
- (and entry
- (cdr entry))))))
-\f
-(define *unparser-special-pairs* '())
-
-(define (add-unparser-special-pair! key unparser)
- (set! *unparser-special-pairs*
- (cons (cons key unparser)
- *unparser-special-pairs*))
- *the-non-printing-object*)
+ (and (not (future? (car object)))
+ (if (eq? (car object) 'QUOTE)
+ (and (pair? (cdr object))
+ (null? (cddr object))
+ unparse-quote-form)
+ (let ((method (unparser/tagged-pair-method (car object))))
+ (and method
+ (lambda (object)
+ (invoke-user-method method object)))))))
(define (unparse-quote-form pair)
(*unparse-char #\')
- (*unparse-object-or-future (cadr pair)))
-
-(define (unparse-unassigned x)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "UNASSIGNED"))))
-
-(define (unparse-unbound x)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "UNBOUND"))))
-
-(define (unparse-reference-trap x)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "REFERENCE-TRAP ")
- (*unparse-object (reference-trap-kind x)))))
+ (*unparse-object (cadr pair)))
\f
;;;; Procedures and Environments
-(define (unparse-compound-procedure procedure)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "COMPOUND-PROCEDURE ")
- (lambda-components* (procedure-lambda procedure)
- (lambda (name required optional rest body)
- (if (eq? name lambda-tag:unnamed)
- (unparse-datum procedure)
- (*unparse-object name)))))))
-
-(define-type 'PROCEDURE unparse-compound-procedure)
-(define-type 'EXTENDED-PROCEDURE unparse-compound-procedure)
-
-(define (unparse-primitive-procedure proc)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "PRIMITIVE-PROCEDURE ")
- (*unparse-object (primitive-procedure-name proc)))))
-
-(define-type 'PRIMITIVE unparse-primitive-procedure)
-
-(define (unparse-compiled-entry entry)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string (symbol->string (compiled-entry-type entry)))
- (*unparse-char #\Space)
- (unparse-datum entry))))
-
-(define-type 'COMPILED-ENTRY unparse-compiled-entry)
-
-(define-type 'ENVIRONMENT
- (lambda (environment)
- (if (lexical-unreferenceable? environment ':PRINT-SELF)
- (unparse-default environment)
- ((access :print-self environment)))))
-
-(define-type 'VARIABLE
- (lambda (variable)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "VARIABLE ")
- (*unparse-object (variable-name variable))))))
-
-(define (unparse-datum object)
- (*unparse-string (number->string (primitive-datum object) 16)))
-
-(define (unparse-number object)
+(define (unparse/compound-procedure procedure)
+ (*unparse-with-brackets 'COMPOUND-PROCEDURE procedure
+ (lambda-components* (procedure-lambda procedure)
+ (lambda (name required optional rest body)
+ required optional rest body
+ (and (not (eq? name lambda-tag:unnamed))
+ (lambda () (*unparse-object name)))))))
+
+(define (unparse/primitive-procedure procedure)
+ (*unparse-with-brackets 'PRIMITIVE-PROCEDURE false
+ (lambda ()
+ (*unparse-object (primitive-procedure-name procedure)))))
+
+(define (unparse/compiled-entry entry)
+ (*unparse-with-brackets (compiled-entry-type entry)
+ false
+ (lambda () (*unparse-datum entry))))
+
+(define (unparse/environment environment)
+ (if (lexical-unreferenceable? environment ':PRINT-SELF)
+ (unparse/default environment)
+ ((lexical-reference environment ':PRINT-SELF))))
+
+(define (unparse/variable variable)
+ (*unparse-with-brackets 'VARIABLE variable
+ (lambda () (*unparse-object (variable-name variable)))))
+
+(define (unparse/number object)
(*unparse-string (number->string object *unparser-radix*)))
-
-(define-type 'FIXNUM unparse-number)
-(define-type 'BIGNUM unparse-number)
-(define-type 'FLONUM unparse-number)
-(define-type 'COMPLEX unparse-number)
-
-;;; end UNPARSER-PACKAGE.
-))
\ No newline at end of file
+(define (unparse/future future)
+ (*unparse-with-brackets 'FUTURE false
+ (lambda ()
+ (*unparse-string
+ (number->string ((ucode-primitive primitive-object-datum 1) future)
+ 16)))))
+
+(define (unparse/entity entity)
+ (*unparse-with-brackets (if (continuation? entity) 'CONTINUATION 'ENTITY)
+ entity
+ false))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 13.49 1988/02/18 16:46:02 jrm Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; UNSYNTAX: SCODE -> S-Expressions
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 14.1 1988/06/13 11:59:14 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
+
+;;;; UNSYNTAX: SCode -> S-Expression
+;;; package: (runtime unsyntaxer)
(declare (usual-integrations))
\f
-(define unsyntax)
-(define unsyntax-lambda-list)
-(define make-unsyntax-table)
-(define unsyntax-table?)
-(define current-unsyntax-table)
-(define set-current-unsyntax-table!)
-(define with-unsyntax-table)
-
-(define unsyntaxer-package
- (make-environment
-
-(set! unsyntax
- (named-lambda (unsyntax scode #!optional unsyntax-table)
- (let ((object (if (compound-procedure? scode)
- (procedure-lambda scode)
- scode)))
- (if (unassigned? unsyntax-table)
- (unsyntax-object object)
- (with-unsyntax-table unsyntax-table
- (lambda ()
- (unsyntax-object object)))))))
+(define (initialize-package!)
+ (set! unsyntaxer/scode-walker
+ (make-scode-walker unsyntax-constant
+ `((ACCESS ,unsyntax-ACCESS-object)
+ (ASSIGNMENT ,unsyntax-ASSIGNMENT-object)
+ (COMBINATION ,unsyntax-COMBINATION-object)
+ (COMMENT ,unsyntax-COMMENT-object)
+ (CONDITIONAL ,unsyntax-CONDITIONAL-object)
+ (DECLARATION ,unsyntax-DECLARATION-object)
+ (DEFINITION ,unsyntax-DEFINITION-object)
+ (DELAY ,unsyntax-DELAY-object)
+ (DISJUNCTION ,unsyntax-DISJUNCTION-object)
+ (ERROR-COMBINATION
+ ,unsyntax-ERROR-COMBINATION-object)
+ (IN-PACKAGE ,unsyntax-IN-PACKAGE-object)
+ (LAMBDA ,unsyntax-LAMBDA-object)
+ (OPEN-BLOCK ,unsyntax-OPEN-BLOCK-object)
+ (QUOTATION ,unsyntax-QUOTATION)
+ (SEQUENCE ,unsyntax-SEQUENCE-object)
+ (THE-ENVIRONMENT ,unsyntax-THE-ENVIRONMENT-object)
+ (UNASSIGNED? ,unsyntax-UNASSIGNED?-object)
+ (VARIABLE ,unsyntax-VARIABLE-object)))))
+
+(define (unsyntax scode)
+ (unsyntax-object
+ (if (compound-procedure? scode) (procedure-lambda scode) scode)))
(define (unsyntax-object object)
- ((unsyntax-dispatcher object) object))
+ ((scode-walk unsyntaxer/scode-walker object) object))
+
+(define unsyntaxer/scode-walker)
(define (unsyntax-objects objects)
(if (null? objects)
(cons (unsyntax-object (car objects))
(unsyntax-objects (cdr objects)))))
-(define (absolute-reference? object)
- (and (access? object)
- (eq? (access-environment object) system-global-environment)))
-
-(define (absolute-reference-name reference)
- (access-name reference))
-
-(define (absolute-reference-to? object name)
- (and (absolute-reference? object)
- (eq? (absolute-reference-name object) name)))
+(define (unsyntax-error keyword message . irritants)
+ (error (string-append "UNSYNTAX: "
+ (symbol->string keyword)
+ ": "
+ message)
+ (cond ((null? irritants) *the-non-printing-object*)
+ ((null? (cdr irritants)) (car irritants))
+ (else irritants))))
\f
;;;; Unsyntax Quanta
+(define (unsyntax-constant object)
+ (if (or (pair? object) (symbol? object))
+ `(QUOTE ,object)
+ object))
+
(define (unsyntax-QUOTATION quotation)
`(SCODE-QUOTE ,(unsyntax-object (quotation-expression quotation))))
-(define (unsyntax-constant object)
- `(QUOTE ,object))
-
(define (unsyntax-VARIABLE-object object)
(variable-name object))
(assignment-components assignment
(lambda (name value)
`(SET! ,name
- ,@(if (unassigned-object? value)
+ ,@(if (unassigned-reference-trap? value)
'()
`(,(unsyntax-object value)))))))
-(define ((definition-unexpander key lambda-key) name value)
+(define (unexpand-definition name value)
(if (lambda? value)
(lambda-components** value
(lambda (lambda-name required optional rest body)
(if (eq? lambda-name name)
- `(,lambda-key (,name . ,(lambda-list required optional rest))
+ `(DEFINE (,name . ,(lambda-list required optional rest))
,@(unsyntax-sequence body))
- `(,key ,name ,@(unexpand-binding-value value)))))
- `(,key ,name ,@(unexpand-binding-value value))))
+ `(DEFINE ,name ,@(unexpand-binding-value value)))))
+ `(DEFINE ,name ,@(unexpand-binding-value value))))
(define (unexpand-binding-value value)
- (if (unassigned-object? value)
+ (if (unassigned-reference-trap? value)
'()
`(,(unsyntax-object value))))
-
-(define unexpand-definition
- (definition-unexpander 'DEFINE 'DEFINE))
\f
-(define (unsyntax-UNBOUND?-object unbound?)
- `(UNBOUND? ,(unbound?-name unbound?)))
-
(define (unsyntax-UNASSIGNED?-object unassigned?)
`(UNASSIGNED? ,(unassigned?-name unassigned?)))
,@(unsyntax-sequence expression)))))
(define (unsyntax-THE-ENVIRONMENT-object object)
+ object
`(THE-ENVIRONMENT))
+(define (unsyntax-MAKE-ENVIRONMENT names values body)
+ names values
+ `(MAKE-ENVIRONMENT ,@(except-last-pair (unsyntax-sequence body))))
+
(define (unsyntax-DISJUNCTION-object object)
`(OR ,@(disjunction-components object unexpand-disjunction)))
\f
;;;; Lambdas
-(define (unsyntax-LAMBDA-object lambda)
- (lambda-components** lambda
+(define (unsyntax-LAMBDA-object expression)
+ (lambda-components** expression
(lambda (name required optional rest body)
(let ((bvl (lambda-list required optional rest))
(body (unsyntax-sequence body)))
`(LAMBDA ,bvl ,@body)
`(NAMED-LAMBDA (,name . ,bvl) ,@body))))))
-(set! unsyntax-lambda-list
- (named-lambda (unsyntax-lambda-list lambda)
- (if (not (lambda? lambda))
- (error "Must be a lambda expression" lambda))
- (lambda-components** lambda
- (lambda (name required optional rest body)
- (lambda-list required optional rest)))))
+(define (unsyntax-lambda-list expression)
+ (if (not (lambda? expression))
+ (error "Must be a lambda expression" expression))
+ (lambda-components** expression
+ (lambda (name required optional rest body)
+ name body
+ (lambda-list required optional rest))))
(define (lambda-list required optional rest)
(cond ((null? rest)
(if (null? optional)
required
- `(,@required ,(access lambda-optional-tag lambda-package)
- ,@optional)))
+ `(,@required ,lambda-optional-tag ,@optional)))
((null? optional)
`(,@required . ,rest))
(else
- `(,@required ,(access lambda-optional-tag lambda-package)
- ,@optional . ,rest))))
+ `(,@required ,lambda-optional-tag ,@optional . ,rest))))
-(define (lambda-components** lambda receiver)
- (lambda-components lambda
+(define (lambda-components** expression receiver)
+ (lambda-components expression
(lambda (name required optional rest auxiliary declarations body)
(receiver name required optional rest
(unscan-defines auxiliary declarations body)))))
(define (unsyntax-COMBINATION-object combination)
(combination-components combination
(lambda (operator operands)
+ (let ((ordinary-combination
+ (lambda ()
+ (cons (unsyntax-object operator)
+ (unsyntax-objects operands)))))
+ (cond ((and (or (eq? operator cons)
+ (absolute-reference-to? operator 'CONS))
+ (= (length operands) 2)
+ (delay? (cadr operands)))
+ `(CONS-STREAM ,(unsyntax-object (car operands))
+ ,(unsyntax-object
+ (delay-expression (cadr operands)))))
+ ((absolute-reference-to? operator 'BREAKPOINT-PROCEDURE)
+ (unsyntax-error-like-form operands 'BKPT))
+ ((lambda? operator)
+ (lambda-components** operator
+ (lambda (name required optional rest body)
+ (if (and (null? optional)
+ (null? rest))
+ (cond ((or (eq? name lambda-tag:unnamed)
+ (eq? name lambda-tag:let))
+ `(LET ,(unsyntax-let-bindings required operands)
+ ,@(unsyntax-sequence body)))
+ ((eq? name lambda-tag:fluid-let)
+ (unsyntax/fluid-let required
+ operands
+ body
+ ordinary-combination))
+ ((eq? name lambda-tag:make-environment)
+ (unsyntax-make-environment required
+ operands
+ body))
+ (else (ordinary-combination)))
+ (ordinary-combination)))))
+ (else
+ (ordinary-combination)))))))
- (define (unsyntax-default)
- (cons (unsyntax-object operator)
- (unsyntax-objects operands)))
-
- (cond ((and (or (eq? operator cons)
- (and (variable? operator)
- (eq? (variable-name operator) 'CONS)))
- (= (length operands) 2)
- (delay? (cadr operands)))
- `(CONS-STREAM ,(unsyntax-object (car operands))
- ,(unsyntax-object
- (delay-expression (cadr operands)))))
- ((eq? operator error-procedure)
- (unsyntax-error-like-form operands 'ERROR))
- ((absolute-reference? operator)
- (case (absolute-reference-name operator)
- ((ERROR-PROCEDURE)
- (unsyntax-error-like-form operands 'ERROR))
- ((BREAKPOINT-PROCEDURE)
- (unsyntax-error-like-form operands 'BKPT))
- (else (unsyntax-default))))
- ((lambda? operator)
- (lambda-components** operator
- (lambda (name required optional rest body)
- (if (and (null? optional)
- (null? rest))
- (cond ((or (eq? name lambda-tag:unnamed)
- (eq? name lambda-tag:let))
- `(LET ,(unsyntax-let-bindings required operands)
- ,@(unsyntax-sequence body)))
- ((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))
- ((eq? name lambda-tag:common-lisp-fluid-let)
- (unsyntax-common-lisp-fluid-let required operands
- body))
- ((eq? name lambda-tag:make-environment)
- (unsyntax-make-environment required operands body))
- #|
- Old way when named-lambda was a letrec
- `(LET ,name
- ,(unsyntax-let-bindings required operands)
- ,@(unsyntax-sequence body))))
- |#
- (else (unsyntax-default)))
- (unsyntax-default)))))
- (else (unsyntax-default))))))
+(define (unsyntax-let-bindings names values)
+ (map unsyntax-let-binding names values))
+
+(define (unsyntax-let-binding name value)
+ `(,name ,@(unexpand-binding-value value)))\f
+(define (unsyntax-ERROR-COMBINATION-object combination)
+ (unsyntax-error-like-form (combination-operands combination) 'ERROR))
-\f
(define (unsyntax-error-like-form operands name)
(cons* name
(unsyntax-object (first operands))
`(,(unsyntax-object operand))))))
(else
`(,(unsyntax-object operand)))))))
-
-(define (unsyntax-shallow-FLUID-LET names values body)
+\f
+(define (unsyntax/fluid-let names values body if-malformed)
(combination-components body
(lambda (operator operands)
- `(FLUID-LET ,(unsyntax-let-bindings
- (map extract-transfer-var
- (sequence-actions (lambda-body (car operands))))
- (let every-other ((values values))
- (if (null? values)
- '()
- (cons (car values) (every-other (cddr values))))))
- ,@(lambda-components** (cadr operands)
- (lambda (name required optional rest body)
- (unsyntax-sequence body)))))))
+ (cond ((or (absolute-reference-to? operator 'DYNAMIC-WIND)
+ (and (variable? operator)
+ (eq? (variable-name operator) 'DYNAMIC-WIND)))
+ (unsyntax/fluid-let/shallow names values operands))
+ ((and (eq? operator (ucode-primitive with-saved-fluid-bindings 1))
+ (null? names)
+ (null? values)
+ (not (null? operands))
+ (null? (cdr operands)))
+ (unsyntax/fluid-let/deep (car operands)))
+ (else
+ (if-malformed))))))
+
+(define (unsyntax/fluid-let/shallow names values operands)
+ names
+ `(FLUID-LET ,(unsyntax-let-bindings
+ (map extract-transfer-var
+ (sequence-actions (lambda-body (car operands))))
+ (let every-other ((values values))
+ (if (null? values)
+ '()
+ (cons (car values) (every-other (cddr values))))))
+ ,@(lambda-components** (cadr operands)
+ (lambda (name required optional rest body)
+ name required optional rest
+ (unsyntax-sequence body)))))
(define (extract-transfer-var assignment)
(assignment-components assignment
(lambda (name value)
+ name
(cond ((assignment? value)
- (assignment-components value (lambda (name value) name)))
+ (assignment-components value (lambda (name value) value name)))
((combination? value)
(combination-components value
(lambda (operator operands)
`(ACCESS ,(cadr operands)
,@(unexpand-access (car operands))))
(else
- (error "FLUID-LET: Unknown SCODE form" assignment))))))
+ (unsyntax-error 'FLUID-LET
+ "Unknown SCODE form"
+ assignment))))))
(else
- (error "FLUID-LET: Unknown SCODE form" assignment))))))
-\f
-(define ((unsyntax-deep-or-common-FLUID-LET name prim)
- ignored-required ignored-operands body)
- (define (sequence->list seq)
- (if (sequence? seq)
- (sequence-actions seq)
- (list seq)))
- (define (unsyntax-fluid-bindings l)
- (define (unsyntax-fluid-assignment combi)
- (let ((operands (combination-operands combi)))
- (let ((env (first operands))
- (name (second operands))
- (val (third operands)))
- (cond ((symbol? name)
- `((ACCESS ,name ,(unsyntax-object env))
- ,(unsyntax-object val)))
- ((quotation? name)
- (let ((var (quotation-expression name)))
- (if (variable? var)
- `(,(variable-name var) ,(unsyntax-object val))
- (error "FLUID-LET unsyntax: unexpected name" name))))
- (else
- (error "FLUID-LET unsyntax: unexpected name" name))))))
- (let ((first (car l)))
- (if (and (combination? first)
- (eq? (combination-operator first) prim))
- (let ((remainder (unsyntax-fluid-bindings (cdr l))))
- (cons
- (cons (unsyntax-fluid-assignment first) (car remainder))
- (cdr remainder)))
- (cons '() (unsyntax-objects l)))))
-
- (let* ((thunk (car (combination-operands body)))
- (real-body (lambda-body thunk))
- (seq-list (sequence->list real-body))
- (fluid-binding-list (unsyntax-fluid-bindings seq-list)))
- `(,name ,(car fluid-binding-list) ,@(cdr fluid-binding-list))))
-
-(define unsyntax-deep-FLUID-LET
- (unsyntax-deep-or-common-FLUID-LET
- 'FLUID-LET (make-primitive-procedure 'add-fluid-binding! 3)))
-
-(define unsyntax-common-lisp-FLUID-LET
- (unsyntax-deep-or-common-FLUID-LET
- 'FLUID-BIND (make-primitive-procedure 'make-fluid-binding! 3)))
-
-(define (unsyntax-MAKE-ENVIRONMENT names values body)
- `(MAKE-ENVIRONMENT ,@(except-last-pair (unsyntax-sequence body))))
-
-(define (unsyntax-let-bindings names values)
- (map unsyntax-let-binding names values))
-
-(define (unsyntax-let-binding name value)
- `(,name ,@(unexpand-binding-value value)))
+ (unsyntax-error 'FLUID-LET "Unknown SCODE form" assignment))))))
\f
-;;;; Unsyntax Tables
-
-(define unsyntax-table-tag
- '(UNSYNTAX-TABLE))
-
-(set! make-unsyntax-table
- (named-lambda (make-unsyntax-table alist)
- (cons unsyntax-table-tag
- (make-type-dispatcher alist identity-procedure))))
-
-(set! unsyntax-table?
- (named-lambda (unsyntax-table? object)
- (and (pair? object)
- (eq? (car object) unsyntax-table-tag))))
-
-(set! current-unsyntax-table
- (named-lambda (current-unsyntax-table)
- *unsyntax-table))
-
-(set! set-current-unsyntax-table!
- (named-lambda (set-current-unsyntax-table! table)
- (if (not (unsyntax-table? table))
- (error "Not an unsyntax table" 'SET-CURRENT-UNSYNTAX-TABLE! table))
- (set-table! table)))
-
-(set! with-unsyntax-table
- (named-lambda (with-unsyntax-table table thunk)
- (define old-table)
- (if (not (unsyntax-table? table))
- (error "Not an unsyntax table" 'WITH-UNSYNTAX-TABLE table))
- (dynamic-wind (lambda ()
- (set! old-table (set-table! table)))
- thunk
- (lambda ()
- (set! table (set-table! old-table))))))
-
-(define unsyntax-dispatcher)
-(define *unsyntax-table)
-
-(define (set-table! table)
- (set! unsyntax-dispatcher (cdr table))
- (set! *unsyntax-table table))
-\f
-;;;; Default Unsyntax Table
-
-(set-table!
- (make-unsyntax-table
- `((,(microcode-type-object 'LIST) ,unsyntax-constant)
- (,symbol-type ,unsyntax-constant)
- (,variable-type ,unsyntax-VARIABLE-object)
- (,unbound?-type ,unsyntax-UNBOUND?-object)
- (,unassigned?-type ,unsyntax-UNASSIGNED?-object)
- (,combination-type ,unsyntax-COMBINATION-object)
- (,quotation-type ,unsyntax-QUOTATION)
- (,access-type ,unsyntax-ACCESS-object)
- (,definition-type ,unsyntax-DEFINITION-object)
- (,assignment-type ,unsyntax-ASSIGNMENT-object)
- (,conditional-type ,unsyntax-CONDITIONAL-object)
- (,disjunction-type ,unsyntax-DISJUNCTION-object)
- (,comment-type ,unsyntax-COMMENT-object)
- (,declaration-type ,unsyntax-DECLARATION-object)
- (,sequence-type ,unsyntax-SEQUENCE-object)
- (,open-block-type ,unsyntax-OPEN-BLOCK-object)
- (,delay-type ,unsyntax-DELAY-object)
- (,in-package-type ,unsyntax-IN-PACKAGE-object)
- (,the-environment-type ,unsyntax-THE-ENVIRONMENT-object)
- (,lambda-type ,unsyntax-LAMBDA-object))))
-
-;;; end UNSYNTAXER-PACKAGE
-))
\ No newline at end of file
+(define (unsyntax/fluid-let/deep expression)
+ (let ((body (lambda-body expression)))
+ (let loop
+ ((actions (sequence-actions body))
+ (receiver
+ (lambda (bindings body)
+ `(FLUID-LET ,bindings ,@body))))
+ (let ((action (car actions)))
+ (if (and (combination? action)
+ (or (eq? (combination-operator action)
+ (ucode-primitive add-fluid-binding! 3))
+ (eq? (combination-operator action)
+ (ucode-primitive make-fluid-binding! 3))))
+ (loop (cdr actions)
+ (lambda (bindings body)
+ (receiver (cons (unsyntax-fluid-assignment action) bindings)
+ body)))
+ (receiver '() (unsyntax-objects actions)))))))
+
+(define (unsyntax-fluid-assignment combination)
+ (let ((operands (combination-operands combination)))
+ (let ((environment (car operands))
+ (name (cadr operands))
+ (value (caddr operands)))
+ (cond ((symbol? name)
+ `((ACCESS ,name ,(unsyntax-object environment))
+ ,(unsyntax-object value)))
+ ((quotation? name)
+ (let ((variable (quotation-expression name)))
+ (if (variable? variable)
+ `(,(variable-name variable) ,(unsyntax-object value))
+ (unsyntax-error 'FLUID-LET "unexpected name" name))))
+ (else
+ (unsyntax-error 'FLUID-LET "unexpected name" name))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxdir.scm,v 14.1 1988/06/13 10:49:56 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxdir.scm,v 14.2 1988/06/13 11:59:36 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Directory Operations -- unix
-;;; package: (directory)
+;;; package: (runtime directory)
(declare (usual-integrations))
\f
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 1.8 1987/11/24 22:27:04 jrm Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
-;;;; Unix pathname parsing and unparsing.
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 14.1 1988/06/13 11:59:45 cph Exp $
-(declare (usual-integrations))
-
-;;; A note about parsing of filename strings: the standard syntax for
-;;; a filename string is "<name>.<version>.<type>". Since the Unix
-;;; file system treats "." just like any other character, it is
-;;; possible to give files strange names like "foo.bar.baz.mum". In
-;;; this case, the resulting name would be "foo.bar.baz", and the
-;;; resulting type would be "mum". In general, degenerate filenames
-;;; (including names with non-numeric versions) are parsed such that
-;;; the characters following the final "." become the type, while the
-;;; characters preceding the final "." become the name.
-\f
-;;;; Parse
-
-(define (symbol->pathname symbol)
- (string->pathname (string-downcase (symbol->string symbol))))
-
-(define parse-pathname)
-(define pathname-as-directory)
-(define home-directory-pathname)
-(let ()
+Copyright (c) 1988 Massachusetts Institute of Technology
-(set! parse-pathname
- (named-lambda (parse-pathname string receiver)
- (let ((end (string-length string)))
- (parse-device string 0 end
- (lambda (device start)
- (let ((components
- (let ((components
- (substring-components string start end #\/)))
- (append (expand-directory-prefixes (car components))
- (cdr components)))))
- (parse-name (car (last-pair components))
- (lambda (name type version)
- (receiver device
- (parse-directory-components
- (except-last-pair components))
- name type version)))))))))
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
-(define (parse-directory-components components)
- (if (null? components)
- '()
- (cons (if (string-null? (car components))
- 'ROOT
- (parse-directory-component (car components)))
- (map parse-directory-component (cdr components)))))
+1. Any copy made of this software must include this copyright notice
+in full.
-(set! pathname-as-directory
- (named-lambda (pathname-as-directory pathname)
- (make-pathname
- (pathname-device pathname)
- (let ((directory (pathname-directory pathname)))
- (let ((file (pathname-unparse-name (pathname-name pathname)
- (pathname-type pathname)
- (pathname-version pathname))))
- (if (string-null? file)
- directory
- (let ((file-components (list (parse-directory-component file))))
- (cond ((or (null? directory) (eq? directory 'UNSPECIFIC))
- file-components)
- ((pair? directory)
- (append directory file-components))
- (else (error "Illegal pathname directory" directory)))))))
- false false false)))
-\f
-(define (parse-device string start end receiver)
- (let ((index (substring-find-next-char string start end #\:)))
- (if index
- (receiver (substring string start index) (1+ index))
- (receiver false start))))
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
-(define (parse-directory-component component)
- (cond ((string=? "*" component) 'WILD)
- ((string=? "." component) 'SELF)
- ((string=? ".." component) 'UP)
- (else component)))
+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.
-(define (expand-directory-prefixes string)
- (if (string-null? string)
- (list string)
- (case (string-ref string 0)
- ((#\$)
- (string-components
- (get-environment-variable
- (substring string 1 (string-length string)))
- #\/))
- ((#\~)
- (let ((user-name (substring string 1 (string-length string))))
- (string-components
- (if (string-null? user-name)
- (get-environment-variable "HOME")
- (get-user-home-directory user-name))
- #\/)))
- (else (list string)))))
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
-(set! home-directory-pathname
- (lambda ()
- (pathname-as-directory
- (string->pathname (get-environment-variable "HOME")))))
+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 without prior written consent from
+MIT in each case. |#
-(define get-environment-variable
- (let ((primitive (make-primitive-procedure 'GET-ENVIRONMENT-VARIABLE)))
- (lambda (name)
- (or (primitive name)
- (error "GET-ENVIRONMENT-VARIABLE: Unbound name" name)))))
-
-(define get-user-home-directory
- (let ((primitive (make-primitive-procedure 'GET-USER-HOME-DIRECTORY)))
- (lambda (user-name)
- (or (primitive user-name)
- (error "User has no home directory" user-name)))))
-\f
-(define (parse-name string receiver)
- (let ((start 0)
- (end (string-length string)))
- (define (find-next-dot start)
- (substring-find-next-char string start end #\.))
-
- (define (find-previous-dot start)
- (substring-find-previous-char string start end #\.))
-
- (define (parse-version start)
- (cond ((= start end) "")
- ((substring=? string start end "*" 0 1) 'WILD)
- ((substring-find-next-char string start end #\*)
- (substring string start end))
- (else
- (let ((n (digits->number (reverse! (substring->list string start
- end))
- 1 0)))
- (if (and n (>= n 0))
- (if (= n 0) 'NEWEST n)
- (substring string start end))))))
-
- (if (= start end)
- (receiver false false false)
- (let ((index (find-next-dot start)))
- (if index
- (let ((start* (1+ index))
- (name (wildify string start index)))
- (if (= start* end)
- (receiver name "" false)
- (or (let ((index (find-next-dot start*)))
- (and index
- (let ((version (parse-version (1+ index))))
- (and (not (string? version))
- (receiver name
- (wildify string start* index)
- version)))))
- (let ((index (find-previous-dot start)))
- (receiver (wildify string start index)
- (wildify string (1+ index) end)
- false)))))
- (receiver (wildify string start end) false false))))))
-\f
-(define (wildify string start end)
- (if (substring=? string start end "*" 0 1)
- 'WILD
- (substring string start end)))
-
-(define (string-components string delimiter)
- (substring-components string 0 (string-length string) delimiter))
-
-(define (substring-components string start end delimiter)
- (define (loop start)
- (let ((index (substring-find-next-char string start end delimiter)))
- (if index
- (cons (substring string start index)
- (loop (1+ index)))
- (list (substring string start end)))))
- (loop start))
-
-(define (digits->number digits weight accumulator)
- (if (null? digits)
- accumulator
- (let ((value (char->digit (car digits) 10)))
- (and value
- (digits->number (cdr digits)
- (* weight 10)
- (+ (* weight value) accumulator))))))
-
-;;; end LET.
-)
-\f
-;;;; Unparse
+;;;; Miscellaneous Pathnames -- Unix
+;;; package: ()
-(define pathname-unparse)
-(define pathname-unparse-name)
-(let ()
-
-(set! pathname-unparse
- (named-lambda (pathname-unparse device directory name type version)
- (string-append (let ((device-string (unparse-component device)))
- (if device-string
- (string-append device-string ":")
- ""))
- (unparse-directory directory)
- (pathname-unparse-name name type version))))
-
-(define (unparse-directory directory)
- (define (loop directory)
- (if (null? directory)
- ""
- (string-append (unparse-directory-component (car directory))
- "/"
- (loop (cdr directory)))))
- (cond ((null? directory) "")
- ((pair? directory)
- (string-append (if (eq? (car directory) 'ROOT)
- ""
- (unparse-directory-component (car directory)))
- "/"
- (loop (cdr directory))))
- (else (error "Illegal pathname directory" directory))))
-
-(define (unparse-directory-component component)
- (cond ((eq? component 'WILD) "*")
- ((eq? component 'SELF) ".")
- ((eq? component 'UP) "..")
- ((string? component) component)
- (else (error "Illegal pathname directory component" component))))
-\f
-(set! pathname-unparse-name
- (named-lambda (pathname-unparse-name name type version)
- (let ((name (unparse-component name))
- (type (unparse-component type))
- (version (unparse-version version)))
- (cond ((not name) "")
- ((not type) name)
- ((not version) (string-append name "." type))
- (else (string-append name "." type "." version))))))
-
-(define (unparse-component component)
- (cond ((or (not component) (string? component)) component)
- ((eq? component 'UNSPECIFIC) false)
- ((eq? component 'WILD) "*")
- (else (error "Illegal pathname component" component))))
-
-(define (unparse-version version)
- (cond ((or (not version) (string? version)) version)
- ((eq? version 'UNSPECIFIC) false)
- ((eq? version 'WILD) "*")
- ((eq? version 'NEWEST) "0")
- ((and (integer? version) (> version 0))
- (list->string (number->digits version '())))
- (else (error "Illegal pathname version" version))))
-
-(define (number->digits number accumulator)
- (if (zero? number)
- accumulator
- (let ((qr (integer-divide number 10)))
- (number->digits (integer-divide-quotient qr)
- (cons (digit->char (integer-divide-remainder qr))
- accumulator)))))
-
-;;; end LET.
-)
+(declare (usual-integrations))
\f
-;;;; Working Directory
-
-(define working-directory-pathname)
-(define set-working-directory-pathname!)
-
-(define working-directory-package
- (make-environment
-
-(define primitive
- (make-primitive-procedure 'WORKING-DIRECTORY-PATHNAME))
-
-(define pathname)
-
-(define (reset!)
- (set! pathname
- (string->pathname
- (let ((string (primitive)))
- (let ((length (string-length string)))
- (if (or (zero? length)
- (not (char=? #\/ (string-ref string (-1+ length)))))
- (string-append string "/")
- string))))))
-
-(set! working-directory-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))
+(define (symbol->pathname symbol)
+ (string->pathname (string-downcase (symbol->string symbol))))
-;;; end WORKING-DIRECTORY-PACKAGE
-))
+(define (home-directory-pathname)
+ (pathname-as-directory (string->pathname (get-environment-variable "HOME"))))
-(define init-file-pathname
+(define (init-file-pathname)
(string->pathname ".scheme.init"))
(define pathname-newest
- false)
\ No newline at end of file
+ false)
+
+(define (file-directory? filename)
+ (let ((truename (pathname->input-truename (->pathname filename))))
+ (and truename
+ ((ucode-primitive file-directory?) (pathname->string truename)))))
+
+(define (file-symbolic-link? filename)
+ (let ((truename (pathname->input-truename (->pathname filename))))
+ (and truename
+ ((ucode-primitive file-symlink?) (pathname->string truename)))))
+
+(define (file-attributes filename)
+ (let ((truename (pathname->input-truename (->pathname filename))))
+ (and truename
+ ((ucode-primitive file-attributes) (pathname->string truename)))))
+
+(define (file-modification-time filename)
+ (let ((attributes (file-attributes filename)))
+ (and attributes
+ (vector-ref attributes 5))))
+
+(define (get-environment-variable name)
+ (or ((ucode-primitive get-environment-variable) name)
+ (error "GET-ENVIRONMENT-VARIABLE: Unbound name" name)))
+
+(define (get-user-home-directory user-name)
+ (or ((ucode-primitive get-user-home-directory) user-name)
+ (error "User has no home directory" user-name)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/urtrap.scm,v 14.1 1988/05/20 01:06:12 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/urtrap.scm,v 14.2 1988/06/13 11:59:56 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Reference Traps
-;;; package: reference-trap-package
+;;; package: (runtime reference-trap)
(declare (usual-integrations))
\f
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/utabs.scm,v 13.48 1988/03/14 16:37:15 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Microcode Table Interface
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/utabs.scm,v 14.1 1988/06/13 12:00:01 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
+
+;;;; Microcode Name <-> Code Maps
+;;; package: (runtime microcode-tables)
(declare (usual-integrations))
\f
-(define fixed-objects-vector-slot)
-
-(define number-of-microcode-types)
-(define microcode-type-name)
-(define microcode-type)
-(define microcode-type-predicate)
-(define object-type)
-
-(define number-of-microcode-returns)
-(define microcode-return)
-(define make-return-address)
-(define return-address?)
-(define return-address-code)
-(define return-address-name)
-
-(define number-of-microcode-errors)
-(define microcode-error)
-
-(define number-of-microcode-terminations)
-(define microcode-termination)
-(define microcode-termination-name)
-
-(define make-primitive-procedure)
-(define primitive-procedure?)
-(define primitive-procedure-name)
-(define implemented-primitive-procedure?)
-
-(define microcode-identification-item)
-
-(define future?)
-
-(define microcode-system
- (make-environment
-
-(define :name "Microcode")
-(define :version)
-(define :modification)
-(define :identification)
-(define :release)
-
-(let-syntax ((define-primitive
- (macro (name arity)
- `(DEFINE ,name ,(make-primitive-procedure name arity)))))
- (define-primitive binary-fasload 1)
- (define-primitive microcode-identify 0)
- (define-primitive microcode-tables-filename 0)
- (define-primitive map-machine-address-to-code 2)
- (define-primitive map-code-to-machine-address 2)
- (define-primitive get-primitive-address 2)
- (define-primitive get-primitive-name 1)
- (define-primitive get-primitive-counts 0))
+(define (initialize-package!)
+ (read-microcode-tables!)
+ (add-event-receiver! event:after-restore read-microcode-tables!))
+
+(define (read-microcode-tables!)
+ (set! microcode-tables-identification
+ (scode-eval ((ucode-primitive binary-fasload)
+ ((ucode-primitive microcode-tables-filename)))
+ system-global-environment))
+ (set! identification-vector ((ucode-primitive microcode-identify)))
+ (set! errors-slot (fixed-object/name->code 'MICROCODE-ERRORS-VECTOR))
+ (set! identifications-slot
+ (fixed-object/name->code 'MICROCODE-IDENTIFICATION-VECTOR))
+ (set! returns-slot (fixed-object/name->code 'MICROCODE-RETURNS-VECTOR))
+ (set! terminations-slot
+ (fixed-object/name->code 'MICROCODE-TERMINATIONS-VECTOR))
+ (set! types-slot (fixed-object/name->code 'MICROCODE-TYPES-VECTOR))
+ (set! non-object-slot (fixed-object/name->code 'NON-OBJECT))
+ (set! microcode-id/version
+ (microcode-identification-item 'MICROCODE-VERSION))
+ (set! microcode-id/modification
+ (microcode-identification-item 'MICROCODE-MODIFICATION))
+ (set! microcode-id/release-string
+ (microcode-identification-item 'SYSTEM-RELEASE-STRING))
+ (set! char:newline (microcode-identification-item 'NEWLINE-CHAR))
+ (set! microcode-id/tty-x-size (microcode-identification-item 'CONSOLE-WIDTH))
+ (set! microcode-id/tty-y-size
+ (microcode-identification-item 'CONSOLE-HEIGHT))
+ (set! microcode-id/floating-mantissa-bits
+ (microcode-identification-item 'FLONUM-MANTISSA-LENGTH))
+ (set! microcode-id/floating-exponent-bits
+ (microcode-identification-item 'FLONUM-EXPONENT-LENGTH)) (set! microcode-id/operating-system-name
+ (microcode-identification-item 'OS-NAME-STRING))
+ (set! microcode-id/operating-system-variant
+ (microcode-identification-item 'OS-VARIANT-STRING))
+ (set! microcode-id/stack-type
+ (let ((string (microcode-identification-item 'STACK-TYPE-STRING)))
+ (cond ((string? string) (intern string))
+ ((not string) 'STANDARD)
+ (else (error "illegal stack type" string))))))
+
+(define microcode-tables-identification)
+(define microcode-id/version)
+(define microcode-id/modification)
+(define microcode-id/release-string)
+(define char:newline)
+(define microcode-id/tty-x-size)
+(define microcode-id/tty-y-size)
+(define microcode-id/floating-mantissa-bits)
+(define microcode-id/floating-exponent-bits)(define microcode-id/operating-system-name)
+(define microcode-id/operating-system-variant)
+(define microcode-id/stack-type)
\f
-;;;; Fixed Objects Vector
+(define-integrable fixed-objects-slot 15)
+(define non-object-slot)
+
+(define (fixed-object/name->code name)
+ (microcode-table-search fixed-objects-slot name))
-(set! fixed-objects-vector-slot
-(named-lambda (fixed-objects-vector-slot name)
- (or (microcode-table-search 15 name)
- (error "FIXED-OBJECTS-VECTOR-SLOT: Unknown name" name))))
+(define (fixed-object/code->name code)
+ (microcode-table-ref fixed-objects-slot code))
-(define fixed-objects)
+(define (fixed-object/code-limit)
+ (vector-length (vector-ref (get-fixed-objects-vector) fixed-objects-slot)))
+
+(define (fixed-objects-vector-slot name)
+ (or (fixed-object/name->code name)
+ (error "FIXED-OBJECTS-VECTOR-SLOT: Unknown name" name)))
+
+(define (fixed-objects-item name)
+ (vector-ref (get-fixed-objects-vector) (fixed-objects-vector-slot name)))
+
+(define (microcode-object/unassigned)
+ (vector-ref (get-fixed-objects-vector) non-object-slot))
(define (microcode-table-search slot name)
- (let ((vector (vector-ref fixed-objects slot)))
+ (let ((vector (vector-ref (get-fixed-objects-vector) slot)))
(let ((end (vector-length vector)))
(define (loop i)
(and (not (= i end))
(loop 0))))
(define (microcode-table-ref slot index)
- (let ((vector (vector-ref fixed-objects slot)))
+ (let ((vector (vector-ref (get-fixed-objects-vector) slot)))
(and (< index (vector-length vector))
(let ((entry (vector-ref vector index)))
(if (pair? entry)
(car entry)
entry)))))
\f
-;;;; Microcode Type Codes
-
-(define types-slot)
-
-(define renamed-user-object-types
- '((FIXNUM . NUMBER)
- (BIGNUM . NUMBER)
- (FLONUM . NUMBER)
- (COMPLEX . NUMBER)
- (INTERNED-SYMBOL . SYMBOL)
- (UNINTERNED-SYMBOL . SYMBOL)
- (EXTENDED-PROCEDURE . PROCEDURE)
- (PRIMITIVE . PRIMITIVE-PROCEDURE)
- (LEXPR . LAMBDA)
- (EXTENDED-LAMBDA . LAMBDA)
- (COMBINATION-1 . COMBINATION)
- (COMBINATION-2 . COMBINATION)
- (PRIMITIVE-COMBINATION-0 . COMBINATION)
- (PRIMITIVE-COMBINATION-1 . COMBINATION)
- (PRIMITIVE-COMBINATION-2 . COMBINATION)
- (PRIMITIVE-COMBINATION-3 . COMBINATION)
- (SEQUENCE-2 . SEQUENCE)
- (SEQUENCE-3 . SEQUENCE)))
-
-(set! microcode-type-name
-(named-lambda (microcode-type-name type)
- (microcode-table-ref types-slot type)))
-
-(set! microcode-type
-(named-lambda (microcode-type name)
- (or (microcode-table-search types-slot name)
- (error "MICROCODE-TYPE: Unknown name" name))))
-
-(set! microcode-type-predicate
-(named-lambda (microcode-type-predicate name)
- (type-predicate (microcode-type name))))
-
-(define ((type-predicate type) object)
- (primitive-type? type object))
-
-(set! object-type
-(named-lambda (object-type object)
- (let ((type (microcode-type-name (primitive-type object))))
- (let ((entry (assq type renamed-user-object-types)))
- (if (not (null? entry))
- (cdr entry)
- type)))))
-\f
-;;;; Microcode Return Codes
-
(define returns-slot)
-(define return-address-type)
-
-(set! microcode-return
-(named-lambda (microcode-return name)
- (microcode-table-search returns-slot name)))
-
-(set! make-return-address
-(named-lambda (make-return-address code)
- (map-code-to-machine-address return-address-type code)))
-(set! return-address?
-(named-lambda (return-address? object)
- (primitive-type? return-address-type object)))
+(define (microcode-return/name->code name)
+ (microcode-table-search returns-slot name))
-(set! return-address-code
-(named-lambda (return-address-code return-address)
- (map-machine-address-to-code return-address-type return-address)))
+(define (microcode-return/code->name code)
+ (microcode-table-ref returns-slot code))
-(set! return-address-name
-(named-lambda (return-address-name return-address)
- (microcode-table-ref returns-slot (return-address-code return-address))))
-
-;;;; Microcode Error Codes
+(define (microcode-return/code-limit)
+ (vector-length (vector-ref (get-fixed-objects-vector) returns-slot)))
(define errors-slot)
-(set! microcode-error
-(named-lambda (microcode-error name)
- (microcode-table-search errors-slot name)))
+(define (microcode-error/name->code name)
+ (microcode-table-search errors-slot name))
-;;;; Microcode Termination Codes
+(define (microcode-error/code->name code)
+ (microcode-table-ref errors-slot code))
-(define termination-vector-slot)
+(define (microcode-error/code-limit)
+ (vector-length (vector-ref (get-fixed-objects-vector) errors-slot)))
-(set! microcode-termination
-(named-lambda (microcode-termination name)
- (microcode-table-search termination-vector-slot name)))
+(define terminations-slot)
-(set! microcode-termination-name
-(named-lambda (microcode-termination-name type)
- (code->name termination-vector-slot type)))
+(define (microcode-termination/name->code name)
+ (microcode-table-search terminations-slot name))
-(define identification-vector-slot)
+(define (microcode-termination/code->name code)
+ (microcode-table-ref terminations-slot code))
-(set! microcode-identification-item
- (lambda (name)
- (vector-ref :identification
- (or (microcode-table-search identification-vector-slot name)
- (error "Unknown identification item" name)))))
-\f
-;;;; Microcode Primitives
-
-(define primitive-type-code)
-
-(define renamed-user-primitives
- '((NOT . NULL?)
- (FALSE? . NULL?)
- (FIRST . CAR)
- (FIRST-TAIL . CDR)
- (SET-FIRST! . SET-CAR!)
- (SET-FIRST-TAIL! . SET-CDR!)
- (VECTOR-SIZE . VECTOR-LENGTH)
- (STRING-SIZE . VECTOR-8B-SIZE)
- (&OBJECT-REF . SYSTEM-MEMORY-REF)
- (&OBJECT-SET! . SYSTEM-MEMORY-SET!)))
-
-(set! primitive-procedure?
-(named-lambda (primitive-procedure? object)
- (primitive-type? primitive-type-code object)))
-
-(set! make-primitive-procedure
-(named-lambda (make-primitive-procedure name #!optional arity)
- (if (unassigned? arity)
- (set! arity false))
- (let* ((name (let ((place (assq name renamed-user-primitives)))
- (if (not (null? place))
- (cdr place)
- name)))
- (result (get-primitive-address name arity)))
- (cond ((or (primitive-type? primitive-type-code result)
- (eq? arity true))
- result)
- ((false? result)
- (error "MAKE-PRIMITIVE-PROCEDURE: Unknown name" name))
- (else
- (error "MAKE-PRIMITIVE-PROCEDURE: Inconsistent arity"
- `(,name new: ,arity old: ,result)))))))
-
-(set! implemented-primitive-procedure?
-(named-lambda (implemented-primitive-procedure? object)
- (if (primitive-type? primitive-type-code object)
- (get-primitive-address (get-primitive-name (primitive-datum object))
- false)
- (error "Not a primitive procedure" implemented-primitive-procedure?
- object))))
-
-(set! primitive-procedure-name
-(named-lambda (primitive-procedure-name primitive-procedure)
- (if (primitive-type? primitive-type-code primitive-procedure)
- (get-primitive-name (primitive-datum primitive-procedure))
- (error "Not a primitive procedure" primitive-procedure-name
- primitive-procedure))))
-\f
-(define (name->code slot type name)
- (or (and (pair? name)
- (eq? (car name) type)
- (pair? (cdr name))
- (let ((x (cdr name)))
- (and (integer? (car x))
- (not (negative? (car x)))
- (null? (cdr x))
- (car x))))
- (microcode-table-search slot name)))
-
-(define (code->name slot type code)
- (or (and (not (negative? code))
- (microcode-table-ref slot code))
- (list type code)))
-\f
-;;;; Initialization
+(define (microcode-termination/code-limit)
+ (vector-length (vector-ref (get-fixed-objects-vector) terminations-slot)))
-(define microcode-tables-identification)
-
-(define (snarf-version)
- (set! :identification (microcode-identify))
-
- (set! microcode-tables-identification
- (scode-eval (binary-fasload (microcode-tables-filename))
- system-global-environment))
-
- (set! fixed-objects (get-fixed-objects-vector))
-
- (set! types-slot (fixed-objects-vector-slot 'MICROCODE-TYPES-VECTOR))
- (set! number-of-microcode-types
- (vector-length (vector-ref fixed-objects types-slot)))
-
- (set! returns-slot (fixed-objects-vector-slot 'MICROCODE-RETURNS-VECTOR))
- (set! return-address-type (microcode-type 'RETURN-ADDRESS))
- (set! number-of-microcode-returns
- (vector-length (vector-ref fixed-objects returns-slot)))
-
- (set! errors-slot (fixed-objects-vector-slot 'MICROCODE-ERRORS-VECTOR))
- (set! number-of-microcode-errors
- (vector-length (vector-ref fixed-objects errors-slot)))
+(define types-slot)
- (set! primitive-type-code (microcode-type 'PRIMITIVE))
+(define (microcode-type/name->code name)
+ (microcode-table-search types-slot name))
- (set! termination-vector-slot
- (fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-VECTOR))
- (set! number-of-microcode-terminations
- (vector-length (vector-ref fixed-objects termination-vector-slot)))
+(define (microcode-type/code->name code)
+ (microcode-table-ref types-slot code))
- (set! identification-vector-slot
- (fixed-objects-vector-slot 'MICROCODE-IDENTIFICATION-VECTOR))
- (set! :release (microcode-identification-item 'SYSTEM-RELEASE-STRING))
- (set! :version (microcode-identification-item 'MICROCODE-VERSION))
- (set! :modification (microcode-identification-item 'MICROCODE-MODIFICATION))
+(define (microcode-type/code-limit)
+ (vector-length (vector-ref (get-fixed-objects-vector) types-slot)))
- ;; Predicate to test if object is a future without touching it.
- (set! future?
- (let ((primitive (make-primitive-procedure 'FUTURE? 1)))
- (if (implemented-primitive-procedure? primitive)
- primitive
- (lambda (object) false)))))
+(define identifications-slot)
+(define identification-vector)
-(snarf-version)
+(define (microcode-identification-vector-slot name)
+ (or (microcode-table-search identifications-slot name)
+ (error "Unknown microcode identification item" name)))
-;;; end MICROCODE-SYSTEM.
-))
\ No newline at end of file
+(define (microcode-identification-item name)
+ (vector-ref identification-vector
+ (microcode-identification-vector-slot name)))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/vector.scm,v 13.45 1987/12/23 04:17:16 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/vector.scm,v 14.1 1988/06/13 12:00:13 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Operations on Vectors
+;;; package: ()
(declare (usual-integrations))
\f
;;; Standard Procedures
-(let-syntax ()
- (define-macro (define-primitives . names)
- `(BEGIN ,@(map (lambda (name)
- `(LOCAL-ASSIGNMENT
- system-global-environment
- ',name ,(make-primitive-procedure name)))
- names)))
- (define-primitives
- vector-length vector-ref vector-set!
- list->vector vector vector-cons subvector->list
- subvector-move-right! subvector-move-left! subvector-fill!))
-
-(let-syntax ()
- (define-macro (define-type-predicate name type-name)
- `(DEFINE (,name OBJECT)
- (PRIMITIVE-TYPE? ,(microcode-type type-name) OBJECT)))
- (define-type-predicate vector? vector))
+(define-primitives
+ vector-length vector-ref vector-set!
+ list->vector vector subvector->list
+ subvector-move-right! subvector-move-left! subvector-fill!)
+
+(define-integrable (vector? object)
+ (object-type? (ucode-type vector) object))
(define (make-vector size #!optional fill)
- (if (unassigned? fill) (set! fill false))
- (vector-cons size fill))
+ (if (default-object? fill) (set! fill false))
+ ((ucode-primitive vector-cons) size fill))
(define (vector->list vector)
(subvector->list vector 0 (vector-length vector)))
(define (vector-fill! vector value)
(subvector-fill! vector 0 (vector-length vector) value))
+
+(define (subvector vector start end)
+ (let ((result (make-vector (- end start))))
+ (subvector-move-right! vector start end result 0)
+ result))
+
+(define-integrable (vector-head vector end)
+ (subvector vector 0 end))
+
+(define (vector-tail vector start)
+ (subvector vector start (vector-length vector)))
\f#|
;;; Nonstandard Primitives
(let-syntax ((check-type
(let ((type (microcode-type 'VECTOR)))
(macro (object)
- `(IF (NOT (PRIMITIVE-TYPE? ,type ,object))
+ `(IF (NOT (OBJECT-TYPE? ,type ,object))
(ERROR "Wrong type argument" ,object)))))
(check-target
(macro (object index)
(subvector-move-right! vector 0 (vector-length vector) new-vector 0)
new-vector))
-(define (vector-first vector) (vector-ref vector 0))
-(define (vector-second vector) (vector-ref vector 1))
-(define (vector-third vector) (vector-ref vector 2))
-(define (vector-fourth vector) (vector-ref vector 3))
-(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))
\ No newline at end of file
+(define-integrable (vector-first vector) (vector-ref vector 0))
+(define-integrable (vector-second vector) (vector-ref vector 1))
+(define-integrable (vector-third vector) (vector-ref vector 2))
+(define-integrable (vector-fourth vector) (vector-ref vector 3))
+(define-integrable (vector-fifth vector) (vector-ref vector 4))
+(define-integrable (vector-sixth vector) (vector-ref vector 5))
+(define-integrable (vector-seventh vector) (vector-ref vector 6))
+(define-integrable (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/version.scm,v 14.1 1988/06/13 10:47:01 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.2 1988/06/13 12:00:18 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Runtime System Version Information
+;;; package: (runtime)
(declare (usual-integrations))
microcode-id/version
microcode-id/modification
'()))
-(add-system! (make-system "Runtime" 14 1 '()))
\ No newline at end of file
+(add-system! (make-system "Runtime" 14 2 '()))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 13.44 1988/01/02 14:21:45 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
-;;;; Environment Inspector
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 14.1 1988/06/13 12:00:44 cph Exp $
-(in-package debugger-package
+Copyright (c) 1988 Massachusetts Institute of Technology
-(declare (usual-integrations))
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
-(define env-package
- (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))
+1. Any copy made of this software must include this copyright notice
+in full.
-;;; Basic Commands
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
-(define-where-command #\? (standard-help-command env-commands)
- "Help, list command letters")
+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.
-(define-where-command #\Q standard-exit-command
- "Quit (exit from Where)")
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
-;;; Lexpr since it can take one or no arguments
+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 without prior written consent from
+MIT in each case. |#
-(define (where #!optional env-spec)
- (if (unassigned? env-spec) (set! env-spec (rep-environment)))
+;;;; Environment Inspector
+;;; package: (runtime environment-inspector)
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (set! command-set
+ (make-command-set
+ 'WHERE-COMMANDS
+ `((#\? ,standard-help-command
+ "Help, list command letters")
+ (#\Q ,standard-exit-command
+ "Quit (exit from Where)")
+ (#\C ,show
+ "Display the bindings in the current frame")
+ (#\A ,show-all
+ "Display the bindings of all the frames in the current chain")
+ (#\P ,parent
+ "Find the parent frame of the current one")
+ (#\S ,son
+ "Find the son of the current environment in the current chain")
+ (#\W ,recursive-where
+ "Eval an expression in the current frame and do WHERE on it")
+ (#\V ,show-object
+ "Eval expression in current frame")
+ (#\E ,enter
+ "Create a read-eval-print loop in the current environment")
+ (#\N ,name
+ "Name of procedure which created current environment")
+ ))))
+
+(define command-set)
+\f
+(define env)
+(define current-frame)
+(define current-frame-depth)
+
+(define (where #!optional environment)
(let ((environment
- (cond ((or (eq? env-spec system-global-environment)
- (environment? env-spec))
- env-spec)
- ((compound-procedure? env-spec)
- (procedure-environment env-spec))
- ((promise? env-spec)
- (promise-environment env-spec))
- (else
- (error "WHERE: Not a legal environment object" env-spec)))))
- (environment-warning-hook environment)
+ (if (default-object? environment)
+ (standard-repl-environment)
+ (->environment environment))))
+ (hook/repl-environment (nearest-repl) environment)
(fluid-let ((env environment)
(current-frame environment)
(current-frame-depth 0))
- (letter-commands env-commands
- (standard-rep-message "Environment Inspector")
+ (letter-commands command-set
+ (cmdl-message/standard "Environment Inspector")
"Where-->"))))
\f
;;;; Display Commands
(if (environment-has-parent? env)
(s1 (environment-parent env) (1+ depth))
*the-non-printing-object*)))))
-
-(define (show-frame frame depth)
- (if (eq? system-global-environment frame)
- (begin (newline)
- (write-string "This frame is the system global environment"))
- (begin (newline) (write-string "Frame created by ")
- (print-user-friendly-name frame)
- (if (>= depth 0)
- (begin (newline)
- (write-string "Depth (relative to starting frame): ")
- (write depth)))
- (newline)
- (let ((bindings (environment-bindings frame)))
- (if (null? bindings)
- (write-string "Has no bindings")
- (begin (write-string "Has bindings:")
- (newline)
- (for-each print-binding bindings))))))
- (newline))
-
-(define print-user-friendly-name
- (let ((rename-list
- `((,lambda-tag:unnamed . LAMBDA)
- (,(access internal-lambda-tag lambda-package) . LAMBDA)
- (,(access internal-lexpr-tag lambda-package) . LAMBDA)
- (,lambda-tag:let . LET)
- (,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-environment . MAKE-ENVIRONMENT))))
- (lambda (frame)
- (let ((name (environment-name frame)))
- (let ((rename (assq name rename-list)))
- (if rename
- (begin (write-string "a ")
- (write (cdr rename))
- (write-string " special form"))
- (begin (write-string "the procedure ")
- (write name))))))))
-\f
-(define (print-binding binding)
- (define line-width 79)
- (define name-width 40)
- (define (truncate str length)
- (set-string-length! str (- length 4))
- (string-append str " ..."))
- (newline)
- (let ((s (write-to-string (car binding) name-width)))
- (if (car s) ; Name was truncated
- (set! s (truncate (cdr s) name-width))
- (set! s (cdr s)))
- (if (null? (cdr binding))
- (set! s (string-append s " is unassigned"))
- (let ((s1 (write-to-string (cadr binding)
- (- line-width (string-length s)))))
- (set! s (string-append s " = " (cdr s1)));
- (if (car s1) ; Value truncated
- (set! s (truncate s line-width)))))
- (write-string s)))
-
-(define-where-command #\C show
- "Display the bindings in the current frame")
-
-(define-where-command #\A show-all
- "Display the bindings of all the frames in the current chain")
\f
;;;; Motion Commands
(let ((inp (prompt-for-expression "Object to eval and examine-> ")))
(write-string "New where!")
(debug/where (debug/eval inp current-frame))))
-
-(define-where-command #\P parent
- "Find the parent frame of the current one")
-
-(define-where-command #\S son
- "Find the son of the current environment in the current chain")
-
-(define-where-command #\W recursive-where
- "Eval an expression in the current frame and do WHERE on it")
\f
;;;; Relative Evaluation Commands
-(define (show-object)
- (let ((inp (prompt-for-expression "Object to eval and print-> ")))
- (newline)
- (write (debug/eval inp current-frame))
- (newline)))
-
(define (enter)
(debug/read-eval-print current-frame
"You are now in the desired environment"
"Eval-in-env-->"))
-(define-where-command #\V show-object
- "Eval an expression in the current frame and print the result")
-
-(define-where-command #\E enter
- "Create a read-eval-print loop in the current environment")
+(define (show-object)
+ (debug/read-eval-print-1 current-frame))
;;;; Miscellaneous Commands
(define (name)
(newline)
(write-string "This frame was created by ")
- (print-user-friendly-name current-frame))
-
-(define-where-command #\N name
- "Name of procedure which created current environment")
-
-;;; end ENV-PACKAGE.
-(the-environment)))
-
-(define print-user-friendly-name
- (access print-user-friendly-name env-package))
-
-;;; end IN-PACKAGE DEBUGGER-PACKAGE.
-)
-
-;;;; Exports
-
-(define where
- (access where env-package debugger-package))
\ No newline at end of file
+ (print-user-friendly-name current-frame))
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wind.scm,v 13.42 1987/02/15 15:46:23 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
-;;;; State Space Model
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wind.scm,v 14.1 1988/06/13 12:00:51 cph Exp $
-(declare (usual-integrations)
- (integrate-primitive-procedures set-fixed-objects-vector!))
-\f
-(vector-set! (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'STATE-SPACE-TAG)
- "State Space")
+Copyright (c) 1988 Massachusetts Institute of Technology
-(vector-set! (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'STATE-POINT-TAG)
- "State Point")
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
-(set-fixed-objects-vector! (get-fixed-objects-vector))
+1. Any copy made of this software must include this copyright notice
+in full.
-(define make-state-space
- (let ((prim (make-primitive-procedure 'MAKE-STATE-SPACE)))
- (named-lambda (make-state-space #!optional mutable?)
- (if (unassigned? mutable?) (set! mutable? #T))
- (prim mutable?))))
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
-(define execute-at-new-state-point
- (make-primitive-procedure 'EXECUTE-AT-NEW-STATE-POINT))
+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.
-(define translate-to-state-point
- (make-primitive-procedure 'TRANSLATE-TO-STATE-POINT))
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
-;;; The following code implements the current model of DYNAMIC-WIND as
-;;; a special case of the more general concept.
+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 without prior written consent from
+MIT in each case. |#
-(define system-state-space
- (make-state-space #F))
+;;;; State Space Model
+;;; package: (runtime state-space)
-(define current-dynamic-state
- (let ((prim (make-primitive-procedure 'current-dynamic-state)))
- (named-lambda (current-dynamic-state #!optional state-space)
- (prim (if (unassigned? state-space)
- system-state-space
- state-space)))))
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (let ((fixed-objects (get-fixed-objects-vector))
+ (state-space-tag "State Space")
+ (state-point-tag "State Point"))
+ (unparser/set-tagged-vector-method!
+ state-space-tag
+ (unparser/standard-method 'STATE-SPACE))
+ (unparser/set-tagged-vector-method!
+ state-point-tag
+ (unparser/standard-method 'STATE-POINT))
+ (vector-set! fixed-objects
+ (fixed-objects-vector-slot 'STATE-SPACE-TAG)
+ state-space-tag)
+ (vector-set! fixed-objects
+ (fixed-objects-vector-slot 'STATE-POINT-TAG)
+ state-point-tag)
+ (set! system-state-space (make-state-space false))
+ (vector-set! fixed-objects
+ (fixed-objects-vector-slot 'STATE-SPACE-ROOT)
+ (current-dynamic-state))
+ ((ucode-primitive set-fixed-objects-vector!) fixed-objects)))
-(define set-current-dynamic-state!
- (make-primitive-procedure 'set-current-dynamic-state!))
+(define-primitives
+ execute-at-new-state-point
+ translate-to-state-point
+ set-current-dynamic-state!
+ (get-fluid-bindings 0)
+ (set-fluid-bindings! 1))
-;; NOTICE that the "before" thunk is executed IN THE NEW STATE,
-;; the "after" thunk is executed IN THE OLD STATE. It is hard to
-;; imagine why anyone would care about this.
+(define (make-state-space #!optional mutable?)
+ ((ucode-primitive make-state-space)
+ (if (default-object? mutable?) true mutable?)))
-(define (dynamic-wind before during after)
- (execute-at-new-state-point system-state-space
- before
- during
- after))
+(define system-state-space)
-;; This is so the microcode can find the base state point.
+(define (current-dynamic-state #!optional state-space)
+ ((ucode-primitive current-dynamic-state)
+ (if (default-object? state-space) system-state-space state-space)))
-(let ((fov (get-fixed-objects-vector)))
- (vector-set! fov
- (fixed-objects-vector-slot 'STATE-SPACE-ROOT)
- (current-dynamic-state))
- (set-fixed-objects-vector! fov))
\ No newline at end of file
+;;; NOTE: the "before" thunk is executed IN THE NEW STATE, the "after"
+;;; thunk is executed IN THE OLD STATE. Your programs should not
+;;; depend on this if it can be avoided.
+(define (dynamic-wind before during after)
+ (execute-at-new-state-point system-state-space before during after))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wrkdir.scm,v 14.1 1988/06/13 10:50:01 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wrkdir.scm,v 14.2 1988/06/13 12:00:56 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Working Directory
-;;; package: (working-directory)
+;;; package: (runtime working-directory)
(declare (usual-integrations))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.1 1988/05/20 00:54:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/conpar.scm,v 14.2 1988/06/13 11:41:24 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Continuation Parser
-;;; package: continuation-parser-package
+;;; package: (runtime continuation-parser)
(declare (usual-integrations))
\f
(if (not (return-address? return-address))
(error "illegal return address" return-address))
(let ((code (return-address/code return-address)))
- (if (>= code (vector-length stack-frame-types))
- (error "return-code too large" code))
- (let ((type (vector-ref stack-frame-types code)))
+ (let ((type (microcode-return/code->type code)))
(if (not type)
(error "return-code has no type" code))
type))))
(parser false read-only true)
(unparser false read-only true))
+(define (microcode-return/code->type code)
+ (if (not (< code (vector-length stack-frame-types)))
+ (error "return-code too large" code))
+ (vector-ref stack-frame-types code))
+
(define (initialize-package!)
(set! stack-frame-types (make-stack-frame-types)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.1 1988/05/20 00:55:52 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/dbgutl.scm,v 14.2 1988/06/13 11:43:10 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Debugger Utilities
-;;; package: debugger-utilities-package
+;;; package: (runtime debugger-utilities)
(declare (usual-integrations))
\f
(string-append s
(write->string (cadr binding)
(max (- x-size (string-length s))
- 0)))))))))
\ No newline at end of file
+ 0)))))))))
+
+(define (debug/read-eval-print-1 environment)
+ (let ((value (debug/eval (prompt-for-expression "Eval--> ") environment)))
+ (newline)
+ (write value)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.1 1988/05/20 00:57:08 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/framex.scm,v 14.2 1988/06/13 11:44:55 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Debugging Info
-;;; package: debugging-info-package
+;;; package: (runtime debugging-info)
(declare (usual-integrations))
\f
(for-each (lambda (entry)
(for-each (lambda (name)
(let ((type
- (or (vector-ref stack-frame-types
- (microcode-return name))
+ (or (microcode-return/code->type
+ (microcode-return name))
(error "Missing return type" name))))
(1d-table/put! (stack-frame-type/properties type)
method-tag
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.1 1988/05/20 00:58:36 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.2 1988/06/13 11:45:33 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Miscellaneous Global Definitions
+;;; package: ()
(declare (usual-integrations))
\f
(object-datum 1)
(object-type? 2)
(object-new-type object-set-type 2)
+ make-non-pointer-object
eq?
;; Cells
(not (object-non-pointer? object)))
(define (impurify object)
- (if (and (object-pointer? object) (pure? object))
+ (if (and (object-pointer? object) (object-pure? object))
((ucode-primitive primitive-impurify) object))
object)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.1 1988/05/20 00:59:11 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.2 1988/06/13 11:47:32 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
MIT in each case. |#
;;;; Code Loader
-;;; package: load-package
+;;; package: (runtime load)
(declare (usual-integrations))
\f
(define fasload/default-types)
(define (read-file filename)
- (stream->list
- (call-with-input-file
- (pathname-default-version (->pathname filename) 'NEWEST)
- read-stream)))
+ (call-with-input-file
+ (pathname-default-version (->pathname filename) 'NEWEST)
+ (lambda (port)
+ (stream->list (read-stream port)))))
(define (fasload filename)
(fasload/internal
(write-string " -- done" port)
value)))
-(define (load-noisily filename #!optional environment)
+(define (load-noisily filename #!optional environment syntax-table purify?)
(fluid-let ((load-noisily? true))
(load filename
- (if (default-object? environment) default-object environment))))
+ ;; This defaulting is a kludge until we get the optional
+ ;; defaulting fixed. Right now it must match the defaulting
+ ;; of `load'.
+ (if (default-object? environment) default-object environment)
+ (if (default-object? syntax-table) default-object syntax-table)
+ (if (default-object? purify?) default-object purify?))))
(define (load-init-file)
(let ((truename (init-file-truename)))
;;; This is careful to do the minimum number of file existence probes
;;; before opening the input file.
-(define (load filename/s #!optional environment)
+(define (load filename/s #!optional environment syntax-table purify?)
(let ((environment
;; Kludge until optional defaulting fixed.
- (if (default-object? environment) default-object environment)))
+ (if (or (default-object? environment)
+ (eq? environment default-object))
+ default-object
+ (->environment environment)))
+ (syntax-table
+ ;; Kludge until optional defaulting fixed.
+ (if (or (default-object? syntax-table)
+ (eq? syntax-table default-object))
+ default-object
+ (guarantee-syntax-table syntax-table)))
+ (purify?
+ (if (or (default-object? purify?)
+ (eq? purify? default-object))
+ false
+ purify?)))
(let ((kernel
(lambda (filename last-file?)
(let ((value
(find-true-filename pathname
load/default-types)
environment
+ syntax-table
+ purify?
load-noisily?))))
(cond (last-file? value)
(load-noisily? (write-line value)))))))
(define default-object
"default-object")
-(define (load/internal pathname true-filename environment load-noisily?)
+(define (load/internal pathname true-filename environment syntax-table
+ purify? load-noisily?)
(let ((port (open-input-file/internal pathname true-filename)))
(if (= 250 (char->ascii (peek-char port)))
(begin (close-input-port port)
- (scode-eval (fasload/internal true-filename)
+ (scode-eval (let ((scode (fasload/internal true-filename)))
+ (if purify? (purify scode))
+ scode)
(if (eq? environment default-object)
(standard-repl-environment)
environment)))
- (write-stream (eval-stream (read-stream port) environment)
+ (write-stream (eval-stream (read-stream port) environment syntax-table)
(if load-noisily?
(lambda (value)
(hook/repl-write (nearest-repl) value))
- (lambda (value) value false))))))
+ (lambda (value) value false))))))\f
(define (find-true-filename pathname default-types)
(pathname->string
(or (let ((try
(or (try (pathname-new-type pathname (car types)))
(loop (cdr types))))))))
(error "No such file" pathname))))
-\f
+
(define (read-stream port)
(parse-objects port
(current-parser-table)
(begin (close-input-port port)
true)))))
-(define (eval-stream stream environment)
+(define (eval-stream stream environment syntax-table)
(stream-map stream
(lambda (s-expression)
- (hook/repl-eval (nearest-repl)
- s-expression
- (if (eq? environment default-object)
- (standard-repl-environment)
- environment)))))
+ (let ((repl (nearest-repl)))
+ (hook/repl-eval repl
+ s-expression
+ (if (eq? environment default-object)
+ (repl/environment repl)
+ environment)
+ (if (eq? syntax-table default-object)
+ (repl/syntax-table repl)
+ syntax-table))))))
(define (write-stream stream write)
(if (stream-pair? stream)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.1 1988/05/20 00:59:28 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.2 1988/06/13 11:47:44 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
\f
((ucode-primitive set-interrupt-enables!) 0)
(define system-global-environment (the-environment))
-(define system-packages (let () (the-environment)))
-(let ()
+(let ((environment-for-package (let () (the-environment))))
(define-primitives
(+ &+)
(file-exists? 1)
garbage-collect
get-fixed-objects-vector
+ get-next-constant
get-primitive-address
get-primitive-name
lexical-reference
substring=?
substring-move-right!
substring-upcase!
+ tty-beep
tty-flush-output
+ tty-read-char-immediate
tty-write-char
tty-write-string
vector-ref
(tty-write-char newline-char)
(tty-flush-output)
(exit))
+
+(define (prompt-for-confirmation prompt)
+ (let loop ()
+ (tty-write-char newline-char)
+ (tty-write-string prompt)
+ (tty-write-string "(y or n) ")
+ (tty-flush-output)
+ (let ((char (tty-read-char-immediate)))
+ (cond ((or (eq? #\y char)
+ (eq? #\Y char))
+ (tty-write-string "Yes")
+ (tty-flush-output)
+ true)
+ ((or (eq? #\n char)
+ (eq? #\N char))
+ (tty-write-string "No")
+ (tty-flush-output)
+ false)
+ (else
+ (tty-beep)
+ (loop))))))
\f
;;;; GC, Interrupts, Errors
(define safety-margin 4500)
+(define constant-space/base (get-next-constant))
(let ((condition-handler/gc
(lambda (interrupt-code interrupt-enables)
(get-primitive-address (get-primitive-name (object-datum primitive)) false))
(define map-filename
- (if (implemented-primitive-procedure? file-exists?)
+ (if (and (implemented-primitive-procedure? file-exists?)
+ (not (prompt-for-confirmation "Load interpreted? ")))
(lambda (filename)
(let ((com-file (string-append filename ".com")))
(if (file-exists? com-file)
(define (package-initialize package-name procedure-name)
(tty-write-char newline-char)
- (tty-write-string "initialize:")
+ (tty-write-string "initialize: (")
(let loop ((name package-name))
(if (not (null? name))
- (begin (tty-write-string " ")
+ (begin (if (not (eq? name package-name))
+ (tty-write-string " "))
(tty-write-string (system-pair-car (car name)))
(loop (cdr name)))))
+ (tty-write-string ")")
+ (if (not (eq? procedure-name 'INITIALIZE-PACKAGE!))
+ (begin (tty-write-string " [")
+ (tty-write-string (system-pair-car procedure-name))
+ (tty-write-string "]")))
(tty-flush-output)
((lexical-reference (package-reference package-name) procedure-name)))
(define (package-reference name)
- (if (null? name)
- system-global-environment
- (let loop ((name name) (environment system-packages))
- (if (null? name)
- environment
- (loop (cdr name) (lexical-reference environment (car name)))))))
+ (package/environment (find-package name)))
(define (package-initialization-sequence packages)
(let loop ((packages packages))
(loop (cdr packages))))))
\f
;; Construct the package structure.
+;; Lotta hair here to load the package code before its package is built.
+(eval (cold-load/purify (fasload (map-filename "packag")))
+ environment-for-package)
+((access initialize-package! environment-for-package))
+(let loop ((names
+ '(FIND-PACKAGE
+ NAME->PACKAGE
+ PACKAGE/ADD-CHILD!
+ PACKAGE/CHILD
+ PACKAGE/CHILDREN
+ PACKAGE/ENVIRONMENT
+ PACKAGE/NAME
+ PACKAGE/PARENT
+ PACKAGE/REFERENCE
+ PACKAGE/SYSTEM-LOADER
+ PACKAGE?
+ SYSTEM-GLOBAL-PACKAGE)))
+ (if (not (null? names))
+ (begin (environment-link-name system-global-environment
+ environment-for-package
+ (car names))
+ (loop (cdr names)))))
+(package/add-child! system-global-package 'PACKAGE environment-for-package)
(eval (fasload "runtim.bcon") system-global-environment)
;; Global databases. Load, then initialize.
-
(let loop
((files
- '(("gcdemn" . (GC-DAEMONS))
- ("poplat" . (POPULATION))
- ("prop1d" . (1D-PROPERTY))
- ("events" . (EVENT-DISTRIBUTOR))
- ("gdatab" . (GLOBAL-DATABASE))
+ '(("gcdemn" . (RUNTIME GC-DAEMONS))
+ ("poplat" . (RUNTIME POPULATION))
+ ("prop1d" . (RUNTIME 1D-PROPERTY))
+ ("events" . (RUNTIME EVENT-DISTRIBUTOR))
+ ("gdatab" . (RUNTIME GLOBAL-DATABASE))
("boot" . ())
("queue" . ())
- ("gc" . (GARBAGE-COLLECTOR)))))
+ ("gc" . (RUNTIME GARBAGE-COLLECTOR)))))
(if (not (null? files))
(begin
(eval (cold-load/purify (fasload (map-filename (car (car files)))))
(package-reference (cdr (car files))))
(loop (cdr files)))))
-(package-initialize '(GC-DAEMONS) 'INITIALIZE-PACKAGE!)
-(package-initialize '(POPULATION) 'INITIALIZE-PACKAGE!)
-(package-initialize '(1D-PROPERTY) 'INITIALIZE-PACKAGE!)
-(package-initialize '(EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE!)
-(package-initialize '(GLOBAL-DATABASE) 'INITIALIZE-PACKAGE!)
-(package-initialize '(POPULATION) 'INITIALIZE-UNPARSER!)
-(package-initialize '(1D-PROPERTY) 'INITIALIZE-UNPARSER!)
-(package-initialize '(EVENT-DISTRIBUTOR) 'INITIALIZE-UNPARSER!)
-(package-initialize '(GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE!)
+(package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE!)
+(package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE!)
+(package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE!)
+(package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE!)
+(package-initialize '(RUNTIME GLOBAL-DATABASE) 'INITIALIZE-PACKAGE!)
+(package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER!)
+(package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER!)
+(package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-UNPARSER!)
+(package-initialize '(PACKAGE) 'INITIALIZE-UNPARSER!)
+(package-initialize '(RUNTIME GARBAGE-COLLECTOR) 'INITIALIZE-PACKAGE!)
+(lexical-assignment (package-reference '(RUNTIME GARBAGE-COLLECTOR))
+ 'CONSTANT-SPACE/BASE
+ constant-space/base)
;; Load everything else.
((eval (fasload "runtim.bldr") system-global-environment)
(lambda (filename environment)
- (if (not (or (string=? filename "gcdemn")
+ (if (not (or (string=? filename "packag")
+ (string=? filename "gcdemn")
(string=? filename "poplat")
(string=? filename "prop1d")
(string=? filename "events")
(package-initialization-sequence
'(
;; Microcode interface
- (MICROCODE-TABLES)
- (PRIMITIVE-IO)
- (SAVE/RESTORE)
- (STATE-SPACE)
- (SYSTEM-CLOCK)
+ (RUNTIME MICROCODE-TABLES)
+ (RUNTIME PRIMITIVE-IO)
+ (RUNTIME SAVE/RESTORE)
+ (RUNTIME STATE-SPACE)
+ (RUNTIME SYSTEM-CLOCK)
;; Basic data structures
- (NUMBER)
- (LIST)
- (CHARACTER)
- (CHARACTER-SET)
- (GENSYM)
- (STREAM)
- (2D-PROPERTY)
- (HASH)
- (RANDOM-NUMBER)
+ (RUNTIME NUMBER)
+ (RUNTIME LIST)
+ (RUNTIME CHARACTER)
+ (RUNTIME CHARACTER-SET)
+ (RUNTIME GENSYM)
+ (RUNTIME STREAM)
+ (RUNTIME 2D-PROPERTY)
+ (RUNTIME HASH)
+ (RUNTIME RANDOM-NUMBER)
;; Microcode data structures
- (HISTORY)
- (LAMBDA-ABSTRACTION)
- (SCODE)
- (SCODE-COMBINATOR)
- (SCODE-SCAN)
- (SCODE-WALKER)
- (CONTINUATION-PARSER)
-
- ;; I/O ports
- (CONSOLE-INPUT)
- (CONSOLE-OUTPUT)
- (FILE-INPUT)
- (FILE-OUTPUT)
- (STRING-INPUT)
- (STRING-OUTPUT)
- (TRUNCATED-STRING-OUTPUT)
- (INPUT-PORT)
- (OUTPUT-PORT)
- (WORKING-DIRECTORY)
- (LOAD)
+ (RUNTIME HISTORY)
+ (RUNTIME LAMBDA-ABSTRACTION)
+ (RUNTIME SCODE)
+ (RUNTIME SCODE-COMBINATOR)
+ (RUNTIME SCODE-SCAN)
+ (RUNTIME SCODE-WALKER)
+ (RUNTIME CONTINUATION-PARSER)
+
+ ;; I/O
+ (RUNTIME CONSOLE-INPUT)
+ (RUNTIME CONSOLE-OUTPUT)
+ (RUNTIME FILE-INPUT)
+ (RUNTIME FILE-OUTPUT)
+ (RUNTIME STRING-INPUT)
+ (RUNTIME STRING-OUTPUT)
+ (RUNTIME TRUNCATED-STRING-OUTPUT)
+ (RUNTIME INPUT-PORT)
+ (RUNTIME OUTPUT-PORT)
+ (RUNTIME WORKING-DIRECTORY)
+ (RUNTIME DIRECTORY)
+ (RUNTIME LOAD)
;; Syntax
- (PARSER)
- (NUMBER-UNPARSER)
- (UNPARSER)
- (SYNTAXER)
- (MACROS)
- (SYSTEM-MACROS)
- (DEFSTRUCT)
- (UNSYNTAXER)
- (PRETTY-PRINTER)
-
+ (RUNTIME PARSER)
+ (RUNTIME NUMBER-UNPARSER) (RUNTIME UNPARSER)
+ (RUNTIME SYNTAXER)
+ (RUNTIME MACROS)
+ (RUNTIME SYSTEM-MACROS)
+ (RUNTIME DEFSTRUCT)
+ (RUNTIME UNSYNTAXER)
+ (RUNTIME PRETTY-PRINTER)
;; REP Loops
- (ERROR-HANDLER)
- (MICROCODE-ERRORS)
- (INTERRUPT-HANDLER)
- (GC-STATISTICS)
- (REP)
+ (RUNTIME ERROR-HANDLER)
+ (RUNTIME MICROCODE-ERRORS)
+ (RUNTIME INTERRUPT-HANDLER)
+ (RUNTIME GC-STATISTICS)
+ (RUNTIME REP)
;; Debugging
- (ADVICE)
- (DEBUGGER-COMMAND-LOOP)
- (DEBUGGER-UTILITIES)
- (ENVIRONMENT-INSPECTOR)
- (DEBUGGING-INFO)
- (DEBUGGER)
-
+ (RUNTIME ADVICE)
+ (RUNTIME DEBUGGER-COMMAND-LOOP)
+ (RUNTIME DEBUGGER-UTILITIES)
+ (RUNTIME ENVIRONMENT-INSPECTOR)
+ (RUNTIME DEBUGGING-INFO)
+ (RUNTIME DEBUGGER)
+
+ (RUNTIME)
;; Emacs -- last because it grabs the kitchen sink.
- (EMACS-INTERFACE)
+ (RUNTIME EMACS-INTERFACE)
))
-\f
+
)
-(add-system! (make-system "Microcode"
- microcode-id/version
- microcode-id/modification
- '()))
-(add-system! (make-system "Runtime" 14 0 '()))
-(remove-environment-parent! system-packages)
(initial-top-level-repl)
\ No newline at end of file
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.1 1988/05/20 01:04:16 cph Exp $
-;;;
-;;; Copyright (c) 1988 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; 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
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; 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
-;;; 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
-;;; without prior written consent from MIT in each case.
-;;;
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.2 1988/06/13 11:58:33 cph Exp $
+
+Copyright (c) 1988 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in 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 research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is 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 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 without prior written consent from
+MIT in each case. |#
;;;; Microcode Environments
+;;; package: (runtime environment)
(declare (usual-integrations))
\f
projects / mit-scheme.git / commitdiff