(FILECREATED " 9-Oct-86 18:21:37" {ERIS}<LISPCORE>SOURCES>LLSYMBOL.;2
 7754   

      changes to:  (FUNCTIONS SYMBOL-FUNCTION)

      previous date: " 3-Sep-86 16:24:17" {ERIS}<LISPCORE>SOURCES>LLSYMBOL.;1)


(* "
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 MAKUNBOUND SYMBOL-NAME SYMBOL-VALUE GET GETF GET-PROPERTIES)
                     (P (MOVD (QUOTE GETPROPLIST)
                              (QUOTE SYMBOL-PLIST)))
                     (FUNCTIONS FBOUNDP FMAKUNBOUND SYMBOL-FUNCTION SETF-SYMBOL-FUNCTION)
                     (VARIABLES *GENSYM-COUNTER* *GENSYM-PREFIX*)
                     (FUNCTIONS CL:COPY-SYMBOL CL:GENSYM CL:MAKE-KEYWORD CL:GENTEMP CL:KEYWORDP)
                     (PROP FILETYPE LLSYMBOL)))



(* ;; "Symbol functions.")





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


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

                                                  (* ;; 

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

                                                    (SET SYMBOL (QUOTE NOBIND))
                                                    SYMBOL)

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

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

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

(DEFUN GET
 (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."
   (GETF (GETPROPLIST SYMBOL)
         INDICATOR DEFAULT))

(DEFUN 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))))))

(DEFUN 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)
           (VALUES NIL NIL NIL))
          (COND
             ((LITATOM (CDR PLIST))
              (ERROR (CONCAT PLACE " is a malformed proprty list.")))
             ((MEMQ (CAR PLIST)
                    INDICATOR-LIST)
              (RETURN (VALUES (CAR PLIST)
                             (CADR PLIST)
                             PLIST))))))

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

(DEFUN FMAKUNBOUND
 (SYMBOL) (PUTD SYMBOL NIL)
                            SYMBOL)

(DEFUN SYMBOL-FUNCTION
 (FN) (COND
                               ((SPECIAL-FORM-P FN)

                                                  (* ; 

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

                                )
                               ((MACRO-FUNCTION FN)

                                                  (* ; 

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

                                )
                               ((GETD FN)
                    (* ; "Return the function definition.")

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

(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))

(DEFVAR *GENSYM-COUNTER*
 0)

(DEFVAR *GENSYM-PREFIX*
 "G" )

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

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

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

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

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


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