From 28eb1229a9e4c0efa691dc27e91f5c5e568f1962 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 2 Jun 1995 04:30:07 +0000 Subject: [PATCH] Add optional argument to PACKAGE/ADD-CHILD! to allow a new environment to overwrite a previous one. This is useful for reloading a packaged system and throwing away the old bindings. --- v7/src/runtime/packag.scm | 30 +++++++++++++++++++++--------- 1 file changed, 21 insertions(+), 9 deletions(-) diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm index 1503ad9ec..597d28d9d 100644 --- a/v7/src/runtime/packag.scm +++ b/v7/src/runtime/packag.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: packag.scm,v 14.20 1995/01/06 18:37:30 cph Exp $ +$Id: packag.scm,v 14.21 1995/06/02 04:30:07 cph Exp $ Copyright (c) 1988-95 Massachusetts Institute of Technology @@ -68,6 +68,9 @@ MIT in each case. |# (define-integrable (package/environment package) (%record-ref package 4)) +(define-integrable (set-package/environment! package environment) + (%record-set! package 4 environment)) + (define (finalize-package-record-type!) (let ((rtd (make-record-type "package" '(PARENT CHILDREN %NAME ENVIRONMENT)))) @@ -132,14 +135,23 @@ MIT in each case. |# '() (cons (car list) (loop (cdr list)))))) -(define (package/add-child! package name environment) - (if (package/child package name) - (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 (interpreter-environment->package environment)) - (local-assignment environment package-name-tag child)) - child)) +(define (package/add-child! package name environment #!optional force?) + (let ((child (package/child package name)) + (finish + (lambda (child) + (if (not (interpreter-environment->package environment)) + (local-assignment environment package-name-tag child)) + child))) + (if child + (if (and (not (default-object? force?)) force?) + (begin + (set-package/environment! child environment) + (finish child)) + (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))) + (finish child))))) (define system-global-package) -- 2.25.1