(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")

(FILECREATED "23-Oct-86 15:11:22" {ERIS}<LISPCORE>SOURCES>LLSYMBOL.;5
 9089   

      changes to%:  (VARS LLSYMBOLCOMS)
                    (FUNCTIONS CL:COPY-SYMBOL CL:MAKE-KEYWORD CL:GENTEMP CL:KEYWORDP CL:GENSYM 
                           MAKE-KEYWORD)

      previous date%: "16-Oct-86 23:52:04" {ERIS}<LISPCORE>SOURCES>LLSYMBOL.;4)


(* "
Copyright (c) 1986 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT LLSYMBOLCOMS)

(RPAQQ LLSYMBOLCOMS
 ((* ;; "Symbol functions.")
                     (* ;; "SET BOUNDP and REMPROP are already in Interlisp-D")
                     (FUNCTIONS CL:MAKUNBOUND CL:SYMBOL-NAME CL:SYMBOL-VALUE GET CL:GETF 
                            CL:GET-PROPERTIES)
                     (P (MOVD 'GETPROPLIST 'CL:SYMBOL-PLIST))
                     (FUNCTIONS CL:FBOUNDP CL:FMAKUNBOUND CL:SYMBOL-FUNCTION SETF-SYMBOL-FUNCTION)
                     (VARIABLES *GENSYM-COUNTER* *GENSYM-PREFIX*)
                     (FUNCTIONS CL:COPY-SYMBOL CL:GENSYM MAKE-KEYWORD CL:GENTEMP CL:KEYWORDP)
                     (PROP FILETYPE LLSYMBOL)))



(* ;; "Symbol functions.")





(* ;; "SET BOUNDP and REMPROP are already in Interlisp-D")


(CL:DEFUN CL:MAKUNBOUND
 (CL:SYMBOL) "Make a symbol unbound." 

                                                  (* ;; 

                "Really should make it have no value at all -- need to have an unbound dynamic value")

                                                             (SET CL:SYMBOL 'NOBIND)
                                                             CL:SYMBOL)

(CL:DEFUN CL:SYMBOL-NAME
 (CL:SYMBOL) (CL:CHECK-TYPE CL:SYMBOL CL:SYMBOL)
                                     (MKSTRING CL:SYMBOL))

(CL:DEFUN CL:SYMBOL-VALUE
 (CL:SYMBOL) 
            (* ;; "Like EVALV, but must give error if unbound - uses fact that \eval has an opcode which hooks into free variable microcode")

   (CL:CHECK-TYPE CL:SYMBOL CL:SYMBOL)
   (\EVAL CL:SYMBOL))

(CL:DEFUN GET
 (CL:SYMBOL INDICATOR &OPTIONAL (DEFAULT NIL)) "Look on the property list of SYMBOL for the specified INDICATOR. If this is found, return the associated value, else return DEFAULT."
   (CL:GETF (GETPROPLIST CL:SYMBOL)
          INDICATOR DEFAULT))

(CL:DEFUN CL:GETF
 (PLACE INDICATOR &OPTIONAL (DEFAULT NIL)) "Searches the property list stored in Place for an indicator EQ to Indicator.  If one is found, the corresponding value is returned, else the Default is returned."
   (CL:DO ((PLIST PLACE (CDDR PLIST)))
          ((NULL PLIST)
           DEFAULT)
          (COND
             ((LITATOM (CDR PLIST))
              (ERROR (CONCAT PLACE " is a malformed property list.")))
             ((EQ (CAR PLIST)
                  INDICATOR)
              (RETURN (CADR PLIST))))))

(CL:DEFUN CL:GET-PROPERTIES
 (PLACE INDICATOR-LIST) "Like GETF, except that Indicator-List is a list of indicators which will be looked for in the property list stored in Place. Three values are returned, see manual for details."
   (CL:DO ((PLIST PLACE (CDDR PLIST)))
          ((NULL PLIST)
           (CL:VALUES NIL NIL NIL))
          (COND
             ((LITATOM (CDR PLIST))
              (ERROR (CONCAT PLACE " is a malformed proprty list.")))
             ((MEMQ (CAR PLIST)
                    INDICATOR-LIST)
              (RETURN (CL:VALUES (CAR PLIST)
                             (CADR PLIST)
                             PLIST))))))

(MOVD 'GETPROPLIST 'CL:SYMBOL-PLIST)
(CL:DEFUN CL:FBOUNDP
 (FN) (AND (CL:SYMBOLP FN)
                               (OR (CL:SPECIAL-FORM-P FN)
                                   (ARGTYPE FN)
                                   (CL:MACRO-FUNCTION FN))
                               T))

(CL:DEFUN CL:FMAKUNBOUND
 (CL:SYMBOL) (PUTD CL:SYMBOL NIL)
                                     CL:SYMBOL)

(CL:DEFUN CL:SYMBOL-FUNCTION
 (CL::FN &AUX CL::TEMP) (COND
                                                       ((CL:SETQ CL::TEMP (CL:SPECIAL-FORM-P CL::FN))

                                                  (* ; 

                                   "Return something representing the special-form's implementation.")

                                                        (CONS :SPECIAL-FORM CL::TEMP))
                                                       ((CL:SETQ CL::TEMP (CL:MACRO-FUNCTION CL::FN))

                                                  (* ; 

                                          "Return something representing the macro's implementation.")

                                                        (CONS :MACRO CL::TEMP))
                                                       ((GETD CL::FN)

                                                             (* ; "Return the function definition.")

                                                        )
                                                       (T (CL:ERROR 'UNDEFINED-FUNCTION :NAME CL::FN)
                                                          )))

(CL:DEFUN SETF-SYMBOL-FUNCTION
 (FN VAL) (PUTD FN (if (CCODEP VAL)
                                                     then VAL elseif (EXPRP VAL)
                                                     then VAL elseif (LITATOM VAL)
                                                     then
                                                     (GETD VAL)
                                                     else VAL)
                                              T))

(CL:DEFVAR *GENSYM-COUNTER*
 0)

(CL:DEFVAR *GENSYM-PREFIX*
 "G" )

(CL:DEFUN CL:COPY-SYMBOL
 (SYM &OPTIONAL COPY-PROPS) (CL:CHECK-TYPE SYM CL:SYMBOL)
                                                    (LET ((NEWSYM (CL:MAKE-SYMBOL (CL:SYMBOL-NAME
                                                                                   SYM))))
                                                         (COND
                                                            (COPY-PROPS (CL:SETF (CL:SYMBOL-VALUE
                                                                                  NEWSYM)
                                                                               (CL:SYMBOL-VALUE
                                                                                SYM))
                                                                   (CL:SETF (CL:SYMBOL-FUNCTION
                                                                             NEWSYM)
                                                                          (CL:SYMBOL-FUNCTION SYM))
                                                                   (CL:SETF (CL:SYMBOL-PLIST NEWSYM)
                                                                          (COPY (CL:SYMBOL-PLIST
                                                                                 SYM)))))
                                                         NEWSYM))

(CL:DEFUN CL:GENSYM
 (&OPTIONAL X) (DECLARE (CL:SPECIAL *GENSYM-COUNTER* *GENSYM-PREFIX*))
                                  (CL:ETYPECASE X (NULL)
                                         (STRING (CL:SETF *GENSYM-PREFIX* X))
                                         (INTEGER (CL:SETF *GENSYM-COUNTER* X)))
                                  (PROG1 (CL:MAKE-SYMBOL (CONCAT *GENSYM-PREFIX* (MKSTRING 
                                                                                     *GENSYM-COUNTER*
                                                                                        )))
                                         (CL:INCF *GENSYM-COUNTER*)))

(CL:DEFUN MAKE-KEYWORD
 (CL:SYMBOL) (DECLARE (CL:SPECIAL *KEYWORD-PACKAGE*))
                                   (CL:INTERN (CL:SYMBOL-NAME CL:SYMBOL)
                                          *KEYWORD-PACKAGE*))

(CL:DEFUN CL:GENTEMP
 (&OPTIONAL (PREFIX "T")
                            (PACKAGE *PACKAGE*)) (CL:CHECK-TYPE PREFIX STRINGP)
                                                 (CL:CHECK-TYPE PACKAGE PACKAGE)
                                                 (CL:DO ((COUNTER 0 (CL:1+ COUNTER))
                                                         (CL:NAMESTRING))
                                                        ((NULL (CL:FIND-SYMBOL (SETQ CL:NAMESTRING
                                                                                (CONCAT PREFIX
                                                                                       (MKSTRING
                                                                                        COUNTER)))
                                                                      PACKAGE))
                                                         (CL:INTERN CL:NAMESTRING PACKAGE))))

(CL:DEFUN CL:KEYWORDP
 (OBJECT) (AND (CL:SYMBOLP OBJECT)
                                    (EQ (CL:SYMBOL-PACKAGE OBJECT)
                                        *KEYWORD-PACKAGE*)))


(PUTPROPS LLSYMBOL FILETYPE
 CL:COMPILE-FILE)
(PUTPROPS LLSYMBOL COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL)))
STOP