#| -*-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
(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
#| -*-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
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
(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))))
;;; -*-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
;;;
(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)))
;;; -*-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
;;;
(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)))
;;; -*-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
;;;
(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)
(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)))))
;;; -*-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
;;;
(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)
(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)
#| -*-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
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))
\f
-;; 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)
#| -*-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
(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)
#| -*-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
create-thread-continuation
current-thread
deregister-all-events
+ deregister-input-descriptor-events
deregister-input-thread-event
deregister-timer-event
detach-thread
#| -*-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
(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.
(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)))
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))
#| -*-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
(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))))))))
\f
(define (%register-input-thread-event descriptor thread event
permanent? front?)
;;; -*-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
;;;
(begin
(if debug:trace-substitution?
(begin
+ (fresh-line)
(pp expression)
- (newline)
(write-string "==>")
- (pp result)
(newline)
+ (pp result)
(newline)))
(optimize-by-substitution result))))
\f
-(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)
remember-on-canvas!
remove-child!
;;remove-from-protection-list!
- remove-from-registry
reset-sensitivity!
rest-segments
restart-uitk
(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")
(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)))
\f
;;;Delayed events
#| -*-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
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.
|#
;;
(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)
projects / mit-scheme.git / commitdiff