1;-*- *cold-load:t; 1Mode: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) 1986-1989 Texas Instruments Incorporated. All rights reserved.

;; The following macro is the standard prologue for the bodies of most of the functions dealing with packages. 
;; It is not wrapped around an EVAL-WHEN since it is used by the DO-SYMBOL family of macros*

(DEFMACRO WITH-PACKAGE-OBJECT ((pack) &BODY body &aux (original-package (gensym)))
  `(LET ((,pack (FIND-PACKAGE ,pack))
	 (,original-package ,pack))
     (UNLESS ,pack (PACKAGE-DOES-NOT-EXIST-ERROR ,original-package))
     . ,body))

(DEFMACRO PKG-BIND (PKG &BODY BODY)
  1"Executes BODY with <pkg> as current package.  <pkg> is a package or the name of one."*
  (IF (EQUAL PKG "USER")
      `(LET ((*PACKAGE* *USER-PACKAGE*))	1;Optimize most common case.*
	 . ,BODY)
      `(LET ((*PACKAGE* (FIND-PACKAGE ,PKG)))
	 . ,BODY)))

1;;; THE SYMBOL-TABLE SLOT
;;; the symbol-table slot of a package object is a 2-dimensional ART-Q array each entry of which *
;1;; has one of the following formats:*
;1;;    *
;1;;    word0    word1
;;;    [ nil ] [ nil ]  -- this slot is INACTIVE
;;;    [ t   ] [ nil ]  -- this slot is also INACTIVE and represents a 'deleted' entry
;;;    [code] [symbol] -- this slot corresponds to a symbol PRESENT in the package. Word1*
;1;;                       contains the pointer to the symbol <symbol> and word0 contains a code.*
;1;;                       The lower 24 bits of word0 is obtained by applying
;;;                       %sxhash-string to the print-name of <symbol>. *
;1;;                       Bit 25, the sign bit, is set for 'external' symbols and is clear *
;1;;                       for 'internal' symbols. 
;;;  In particular, if  word0 of an entry is a number, then the entry is ACTIVE  and , *
;1;;  if negative, corresponds to an 'external' symbol. *
;1;;  The size of the symbol table is roughly 20% bigger than the size argument to make-package.
;;;  The following macros are used to access the fields of an entry in the symbol-table. The variable
;;;   <symbol-table> denotes symbol table slot of a package structure.*

;;; (the following are needed by the DO-SYMBOL macro and friends and therefore cannot be contained with an EVAL-WHEN)

(DEFMACRO P-WORD0 (symbol-table entry) 
;1; fetch word0 of <entry> in <symbol-table>*
  `(AREF ,symbol-table ,entry 0))

(DEFMACRO P-WORD1 (symbol-table entry)
;1; fetch word1 of <entry> in <symbol-table>*
  `(AREF ,symbol-table ,entry 1))

(DEFMACRO P-ACTIVE-ENTRY (word0)
;1; test word0 to see if an entry is active*
  `(NUMBERP ,word0))

(DEFMACRO P-INACTIVE-ENTRY (word0)
;1; test word0 to see if entry is inactive*
  `(SYMBOLP ,word0))

;1;  the next combines *P-WORD01 and *P-ACTIVE-ENTRY1 into a single operation*
(DEFMACRO P-ACTIVE-ENTRY-P (symbol-table slotnum) `(NUMBERP (AREF ,symbol-table ,slotnum 0)))

(DEFMACRO P-EXTERNAL-SYMBOL (word0)
;1;  tests to see if an active entry corresponds to an external symbol*
  `(MINUSP ,word0)) 

(DEFMACRO P-EXTRACT-CODE (word0)
;1; extract the hashcode stored in word0*
  `(LDB (1- %%Q-POINTER) ,word0)) 

(DEFMACRO P-MAKE-WORD0 (external-flag hash-code)
;1; create word0 from a flag and a 24-bit hashcode*
  `(%LOGDPB ,external-flag %%Q-BOXED-SIGN-BIT
	    (P-EXTRACT-CODE ,hash-code)))

(DEFMACRO P-NUMBER-OF-ENTRIES (symbol-table)
1;;  number of entries in the symbol table is the length of the symbol-table divided by 2.*
  `(ASH (LENGTH ,symbol-table) -1))  



(DEFMACRO DO-LOCAL-SYMBOLS-LOOP (variable pkg result-form &BODY body)
  (LET ((symtab (gensym))
	(limit (gensym))
	(index (gensym)))
    `(LET* ((,symtab (PACK-SYMBOL-TABLE ,pkg))
	    (,limit (P-NUMBER-OF-ENTRIES ,symtab)))	
       (DOTIMES (,index ,limit ,result-form)
	 (WHEN (P-ACTIVE-ENTRY (P-WORD0 ,symtab ,index))
	   (LET ((,variable (P-WORD1 ,symtab ,index)))
	     . ,body))))))

(DEFMACRO DO-LOCAL-SYMBOLS ((variable pack result-form) &BODY body)
1  "For EACH symbol PRESENT in package <pack>, execute <body> with <variable> 
bound to symbol.  Conclude by executing <result-form> and returning its value(s).
/(Cf. DO-SYMBOLS, DO-EXTERNAL-SYMBOLS, DO-ACCESSIBLE-EXTERNAL-SYMBOLS, DO-ALL-SYMBOLS.)"*

  (LET ((pkg (GENSYM)))
    `(LET ((,pkg ,pack))
       (WITH-PACKAGE-OBJECT (,pkg)
	 (DO-LOCAL-SYMBOLS-LOOP ,variable ,pkg ,result-form . ,body)))))

(DEFMACRO DO-EXTERNAL-SYMBOLS-LOOP (variable pkg result-form &BODY body)
  (LET ((index (GENSYM))
	(symtab (GENSYM))
	(limit (GENSYM))
	(word0 (GENSYM)))
    `(LET* ((,symtab (PACK-SYMBOL-TABLE ,pkg))
	    (,limit (P-NUMBER-OF-ENTRIES ,symtab))
	    (,word0))
       (DOTIMES (,index ,limit ,result-form)
	 (WHEN (AND (P-ACTIVE-ENTRY (SETQ ,word0 (P-WORD0 ,symtab ,index)))
		    (P-EXTERNAL-SYMBOL ,word0))
	   (LET ((,variable (P-WORD1 ,symtab ,index)))
	     . ,body))))))

(DEFMACRO DO-EXTERNAL-SYMBOLS ((variable pack result-form) &BODY body)
1  "For EACH external symbol PRESENT in package <pack>, execute <body> with <variable> 
bound to symbol.  Conclude by executing <result-form> and returning its value(s). 
/(Cf. DO-SYMBOLS, DO-LOCAL-SYMBOLS, DO-ACCESSIBLE-EXTERNAL-SYMBOLS, DO-ALL-SYMBOLS.)"*

  (LET ((pkg (GENSYM)))
    `(LET ((,pkg ,pack))
       (WITH-PACKAGE-OBJECT (,pkg)
	 (DO-EXTERNAL-SYMBOLS-LOOP ,variable ,pkg ,result-form . ,body)))))

(compiler:make-obsolete do-local-external-symbols do-external-symbols)

(deff do-local-external-symbols 'do-external-symbols)

(DEFMACRO DO-ACCESSIBLE-EXTERNAL-SYMBOLS ((variable pack result-form) &BODY body)
  1"For EACH external symbol ACCESSIBLE in package <pack>, execute <body> with <variable> 
bound to symbol.  Conclude by executing <result-form> and returning its value(s). 
/(Cf. DO-SYMBOLS, DO-LOCAL-SYMBOLS, DO-EXTERNAL-SYMBOLS, DO-ALL-SYMBOLS.)"*
  
  (LET ((pkg (GENSYM))
	(up (GENSYM)))
    `(LET ((,pkg ,pack))
       (WITH-PACKAGE-OBJECT (,pkg)
	 (DOLIST (,up (CONS (FIND-PACKAGE ,pkg) (PACKAGE-USE-LIST ,pkg))  ,result-form)
	   (DO-EXTERNAL-SYMBOLS-LOOP ,variable ,up nil . ,body))))))
  


(DEFMACRO DO-ALL-SYMBOLS ((variable result-form) &BODY body)
1  "For EACH symbol PRESENT in EACH package, execute <body> with <variable>
bound to symbol.  Conclude by executing <result-form> and returning its value(s).  
Some symbols may be processed more than once.  (Cf. DO-SYMBOLS, DO-LOCAL-SYMBOLS, 
DO-EXTERNAL-SYMBOLS, DO-ACCESSIBLE-EXTERNAL-SYMBOLS.)"*

  (LET ((up (GENSYM)))
    `(DOLIST (,up (LIST-ALL-PACKAGES) ,result-form)
       (DO-LOCAL-SYMBOLS-LOOP ,variable ,up  nil  . ,body))))

(DEFMACRO WITH-PKG-LOCK-HT (ht &REST body)
;; unlock the hash table after excuting forms in body
  `(unwind-protect
       (progn . ,body)
     (setf (car ,ht) t)))

(DEFMACRO DO-SYMBOLS ((variable pack result-form) &BODY body)
1  "For EACH symbol ACCESSIBLE in package <pack>, execute <body> with <variable>
bound to symbol.  Conclude by executing <result-form> and returning its value(s). 
/(Cf. DO-ALL-SYMBOLS, DO-LOCAL-SYMBOLS, DO-EXTERNAL-SYMBOLS, DO-ACCESSIBLE-EXTERNAL-SYMBOLS.)"*
  
  (LET ((pkg (GENSYM))
	(up  (GENSYM))
	(ssl (GENSYM))
	(ss (GENSYM))
	(ht (GENSYM))
	(htp (GENSYM)))
    `(LET ((,pkg ,pack))
       (WITH-PACKAGE-OBJECT (,pkg)
	 (LET* ((,ssl (PACK-SHADOWING-SYMBOLS ,pkg))
		(,htp (GET-UTILITY-HASH-TABLE-FOR-PACKAGE ,pkg  (MAX 25 (LENGTH ,ssl))))
		(,ht (CDR ,htp)))
	   (WITH-PKG-LOCK-HT ,htp
	     (DOLIST (,ss ,ssl) (SETF (GETHASH (SYMBOL-NAME ,ss) ,ht) ,ss))
	     (DO-LOCAL-SYMBOLS-LOOP ,variable ,pkg  nil  . ,body)
	     (DOLIST (,up (PACK-USE-LIST ,pkg))
	       (DO-EXTERNAL-SYMBOLS-LOOP ,variable ,up  nil 
		 (UNLESS (GETHASH (SYMBOL-NAME ,variable) ,ht)
		   . ,body))))
	   ,result-form)))))



(DEFMACRO DO-ALL-PACKAGES ((variable &OPTIONAL result-form) &BODY body)
  1"FOR EACH 2package* DO execute <body> with <variable>2 *bound to 2the package*.
Conclude by executing <result-form> and returning its value(s). 2This is preferrable
to LIST-ALL-PACKAGES since the latter conses.**"

  (LET ((i (GENSYM))
	(pp (GENSYM)))
    `(DOTIMES (,i *package-hash-table-size* ,result-form)
	(DOLIST (,pp (AREF *package-hash-table* ,i))
	  (WHEN (EQUAL (CAR ,pp) (PACKAGE-NAME (CDR ,pp)))  ;1; execute once for each package*
	    (LET ((,variable (CDR ,pp)))
	      .,body))))))



(Defmacro DEFPACKAGE (name &BODY alist-of-options)
1  "Defines (creates or alters) a package object named <name>.
Each element of <alist-of-options> looks like (OPTION ARGS...)
Options are:
1) :USE specifies a list of names of packages for this one to use. 
   (see USE-PACKAGE).
2) :NICKNAMES specifies a list of nicknames for this package.  The nicknames
   must be distinct from the names and nicknames of all existing packages.
3) :SHADOW specifies a list of names of symbols to shadow in this package
   (see SHADOW).
4) :EXPORT specifies a list of names of symbols to export in this package
   (see EXPORT).
5) :IMPORT specifies a list of symbols to import in this package
   (see IMPORT).
6) :SHADOWING-IMPORT specifies a list of symbols to import in this package,
    overriding any name conflicts (see SHADOWING-IMPORT).
7) :PREFIX-NAME specifies the name to be used when printing the symbols.  
   This MUST be a name or nickname of the package.
8) :AUTO-EXPORT-P non-NIL specifies that all symbols placed in this package
   should be exported automatically at that time.
9) :SIZE specifies the number of symbols to allocate space for initially."

 * `(LET* ((pkg 
	    (APPLY (IF (FIND-PACKAGE ',name) #'ALTER-PACKAGE #'MAKE-PACKAGE)
		   ',name
		   (LOOP FOR (keyword . args) IN ',alist-of-options
			 NCONC (LIST keyword (IF (OR (CDR args) (CONSP (CAR args)))  args (CAR args))))))
	  (sym (INTERN ',name *user-package*)))
     (RECORD-SOURCE-FILE-NAME sym 'defpackage)
     (SETF (GETF (PACK-PLIST pkg) :source-file-name)
	   (CADR (ASSOC 'defpackage (GET sym :source-file-name))))))