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

(FILECREATED "26-Oct-86 00:03:57" {ERIS}<LISPCORE>SOURCES>LLSYMBOL.;9
 12068  

      changes to%:  (FUNCTIONS CL:SYMBOL-FUNCTION UNDOABLY-SETF-SYMBOL-FUNCTION)
                    (VARS LLSYMBOLCOMS)

      previous date%: "25-Oct-86 23:07:46" {ERIS}<LISPCORE>SOURCES>LLSYMBOL.;8)


(* "
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 
                            UNDOABLY-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." (SET CL:SYMBOL 'NOBIND)

                                                       (* ; " unbound symbols are set to IL:NOBIND")

                                                             (PUTHASH CL:SYMBOL NIL COMPVARMACROHASH)

                                                             (* ; "remove any constant entry")

                                                             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)
                                     (REMPROP CL:SYMBOL 'CL:MACRO-FUNCTION)
                                     (REMPROP CL:SYMBOL 'CL::SPECIAL-FORM)
                                     CL:SYMBOL)

(CL:DEFUN CL:SYMBOL-FUNCTION
 (CL:SYMBOL &AUX (DEF (GETD CL:SYMBOL))) (COND
                                                                        (DEF)

                                                             (* ; "GETD returned non-NIL")

                                                                        ((CL:SETQ DEF (
                                                                                    CL:SPECIAL-FORM-P
                                                                                       CL:SYMBOL))

                                                  (* ; 

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

                                                                         (CONS :SPECIAL-FORM DEF))
                                                                        ((CL:SETQ DEF (
                                                                                    CL:MACRO-FUNCTION
                                                                                       CL:SYMBOL))

                                                  (* ; 

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

                                                                         (CONS :MACRO DEF))
                                                                        (T (CL:ERROR '
                                                                                  UNDEFINED-FUNCTION 
                                                                                  :NAME CL:SYMBOL))))

(CL:DEFUN SETF-SYMBOL-FUNCTION
 (CL:SYMBOL CL::DEFINITION) 
   (* ;; " inverse of SYMBOL-FUNCTION")

   (IF
 (LISTP CL::DEFINITION)
       THEN
 (CASE (CAR CL::DEFINITION)
                  (:MACRO 
                               (* ; "SYMBOL-FUNCTION conses up this list")

                         (CL:SETF (CL:MACRO-FUNCTION CL:SYMBOL)
                                (CDR CL::DEFINITION))
                         (CL:RETURN-FROM SETF-SYMBOL-FUNCTION CL::DEFINITION))
                  (:SPECIAL-FORM (CL:SETF (GET CL:SYMBOL 'SPECIAL-FORM)
                                        (CDR CL::DEFINITION))
                         (CL:RETURN-FROM SETF-SYMBOL-FUNCTION CL::DEFINITION)))
     ELSEIF
 (CL:SYMBOLP CL::DEFINITION)
       THEN
 (CL:RETURN-FROM SETF-SYMBOL-FUNCTION (PUTD CL:SYMBOL (GETD CL::DEFINITION)
                                                       T))
            CL::DEFINITION)
   (PUTD CL:SYMBOL CL::DEFINITION T))

(CL:DEFUN UNDOABLY-SETF-SYMBOL-FUNCTION
 (CL:SYMBOL CL::DEFINITION) 

                                                       (* ;; " undoable inverse of SYMBOL-FUNCTION")

   (IF
 (NULL LISPXHIST)
       THEN
 
                                                 (* ; "don't make undoable")

            (SETF-SYMBOL-FUNCTION CL:SYMBOL CL::DEFINITION)
     ELSE
 (UNDOABLY (IF
 (LISTP CL::DEFINITION)
                        THEN
 (CASE (CAR CL::DEFINITION)
                                   (:MACRO 
              (* ; "SYMBOL-FUNCTION conses up this list")

                                          (CL:SETF (CL:MACRO-FUNCTION CL:SYMBOL)
                                                 (CDR CL::DEFINITION))
                                          (CL:RETURN-FROM UNDOABLY-SETF-SYMBOL-FUNCTION 
                                                 CL::DEFINITION))
                                   (:SPECIAL-FORM (CL:SETF (GET CL:SYMBOL 'SPECIAL-FORM)
                                                         (CDR CL::DEFINITION))
                                          (CL:RETURN-FROM UNDOABLY-SETF-SYMBOL-FUNCTION 
                                                 CL::DEFINITION)))
                      ELSEIF
 (CL:SYMBOLP CL::DEFINITION)
                        THEN
 (CL:RETURN-FROM UNDOABLY-SETF-SYMBOL-FUNCTION (PUTD CL:SYMBOL
                                                                                 (GETD CL::DEFINITION
                                                                                       )
                                                                                 T))
                             CL::DEFINITION)
                 (PUTD CL:SYMBOL CL::DEFINITION 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