From 3a7edb7535ec61ea5e171bcb2195116f578331ab Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 20 Dec 2001 16:13:19 +0000 Subject: [PATCH] Eliminate IN-PACKAGE and USING-SYNTAX special forms. --- v7/src/6001/make.scm | 43 ++++++++++++++++--------------- v7/src/compiler/rtlopt/rdebug.scm | 9 ++++--- v7/src/edwin/artdebug.scm | 5 ++-- v7/src/edwin/debug.scm | 17 ++++++------ v7/src/edwin/kmacro.scm | 31 +++++++++++----------- v7/src/edwin/schmod.scm | 4 +-- v7/src/imail/fake-env.scm | 4 +-- v7/src/pcsample/load.scm | 16 +++--------- v7/src/runtime/pp.scm | 6 ++--- v7/src/runtime/runtime.pkg | 3 ++- v7/src/runtime/syntax.scm | 16 +----------- v7/src/runtime/thread.scm | 20 +++++++++++++- v7/src/star-parser/shared.scm | 6 ++--- v7/src/swat/scheme/load.scm | 12 +++------ v7/src/swat/scheme/mit-xhooks.scm | 23 +---------------- v7/src/win32/wt_user.scm | 14 +++++++--- 16 files changed, 103 insertions(+), 126 deletions(-) diff --git a/v7/src/6001/make.scm b/v7/src/6001/make.scm index d40751463..f56428874 100644 --- a/v7/src/6001/make.scm +++ b/v7/src/6001/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 15.32 2001/08/18 04:50:22 cph Exp $ +$Id: make.scm,v 15.33 2001/12/20 16:13:18 cph Exp $ Copyright (c) 1991-1999, 2001 Massachusetts Institute of Technology @@ -34,37 +34,38 @@ USA. (load-package-set "6001") (if (and (eq? 'UNIX microcode-id/operating-system) (string-ci=? "HP-UX" microcode-id/operating-system-variant)) - (load "floppy" (->environment '(edwin)))))))) + (load "floppy" (->environment '(EDWIN)))))))) (add-identification! "6.001" 15 30) ;;; Customize the runtime system: -(set! repl:allow-restart-notifications? false) -(set! repl:write-result-hash-numbers? false) -(set! *unparse-disambiguate-null-as-itself?* false) +(set! repl:allow-restart-notifications? #f) +(set! repl:write-result-hash-numbers? #f) +(set! *unparse-disambiguate-null-as-itself?* #f) (set! *unparse-disambiguate-null-lambda-list?* true) (set! *pp-default-as-code?* true) (set! *pp-named-lambda->define?* 'LAMBDA) (set! x-graphics:auto-raise? true) (set! (access write-result:undefined-value-is-special? - (->environment '(runtime user-interface))) - false) + (->environment '(RUNTIME USER-INTERFACE))) + #f) (set! hook/exit (lambda (integer) integer (warn "EXIT has been disabled."))) (set! hook/quit (lambda () (warn "QUIT has been disabled."))) -(set! user-initial-environment (->environment '(student))) -(in-package (->environment '(edwin)) +(let ((edwin-env (->environment '(EDWIN))) + (student-env (->environment '(STUDENT)))) + ;; These defaults will be overridden when the editor is started. - (set! student-root-directory "~u6001/") - (set! student-work-directory "~/work/") - (set! pset-directory "~u6001/psets/") - (set! pset-list-file "~u6001/psets/probsets.scm")) + (set! (access student-root-directory edwin-env) "~u6001/") + (set! (access student-work-directory edwin-env) "~/work/") + (set! (access pset-directory edwin-env) "~u6001/psets/") + (set! (access pset-list-file edwin-env) "~u6001/psets/probsets.scm") + + (environment-define student-env 'U6001-DIR + (lambda (filename) + (->namestring + (merge-pathnames filename (access student-root-directory edwin-env))))) + (environment-define student-env 'NIL #f) -(in-package (->environment '(student)) - (define u6001-dir - (let ((edwin (->environment '(edwin)))) - (lambda (filename) - (->namestring - (merge-pathnames filename (access student-root-directory edwin)))))) - (define nil #f)) + (set! user-initial-environment student-env)) -(ge '(student)) \ No newline at end of file +(ge user-initial-environment) \ No newline at end of file diff --git a/v7/src/compiler/rtlopt/rdebug.scm b/v7/src/compiler/rtlopt/rdebug.scm index b879e8e6b..ab6e7c99c 100644 --- a/v7/src/compiler/rtlopt/rdebug.scm +++ b/v7/src/compiler/rtlopt/rdebug.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: rdebug.scm,v 1.3 1999/01/02 06:06:43 cph Exp $ +$Id: rdebug.scm,v 1.4 2001/12/20 16:13:18 cph Exp $ -Copyright (c) 1987, 1999 Massachusetts Institute of Technology +Copyright (c) 1987, 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 @@ -16,7 +16,8 @@ General Public License for more details. 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. |# ;;;; RTL Optimizer Debugging Output @@ -56,9 +57,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (lambda (register) (regset-adjoin! machine-regs register))) (for-each (lambda (bblock) - (newline) (newline) (write bblock) + (newline) (bblock-walk-forward bblock (lambda (rinst) (pp (rinst-rtl rinst)))) diff --git a/v7/src/edwin/artdebug.scm b/v7/src/edwin/artdebug.scm index 4e69560f3..5e080d2c9 100644 --- a/v7/src/edwin/artdebug.scm +++ b/v7/src/edwin/artdebug.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: artdebug.scm,v 1.29 2001/12/19 05:25:08 cph Exp $ +;;; $Id: artdebug.scm,v 1.30 2001/12/20 16:13:18 cph Exp $ ;;; ;;; Copyright (c) 1989-1999, 2001 Massachusetts Institute of Technology ;;; @@ -662,8 +662,7 @@ Move to the last subproblem if the subproblem number is too high." (write-string string port))) (pp (lambda (obj) (fresh-line port) - (pretty-print obj port #t) - (newline port)))) + (pp obj port #t)))) (if (dstate/reduction-number dstate) (pp (reduction-expression (dstate/reduction dstate))) diff --git a/v7/src/edwin/debug.scm b/v7/src/edwin/debug.scm index de33e7037..33bc5b561 100644 --- a/v7/src/edwin/debug.scm +++ b/v7/src/edwin/debug.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: debug.scm,v 1.58 2001/12/19 05:25:21 cph Exp $ +;;; $Id: debug.scm,v 1.59 2001/12/20 16:13:18 cph Exp $ ;;; ;;; Copyright (c) 1992-2001 Massachusetts Institute of Technology ;;; @@ -1673,13 +1673,14 @@ once it has been renamed, it will not be deleted automatically.") (let ((indentation (+ (string-length name1) (string-length separator)))) - (write-string (string-tail (with-output-to-string - (lambda () - (pp value - (current-output-port) - #t - indentation))) - indentation) + (write-string (string-tail + (with-output-to-string + (lambda () + (pretty-print value + (current-output-port) + #t + indentation))) + indentation) port))))) (debugger-newline port))) diff --git a/v7/src/edwin/kmacro.scm b/v7/src/edwin/kmacro.scm index 100bcbf92..4f287ba19 100644 --- a/v7/src/edwin/kmacro.scm +++ b/v7/src/edwin/kmacro.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: kmacro.scm,v 1.43 2001/07/21 05:49:25 cph Exp $ +;;; $Id: kmacro.scm,v 1.44 2001/12/20 16:13:18 cph Exp $ ;;; ;;; Copyright (c) 1985, 1989-2001 Massachusetts Institute of Technology ;;; @@ -166,7 +166,7 @@ To make a macro permanent so you can call it even after (define-command write-kbd-macro "Save keyboard macro in file. -Use LOAD to load the file. +Use \\[load-file] to load the file. With argument, also record the keys it is bound to." "P" (lambda (argument) @@ -184,20 +184,19 @@ With argument, also record the keys it is bound to." (buffer (temporary-buffer "*write-keyboard-macro-temp*"))) (call-with-output-mark (buffer-point buffer) (lambda (port) - (pretty-print - `(IN-PACKAGE EDWIN-PACKAGE - (KEYBOARD-MACRO-DEFINE - ',name - ',(string-table-get named-keyboard-macros name)) - ,@(if argument - (map (lambda (key) - `(DEFINE-KEY 'FUNDAMENTAL ',key ',name)) - (comtab-key-bindings - (mode-comtabs (ref-mode-object fundamental)) - (name->command name))) - '())) - port - #t))) + (pp `(KEYBOARD-MACRO-DEFINE + ',name + ',(string-table-get named-keyboard-macros name)) + port + #t) + (if argument + (for-each (lambda (key) + (pp `(DEFINE-KEY 'FUNDAMENTAL ',key ',name) + port + #t)) + (comtab-key-bindings + (mode-comtabs (ref-mode-object fundamental)) + (name->command name)))))) (set-buffer-pathname! buffer pathname) (write-buffer buffer) (kill-buffer buffer))))) diff --git a/v7/src/edwin/schmod.scm b/v7/src/edwin/schmod.scm index 7c50d7196..43431caf9 100644 --- a/v7/src/edwin/schmod.scm +++ b/v7/src/edwin/schmod.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: schmod.scm,v 1.55 2001/12/19 05:25:43 cph Exp $ +;;; $Id: schmod.scm,v 1.56 2001/12/20 16:13:18 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology ;;; @@ -164,13 +164,11 @@ The following commands evaluate Scheme expressions: (DEFINE-STRUCTURE . 1) (FLUID-LET . 1) - (IN-PACKAGE . 1) (LET-SYNTAX . 1) (LOCAL-DECLARE . 1) (MACRO . 1) (MAKE-ENVIRONMENT . 0) (NAMED-LAMBDA . 1) - (USING-SYNTAX . 1) (CALL-WITH-APPEND-FILE . 1) (CALL-WITH-BINARY-APPEND-FILE . 1) diff --git a/v7/src/imail/fake-env.scm b/v7/src/imail/fake-env.scm index 77766cd92..a578a08e4 100644 --- a/v7/src/imail/fake-env.scm +++ b/v7/src/imail/fake-env.scm @@ -3,8 +3,8 @@ (let ((package (name->package parent))) (package/add-child! package name - (in-package (package/environment package) - (make-environment))))))) + (extend-interpreter-environment + (package/environment package))))))) (new-child '(EDWIN) 'IMAIL) (new-child '(EDWIN IMAIL) 'IMAP-RESPONSE) (new-child '(EDWIN IMAIL) 'IMAP-SYNTAX) diff --git a/v7/src/pcsample/load.scm b/v7/src/pcsample/load.scm index db6507e11..43c0ca4b4 100644 --- a/v7/src/pcsample/load.scm +++ b/v7/src/pcsample/load.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: load.scm,v 1.5 1999/01/02 06:11:34 cph Exp $ +$Id: load.scm,v 1.6 2001/12/20 16:13:18 cph Exp $ -Copyright (c) 1995-1999 Massachusetts Institute of Technology +Copyright (c) 1995-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 @@ -16,22 +16,14 @@ General Public License for more details. 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. |# ;;;; System Packaging (declare (usual-integrations)) -;; This kludge keeps the 7.4 and 8.0 sources the same: - -(let ((compiler-info (->environment '(runtime compiler-info)))) - (if (environment-bound? compiler-info 'COMPILED-ENTRY/FILENAME) - (in-package compiler-info - (define compiled-entry/filename-and-index compiled-entry/filename) - (define compiled-code-block/filename-and-index - compiled-code-block/filename)))) - (package/system-loader "pcs" '() 'QUERY) (add-identification! "PC Sampler" 1 0) diff --git a/v7/src/runtime/pp.scm b/v7/src/runtime/pp.scm index 5c531fd01..59f923152 100644 --- a/v7/src/runtime/pp.scm +++ b/v7/src/runtime/pp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: pp.scm,v 14.42 2001/07/02 18:47:51 cph Exp $ +$Id: pp.scm,v 14.43 2001/12/20 16:13:18 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -70,8 +70,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let ((port (if (default-object? port) (current-output-port) port))) (let ((pretty-print (lambda (object) - (fresh-line port) - (apply pretty-print object port rest)))) + (apply pretty-print object port rest) + (newline port)))) (cond ((pp-description object) => (lambda (description) (pretty-print object) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 20cbbb0be..cd41dbb21 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.393 2001/12/20 06:52:30 cph Exp $ +$Id: runtime.pkg,v 14.394 2001/12/20 16:13:18 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -3919,6 +3919,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA create-thread-continuation current-thread deregister-all-events + deregister-input-descriptor-events deregister-input-thread-event deregister-timer-event detach-thread diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm index a9073ecc2..0ae79bf64 100644 --- a/v7/src/runtime/syntax.scm +++ b/v7/src/runtime/syntax.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: syntax.scm,v 14.41 2001/12/20 06:52:03 cph Exp $ +$Id: syntax.scm,v 14.42 2001/12/20 16:13:18 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -66,11 +66,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (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. @@ -338,11 +336,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define (syntax/begin top-level? . actions) (syntax-sequence top-level? actions)) -(define (syntax/in-package top-level? environment . body) - top-level? - (make-in-package (syntax-subexpression environment) - (make-scode-sequence (syntax-sequence-internal #t body)))) - (define (syntax/delay top-level? expression) top-level? (make-delay (syntax-subexpression expression))) @@ -450,13 +443,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA values)))) (syntax-sequence top-level? body))))) -(define (syntax/using-syntax top-level? table . body) - (let ((table* (syntax-eval (syntax-subexpression table)))) - (if (not (syntax-table? table*)) - (syntax-error "not a syntax table" table)) - (fluid-let ((*syntax-table* table*)) - (syntax-sequence top-level? body)))) - (define (syntax/define-syntax top-level? name value) top-level? (if (not (symbol? name)) diff --git a/v7/src/runtime/thread.scm b/v7/src/runtime/thread.scm index ab9ff16b6..c85f30cb7 100644 --- a/v7/src/runtime/thread.scm +++ b/v7/src/runtime/thread.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: thread.scm,v 1.34 2001/04/03 03:44:02 cph Exp $ +$Id: thread.scm,v 1.35 2001/12/20 16:13:18 cph Exp $ Copyright (c) 1991-1999 Massachusetts Institute of Technology @@ -508,6 +508,24 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (lambda () (%deregister-input-thread-event tentry) (%maybe-toggle-thread-timer)))) + +(define (deregister-input-descriptor-events descriptor) + (without-interrupts + (lambda () + (let loop ((dentry input-registrations)) + (if dentry + (if (eqv? descriptor (dentry/descriptor dentry)) + (begin + (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor)) + (remove-from-select-registry! input-registry descriptor)) + (let ((prev (dentry/prev dentry)) + (next (dentry/next dentry))) + (if prev + (set-dentry/next! prev next) + (set! input-registrations next)) + (if next + (set-dentry/prev! next prev)))) + (loop (dentry/next dentry)))))))) (define (%register-input-thread-event descriptor thread event permanent? front?) diff --git a/v7/src/star-parser/shared.scm b/v7/src/star-parser/shared.scm index 3dd28613f..70743f892 100644 --- a/v7/src/star-parser/shared.scm +++ b/v7/src/star-parser/shared.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: shared.scm,v 1.21 2001/11/20 04:13:00 cph Exp $ +;;; $Id: shared.scm,v 1.22 2001/12/20 16:13:18 cph Exp $ ;;; ;;; Copyright (c) 2001 Massachusetts Institute of Technology ;;; @@ -398,11 +398,11 @@ (begin (if debug:trace-substitution? (begin + (fresh-line) (pp expression) - (newline) (write-string "==>") - (pp result) (newline) + (pp result) (newline))) (optimize-by-substitution result)))) diff --git a/v7/src/swat/scheme/load.scm b/v7/src/swat/scheme/load.scm index 25f48f42a..9338147fe 100644 --- a/v7/src/swat/scheme/load.scm +++ b/v7/src/swat/scheme/load.scm @@ -19,10 +19,7 @@ -(let ((swat-env - (in-package system-global-environment - (let () - (the-environment))))) +(let ((swat-env (extend-interpreter-environment system-global-environment))) (package/add-child! (find-package '()) 'SWAT swat-env) @@ -595,7 +592,6 @@ remember-on-canvas! remove-child! ;;remove-from-protection-list! - remove-from-registry reset-sensitivity! rest-segments restart-uitk @@ -1010,10 +1006,10 @@ (directory-pathname (current-load-pathname)) (lambda () - (in-package (->environment '(SWAT)) + (let ((swat-env (->environment '(SWAT)))) ;; These get overriden when TK is loaded - (define (tk-doevents) 'tk-doevents) - (define (tk-init dsp) 'tk-init)) + (environment-define-name swat-env 'TK-DOEVENTS (lambda () 'TK-DOEVENTS)) + (environment-define-name swat-env 'TK-INIT (lambda () 'TK-INIT))) ;; Dynamically load the microcode. Order important. (load "dynload/scxl") diff --git a/v7/src/swat/scheme/mit-xhooks.scm b/v7/src/swat/scheme/mit-xhooks.scm index 390d265f1..8a85e6bb7 100644 --- a/v7/src/swat/scheme/mit-xhooks.scm +++ b/v7/src/swat/scheme/mit-xhooks.scm @@ -349,29 +349,8 @@ end of debugging stuff (deregister-input-thread-event registration) 'OK) -(define remove-from-registry - ;; This is called with a file descriptor when the file is closed to - ;; remove any registered requests for activity on the file. - (in-package (->environment '(runtime thread)) - (lambda (descriptor) - (let loop ((dentry input-registrations)) - (cond ((null? dentry) 'NOT-FOUND) - ((eq? descriptor (dentry/descriptor dentry)) - (without-interrupts - (lambda () - (remove-from-select-registry! input-registry descriptor) - (let ((prev (dentry/prev dentry)) - (next (dentry/next dentry))) - (if prev - (set-dentry/next! prev next) - (set! input-registrations next)) - (if next - (set-dentry/prev! next prev))))) - 'REMOVED) - (else (loop (dentry/next dentry)))))))) - (define (shut-down-event-server display-number) - (remove-from-registry (%XConnectionNumber display-number))) + (deregister-input-descriptor-events (%XConnectionNumber display-number))) ;;;Delayed events diff --git a/v7/src/win32/wt_user.scm b/v7/src/win32/wt_user.scm index 556557cfd..50ccafcc1 100644 --- a/v7/src/win32/wt_user.scm +++ b/v7/src/win32/wt_user.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: wt_user.scm,v 1.4 1999/01/02 06:19:10 cph Exp $ +$Id: wt_user.scm,v 1.5 2001/12/20 16:13:19 cph Exp $ -Copyright (c) 1993, 1999 Massachusetts Institute of Technology +Copyright (c) 1993, 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 @@ -16,7 +16,8 @@ General Public License for more details. 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. |# ;; @@ -138,7 +139,12 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define (pp-paintstruct r) (define (pp-field name accessor) - (newline)(display "(") (display name) (display " ") (display (accessor r)) (display ")") ) + (display "(") + (display name) + (display " ") + (display (accessor r)) + (display ")") + (newline)) (pp r) (pp-field 'hdc paintstruct/hdc) (pp-field 'f-erase paintstruct/f-erase) -- 2.25.1