Change `define-structure' macro to handle `named' option better,

allowing it to be a constant which is used as the tag.  This allows
redefinition of several structures in the runtime system, making them
fasdumpable.  Change handling of packages to attach a package to its
environment if that environment is not already attached to another
package.  Change the rep loop to show this package name when the
package is changed; also add command `pe' to return the current
package.

diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm
index dc3a57209877120097b5d7148ad228d80026ca58..7b14f3823a618fbea15f6cffc55fb17655661738 100644 (file)
--- a/v7/src/runtime/defstr.scm
+++ b/v7/src/runtime/defstr.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/defstr.scm,v 14.2 1988/06/16 06:26:59 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/defstr.scm,v 14.3 1988/10/29 00:12:22 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -69,11 +69,11 @@ 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.  If the structure has a PRINT-PROCEDURE
-(the default) the variable must be defined when the defstruct is
-evaluated.
+* The NAMED option may optionally take an argument, which is normally
+the name of a variable (any expression may be used, but it will be
+evaluated whenever the tag name is needed).  If used, structure
+instances will be tagged with that variable's value.  The variable
+must be defined when the defstruct is evaluated.
 
 * The TYPE option is restricted to the values VECTOR and LIST.
 
@@ -108,6 +108,10 @@ evaluated.
       (parse/options name-and-options '())))
 
 (define (parse/options name options)
+  (if (not (symbol? name))
+      (error "Structure name must be a symbol" name))
+  (if (not (list? options))
+      (error "Structure options must be a list" options))
   (let ((conc-name (symbol-append name '-))
        (constructor-seen? false)
        (keyword-constructor? false)
@@ -115,11 +119,11 @@ evaluated.
        (boa-constructors '())
        (copier-name false)
        (predicate-name (symbol-append name '?))
-       (print-procedure print-procedure/default)
+       (print-procedure default-value)
        (type-seen? false)
        (type 'STRUCTURE)
        (named-seen? false)
-       (tag-name name)
+       (tag-name default-value)
        (offset 0)
        (include false))
 
@@ -130,22 +134,23 @@ evaluated.
              (error "Structure option used with wrong number of arguments"
                     keyword
                     arguments)))
+
+       (define (symbol-option default)
+         (parse/option-value symbol? keyword (car arguments) default))
+
        (case keyword
          ((CONC-NAME)
           (check-arguments 0 1)
           (set! conc-name
                 (and (not (null? arguments))
-                     (parse/option-value (car arguments)
-                                         (symbol-append name '-)))))
+                     (symbol-option (symbol-append name '-)))))
          ((KEYWORD-CONSTRUCTOR)
           (check-arguments 0 1)
           (set! constructor-seen? true)
           (set! keyword-constructor? true)
           (if (not (null? (cdr arguments)))
               (set! constructor-name
-                    (parse/option-value (car arguments)
-                                        (symbol-append 'make- name)))))
-\f
+                    (symbol-option (symbol-append 'make- name)))))
          ((CONSTRUCTOR)
           (check-arguments 0 2)
           (cond ((null? arguments)
@@ -153,26 +158,25 @@ evaluated.
                 ((null? (cdr arguments))
                  (set! constructor-seen? true)
                  (set! constructor-name
-                       (parse/option-value (car arguments)
-                                           (symbol-append 'make- name))))
+                       (symbol-option (symbol-append 'make- name))))
                 (else
                  (set! boa-constructors (cons arguments boa-constructors)))))
          ((COPIER)
           (check-arguments 0 1)
           (if (not (null? arguments))
-              (set! copier-name
-                    (parse/option-value (car arguments)
-                                        (symbol-append 'copy- name)))))
+              (set! copier-name (symbol-option (symbol-append 'copy- name)))))
+\f
          ((PREDICATE)
           (check-arguments 0 1)
           (if (not (null? arguments))
-              (set! predicate-name
-                    (parse/option-value (car arguments)
-                                        (symbol-append name '?)))))
+              (set! predicate-name (symbol-option (symbol-append name '?)))))
          ((PRINT-PROCEDURE)
           (check-arguments 1 1)
           (set! print-procedure
-                (parse/option-value (car arguments) false)))
+                (parse/option-value (lambda (x) x true)
+                                    keyword
+                                    (car arguments)
+                                    false)))
          ((NAMED)
           (check-arguments 0 1)
           (set! named-seen? true)
@@ -192,7 +196,7 @@ evaluated.
          |#
          (else
           (error "Unrecognized structure option" keyword)))))
-\f
+
     (for-each (lambda (option)
                (if (pair? option)
                    (parse/option (car option) (cdr option))
@@ -208,7 +212,7 @@ evaluated.
            boa-constructors
            copier-name
            predicate-name
-           (if (eq? print-procedure print-procedure/default)
+           (if (eq? print-procedure default-value)
                `(,(absolute 'UNPARSER/STANDARD-METHOD) ',name)
                print-procedure)
            type
@@ -216,13 +220,16 @@ evaluated.
                  ((eq? type 'VECTOR) 'VECTOR)
                  ((eq? type 'LIST) 'LIST)
                  (else (error "Unsupported structure type" type)))
-           (or (not type-seen?) named-seen?)
-           tag-name
+           (and (or (not type-seen?) named-seen?)
+                (if (eq? tag-name default-value) 'DEFAULT true))
+           (if (eq? tag-name default-value)
+               name
+               tag-name)
            offset
            include
            '())))
 
-(define print-procedure/default
+(define default-value
   "default")
 \f
 ;;;; Parse Slot-Descriptions
@@ -242,6 +249,8 @@ evaluated.
   structure
   (let ((kernel
         (lambda (name default options)
+          (if (not (list? options))
+              (error "Structure slot options must be a list" options))
           (let ((type #T)
                 (read-only? false))
             (define (loop options)
@@ -249,10 +258,17 @@ evaluated.
                   (begin
                     (case (car options)
                       ((TYPE)
-                       (set! type (parse/option-value (cadr options) true)))
+                       (set! type
+                             (parse/option-value symbol?
+                                                 (car options)
+                                                 (cadr options)
+                                                 true)))
                       ((READ-ONLY)
                        (set! read-only?
-                             (parse/option-value (cadr options) true)))
+                             (parse/option-value boolean?
+                                                 (car options)
+                                                 (cadr options)
+                                                 true)))
                       (else
                        (error "Unrecognized structure slot option"
                               (car options))))
@@ -267,11 +283,18 @@ evaluated.
            (kernel (car slot-description) false '()))
        (kernel slot-description false '()))))
 
-(define (parse/option-value name default)
-  (case name
-    ((FALSE NIL) #F)
-    ((TRUE T) default)
-    (else name)))
+(define (parse/option-value predicate keyword option default)
+  (case option
+    ((FALSE NIL)
+     #F)
+    ((TRUE T)
+     default)
+    (else
+     (if (not (or (predicate option)
+                 (not option)
+                 (eq? option default)))
+        (error "Structure option has incorrect type" keyword option))
+     option)))
 \f
 ;;;; Descriptive Structure
 
@@ -517,8 +540,8 @@ evaluated.
 (define (type-definitions structure)
   (cond ((not (structure/named? structure))
         '())
-       ((eq? (structure/tag-name structure) (structure/name structure))
-        `((DEFINE ,(structure/name structure)
+       ((eq? (structure/named? structure) 'DEFAULT)
+        `((DEFINE ,(structure/tag-name structure)
             ',structure)))
        (else
         `((NAMED-STRUCTURE/SET-TAG-DESCRIPTION!

diff --git a/v7/src/runtime/lambda.scm b/v7/src/runtime/lambda.scm
index 580fa42a0fb5422f9c5226f2826127ee165d3213..0d6e32c357957818ef2b2ec963ed99031e79f576 100644 (file)
--- a/v7/src/runtime/lambda.scm
+++ b/v7/src/runtime/lambda.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 14.2 1988/06/16 06:28:28 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 14.3 1988/10/29 00:12:28 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -407,10 +407,8 @@ MIT in each case. |#
 (define set-lambda-body!)
 (define lambda-bound)
 
-(define-integrable block-declaration-tag
-  (string->symbol "#[Block Declaration]"))
-
-(define-structure (block-declaration (named block-declaration-tag))
+(define-structure (block-declaration
+                  (named (string->symbol "#[Block Declaration]")))
   (text false read-only true))
 \f
 ;;;; Simple Lambda/Lexpr

diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index 91783d9c255c78aa4944d5458a88e536ac1a9ff7..f5599a150881ba94854bfe29aff9729b3838a602 100644 (file)
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.4 1988/07/07 16:13:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.5 1988/10/29 00:12:33 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -227,7 +227,8 @@ MIT in each case. |#
       environment-for-package)
 ((access initialize-package! environment-for-package))
 (let loop ((names
-           '(FIND-PACKAGE
+           '(ENVIRONMENT->PACKAGE
+             FIND-PACKAGE
              NAME->PACKAGE
              PACKAGE/ADD-CHILD!
              PACKAGE/CHILD
@@ -369,4 +370,4 @@ MIT in each case. |#
 
 )
 
-(initial-top-level-repl)
\ No newline at end of file
+(package/add-child! system-global-package 'USER user-initial-environment)(initial-top-level-repl)
\ No newline at end of file

diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm
index e429e90f1ca9237718e882eb2072118c883a3de6..7d5f50c0b64ab18abd27b2e64a804eea2ac3be50 100644 (file)
--- a/v7/src/runtime/packag.scm
+++ b/v7/src/runtime/packag.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/packag.scm,v 14.5 1988/10/29 00:12:38 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -67,6 +67,16 @@ MIT in each case. |#
          (and child
               (loop (cdr path) child))))))
 
+(define (environment->package environment)
+  (and (not (lexical-unreferenceable? environment package-name-tag))
+       (let ((package (lexical-reference environment package-name-tag)))
+        (and (package? package)
+             (eq? environment (package/environment package))
+             package))))
+
+(define-integrable package-name-tag
+  (string->symbol "#[(package)package-name-tag]"))
+
 (define (find-package name)
   (let loop ((path name) (package system-global-package))
     (if (null? path)
@@ -87,6 +97,8 @@ MIT in each case. |#
       (error "Package already has child of given name" package name))
   (let ((child (make-package package name environment)))
     (set-package/children! package (cons child (package/children package)))
+    (if (not (environment->package environment))
+       (local-assignment environment package-name-tag child))
     child))
 
 (define system-global-package)

diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm
index f8aa6ae15a086e9de3962bfc1021ee43cdad1dbd..ec2a2fd3b8bd09437f5f1cdc380a3ccbc4bf8992 100644 (file)
--- a/v7/src/runtime/pathnm.scm
+++ b/v7/src/runtime/pathnm.scm
@@ -1,6 +1,6 @@
 #| -*-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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.2 1988/10/29 00:12:42 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -95,6 +95,7 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|#
 ;;;; Basic Pathnames
 
 (define-structure (pathname
+                  (named (string->symbol "#[(runtime pathname)pathname]"))
                   (copier pathname-copy)
                   (print-procedure
                    (unparser/standard-method 'PATHNAME

diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm
index 72819ec1d157d405f2c04efb9f69ca36c499bade..d26605146f6baf55d3294105da3f6ad151b70303 100644 (file)
--- a/v7/src/runtime/rep.scm
+++ b/v7/src/runtime/rep.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.7 1988/08/05 20:51:27 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.8 1988/10/29 00:12:47 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -376,8 +376,13 @@ MIT in each case. |#
 (define hook/repl-write)
 
 (define (default/repl-environment repl environment)
-  repl environment
-  false)
+  (let ((package (environment->package environment))
+       (port (cmdl/output-port repl)))
+    (if package
+       (begin
+         (write-string "\n;Package: " port)
+         (write (package/name package) port))))
+  unspecific)
 
 (define (default/repl-read repl)
   (let ((s-expression (read (cmdl/input-port repl))))
@@ -431,6 +436,13 @@ MIT in each case. |#
 (define user-repl-environment)
 (define user-repl-syntax-table)
 
+(define (pe)
+  (let ((environment (nearest-repl/environment)))
+    (let ((package (environment->package environment)))
+      (if package
+         (package/name package)
+         environment))))
+
 (define (ge environment)
   (let ((repl (nearest-repl))
        (environment (->environment environment)))

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 7d0435cee41b8e419d1b4fa222dbd4482fa432fc..d2efc32d6a09c2a6dab6b9e9a36a27e5395ef1e3 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.21 1988/10/12 07:48:24 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.22 1988/10/29 00:12:53 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -62,6 +62,7 @@ MIT in each case. |#
   (files "packag")
   (parent ())
   (export ()
+         environment->package
          find-package
          name->package
          package/add-child!
@@ -1206,6 +1207,7 @@ MIT in each case. |#
          nearest-repl/environment
          nearest-repl/syntax-table
          out
+         pe
          proceed
          prompt-for-command-char
          prompt-for-confirmation

diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index f8e89d75939cd9c5317a2c93fa59ef5fce9bbbcf..f2d03fd34d165ca4c126aebf5493d24542eaec68 100644 (file)
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.25 1988/10/21 22:22:10 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.26 1988/10/29 00:13:00 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -45,7 +45,7 @@ MIT in each case. |#
                     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 25))
+  (add-identification! "Runtime" 14 26))
 
 (define microcode-system)
 

diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm
index 33c5f6957876154a67c0010b1933dad5b00c4ae9..13e765f7de8b908fb0f2ed5150b0fe0a722ca93a 100644 (file)
--- a/v8/src/runtime/make.scm
+++ b/v8/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.4 1988/07/07 16:13:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.5 1988/10/29 00:12:33 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -227,7 +227,8 @@ MIT in each case. |#
       environment-for-package)
 ((access initialize-package! environment-for-package))
 (let loop ((names
-           '(FIND-PACKAGE
+           '(ENVIRONMENT->PACKAGE
+             FIND-PACKAGE
              NAME->PACKAGE
              PACKAGE/ADD-CHILD!
              PACKAGE/CHILD
@@ -369,4 +370,4 @@ MIT in each case. |#
 
 )
 
-(initial-top-level-repl)
\ No newline at end of file
+(package/add-child! system-global-package 'USER user-initial-environment)(initial-top-level-repl)
\ No newline at end of file

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index 9216e6a46cd948d213279372cca9fb1709a4fa8e..fe759a9ebc036f5148be25a1e9b97050fc5eb2c0 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.21 1988/10/12 07:48:24 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.22 1988/10/29 00:12:53 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -62,6 +62,7 @@ MIT in each case. |#
   (files "packag")
   (parent ())
   (export ()
+         environment->package
          find-package
          name->package
          package/add-child!
@@ -1206,6 +1207,7 @@ MIT in each case. |#
          nearest-repl/environment
          nearest-repl/syntax-table
          out
+         pe
          proceed
          prompt-for-command-char
          prompt-for-confirmation