home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / symbol.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  7.9 KB  |  234 lines
  1. ;;; -*- Log: code.log; Package: Lisp -*-
  2. ;;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: symbol.lisp,v 1.10 92/03/02 17:22:49 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Symbol manipulating functions for Spice Lisp.
  15. ;;;
  16. ;;; Written by Scott Fahlman.
  17. ;;; Hacked on and maintained by Skef Wholey.
  18. ;;;
  19. ;;; Many of these are trivial interpreter entries to functions
  20. ;;; open-coded by the compiler.
  21. ;;;
  22. (in-package "LISP")
  23. (export '(get remprop symbol-plist getf get-properties symbol-name
  24.       make-symbol copy-symbol gensym gentemp *gensym-counter*
  25.       symbol-package keywordp makunbound symbol-value symbol-function
  26.       boundp set))
  27.  
  28. (in-package "KERNEL")
  29. (export '(%set-symbol-value %set-symbol-definition %set-symbol-plist
  30.                 %set-symbol-package fset))
  31.  
  32. (in-package "LISP")
  33.  
  34. (declaim (maybe-inline get %put getf remprop %putf get-properties keywordp))
  35.  
  36. (defun symbol-value (variable)
  37.   "VARIABLE must evaluate to a symbol.  This symbol's current special
  38.   value is returned."
  39.   (declare (optimize (safety 1)))
  40.   (symbol-value variable))
  41.  
  42. (defun boundp (variable)
  43.   "VARIABLE must evaluate to a symbol.  Return NIL if this symbol is
  44.   unbound, T if it has a value."
  45.   (boundp variable))
  46.  
  47. (defun set (variable new-value)
  48.   "VARIABLE must evaluate to a symbol.  This symbol's special value cell is
  49.   set to the specified new value."
  50.   (declare (type symbol variable))
  51.   (cond ((null variable)
  52.      (error "Nihil ex nihil, can't set NIL."))
  53.     ((eq variable t)
  54.      (error "Veritas aeterna, can't set T."))
  55.     ((and (boundp '*keyword-package*)
  56.           (keywordp variable))
  57.      (error "Can't set keywords."))
  58.     (t
  59.      (%set-symbol-value variable new-value))))
  60.  
  61. (defun %set-symbol-value (symbol new-value)
  62.   (%set-symbol-value symbol new-value))
  63.  
  64. (defun makunbound (variable)
  65.   "VARIABLE must evaluate to a symbol.  This symbol is made unbound,
  66.   removing any value it may currently have."
  67.   (set variable
  68.        (%primitive make-other-immediate-type 0 vm:unbound-marker-type))
  69.   variable)
  70.  
  71. (defun symbol-function (variable)
  72.   "VARIABLE must evaluate to a symbol.  This symbol's current definition
  73.   is returned."
  74.   (declare (optimize (safety 1)))
  75.   (symbol-function variable))
  76.  
  77. (defun fset (symbol new-value)
  78.   (declare (type symbol symbol) (type function new-value))
  79.   (if symbol
  80.       (%set-symbol-function symbol new-value)
  81.       (error "Can't define NIL.")))
  82.  
  83. (defun %set-symbol-function (symbol new-value)
  84.   (declare (type symbol symbol) (type function new-value))
  85.   (%set-symbol-function symbol new-value))
  86.  
  87.  
  88. (defun symbol-plist (variable)
  89.   "VARIABLE must evaluate to a symbol.  Return its property list."
  90.   (symbol-plist variable))
  91.  
  92. (defun %set-symbol-plist (symbol new-value)
  93.   (setf (symbol-plist symbol) new-value))
  94.  
  95. (defun symbol-name (variable)
  96.   "VARIABLE must evaluate to a symbol.  Return its print name."
  97.   (symbol-name variable))
  98.  
  99. (defun symbol-package (variable)
  100.   "VARIABLE must evaluate to a symbol.  Return its package."
  101.   (symbol-package variable))
  102.  
  103. (defun %set-symbol-package (symbol package)
  104.   (declare (type symbol symbol))
  105.   (%set-symbol-package symbol package))
  106.  
  107. (defun make-symbol (string)
  108.   "Make and return a new symbol with the STRING as its print name."
  109.   (make-symbol string))
  110.  
  111. (defun get (symbol indicator &optional (default nil))
  112.   "Look on the property list of SYMBOL for the specified INDICATOR.  If this
  113.   is found, return the associated value, else return DEFAULT."
  114.   (do ((pl (symbol-plist symbol) (cddr pl)))
  115.       ((atom pl) default)
  116.     (cond ((atom (cdr pl))
  117.        (error "~S has an odd number of items in its property list."
  118.            symbol))
  119.       ((eq (car pl) indicator)
  120.        (return (cadr pl))))))
  121.  
  122. (defun %put (symbol indicator value)
  123.   "The VALUE is added as a property of SYMBOL under the specified INDICATOR.
  124.   Returns VALUE."
  125.   (do ((pl (symbol-plist symbol) (cddr pl)))
  126.       ((endp pl)
  127.        (setf (symbol-plist symbol)
  128.          (list* indicator value (symbol-plist symbol)))
  129.        value)
  130.     (cond ((endp (cdr pl))
  131.        (error "~S has an odd number of items in its property list."
  132.           symbol))
  133.       ((eq (car pl) indicator)
  134.        (rplaca (cdr pl) value)
  135.        (return value)))))
  136.  
  137. (defun remprop (symbol indicator)
  138.   "Look on property list of SYMBOL for property with specified
  139.   INDICATOR.  If found, splice this indicator and its value out of
  140.   the plist, and return the tail of the original list starting with
  141.   INDICATOR.  If not found, return () with no side effects."
  142.   (do ((pl (symbol-plist symbol) (cddr pl))
  143.        (prev nil pl))
  144.       ((atom pl) nil)
  145.     (cond ((atom (cdr pl))
  146.        (error "~S has an odd number of items in its property list."
  147.           symbol))
  148.       ((eq (car pl) indicator)
  149.        (cond (prev (rplacd (cdr prev) (cddr pl)))
  150.          (t
  151.           (setf (symbol-plist symbol) (cddr pl))))
  152.        (return pl)))))
  153.  
  154. (defun getf (place indicator &optional (default ()))
  155.   "Searches the property list stored in Place for an indicator EQ to Indicator.
  156.   If one is found, the corresponding value is returned, else the Default is
  157.   returned."
  158.   (do ((plist place (cddr plist)))
  159.       ((null plist) default)
  160.     (cond ((atom (cdr plist))
  161.        (error "~S is a malformed property list."
  162.           place))
  163.       ((eq (car plist) indicator)
  164.        (return (cadr plist))))))
  165.  
  166. (defun %putf (place property new-value)
  167.   (declare (type list place))
  168.   (do ((plist place (cddr plist)))
  169.       ((endp plist) (list* property new-value place))
  170.     (declare (type list plist))
  171.     (when (eq (car plist) property)
  172.       (setf (cadr plist) new-value)
  173.       (return place))))
  174.  
  175.  
  176. (defun get-properties (place indicator-list)
  177.   "Like GETF, except that Indicator-List is a list of indicators which will
  178.   be looked for in the property list stored in Place.  Three values are
  179.   returned, see manual for details."
  180.   (do ((plist place (cddr plist)))
  181.       ((null plist) (values nil nil nil))
  182.     (cond ((atom (cdr plist))
  183.        (error "~S is a malformed proprty list."
  184.           place))
  185.       ((memq (car plist) indicator-list)
  186.        (return (values (car plist) (cadr plist) plist))))))
  187.  
  188. (defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol)
  189.   "Make and return a new uninterned symbol with the same print name
  190.   as SYMBOL.  If COPY-PROPS is null, the new symbol has no properties.
  191.   Else, it has a copy of SYMBOL's property list."
  192.   (setq new-symbol (make-symbol (symbol-name symbol)))
  193.   (if copy-props
  194.       (setf (symbol-plist new-symbol) (copy-list (symbol-plist symbol))))
  195.   new-symbol)
  196.  
  197. (proclaim '(special *keyword-package*))
  198.  
  199. (defun keywordp (object)
  200.   "Returns true if Object is a symbol in the keyword package."
  201.   (and (symbolp object)
  202.        (eq (symbol-package object) *keyword-package*)))
  203.  
  204.  
  205. ;;;; Gensym and friends.
  206.  
  207. (defvar *gensym-counter* 0
  208.   "Counter for generating unique GENSYM symbols.")
  209.  
  210. (defun gensym (&optional string)
  211.   "Creates a new uninterned symbol whose name is a prefix string (defaults
  212.   to \"G\"), followed by a decimal number.  String, when supplied, will
  213.   alter the prefix if it is a string, or the decimal number if it is a
  214.   number, of this symbol.  The number, defaultly *gensym-counter*, is
  215.   incremented by each call to GENSYM."
  216.   (make-symbol
  217.    (concatenate 'simple-string
  218.         (if (stringp string) string "G")
  219.         (quick-integer-to-string
  220.          (if (integerp string) string (incf *gensym-counter*))))))
  221.  
  222. (defun gentemp (&optional (prefix t) (package *package*))
  223.   "Creates a new symbol interned in package Package with the given Prefix."
  224.   (loop
  225.     (let ((*print-base* 10)
  226.       (*print-radix* nil)
  227.       (*print-pretty* nil)
  228.       (new-pname (format nil "~A~D"
  229.                  (string prefix) (incf *gensym-counter*))))
  230.       (multiple-value-bind (symbol existsp)
  231.                (find-symbol new-pname package)
  232.     (declare (ignore symbol))
  233.     (unless existsp (return (values (intern new-pname package))))))))
  234.