;-*- cold-load:t; Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:10; Fonts:(CPTFONT CPTFONTB) -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; Copyright (C) 1985-1989 Texas Instruments Incorporated. All rights reserved. ;;; 4/28/89 Fixed pkg-initialize to set up CL ;;; 4/25/89 JLM fixed LOCATE-DUP-SYMBOLS to ignore symbols that have nil package. (Defvar *PKG-HACK*) ;; a list of all symbols found in the package cell of a symbol in nr-sym (Defvar *kernel-symbol-package* sys:nr-sym "A nickname for NR-SYM the place where kernel-symbols reside") (Defvar PKG-AREA si:working-storage-area "The area which packages are consed in.") (DEFUN make-named-package (name symbol) (let ((pack-options (cdr (assoc (the string name) initial-packages :test #'string-equal)))) (if pack-options (set symbol (apply #'make-package name pack-options)) (ferror nil "This should never happen!")))) ;;; Create the packages that should initially exist, ;;; and fill them with the appropriate symbols. ;; 3/16/89 DNG - Added MAKE-INSTANCE to ZLC shadow list. (Defun PKG-INITIALIZE () (DECLARE (SPECIAL *PACKAGE-HASH-TABLE* *INITIAL-COMMON-LISP-SYMBOLS* *INITIAL-TICL-SYMBOLS* *INITIAL-ZLC-SYMBOLS* *EXTERNAL-ZLC-SYMBOLS* *EXTERNAL-SYSTEM-SYMBOLS*)) (SETQ *PACK-BAD-SYMBOLS* NIL *SYMBOLS-SEEN-TWICE* NIL *MULTIPLE-SYMBOL-BLOCKS* NIL) (SETQ *PACKAGE-HASH-TABLE* (MAKE-ARRAY *package-hash-table-size* :AREA pkg-area )) (make-named-package "KEYWORD" '*KEYWORD-PACKAGE*) (make-named-package "TICL" '*TICL-PACKAGE*) ;Must make TICL before LISP (make-named-package "LISP" '*LISP-PACKAGE*) (make-named-package "COMMON-LISP" '*COMMON-LISP-PACKAGE*) (make-named-package "SYSTEM" '*SYSTEM-PACKAGE*) (make-named-package "ZLC" '*ZLC-PACKAGE*) (make-named-package "GLOBAL" '*GLOBAL-PACKAGE*) (make-named-package "COMPILER" 'PKG-COMPILER-PACKAGE) (make-named-package "USER" '*USER-PACKAGE*) (make-named-package "COMMON-LISP-USER" '*COMMON-LISP-USER-PACKAGE*) ;; Intern the LISP, TICL, and ZLC symbols. (DOLIST (SYM *INITIAL-COMMON-LISP-SYMBOLS*) (BOOTSTRAP-INTERN-AND-OPTIONALLY-EXPORT SYM *LISP-PACKAGE* T)) (DOLIST (SYM *INITIAL-COMMON-LISP-SYMBOLS*) (BOOTSTRAP-INTERN-AND-OPTIONALLY-EXPORT SYM *COMMON-LISP-PACKAGE* T)) (DOLIST (SYM *INITIAL-TICL-SYMBOLS*) (BOOTSTRAP-INTERN-AND-OPTIONALLY-EXPORT SYM *TICL-PACKAGE* T)) (DOLIST (SYM *INITIAL-ZLC-SYMBOLS*) (BOOTSTRAP-INTERN-AND-OPTIONALLY-EXPORT SYM *ZLC-PACKAGE* NIL)) (BOOTSTRAP-EXPORT *EXTERNAL-ZLC-SYMBOLS* *ZLC-PACKAGE*) ;; export (SETF (PACK-SHADOWING-SYMBOLS *ZLC-PACKAGE*) 'ZLC:(/ *DEFAULT-PATHNAME-DEFAULTS* APPLYHOOK AR-1 AR-1-FORCE AREF ASSOC ATAN CHARACTER CLOSE DEFSTRUCT DELETE EVAL EVALHOOK EVERY FLOAT FORMAT INTERSECTION LAMBDA LISTP MAKE-HASH-TABLE MAKE-INSTANCE MAP MEMBER NAMED-LAMBDA NAMED-SUBST NINTERSECTION NLISTP NUNION PACKAGE RASSOC READ READ-FROM-STRING READTABLE REM REMOVE SOME STRING SUBST TERPRI UNION)) ;; Set up the GLOBAL package. (dolist (pkg '(ticl lisp)) (do-external-symbols (sym pkg) (unless (assoc sym *zetalisp-symbol-substitutions* :test #'eq) (bootstrap-intern-and-optionally-export sym *global-package* t)))) (do-local-symbols (sym 'zlc t) (bootstrap-intern-and-optionally-export sym *global-package* t)) (DOLIST (elem initial-packages) (unless (find-package (car elem)) (APPLY #'MAKE-PACKAGE (car elem)(cdr elem)))) ;; We have packages!! (SETQ *PACKAGE* *USER-PACKAGE*) ;; Put system variables and system constants in the SYSTEM package ;; (unless they are already in the LISP or TICL package). (DOLIST (LIST SYSTEM-VARIABLE-LISTS) (DOLIST (VAR (SYMBOL-VALUE LIST)) (BOOTSTRAP-INTERN-AND-OPTIONALLY-EXPORT VAR *SYSTEM-PACKAGE* T))) (DOLIST (LIST SYSTEM-CONSTANT-LISTS) (DOLIST (VAR (SYMBOL-VALUE LIST)) (BOOTSTRAP-INTERN-AND-OPTIONALLY-EXPORT VAR *SYSTEM-PACKAGE* T))) (DOLIST (VAR A-MEMORY-COUNTER-BLOCK-NAMES) (BOOTSTRAP-INTERN-AND-OPTIONALLY-EXPORT VAR *SYSTEM-PACKAGE* T)) (SETQ *PKG-HACK* NIL) ;; **** DEBUG ;; Now all other system symbols go in the SYSTEM package, unless the cold-load ;; has specified a different place for them to go. Symbols shared among various ;; systems programs are made external, while all the others remain internal. (MAPATOMS-NR-SYM #'(LAMBDA (SYM &AUX PKG PKG1) (UNLESS (PACKAGEP (SETQ PKG1 (SYMBOL-PACKAGE SYM))) ;already interned on a package (UNLESS (ASSOC PKG1 *PKG-HACK* :TEST #'EQ) (PUSH (CONS PKG1 SYM) *PKG-HACK*)) (SETF (SYMBOL-PACKAGE SYM) NIL) (SETQ PKG (OR (AND PKG1 (OR (FIND-PACKAGE PKG1) (MAKE-PACKAGE PKG1))) *SYSTEM-PACKAGE*)) (WHEN (EQ PKG *KEYWORD-PACKAGE*) (SET SYM SYM)) (BOOTSTRAP-INTERN-AND-OPTIONALLY-EXPORT SYM PKG)))) (BOOTSTRAP-EXPORT *EXTERNAL-SYSTEM-SYMBOLS* *SYSTEM-PACKAGE*) (SETQ ARRAY-TYPE-KEYWORDS (LOOP FOR A IN ARRAY-TYPES COLLECT (INTERN (STRING A) *KEYWORD-PACKAGE*))) ;; Must SHADOW after BOOTSTRAP-INTERN to prevent allocation of multiple symbol blocks - JK (shadow "ARG" 'eh) (locate-dup-symbols) T) (defvar *dup-symbols* nil) (defun locate-dup-symbols () ;;; locate multiple copies of symbols -- (setf *dup-symbols* nil) (si:mapatoms-nr-sym #'(lambda (s) (let* ((name (symbol-name s)) (pack (symbol-package s)) (cs (find-symbol name pack))) (if (and pack (not (eq cs s))) ; jlm 4/25/89 (progn (push (cons cs s) *dup-symbols*)))))) 'done) (Defun Forward-compiler-variable (from-symbol to-symbol) (check-arg from-symbol symbolp "a symbol") (check-arg to-symbol symbolp "a symbol") (and (eq from-symbol to-symbol) (ferror nil "Forwarding symbol's value to itself")) (%p-store-tag-and-pointer (value-cell-location from-symbol) DTP-One-Q-Forward (value-cell-location to-symbol)) (%p-store-tag-and-pointer (function-cell-location from-symbol) DTP-One-Q-Forward (function-cell-location to-symbol)) (%p-store-tag-and-pointer (property-cell-location from-symbol) DTP-One-Q-Forward (property-cell-location to-symbol))) (defvar *compiler-duplicated-symbols* nil) (defun symbol-with-something? (symbol) (or (fboundp symbol) (boundp symbol) (symbol-plist symbol))) (defun disambiguate-compiler-symbols() (let ((cp (find-package 'compiler))) (dolist (pair *dup-symbols*) (when (eq (symbol-package (car pair)) cp) (push pair *compiler-duplicated-symbols*)))) (dolist (pair *compiler-duplicated-symbols* 'done) (cond ((or (symbol-with-something? (car pair)) (symbol-with-something? (cdr pair))) (if (symbol-with-something? (car pair)) (forward-compiler-variable (cdr pair) (car pair)) (forward-compiler-variable (car pair) (cdr pair)))) (t (forward-compiler-variable (car pair) (cdr pair))))))