#| -*-Scheme-*-
-$Id: nodefs.scm,v 1.11 1999/01/02 06:06:43 cph Exp $
+$Id: nodefs.scm,v 1.12 2001/12/19 05:23:50 cph Exp $
-Copyright (c) 1991-1999 Massachusetts Institute of Technology
+Copyright (c) 1991-1999, 2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
;;;; SCode rewriting for 6.001
(set! hook/repl-eval student/repl-eval)
unspecific)
-(define (student/repl-eval repl s-expression environment syntax-table)
+(define (student/repl-eval repl s-expression environment)
(repl-scode-eval
repl
- (rewrite-scode (syntax s-expression syntax-table)
+ (rewrite-scode (syntax s-expression environment)
(and repl
(let ((port (cmdl/port repl)))
(let ((operation
;;; -*-Scheme-*-
;;;
-;;; $Id: artdebug.scm,v 1.28 1999/02/24 21:35:54 cph Exp $
+;;; $Id: artdebug.scm,v 1.29 2001/12/19 05:25:08 cph Exp $
;;;
-;;; Copyright (c) 1989-1999 Massachusetts Institute of Technology
+;;; Copyright (c) 1989-1999, 2001 Massachusetts Institute of Technology
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
-;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;;; 02111-1307, USA.
;;;; Continuation Browser
(fluid-let
((in-debugger-evaluation? #t)
(hook/repl-eval
- (lambda (expression environment syntax-table)
+ (lambda (expression environment)
(let ((unique (cons 'unique 'id)))
(let ((result
(call-with-current-continuation
(lambda ()
(continuation*
(repl-eval expression
- environment
- syntax-table))))))))))
+ environment))))))))))
(if (and (pair? result)
(eq? unique (car result)))
(error (cdr result))
;;; -*-Scheme-*-
;;;
-;;; $Id: comred.scm,v 1.122 2001/07/21 05:49:36 cph Exp $
+;;; $Id: comred.scm,v 1.123 2001/12/19 05:25:12 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
;;;
(apply (command-procedure (name->command (car entry)))
(map (let ((environment (->environment '(EDWIN))))
(lambda (expression)
- (eval-with-history (current-buffer) expression environment)))
+ (eval-with-history expression environment)))
(cdr entry))))
\f
(define (interactive-argument key prompt)
;;; -*-Scheme-*-
;;;
-;;; $Id: debug.scm,v 1.57 2001/12/19 01:45:58 cph Exp $
+;;; $Id: debug.scm,v 1.58 2001/12/19 05:25:21 cph Exp $
;;;
;;; Copyright (c) 1992-2001 Massachusetts Institute of Technology
;;;
(buffer-end buffer))
(buffer-not-modified! buffer)
(if env-exists?
- (start-inferior-repl!
- buffer
- environment
- (evaluation-syntax-table buffer environment)
- #f))
+ (start-inferior-repl! buffer environment #f))
buffer))))))))
(define evaluation-line-marker
(prompt-for-expression prompt)
(if (default-object? environment)
(nearest-repl/environment)
- environment)
- (nearest-repl/syntax-table))))))
+ environment))))))
(hook/invoke-restart
(lambda (continuation arguments)
(invoke-continuation continuation
;;; -*-Scheme-*-
;;;
-;;; $Id: editor.scm,v 1.252 2001/07/21 05:49:45 cph Exp $
+;;; $Id: editor.scm,v 1.253 2001/12/19 05:25:25 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
;;;
(start-inferior-repl!
buffer
(nearest-repl/environment)
- (nearest-repl/syntax-table)
(and (not (ref-variable inhibit-startup-message))
(cmdl-message/append
(cmdl-message/active
;;; -*-Scheme-*-
;;;
-;;; $Id: evlcom.scm,v 1.64 2001/12/19 01:46:03 cph Exp $
+;;; $Id: evlcom.scm,v 1.65 2001/12/19 05:25:29 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
;;;
(->environment object))))))))
(define-variable scheme-syntax-table
- "The syntax table used by the evaluation commands, or #F.
-If #F, use the default (REP loop) syntax-table."
- #f
- (lambda (object)
- (or (not object)
- (symbol? object)
- (syntax-table? object))))
-
-(let ((daemon
- (lambda (buffer variable)
- variable
- (if buffer (normal-buffer-evaluation-mode buffer)))))
- (add-variable-assignment-daemon! (ref-variable-object scheme-environment)
- daemon)
- (add-variable-assignment-daemon! (ref-variable-object scheme-syntax-table)
- daemon))
+ "This variable is obsolete and its value is ignored."
+ #f)
+
+(add-variable-assignment-daemon! (ref-variable-object scheme-environment)
+ (lambda (buffer variable)
+ variable
+ (if buffer (normal-buffer-evaluation-mode buffer))))
(define (normal-buffer-evaluation-mode buffer)
(let ((environment (ref-variable-object scheme-environment))
- (syntax-table (ref-variable-object scheme-syntax-table))
(evaluate-inferior (ref-variable-object evaluate-in-inferior-repl))
(run-light (ref-variable-object run-light)))
(if (and (not (repl-buffer? buffer))
(not (variable-local-value? buffer evaluate-inferior))
- (or (and (variable-local-value? buffer environment)
- (not (eq? 'DEFAULT
- (variable-local-value buffer environment))))
- (and (variable-local-value? buffer syntax-table)
- (not (memq (variable-local-value buffer syntax-table)
- '(#F DEFAULT))))))
+ (and (variable-local-value? buffer environment)
+ (not (eq? 'DEFAULT
+ (variable-local-value buffer environment)))))
(begin
(define-variable-local-value! buffer evaluate-inferior #f)
(if (not (variable-local-value? buffer run-light))
(lambda (environment)
(local-set-variable! scheme-environment environment)))
-(define-command set-syntax-table
- "Make SYNTAX-TABLE the current syntax table."
- "XSet syntax table"
- (lambda (syntax-table)
- (local-set-variable! scheme-syntax-table syntax-table)))
-
(define-command set-default-environment
"Make ENVIRONMENT the default evaluation environment."
"XSet default environment"
(set-variable-default-value! (ref-variable-object scheme-environment)
environment)))
-(define-command set-default-syntax-table
- "Make SYNTAX-TABLE the default syntax table."
- "XSet default syntax table"
- (lambda (syntax-table)
- (set-variable-default-value! (ref-variable-object scheme-syntax-table)
- syntax-table)))
-
(define-command set-repl-environment
"Make ENVIRONMENT the environment of the nearest REP loop."
"XSet REPL environment"
(lambda (environment)
(set-repl/environment! (nearest-repl) (->environment environment))))
-(define-command set-repl-syntax-table
- "Make SYNTAX-TABLE the syntax table of the nearest REP loop."
- "XSet REPL syntax table"
- (lambda (syntax-table)
- (set-repl/syntax-table! (nearest-repl) syntax-table)))
-
(define-command select-transcript-buffer
"Select the transcript buffer."
()
(define (prompt-for-expression-value prompt #!optional default . options)
(let ((buffer (current-buffer)))
- (eval-with-history buffer
- (apply prompt-for-expression
+ (eval-with-history (apply prompt-for-expression
prompt
(cond ((default-object? default)
default-object-kludge)
(non-default environment)))
(nearest-repl/environment)))
(non-default environment)))))
-
-(define (evaluation-syntax-table buffer environment)
- (let ((syntax-table (ref-variable scheme-syntax-table buffer)))
- (cond ((or (not syntax-table) (eq? 'DEFAULT syntax-table))
- (environment-syntax-table environment))
- ((syntax-table? syntax-table)
- syntax-table)
- ((symbol? syntax-table)
- (or (and (environment-bound? environment syntax-table)
- (environment-assigned? environment syntax-table)
- (let ((syntax-table
- (environment-lookup environment syntax-table)))
- (and (syntax-table? syntax-table)
- syntax-table)))
- (editor-error "Undefined syntax table" syntax-table)))
- (else
- (editor-error "Illegal syntax table" syntax-table)))))
\f
(define-variable run-light
"Scheme run light. Not intended to be modified by users.
(let ((output-string
(with-output-to-string
(lambda ()
- (set! value
- (eval-with-history buffer sexp environment))
+ (set! value (eval-with-history sexp environment))
unspecific))))
(let ((evaluation-output-receiver
(ref-variable evaluation-output-receiver buffer)))
(update-screens! #f))))
(core))))
-(define (eval-with-history buffer expression environment)
- (let ((syntax-table (evaluation-syntax-table buffer environment)))
- (bind-condition-handler (list condition-type:error)
- evaluation-error-handler
- (lambda ()
- (hook/repl-eval #f expression environment syntax-table)))))
+(define (eval-with-history expression environment)
+ (bind-condition-handler (list condition-type:error)
+ evaluation-error-handler
+ (lambda ()
+ (hook/repl-eval #f expression environment))))
(define (evaluation-error-handler condition)
(maybe-debug-scheme-error (ref-variable-object debug-on-evaluation-error)
;;; -*-Scheme-*-
;;;
-;;; $Id: filcom.scm,v 1.222 2001/12/18 21:35:06 cph Exp $
+;;; $Id: filcom.scm,v 1.223 2001/12/19 05:25:33 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
;;;
(local-set-variable! scheme-environment (cadr entry) buffer)
(if (and (eq? 'DEFAULT (ref-variable scheme-environment buffer))
(not (eq? 'DEFAULT (cadr entry))))
- (begin
- (message "Ignoring bad evaluation environment: "
- (cadr entry))
- (local-set-variable! scheme-syntax-table
- 'DEFAULT
- buffer))
- (local-set-variable! scheme-syntax-table
- (if (pair? (cddr entry))
- (caddr entry)
- 'DEFAULT)
- buffer)))))))
+ (message "Ignoring bad evaluation environment: "
+ (cadr entry))))))))
\f
(define (find-file-revert buffer)
(if (verify-visited-file-modification-time? buffer)
;;; -*-Scheme-*-
;;;
-;;; $Id: intmod.scm,v 1.114 2001/12/18 20:50:51 cph Exp $
+;;; $Id: intmod.scm,v 1.115 2001/12/19 05:25:39 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
;;;
(let ((make-new
(lambda (environment)
(let ((repl-buffer (new-buffer initial-buffer-name)))
- (start-inferior-repl! repl-buffer
- environment
- (environment-syntax-table environment)
- #f)
+ (start-inferior-repl! repl-buffer environment #f)
repl-buffer))))
(if (>= argument 16)
(make-new
(lambda (repl-buffer)
(set-local-repl-buffer! (current-buffer) repl-buffer)))
\f
-(define (start-inferior-repl! buffer environment syntax-table message)
+(define (start-inferior-repl! buffer environment message)
(set-buffer-major-mode! buffer (ref-mode-object inferior-repl))
(if (ref-variable repl-mode-locked)
(buffer-put! buffer 'MAJOR-MODE-LOCKED #t))
(repl/start (make-repl #f
port
environment
- syntax-table
#f
`((ERROR-DECISION ,error-decision))
user-initial-prompt)
(mark-buffer mark)))
#t)))
-(define (operation/set-default-syntax-table port syntax-table)
- (enqueue-output-operation! port
- (lambda (mark transcript?)
- (if (not transcript?)
- (local-set-variable! scheme-syntax-table syntax-table
- (mark-buffer mark)))
- #t)))
-
(define interface-port-type
(make-port-type
`((WRITE-CHAR ,operation/write-char)
(PROMPT-FOR-COMMAND-CHAR ,operation/prompt-for-command-char)
(SET-DEFAULT-DIRECTORY ,operation/set-default-directory)
(SET-DEFAULT-ENVIRONMENT ,operation/set-default-environment)
- (SET-DEFAULT-SYNTAX-TABLE ,operation/set-default-syntax-table)
(PEEK-CHAR ,operation/peek-char)
(READ-CHAR ,operation/read-char)
(READ ,operation/read)
;;; -*-Scheme-*-
;;;
-;;; $Id: schmod.scm,v 1.54 2001/12/18 22:12:27 cph Exp $
+;;; $Id: schmod.scm,v 1.55 2001/12/19 05:25:43 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
;;;
(LIST-TRANSFORM-NEGATIVE . 1)
(LIST-SEARCH-POSITIVE . 1)
(LIST-SEARCH-NEGATIVE . 1)
- (SYNTAX-TABLE-DEFINE . 2)
(FOR-ALL? . 1)
(THERE-EXISTS? . 1)))
(let ((environment (evaluation-environment buffer)))
(extended-scode-eval
(syntax (with-input-from-region (make-region start end) read)
- (evaluation-syntax-table buffer environment))
+ environment)
environment))))
(if (procedure? procedure)
(let ((argl (procedure-argl procedure)))
#| -*-Scheme-*-
-$Id: error.scm,v 14.51 2000/01/10 03:48:33 cph Exp $
+$Id: error.scm,v 14.52 2001/12/19 05:21:37 cph Exp $
-Copyright (c) 1988-2000 Massachusetts Institute of Technology
+Copyright (c) 1988-2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
;;;; Error System
(lambda (type port)
(write-char #\space port)
(write-string (%condition-type/name type) port)))))
- (name false read-only true)
+ (name #f read-only #t)
generalizations
- (field-indexes false read-only true)
- (number-of-fields false read-only true)
- (reporter false read-only true)
- (properties (make-1d-table) read-only true))
+ (field-indexes #f read-only #t)
+ (number-of-fields #f read-only #t)
+ (reporter #f read-only #t)
+ (properties (make-1d-table) read-only #t))
(define (make-condition-type name generalization field-names reporter)
(if generalization
(%make-condition-type
(cond ((string? name) (string-copy name))
((symbol? name) (symbol->string name))
- ((false? name) "(anonymous)")
+ ((not name) "(anonymous)")
(else
(error:wrong-type-argument name "condition-type name"
'MAKE-CONDITION-TYPE)))
(write-string reporter port)))
((procedure-of-arity? reporter 2)
reporter)
- ((false? reporter)
+ ((not reporter)
(if generalization
(%condition-type/reporter generalization)
(lambda (condition port)
((field-names field-names)
(index old-n-fields)
(indexes (let loop ((old-indexes old-indexes) (indexes '()))
- (if (null? old-indexes)
- indexes
+ (if (pair? old-indexes)
(loop (cdr old-indexes)
(let ((entry (car old-indexes)))
(if (memq (car entry) field-names)
indexes
- (cons entry indexes))))))))
- (if (null? field-names)
- (values index (reverse! indexes))
+ (cons entry indexes))))
+ indexes))))
+ (if (pair? field-names)
(loop (cdr field-names)
(+ index 1)
- (cons (cons (car field-names) index) indexes)))))))
+ (cons (cons (car field-names) index) indexes))
+ (values index (reverse! indexes)))))))
(define (%condition-type/field-index type field-name operator)
(let ((association (assq field-name (%condition-type/field-indexes type))))
(1d-table/put! (condition-type/properties type) key datum))
(define (condition-type/get type key)
- (1d-table/get (condition-type/properties type) key false))
+ (1d-table/get (condition-type/properties type) key #f))
\f
;;;; Condition Instances
(write-string
(%condition-type/name (%condition/type condition))
port)))))
- (type false read-only true)
- (continuation false read-only true)
- (restarts false read-only true)
- (field-values (make-vector (%condition-type/number-of-fields type) false)
- read-only true)
- (properties (make-1d-table) read-only true))
+ (type #f read-only #t)
+ (continuation #f read-only #t)
+ (restarts #f read-only #t)
+ (field-values (make-vector (%condition-type/number-of-fields type) #f)
+ read-only #t)
+ (properties (make-1d-table) read-only #t))
(define (make-condition type continuation restarts field-alist)
(guarantee-condition-type type 'MAKE-CONDITION)
(%restarts-argument restarts 'MAKE-CONDITION))))
(let ((field-values (%condition/field-values condition)))
(do ((alist field-alist (cddr alist)))
- ((null? alist))
+ ((not (pair? alist)))
(vector-set! field-values
(%condition-type/field-index type (car alist)
'MAKE-CONDITION)
(let ((values (%condition/field-values condition)))
(do ((i indexes (cdr i))
(v field-values (cdr v)))
- ((or (null? i) (null? v))
- (if (not (and (null? i) (null? v)))
+ ((or (not (pair? i))
+ (not (pair? v)))
+ (if (or (pair? i) (pair? v))
(error:wrong-number-of-arguments
constructor
(+ (length indexes) 1)
(1d-table/put! (condition/properties condition) key datum))
(define (condition/get condition key)
- (1d-table/get (condition/properties condition) key false))
+ (1d-table/get (condition/properties condition) key #f))
(define (write-condition-report condition port)
(guarantee-condition condition 'WRITE-CONDITION-REPORT)
(if name
(write name port)
(write-string "(anonymous)" port)))))))
- (name false read-only true)
- (reporter false read-only true)
- (effector false read-only true)
- (interactor false)
- (properties (make-1d-table) read-only true))
+ (name #f read-only #t)
+ (reporter #f read-only #t)
+ (effector #f read-only #t)
+ (interactor #f)
+ (properties (make-1d-table) read-only #t))
(define (with-restart name reporter effector interactor thunk)
(if name (guarantee-symbol name 'WITH-RESTART))
(define (restart/get restart key)
(if (eq? key 'INTERACTIVE)
(restart/interactor restart)
- (1d-table/get (restart/properties restart) key false)))
+ (1d-table/get (restart/properties restart) key #f)))
(define (restart/put! restart key datum)
(if (eq? key 'INTERACTIVE)
(define (continue-from-derived-thread-error condition)
(let loop ((restarts (bound-restarts)))
- (if (not (null? restarts))
+ (if (pair? restarts)
(if (and (eq? 'CONTINUE (restart/name (car restarts)))
(eq? condition
(restart/get (car restarts) 'ASSOCIATED-CONDITION)))
(define (bound-restarts)
(let loop ((restarts *bound-restarts*))
- (if (null? restarts)
- '()
- (cons (car restarts) (loop (cdr restarts))))))
+ (if (pair? restarts)
+ (cons (car restarts) (loop (cdr restarts)))
+ '())))
(define (first-bound-restart)
(let ((restarts *bound-restarts*))
- (if (null? restarts)
+ (if (not (pair? restarts))
(error:no-such-restart #f))
(car restarts)))
(define (%find-restart name restarts)
(let loop ((restarts restarts))
- (and (not (null? restarts))
+ (and (pair? restarts)
(if (eq? name (%restart/name (car restarts)))
(car restarts)
(loop (cdr restarts))))))
(lambda (types)
(let outer ((type (car types)) (types (cdr types)))
(let inner ((generalizations generalizations))
- (if (null? generalizations)
- (and (not (null? types))
- (outer (car types) (cdr types)))
+ (if (pair? generalizations)
(or (eq? type (car generalizations))
- (inner (cdr generalizations)))))))))
+ (inner (cdr generalizations)))
+ (and (pair? types)
+ (outer (car types) (cdr types)))))))))
(if (let ((types break-on-signals-types))
- (and (not (null? types))
+ (and (pair? types)
(intersect-generalizations? types)))
(fluid-let ((break-on-signals-types '()))
(breakpoint-procedure 'INHERIT
"BKPT entered because of BREAK-ON-SIGNALS:"
condition)))
(do ((frames dynamic-handler-frames (cdr frames)))
- ((null? frames))
+ ((not (pair? frames)))
(if (let ((types (caar frames)))
- (or (null? types)
+ (or (not (pair? types))
(intersect-generalizations? types)))
(fluid-let ((dynamic-handler-frames (cdr frames)))
(hook/invoke-condition-handler (cdar frames) condition))))
(do ((frames static-handler-frames (cdr frames)))
- ((null? frames))
+ ((not (pair? frames)))
(if (let ((types (caar frames)))
- (or (null? types)
+ (or (not (pair? types))
(intersect-generalizations? types)))
(fluid-let ((static-handler-frames (cdr frames))
(dynamic-handler-frames '()))
(define (standard-error-handler condition)
(let ((hook standard-error-hook))
(if hook
- (fluid-let ((standard-error-hook false))
+ (fluid-let ((standard-error-hook #f))
(hook condition))))
- (repl/start (push-repl 'INHERIT 'INHERIT condition '() "error>")))
+ (repl/start (push-repl 'INHERIT condition '() "error>")))
(define (standard-warning-handler condition)
(let ((hook standard-warning-hook))
(if hook
- (fluid-let ((standard-warning-hook false))
+ (fluid-let ((standard-warning-hook #f))
(hook condition))
(let ((port (notification-output-port)))
(fresh-line port)
(write-condition-report condition port)
(newline port)))))
-(define standard-error-hook false)
-(define standard-warning-hook false)
+(define standard-error-hook #f)
+(define standard-warning-hook #f)
(define (condition-signaller type field-names default-handler)
(guarantee-condition-handler default-handler 'CONDITION-SIGNALLER)
(lambda (effector arguments)
(apply effector arguments)))
(set! condition-type:serious-condition
- (make-condition-type 'SERIOUS-CONDITION false '() false))
+ (make-condition-type 'SERIOUS-CONDITION #f '() #f))
(set! condition-type:warning
- (make-condition-type 'WARNING false '() false))
+ (make-condition-type 'WARNING #f '() #f))
(set! condition-type:error
- (make-condition-type 'ERROR condition-type:serious-condition '()
- false))
+ (make-condition-type 'ERROR condition-type:serious-condition '() #f))
(let ((reporter/simple-condition
(lambda (condition port)
(access-condition condition 'IRRITANTS)
port))))
(set! condition-type:simple-condition
- (make-condition-type 'SIMPLE-CONDITION false '(MESSAGE IRRITANTS)
+ (make-condition-type 'SIMPLE-CONDITION #f '(MESSAGE IRRITANTS)
reporter/simple-condition))
(set! condition-type:simple-error
(make-condition-type 'SIMPLE-ERROR condition-type:error
(let ((type (access-condition condition 'TYPE)))
(if (string? type)
(begin
- (if (and (not (string-null? type))
- (not (or (string-prefix-ci? "a " type)
- (string-prefix-ci? "an " type))))
+ (if (not (or (string-null? type)
+ (string-prefix-ci? "a " type)
+ (string-prefix-ci? "an " type)))
(write-string
(if (char-set-member? char-set:vowels
(string-ref type 0))
(define (list-of-symbols? object)
(and (list? object)
(let loop ((field-names object))
- (or (null? field-names)
+ (or (not (pair? field-names))
(and (symbol? (car field-names))
(not (memq (car field-names) (cdr field-names)))
(loop (cdr field-names)))))))
(define (keyword-association-list? object)
(and (list? object)
(let loop ((l object) (symbols '()))
- (or (null? l)
+ (or (not (pair? l))
(and (symbol? (car l))
(not (memq (car l) symbols))
- (not (null? (cdr l)))
+ (pair? (cdr l))
(loop (cddr l) (cons (car l) symbols)))))))
(define-integrable (procedure-of-arity? object arity)
#| -*-Scheme-*-
-$Id: load.scm,v 14.59 2001/12/18 22:17:06 cph Exp $
+$Id: load.scm,v 14.60 2001/12/19 05:21:42 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
;;; before opening the input file.
(define (load filename/s #!optional environment syntax-table purify?)
+ syntax-table ;ignored
(let ((environment
;; Kludge until optional defaulting fixed.
(if (or (default-object? environment)
(eq? environment default-object))
default-object
(->environment environment)))
- (syntax-table
- (if (or (default-object? syntax-table)
- (eq? syntax-table default-object)
- (eq? syntax-table 'DEFAULT))
- default-object
- (guarantee-syntax-table syntax-table 'LOAD)))
(purify?
(if (or (default-object? purify?) (eq? purify? default-object))
#f
(lambda ()
(loader pathname
environment
- syntax-table
purify?
load-noisily?))))
(cond (last-file? (load-it))
(list 'DEFAULT-OBJECT))
\f
(define (load-noisily filename #!optional environment syntax-table purify?)
+ syntax-table ;ignored
(fluid-let ((load-noisily? #t))
(load filename
;; 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)
+ 'DEFAULT
(if (default-object? purify?) default-object purify?))))
(define (load-latest . args)
(loop (cdr types) pathname (cadar types) time)
(skip)))))))
\f
-(define (load/internal pathname environment syntax-table purify? load-noisily?)
+(define (load/internal pathname environment purify? load-noisily?)
(let* ((port (open-input-file pathname))
(fasl-marker (peek-char port)))
(if (and (not (eof-object? fasl-marker))
purify?))
(let ((value-stream
(lambda ()
- (eval-stream (read-stream port) environment syntax-table))))
+ (eval-stream (read-stream port) environment))))
(if load-noisily?
(write-stream (value-stream)
(lambda (exp&value)
(fasload/update-debugging-info! value pathname)
value))
-(define (load-object-file pathname environment
- syntax-table purify? load-noisily?)
- syntax-table load-noisily? ; ignored
+(define (load-object-file pathname environment purify? load-noisily?)
+ load-noisily? ; ignored
(loading-message
load/suppress-loading-message? pathname
(lambda ()
(close-input-port port)
#t)))))
-(define (eval-stream stream environment syntax-table)
+(define (eval-stream stream environment)
(stream-map stream
(let ((repl (nearest-repl)))
(let* ((environment
(if (eq? environment default-object)
(repl/environment repl)
- environment))
- (syntax-table
- (make-syntax-table
- (if (eq? syntax-table default-object)
- (environment-syntax-table environment)
- syntax-table))))
+ environment)))
(lambda (s-expression)
(cons s-expression
- (hook/repl-eval #f
- s-expression
- environment
- syntax-table)))))))
+ (hook/repl-eval #f s-expression environment)))))))
(define (write-stream stream write)
(if (stream-pair? stream)
(fluid-let
((load
(lambda (fname #!optional env syntax-table purify?)
+ syntax-table ;ignored
(let ((env (if (default-object? env) default-object env))
(purify?
(if (default-object? purify?) default-object purify?)))
(let ((place (find-filename fname alist)))
(if (not place)
- (real-load fname
- env
- (if (default-object? syntax-table)
- default-object
- syntax-table)
- purify?)
+ (real-load fname env 'DEFAULT purify?)
(handle-load-hooks
(lambda ()
(let ((scode (caddr place)))
#| -*-Scheme-*-
-$Id: packag.scm,v 14.38 2001/12/18 20:42:50 cph Exp $
+$Id: packag.scm,v 14.39 2001/12/19 05:21:46 cph Exp $
Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
(let ((alternate-loader
(lookup-option 'ALTERNATE-PACKAGE-LOADER options))
(load-component
- (let ((syntax-table (nearest-repl/syntax-table)))
- (lambda (component environment)
- (let ((value
- (filename->compiled-object filename component)))
- (if value
- (begin
- (purify (load/purification-root value))
- (scode-eval value environment))
- (load component environment syntax-table #t)))))))
+ (lambda (component environment)
+ (let ((value
+ (filename->compiled-object filename component)))
+ (if value
+ (begin
+ (purify (load/purification-root value))
+ (scode-eval value environment))
+ (load component environment 'DEFAULT #t))))))
(if alternate-loader
(alternate-loader load-component options)
(begin
#| -*-Scheme-*-
-$Id: rep.scm,v 14.56 2001/02/27 17:21:01 cph Exp $
+$Id: rep.scm,v 14.57 2001/12/19 05:21:51 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
;;;; Read-Eval-Print Loop
(declare (usual-integrations))
-(define repl:allow-restart-notifications? true)
-(define repl:write-result-hash-numbers? true)
+(define repl:allow-restart-notifications? #t)
+(define repl:write-result-hash-numbers? #t)
(define (initialize-package!)
- (set! *nearest-cmdl* false)
+ (set! *nearest-cmdl* #f)
(set! hook/repl-eval default/repl-eval)
(set! hook/repl-write default/repl-write)
(set! hook/set-default-environment default/set-default-environment)
- (set! hook/error-decision false)
+ (set! hook/error-decision #f)
(initialize-breakpoint-condition!)
unspecific)
(call-with-current-continuation
(lambda (continuation)
(set! root-continuation continuation)
- (repl/start (make-repl false
+ (repl/start (make-repl #f
console-i/o-port
user-initial-environment
- user-initial-syntax-table
- false
+ #f
`((SET-DEFAULT-DIRECTORY
,top-level-repl/set-default-directory))
user-initial-prompt)
cmdl-rtd
'(LEVEL PARENT PORT DRIVER STATE OPERATIONS PROPERTIES))))
(lambda (parent port driver state operations)
- (if (not (or (false? parent) (cmdl? parent)))
+ (if (not (or (not parent) (cmdl? parent)))
(error:wrong-type-argument parent "cmdl" 'MAKE-CMDL))
(if (not (or parent port))
(error:bad-range-argument port 'MAKE-CMDL))
(define (cmdl/operation-names cmdl)
(let cmdl-loop ((cmdl cmdl) (names '()))
(let loop ((bindings (cmdl/operations cmdl)) (names names))
- (if (null? bindings)
- (let ((parent (cmdl/parent cmdl)))
- (if parent
- (cmdl-loop parent names)
- names))
+ (if (pair? bindings)
(loop (cdr bindings)
(if (memq (caar bindings) names)
names
- (cons (caar bindings) names)))))))
+ (cons (caar bindings) names)))
+ (let ((parent (cmdl/parent cmdl)))
+ (if parent
+ (cmdl-loop parent names)
+ names))))))
\f
;;;; Messages
(define (cmdl-message/append . messages)
(do ((messages messages (cdr messages)))
- ((null? messages))
+ ((not (pair? messages)))
(set-car! messages (->cmdl-message (car messages))))
(let ((messages (delq! %cmdl-message/null messages)))
- (cond ((null? messages)
- (cmdl-message/null))
- ((null? (cdr messages))
- (car messages))
- (else
- (lambda (cmdl)
- (for-each (lambda (message) (message cmdl)) messages))))))
+ (if (pair? messages)
+ (if (pair? (cdr messages))
+ (lambda (cmdl)
+ (for-each (lambda (message) (message cmdl)) messages))
+ (car messages))
+ (cmdl-message/null))))
(define-integrable (cmdl-message/null)
%cmdl-message/null)
(define (%cmdl-message/null cmdl)
cmdl
- false)
+ #f)
\f
;;;; Interrupts
(define (abort->previous #!optional message)
(invoke-abort (let ((restarts (find-restarts 'ABORT (bound-restarts))))
(let ((next (find-restarts 'ABORT (cdr restarts))))
- (cond ((not (null? next)) (car next))
- ((not (null? restarts)) (car restarts))
+ (cond ((pair? next) (car next))
+ ((pair? restarts) (car restarts))
(else (error:no-such-restart 'ABORT)))))
(if (default-object? message) "Up!" message)))
(define (abort->top-level #!optional message)
(invoke-abort (let loop ((restarts (find-restarts 'ABORT (bound-restarts))))
(let ((next (find-restarts 'ABORT (cdr restarts))))
- (cond ((not (null? next)) (loop next))
- ((not (null? restarts)) (car restarts))
+ (cond ((pair? next) (loop next))
+ ((pair? restarts) (car restarts))
(else (error:no-such-restart 'ABORT)))))
(if (default-object? message) "Quit!" message)))
(define (find-restarts name restarts)
(let loop ((restarts restarts))
- (if (or (null? restarts)
+ (if (or (not (pair? restarts))
(eq? name (restart/name (car restarts))))
restarts
(loop (cdr restarts)))))
\f
;;;; REP Loops
-(define (make-repl parent port environment syntax-table
+(define (make-repl parent port environment
#!optional condition operations prompt)
(make-cmdl parent
port
repl/environment
'ENVIRONMENT
->environment)
- (inherit syntax-table
- repl/syntax-table
- 'SYNTAX-TABLE
- guarantee-syntax-table)
(if (default-object? condition) #f condition)))
(append (if (default-object? operations) '() operations)
default-repl-operations)))
(error:derived-thread thread condition)
(error "Non-owner thread can't start REPL:" thread)))))))
-(define (push-repl environment syntax-table
+(define (push-repl environment
#!optional condition operations prompt)
(let ((parent (nearest-cmdl)))
(make-repl parent
#f
environment
- syntax-table
- (if (default-object? condition) false condition)
+ (if (default-object? condition) #f condition)
(if (default-object? operations) '() operations)
(if (default-object? prompt) 'INHERIT prompt))))
\f
(let ((reader-history (repl/reader-history repl))
(printer-history (repl/printer-history repl)))
(port/set-default-environment (cmdl/port repl) (repl/environment repl))
- (port/set-default-syntax-table (cmdl/port repl) (repl/syntax-table repl))
- (do () (false)
+ (do () (#f)
(let ((s-expression
(prompt-for-command-expression (cons 'STANDARD (repl/prompt repl))
(cmdl/port repl))))
(repl-history/record! reader-history s-expression)
(let ((value
- (hook/repl-eval repl
- s-expression
- (repl/environment repl)
- (repl/syntax-table repl))))
+ (hook/repl-eval repl s-expression (repl/environment repl))))
(repl-history/record! printer-history value)
(hook/repl-write repl s-expression value))))))
(define hook/repl-eval)
-(define (default/repl-eval repl s-expression environment syntax-table)
- (let ((scode (syntax s-expression syntax-table)))
+(define (default/repl-eval repl s-expression environment)
+ (let ((scode (syntax s-expression environment)))
(with-repl-eval-boundary repl
(lambda ()
(extended-scode-eval scode environment)))))
(cmdl/start repl
(make-repl-message repl
(if (default-object? message)
- false
+ #f
message))))
(define (make-repl-message repl message)
(newline port)
(do ((restarts restarts (cdr restarts))
(index (length restarts) (- index 1)))
- ((null? restarts))
+ ((not (pair? restarts)))
(write-index index port)
(write-string " " port)
(write-restart-report (car restarts) port)
(define (filter-restarts restarts)
(let loop ((restarts restarts))
- (if (null? restarts)
- '()
+ (if (pair? restarts)
(let ((rest
(if (cmdl-abort-restart? (car restarts))
(list-transform-positive (cdr restarts) cmdl-abort-restart?)
(loop (cdr restarts)))))
(if (restart/interactor (car restarts))
(cons (car restarts) rest)
- rest)))))
+ rest))
+ '())))
(define (condition-restarts-message condition)
(cmdl-message/active
(define-structure (repl-state
(conc-name repl-state/)
(constructor make-repl-state
- (prompt environment syntax-table condition)))
+ (prompt environment condition)))
prompt
environment
- syntax-table
- (condition false read-only true)
+ (condition #f read-only #t)
(reader-history (make-repl-history repl-reader-history-size))
(printer-history (make-repl-history repl-printer-history-size)))
(repl/set-default-environment repl)
(port/set-default-environment (cmdl/port repl) environment))
-(define-integrable (repl/syntax-table repl)
- (repl-state/syntax-table (cmdl/state repl)))
-
-(define (set-repl/syntax-table! repl syntax-table)
- (set-repl-state/syntax-table! (cmdl/state repl) syntax-table)
- (port/set-default-syntax-table (cmdl/port repl) syntax-table))
-
(define-integrable (repl/condition repl)
(repl-state/condition (cmdl/state repl)))
(define (nearest-repl/environment)
(repl/environment (nearest-repl)))
-(define (nearest-repl/syntax-table)
- (repl/syntax-table (nearest-repl)))
-
(define (nearest-repl/condition)
(repl/condition (nearest-repl)))
\f
(define-structure (repl-history (constructor %make-repl-history)
(conc-name repl-history/))
- (size false read-only true)
+ (size #f read-only #t)
elements)
(define (make-repl-history size)
(define (repl-history/record! history object)
(let ((elements (repl-history/elements history)))
- (if (not (null? elements))
+ (if (pair? elements)
(begin
(set-car! elements object)
(set-repl-history/elements! history (cdr elements))))))
(define (repl-history/replace-current! history object)
(let ((elements (repl-history/elements history)))
- (if (not (null? elements))
+ (if (pair? elements)
(set-car! (list-tail elements (- (repl-history/size history) 1))
object))))
(let ((package-name
(cond ((symbol? object) (list object))
((list? object) object)
- (else false))))
+ (else #f))))
(and package-name
(name->package package-name)))))
(if (not package)
(error:wrong-type-argument object "environment" procedure))
(package/environment package))))))
-(define (gst syntax-table)
- (guarantee-syntax-table syntax-table 'GST)
- (set-repl/syntax-table! (nearest-repl) syntax-table))
-
(define (re #!optional index)
(let ((repl (nearest-repl)))
(hook/repl-eval repl
index))))
(repl-history/replace-current! history s-expression)
s-expression))
- (repl/environment repl)
- (repl/syntax-table repl))))
+ (repl/environment repl))))
(define (in #!optional index)
(repl-history/read (repl/reader-history (nearest-repl))
(- (if (default-object? index) 1 index) 1)))
(define (read-eval-print environment message prompt)
- (repl/start (push-repl environment 'INHERIT false '() prompt) message))
+ (repl/start (push-repl environment #f '() prompt) message))
(define (ve environment)
- (read-eval-print (->environment environment 'VE) false 'INHERIT))
+ (read-eval-print (->environment environment 'VE) #f 'INHERIT))
(define (proceed #!optional value)
(if (default-object? value)
(fluid-let ((standard-breakpoint-hook #f))
(hook condition))))
(repl/start (push-repl (breakpoint/environment condition)
- 'INHERIT
condition
'()
(breakpoint/prompt condition))
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.389 2001/12/19 04:11:02 cph Exp $
+$Id: runtime.pkg,v 14.390 2001/12/19 05:22:04 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
condition-type:breakpoint
condition/breakpoint?
ge
- gst
in
initial-top-level-repl
make-cmdl
nearest-repl
nearest-repl/condition
nearest-repl/environment
- nearest-repl/syntax-table
out
pe
proceed
repl/prompt
repl/reader-history
repl/start
- repl/syntax-table
repl:allow-restart-notifications?
repl:write-result-hash-numbers?
repl?
set-repl/printer-history!
set-repl/prompt!
set-repl/reader-history!
- set-repl/syntax-table!
signal-breakpoint
standard-breakpoint-handler
standard-breakpoint-hook
syntax-closure/expression
syntax-closure?
syntax/top-level?
- system-global-syntax-table
- user-initial-syntax-table)
+ system-global-syntax-table)
(export (runtime defstruct)
parse-lambda-list)
(initialization (initialize-package!)))
prompt-for-expression)
(export (runtime rep)
port/set-default-environment
- port/set-default-syntax-table
port/write-result)
(export (runtime rep)
port/set-default-directory)
#| -*-Scheme-*-
-$Id: syntax.scm,v 14.38 2001/12/19 04:12:03 cph Exp $
+$Id: syntax.scm,v 14.39 2001/12/19 05:22:09 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
(set! system-global-syntax-table (make-system-global-syntax-table))
(set-environment-syntax-table! system-global-environment
system-global-syntax-table)
- (set! user-initial-syntax-table
- (make-syntax-table system-global-syntax-table))
(set-environment-syntax-table! user-initial-environment
- user-initial-syntax-table)
+ (make-syntax-table system-global-environment))
(set! syntaxer/default-environment
(extend-interpreter-environment system-global-environment))
unspecific)
(define system-global-syntax-table)
-(define user-initial-syntax-table)
(define *syntax-table*)
(define *current-keyword* #f)
(define *syntax-top-level?*)
(fluid-let ((*syntax-table*
(if (eq? table 'DEFAULT)
(if (unassigned? *syntax-table*)
- (nearest-repl/syntax-table)
+ (environment-syntax-table
+ (nearest-repl/environment))
*syntax-table*)
(guarantee-syntax-table table name)))
(*current-keyword* #f))
#| -*-Scheme-*-
-$Id: usrint.scm,v 1.16 1999/01/02 06:19:10 cph Exp $
+$Id: usrint.scm,v 1.17 2001/12/19 05:22:13 cph Exp $
-Copyright (c) 1991-1999 Massachusetts Institute of Technology
+Copyright (c) 1991-1999, 2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
|#
;;;; User Interface
port))
(if (default-object? environment)
(nearest-repl/environment)
- environment)
- (nearest-repl/syntax-table)))
+ environment)))
\f
(define (prompt-for-command-char prompt #!optional port)
(let ((prompt (canonicalize-command-prompt prompt))
(if operation
(operation port environment))))
-(define (port/set-default-syntax-table port syntax-table)
- (let ((operation (port/operation port 'SET-DEFAULT-SYNTAX-TABLE)))
- (if operation
- (operation port syntax-table))))
-
(define (port/gc-start port)
(let ((operation (port/operation port 'GC-START)))
(if (and operation (not *within-restore-window?*))
projects / mit-scheme.git / commitdiff