1;;; -*- *cold-load:t; 1Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10. -*-

;;;                           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.*

(PROCLAIM '(SPECIAL *KEYWORD-PACKAGE*))

(DEFMACRO REMF (PLACE PROPERTY)
  1"Removes the PROPERTY property from the plist stored in PLACE.
PLACE should be such that simply evaluating it would return
the contents of the property list."*
  (if (or (symbolp place) (get (car place) 'locf-method))
      ;; If there is a locf-method, store-form is not necessary.
      `(REMPROP (LOCF ,PLACE) ,PROPERTY)
      (multiple-value-bind (temps vals stores store-form access-form)
	  (get-setf-method place)
	(let ((stemp (first stores)))
	  `(let* (,@(mapcar #'(lambda (temp v) (list temp v)) temps vals)
		  (,stemp ,access-form))
	     (prog1
	       (remprop (locf ,stemp) ,property)
	       ,store-form))))))

(DEFSUBST KEYWORDP (SYMBOL)
  1"T if SYMBOL belongs to the KEYWORD package."*
  (AND (SYMBOLP SYMBOL)
       (EQ (SYMBOL-PACKAGE SYMBOL) *KEYWORD-PACKAGE*)))

(DEFSUBST GET-PROPERTIES (PLACE INDICATOR-LIST)
  1"Searches the property list stored in PLACE for any of the indicators
in INDICATOR-LIST until it finds the first match.  Three values are returned.
If there was a match, the first value is the matching indicator,
the second is its value, and the third is the tail of the property list 
whose CAR is the indicator.
If no property was found, all three values are NIL."*
  (GET-PROPERTIES-INTERNAL (LOCF PLACE) INDICATOR-LIST))


(DEFMACRO DEFVAR (VARIABLE . ARGS)
1  "Define a special variable named VARIABLE, and initialize to INITIAL-VALUE if unbound.
Normally, reevaluating the DEFVAR does not change the variable's value.
But in patch files, and if you do CTRL-SHIFT-E with no region on a DEFVAR,
the variable is reinitialized.  DOCUMENTATION is available if the user
asks for the documentation of the symbol VARIABLE.
If you want your variable to be initially unbound, yet have documentation, 
use :UNBOUND as the initial value."*
  (DECLARE (ARGLIST VARIABLE &OPTIONAL INITIAL-VALUE DOCUMENTATION))
  `(PROGN (EVAL-WHEN (COMPILE)
	    (SPECIAL ,VARIABLE))
	  (DEFVAR-1 ,VARIABLE . ,ARGS)))

(DEFMACRO DEFPARAMETER (VARIABLE INITIAL-VALUE . ARGS)
  1"Declare and initialize a special variable.
It is set unconditionally to the value of INITIAL-VALUE.
DOCUMENTATION is available if the user asks for the documentation of the symbol VARIABLE."*
  (DECLARE (ARGLIST VARIABLE INITIAL-VALUE &OPTIONAL DOCUMENTATION))
  `(PROGN (EVAL-WHEN (COMPILE)
	    (SPECIAL ,VARIABLE))
	  (DEFCONST-1 ,VARIABLE ,INITIAL-VALUE . ,ARGS)))

(DEFF-MACRO ZLC:DEFCONST 'DEFPARAMETER)

(DEFMACRO DEFCONSTANT (VARIABLE INITIAL-VALUE &OPTIONAL DOCUMENTATION)
  1"Define a special variable which will never be changed, and the compiler may assume so.
It is set unconditionally to the value of INITIAL-VALUE.
DOCUMENTATION is available if the user asks for the documentation of the symbol VARIABLE."*
  `(PROGN
     (EVAL-WHEN (COMPILE) (SPECIAL ,VARIABLE))
     (EVAL-WHEN (EVAL COMPILE LOAD)
       (DEFCONST-1 ,VARIABLE ,INITIAL-VALUE ,DOCUMENTATION T))))


(DEFCONSTANT SYMBOL-PACKAGE-OFFSET 4)

(DEFSUBST PACKAGE-CELL-LOCATION (SYM)
  1"Return a locative pointing to the cell in which SYMBOL's package is stored."*
  (%MAKE-POINTER-OFFSET DTP-LOCATIVE SYM SYMBOL-PACKAGE-OFFSET))

;;;  Remove so the Lisp function that executes the SYMBOL-PACKAGE miscop isn't clobbered - JK.
;(DEFSUBST SYMBOL-PACKAGE (SYM)
;  1"Return the package which SYMBOL belongs to, or NIL if none."*
;  (%P-CONTENTS-OFFSET SYM SYMBOL-PACKAGE-OFFSET))