#| -*-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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 14.2 1988/08/05 20:46:42 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(define ((wrap-general-advisor advisor) procedure advice . path)
(advisor (find-internal-lambda procedure path) advice)
- *the-non-printing-object*)
+ unspecific)
(define advise-entry)
(define advise-exit)
(map-over-population unadvisor)
(unadvisor (find-internal-lambda (car procedure&path)
(cdr procedure&path))))
- *the-non-printing-object*)
+ unspecific)
(define wrap-entry-unadvisor)
(define wrap-exit-unadvisor)
(define ((wrap-advisor advisor) procedure . path)
(advisor (find-internal-lambda procedure path))
- *the-non-printing-object*)
+ unspecific)
(define trace-entry)
(define trace-exit)
#| -*-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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.3 1988/08/05 20:46:52 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(write-string " ")
(write-string (caddr entry)))
(cdr command-set))
- *the-non-printing-object*)
+ unspecific)
(define (standard-exit-command) (proceed))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.4 1988/07/14 07:40:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.5 1988/08/05 20:47:00 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(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)))))))
+ (simple-error environment message irritants))))
(define (error-from-compiled-code message . irritants)
(with-proceed-point proceed-value-filter
(continuation/first-subproblem continuation))))
(if next-subproblem
((stack-frame->continuation next-subproblem) (car values))
- (continuation *the-non-printing-object*))))
+ (continuation unspecific))))
\f
(define (simple-error environment message irritants)
(signal-error
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/format.scm,v 14.3 1988/07/07 15:45:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/format.scm,v 14.4 1988/08/05 20:47:10 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
(lambda (port)
(format-loop port format-string arguments)
(output-port/flush-output port)
- *the-non-printing-object*)))
+ unspecific)))
(cond ((not destination)
(with-output-to-string (lambda () (start (current-output-port)))))
((eq? destination true)
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcnote.scm,v 14.3 1988/08/05 20:47:17 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
(cond ((eq? current gc-notification) default/record-statistic!)
((eq? current default/record-statistic!) gc-notification)
(else (error "Can't grab GC statistics hook")))))
- *the-non-printing-object*)
-
+ unspecific)
(define (gc-notification statistic)
(with-output-to-port (cmdl/output-port (nearest-cmdl))
(lambda ()
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.4 1988/08/05 20:15:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.5 1988/08/05 20:47:24 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(define (quit)
(with-absolutely-no-interrupts (ucode-primitive halt))
- *the-non-printing-object*)
+ unspecific)
(define syntaxer/default-environment
(let () (the-environment)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.2 1988/06/16 06:31:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.3 1988/08/05 20:47:32 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(procedure (vector-ref vector index))
(if (< index high)
(loop (1+ index))))))
- (lambda () *the-non-printing-object*)))
+ (lambda () unspecific)))
\f
(define (vector-binary-search-range vector key key=? compare if-found
if-not-found)
#| -*-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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/list.scm,v 14.2 1988/08/05 20:47:45 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(cons (cdr (car lists)) cdrs)))))
((not (null? (car lists)))
(error "FOR-EACH: Argument not a list" (car lists)))))))
- *the-non-printing-object*)
+ unspecific)
(define (mapcan f . lists)
;; Compiler doesn't, but ought to, make this very fast.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.3 1988/07/14 07:40:16 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.4 1988/08/05 20:47:59 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(let ((truename (init-file-truename)))
(if truename
(load truename user-initial-environment)))
- *the-non-printing-object*)
+ unspecific)
\f
;;; This is careful to do the minimum number of file existence probes
;;; before opening the input file.
(if (stream-pair? stream)
(begin (write value)
(loop (stream-car stream) (stream-cdr stream))) value))
- *the-non-printing-object*))
\ No newline at end of file
+ unspecific))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 14.2 1988/07/14 07:40:24 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 14.3 1988/08/05 20:48:08 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(guarantee-output-port port))))
(output-port/write-char port #\Newline)
(output-port/flush-output port))
- *the-non-printing-object*)
+ unspecific)
(define (write-char char #!optional port)
(let ((port
(guarantee-output-port port))))
(output-port/write-char port char)
(output-port/flush-output port))
- *the-non-printing-object*)
+ unspecific)
(define (write-string string #!optional port)
(let ((port
(guarantee-output-port port))))
(output-port/write-string port string)
(output-port/flush-output port))
- *the-non-printing-object*)
+ unspecific)
(define (close-output-port port)
(let ((operation (output-port/custom-operation port 'CLOSE)))
(if operation
(operation port)))
- *the-non-printing-object*)
+ unspecific)
(define (wrap-custom-operation-0 operation-name)
(lambda (#!optional port)
(begin
(operation port)
(output-port/flush-output port)))))
- *the-non-printing-object*))
+ unspecific))
(define beep)
(define clear)
(output-port/write-string port object)
(unparse-object/internal object port 0 false unparser-table))
(output-port/flush-output port))
- *the-non-printing-object*)
+ unspecific)
(define (write object #!optional port unparser-table)
(let ((port
(guarantee-unparser-table unparser-table))))
(unparse-object/internal object port 0 true unparser-table)
(output-port/flush-output port))
- *the-non-printing-object*)
+ unspecific)
(define (write-line object #!optional port unparser-table)
(let ((port
(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
+ unspecific)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/packag.scm,v 14.3 1988/07/14 07:40:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/packag.scm,v 14.4 1988/08/05 20:48:18 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(lambda (filename environment)
(load filename environment syntax-table true)))
options)))))
- *the-non-printing-object*)
-
+ unspecific)
(define-integrable (package/reference package name)
(lexical-reference (package/environment package) name))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 14.3 1988/07/15 22:31:58 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 14.4 1988/08/05 20:48:25 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(parse-error "end of file"))
(define (parse-error message #!optional irritant)
- (error (string-append "PARSE-OBJECT: " message)
- (if (default-object? irritant) *the-non-printing-object* irritant)))
+ (let ((message (string-append "PARSE-OBJECT: " message)))
+ (if (default-object? irritant)
+ (error message)
+ (error message irritant))))
\f
;;;; Dispatch Points
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.2 1988/08/05 19:44:30 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 14.3 1988/08/05 20:48:37 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(named-structure/description object)))
(else
(pp-top-level port object as-code?))))
- *the-non-printing-object*)
+ unspecific)
(define (pp-top-level port expression as-code?)
(fluid-let
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.5 1988/08/01 23:09:21 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.6 1988/08/05 20:48:47 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(define (standard-value-filter continuation arguments)
(continuation
(if (null? arguments)
- *the-non-printing-object*
+ unspecific
(car arguments))))
\f
;;;; REP Loops
(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*)
+ unspecific)
(define (vst syntax-table)
(guarantee-syntax-table syntax-table)
(set-repl-state/syntax-table! (cmdl/state (nearest-repl)) syntax-table)
- *the-non-printing-object*)
+ unspecific)
(define (re #!optional index)
(let ((repl (nearest-repl)))
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/savres.scm,v 14.3 1988/08/05 20:48:56 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(save-image filename
(lambda ()
(set! time-world-saved time)
- *the-non-printing-object*)
+ unspecific)
(lambda ()
(set! time-world-saved time)
(event-distributor/invoke! event:after-restore)
#| -*-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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sfile.scm,v 14.2 1988/08/05 20:49:04 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(if (not ((ucode-primitive photo-open)
(canonicalize-output-filename filename)))
(error "TRANSCRIPT-ON: Transcript file already open" filename))
- *the-non-printing-object*)
+ unspecific)
(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
+ unspecific)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 14.4 1988/07/16 10:14:30 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 14.5 1988/08/05 20:49:14 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(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))))
+ (error-procedure
+ (string-append "SYNTAX: "
+ (if *current-keyword*
+ (string-append (symbol->string *current-keyword*)
+ ": "
+ message)
+ message))
+ irritants
+ ;; This is not really the right environment. Perhaps nothing is.
+ syntaxer/default-environment))
(define (syntax-expressions expressions)
(if (null? expressions)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 14.3 1988/06/30 22:22:23 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 14.4 1988/08/05 20:49:26 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(define (add-system! system)
(set! known-systems (append! known-systems (list system)))
- *the-non-printing-object*)
+ unspecific)
(define (for-each-system! procedure)
(for-each procedure known-systems))
(newline)
(write-string "Done"))
(add-system! system)
- *the-non-printing-object*)
+ unspecific)
(define (split-list list n receiver)
(if (or (not (pair? list)) (zero? n))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.3 1988/07/22 22:53:14 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.4 1988/08/05 20:49:33 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(cons frame-filter handler)))))
(else
(error "Can't overwrite error handler" entry)))))
- *the-non-printing-object*)
+ unspecific)
(define (define-standard-frame-handler error-type frame-type frame-filter
irritant)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 14.2 1988/06/14 14:45:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 14.3 1988/08/05 20:49:43 cph Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
(unsyntax-objects (cdr objects)))))
(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))))
+ (error-procedure
+ (string-append "UNSYNTAX: " (symbol->string keyword) ": " message)
+ irritants
+ system-global-environment))
\f
;;;; Unsyntax Quanta
(define (unsyntax-error-like-form operands name)
(cons* name
(unsyntax-object (first operands))
- (let ((operand (second operands)))
- (cond ((absolute-reference-to? operand '*THE-NON-PRINTING-OBJECT*)
- '())
- ((combination? operand)
- (combination-components operand
- (lambda (operator operands)
- (if (absolute-reference-to? operator 'LIST)
- (unsyntax-objects operands)
- `(,(unsyntax-object operand))))))
- (else
- `(,(unsyntax-object operand)))))))
+ (unsyntax-objects
+ (let loop ((irritants (cadr operands)))
+ (cond ((null? irritants) '())
+ ((and (combination? irritants)
+ (absolute-reference-to?
+ (combination-operator irritants)
+ 'LIST))
+ (combination-operands irritants))
+ ((and (combination? irritants)
+ (eq? (combination-operator irritants) cons))
+ (let ((operands (combination-operands irritants)))
+ (cons (car operands)
+ (loop (cadr operands)))))
+ (else
+ ;; Actually, this is an error. But do something useful
+ ;; here just in case it actually happens.
+ (list irritants)))))))
\f
(define (unsyntax/fluid-let names values body if-malformed)
(combination-components body
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 14.3 1988/08/01 23:09:58 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 14.4 1988/08/05 20:49:51 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(begin (show-frame env depth)
(if (environment-has-parent? env)
(s1 (environment-parent env) (1+ depth))))))
- *the-non-printing-object*)
+ unspecific)
;;;; Motion Commands
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.4 1988/08/05 20:15:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.5 1988/08/05 20:47:24 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(define (quit)
(with-absolutely-no-interrupts (ucode-primitive halt))
- *the-non-printing-object*)
+ unspecific)
(define syntaxer/default-environment
(let () (the-environment)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.2 1988/06/16 06:31:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.3 1988/08/05 20:47:32 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(procedure (vector-ref vector index))
(if (< index high)
(loop (1+ index))))))
- (lambda () *the-non-printing-object*)))
+ (lambda () unspecific)))
\f
(define (vector-binary-search-range vector key key=? compare if-found
if-not-found)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.3 1988/07/14 07:40:16 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.4 1988/08/05 20:47:59 cph Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(let ((truename (init-file-truename)))
(if truename
(load truename user-initial-environment)))
- *the-non-printing-object*)
+ unspecific)
\f
;;; This is careful to do the minimum number of file existence probes
;;; before opening the input file.
(if (stream-pair? stream)
(begin (write value)
(loop (stream-car stream) (stream-cdr stream))) value))
- *the-non-printing-object*))
\ No newline at end of file
+ unspecific))
\ No newline at end of file
projects / mit-scheme.git / commitdiff