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

(filecreated "16-Oct-86 14:44:57" {eris}<lispcore>sources>llsymbol.\;3
 8713   

      |previous| |date:| " 9-Oct-86 18:21:37" {eris}<lispcore>sources>llsymbol.\;2)


; 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 cl\: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
 (fn) (cond
                                     ((cl:special-form-p fn)

                                                  (* \; 

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

                                      )
                                     ((cl:macro-function fn)

                                                  (* \; 

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

                                      )
                                     ((getd fn)
             (* \; "Return the function definition.")

                                      )
                                     (t (cl:error 'undefined-function :name 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 cl\: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