From 2972685666f850f27d59c73fb7c472a228aa99d8 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 29 Oct 1988 00:13:00 +0000 Subject: [PATCH] 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. --- v7/src/runtime/defstr.scm | 95 +++++++++++++++++++++++--------------- v7/src/runtime/lambda.scm | 8 ++-- v7/src/runtime/make.scm | 7 +-- v7/src/runtime/packag.scm | 14 +++++- v7/src/runtime/pathnm.scm | 3 +- v7/src/runtime/rep.scm | 18 ++++++-- v7/src/runtime/runtime.pkg | 4 +- v7/src/runtime/version.scm | 4 +- v8/src/runtime/make.scm | 7 +-- v8/src/runtime/runtime.pkg | 4 +- 10 files changed, 108 insertions(+), 56 deletions(-) diff --git a/v7/src/runtime/defstr.scm b/v7/src/runtime/defstr.scm index dc3a57209..7b14f3823 100644 --- 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))))) - + (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))))) + ((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))))) - + (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") ;;;; 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))) ;;;; 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 580fa42a0..0d6e32c35 100644 --- 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)) ;;;; Simple Lambda/Lexpr diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index 91783d9c2..f5599a150 100644 --- 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 e429e90f1..7d5f50c0b 100644 --- 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 f8aa6ae15..ec2a2fd3b 100644 --- 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 72819ec1d..d26605146 100644 --- 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 7d0435cee..d2efc32d6 100644 --- 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 f8e89d759..f2d03fd34 100644 --- 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 33c5f6957..13e765f7d 100644 --- 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 9216e6a46..fe759a9eb 100644 --- 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 -- 2.25.1