home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / sharpm.lisp < prev    next >
Encoding:
Text File  |  1992-07-28  |  14.0 KB  |  425 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: sharpm.lisp,v 1.10 92/07/10 17:47:42 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Spice Lisp Interim Sharp Macro
  15. ;;; Written by David Dill
  16. ;;; Runs in the standard Spice Lisp environment.
  17. ;;; This uses the special std-lisp-readtable, which is internal to READER.LISP
  18. ;;;
  19. (in-package "LISP")
  20. (export '(*read-eval*))
  21.  
  22.  
  23. ;;; declared in READ.LISP
  24.  
  25. (proclaim '(special *read-suppress* std-lisp-readtable *bq-vector-flag*))
  26.  
  27. (defun ignore-numarg (sub-char numarg)
  28.   (when numarg
  29.     (warn "Numeric argument ignored in #~D~A." numarg sub-char)))
  30.  
  31. (defun sharp-backslash (stream backslash numarg)
  32.   (ignore-numarg backslash numarg)
  33.   (unread-char backslash stream)
  34.   (let* ((*readtable* std-lisp-readtable)
  35.      (charstring (read-extended-token stream)))
  36.     (declare (simple-string charstring))
  37.     (cond (*read-suppress* nil)
  38.       ((= (the fixnum (length charstring)) 1)
  39.        (char charstring 0))
  40.       ((name-char charstring))
  41.       (t
  42.        (%reader-error stream "Unrecognized character name: ~S"
  43.               charstring)))))
  44.  
  45.  
  46. (defun sharp-quote (stream sub-char numarg)
  47.   (ignore-numarg sub-char numarg)
  48.   ;; 4th arg tells read that this is a recrusive call.
  49.   `(function ,(read stream t nil t)))
  50.  
  51. (defun sharp-left-paren (stream ignore length)
  52.   (declare (ignore ignore) (special *backquote-count*))
  53.   (let* ((list (read-list stream nil))
  54.      (listlength (length list)))
  55.     (declare (list list)
  56.          (fixnum listlength))
  57.     (cond (*read-suppress* nil)
  58.       ((zerop *backquote-count*)
  59.        (if length
  60.            (cond ((> listlength (the fixnum length))
  61.               (%reader-error
  62.                stream
  63.                "Vector longer than specified length: #~S~S"
  64.                length list))
  65.              (t
  66.               (fill (the simple-vector
  67.                  (replace (the simple-vector
  68.                            (make-array length))
  69.                       list))
  70.                 (car (last list))
  71.                 :start listlength)))
  72.            (coerce list 'vector)))
  73.       (t (cons *bq-vector-flag* list)))))
  74.  
  75. (defun sharp-star (stream ignore numarg)
  76.   (declare (ignore ignore))
  77.   (multiple-value-bind (bstring escape-appearedp)
  78.                (read-extended-token stream)
  79.     (declare (simple-string bstring))
  80.     (cond (*read-suppress* nil)
  81.       (escape-appearedp
  82.        (%reader-error stream "Escape character appeared after #*"))
  83.       ((and numarg (zerop (length bstring)) (not (zerop numarg)))
  84.        (%reader-error
  85.         stream
  86.         "You have to give a little bit for non-zero #* bit-vectors."))
  87.       ((or (null numarg) (>= (the fixnum numarg) (length bstring)))
  88.        (let* ((len1 (length bstring))
  89.           (last1 (1- len1))
  90.           (len2 (or numarg len1))
  91.           (bvec (make-array len2 :element-type 'bit
  92.                     :initial-element 0)))
  93.          (declare (fixnum len1 last1 len2))
  94.          (do ((i 0 (1+ i))
  95.           (char ()))
  96.          ((= i len2))
  97.            (declare (fixnum i))
  98.            (setq char (elt bstring (if (< i len1) i last1)))
  99.            (setf (elt bvec i)
  100.              (cond ((char= char #\0) 0)
  101.                ((char= char #\1) 1)
  102.                (t
  103.                 (%reader-error
  104.                  stream
  105.                  "Illegal element given for bit-vector: ~S"
  106.                  char)))))
  107.          bvec))
  108.       (t
  109.        (%reader-error stream
  110.              "Bit vector is longer than specified length #~A*~A"
  111.              numarg bstring)))))
  112.  
  113.  
  114. (defun sharp-colon (stream sub-char numarg)
  115.   (ignore-numarg sub-char numarg)
  116.   (multiple-value-bind (token escapep colon)
  117.                (read-extended-token stream)
  118.     (declare (simple-string token) (ignore escapep))
  119.     (cond
  120.      (*read-suppress* nil)
  121.      (colon
  122.       (%reader-error stream "Symbol following #: contains a package marker: ~S"
  123.              token))
  124.      ((eql (length token) 0)
  125.       (let ((ch (read-char stream nil nil t)))
  126.     (when ch
  127.       (%reader-error stream
  128.              "Illegal terminating character after a colon: ~S."
  129.              ch))
  130.     (reader-eof-error stream "after a colon")))
  131.      (t
  132.       (make-symbol token)))))
  133.  
  134. ;;;; #. handling.
  135.  
  136. (defvar *read-eval* t
  137.   "If false, then the #. read macro is disabled.")
  138.  
  139. (defun sharp-dot (stream sub-char numarg)
  140.   (ignore-numarg sub-char numarg)
  141.   (let ((token (read stream t nil t)))
  142.     (unless *read-suppress*
  143.       (unless *read-eval*
  144.     (%reader-error stream
  145.               "Attempt to read #. while *READ-EVAL* is bound to NIL."))
  146.       (eval token))))
  147.  
  148.  
  149. ;;;; Numeric radix stuff:
  150.  
  151. (defun sharp-R (stream sub-char radix)
  152.   (cond (*read-suppress*
  153.      (read-extended-token stream)
  154.      nil)
  155.     ((not radix)
  156.      (%reader-error stream "Radix missing in #R."))
  157.     ((not (<= 2 radix 36))
  158.      (%reader-error stream "Illegal radix for #R: ~D." radix))
  159.     (t
  160.      (let ((res (let ((*read-base* radix))
  161.               (read stream t nil t))))
  162.        (unless (typep res 'rational)
  163.          (%reader-error stream "#~A (base ~D) value is not a rational: ~S."
  164.                sub-char radix res))
  165.        res))))
  166.  
  167. (defun sharp-B (stream sub-char numarg)
  168.   (ignore-numarg sub-char numarg)
  169.   (sharp-r stream sub-char 2))
  170.  
  171. (defun sharp-O (stream sub-char numarg)
  172.   (ignore-numarg sub-char numarg)
  173.   (sharp-r stream sub-char 8))
  174.  
  175. (defun sharp-X (stream sub-char numarg)
  176.   (ignore-numarg sub-char numarg)
  177.   (sharp-r stream sub-char 16))
  178.  
  179.  
  180.  
  181. (defun sharp-A (stream ignore dimensions)
  182.   (declare (ignore ignore))
  183.   (when *read-suppress*
  184.     (read stream t nil t)
  185.     (return-from sharp-A nil))
  186.   (unless dimensions (%reader-error stream "No dimensions argument to #A."))
  187.   (collect ((dims))
  188.     (let* ((contents (read stream t nil t))
  189.        (seq contents))
  190.       (dotimes (axis dimensions
  191.              (make-array (dims) :initial-contents contents))
  192.     (unless (typep seq 'sequence)
  193.       (%reader-error stream
  194.              "#~DA axis ~D is not a sequence:~%  ~S"
  195.              dimensions axis seq))
  196.     (let ((len (length seq)))
  197.       (dims len)
  198.       (unless (= axis (1- dimensions))
  199.         (when (zerop len)
  200.           (%reader-error stream
  201.                  "#~DA axis ~D is empty, but is not ~
  202.                   the last dimension."
  203.                  dimensions axis))
  204.         (setq seq (elt seq 0))))))))
  205.  
  206.  
  207. (defun sharp-S (stream sub-char numarg)
  208.   (ignore-numarg sub-char numarg)
  209.   ;;this needs to know about defstruct implementation
  210.   (when *read-suppress*
  211.     (read stream t nil t)
  212.     (return-from sharp-S nil))
  213.   (let ((body (if (char= (read-char stream t) #\( )
  214.           (read-list stream nil)
  215.           (%reader-error stream "Non-list following #S"))))
  216.     (cond ((listp body)
  217.        (unless (symbolp (car body))
  218.          (%reader-error stream
  219.                "Structure type is not a symbol: ~S" (car body)))
  220.        (let ((defstruct (info type defined-structure-info (car body))))
  221.          (unless defstruct
  222.            (%reader-error stream
  223.                  "~S is not a defined structure type."
  224.                  (car body)))
  225.          (unless (c::dd-constructors defstruct)
  226.            (%reader-error
  227.         stream "The ~S structure does not have a default constructor."
  228.         (car body)))
  229.          (do ((arg (cdr body) (cddr arg))
  230.           (res ()))
  231.          ((endp arg)
  232.           (apply (car (c::dd-constructors defstruct)) res))
  233.            (push (cadr arg) res)
  234.            (push (intern (string (car arg)) *keyword-package*) res))))
  235.       (t (%reader-error stream "Non-list following #S: ~S" body)))))
  236.  
  237.  
  238.  
  239. ;;;; #=/##
  240.  
  241. ;;; Holds objects already seen by CIRCLE-SUBST.
  242. ;;;
  243. (defvar *sharp-equal-circle-table*)
  244.  
  245. ;; This function is kind of like to NSUBLIS, but checks for circularities and
  246. ;; substitutes in arrays and structures as well as lists.  The first arg is an
  247. ;; alist of the things to be replaced assoc'd with the things to replace them.
  248. ;;
  249. (defun circle-subst (old-new-alist tree)
  250.   (cond ((not (typep tree '(or cons (array t) structure)))
  251.      (let ((entry (find tree old-new-alist :key #'second)))
  252.        (if entry (third entry) tree)))
  253.     ((null (gethash tree *sharp-equal-circle-table*))
  254.      (setf (gethash tree *sharp-equal-circle-table*) t)
  255.      (cond ((structurep tree)
  256.         (dotimes (i (structure-length tree) tree)
  257.           (structure-set tree i
  258.                  (circle-subst old-new-alist
  259.                            (structure-ref tree i)))))
  260.            ((arrayp tree)
  261.         (with-array-data ((data tree) (start) (end))
  262.           (declare (fixnum start end))
  263.           (do ((i start (1+ i)))
  264.               ((>= i end))
  265.             (setf (aref data i)
  266.               (circle-subst old-new-alist (aref data i)))))
  267.         tree)
  268.            (t
  269.         (let ((a (circle-subst old-new-alist (car tree)))
  270.               (d (circle-subst old-new-alist (cdr tree))))
  271.           (if (eq a (car tree))
  272.               tree
  273.               (rplaca tree a))
  274.           (if (eq d (cdr tree))
  275.               tree
  276.               (rplacd tree d)))
  277.           tree)))
  278.     (t tree)))
  279.  
  280. ;;; Sharp-equal works as follows.  When a label is assigned (ie when #= is
  281. ;;; called) we GENSYM a symbol is which is used as an unforgeable tag.
  282. ;;; *SHARP-SHARP-ALIST* maps the integer tag to this gensym.
  283. ;;;
  284. ;;; When SHARP-SHARP encounters a reference to a label, it returns the symbol
  285. ;;; assoc'd with the label.  Resolution of the reference is deferred until the
  286. ;;; read done by #= finishes.  Any already resolved tags (in
  287. ;;; *SHARP-EQUAL-ALIST*) are simply returned.
  288. ;;;
  289. ;;; After reading of the #= form is completed, we add an entry to
  290. ;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved object.  Then
  291. ;;; for each entry in the *SHARP-SHARP-ALIST, the current object is searched
  292. ;;; and any uses of the gensysm token are replaced with the actual value.
  293. ;;;
  294. (defvar *sharp-sharp-alist* ())
  295. ;;;
  296. (defun sharp-equal (stream ignore label)
  297.   (declare (ignore ignore))
  298.   (when *read-suppress* (return-from sharp-equal (values)))
  299.   (unless label
  300.     (%reader-error stream "Missing label for #=." label))
  301.   (when (or (assoc label *sharp-sharp-alist*)
  302.         (assoc label *sharp-equal-alist*))
  303.     (%reader-error stream "Multiply defined label: #~D=" label))
  304.   (let* ((tag (gensym))
  305.      (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*))
  306.      (obj (read stream t nil t)))
  307.     (when (eq obj tag)
  308.       (%reader-error stream "Have to tag something more than just #~D#."
  309.              label))
  310.     (push (list label tag obj) *sharp-equal-alist*)
  311.     (let ((*sharp-equal-circle-table* (make-hash-table :test #'eq :size 20)))
  312.       (circle-subst *sharp-equal-alist* obj))))
  313. ;;;
  314. (defun sharp-sharp (stream ignore label)
  315.   (declare (ignore ignore))
  316.   (when *read-suppress* (return-from sharp-sharp nil))
  317.   (unless label
  318.     (%reader-error stream "Missing label for ##." label))
  319.  
  320.   (let ((entry (assoc label *sharp-equal-alist*)))
  321.     (if entry
  322.     (third entry)
  323.     (let ((pair (assoc label *sharp-sharp-alist*)))
  324.       (unless pair
  325.         (%reader-error stream "Object is not labelled #~S#" label))
  326.       (cdr pair)))))
  327.  
  328.  
  329. ;;;; #+/-
  330.  
  331. (flet ((guts (stream not-p)
  332.      (unless (if (handler-case
  333.              (let ((*package* *keyword-package*)
  334.                    (*read-suppress* nil))
  335.                (featurep (read stream t nil t)))
  336.                (reader-package-error
  337.             (condition)
  338.             (declare (ignore condition))
  339.             nil))
  340.              (not not-p)
  341.              not-p)
  342.        (let ((*read-suppress* t))
  343.          (read stream t nil t)))
  344.      (values)))
  345.  
  346.   (defun sharp-plus (stream sub-char numarg)
  347.     (ignore-numarg sub-char numarg)
  348.     (guts stream nil))
  349.  
  350.   (defun sharp-minus (stream sub-char numarg)
  351.     (ignore-numarg sub-char numarg)
  352.     (guts stream t)))
  353.  
  354. (defun sharp-C (stream sub-char numarg)
  355.   (ignore-numarg sub-char numarg)
  356.   ;;next thing better be a list of two numbers.
  357.   (let ((cnum (read stream t nil t)))
  358.     (when *read-suppress* (return-from sharp-c nil))
  359.     (if (and (listp cnum) (= (length cnum) 2))
  360.     (complex (car cnum) (cadr cnum))
  361.     (%reader-error stream "Illegal complex number format: #C~S" cnum))))
  362.  
  363. (defun sharp-vertical-bar (stream sub-char numarg)
  364.   (ignore-numarg sub-char numarg)
  365.   (prepare-for-fast-read-char stream
  366.     (do ((level 1)
  367.      (prev (fast-read-char) char)
  368.      (char (fast-read-char) (fast-read-char)))
  369.     (())
  370.       (cond ((and (char= prev #\|) (char= char #\#))
  371.          (setq level (1- level))
  372.          (when (zerop level)
  373.            (done-with-fast-read-char)
  374.            (return (values)))
  375.          (setq char (fast-read-char)))
  376.         ((and (char= prev #\#) (char= char #\|))
  377.          (setq char (fast-read-char))
  378.          (setq level (1+ level)))))))
  379.  
  380. (defun sharp-illegal (stream sub-char ignore)
  381.   (declare (ignore ignore))
  382.   (%reader-error stream "Illegal sharp character ~S" sub-char))
  383.  
  384. (defun sharp-P (stream sub-char numarg)
  385.   (ignore-numarg sub-char numarg)
  386.   (parse-namestring (read stream t nil t)))
  387.  
  388. (defun sharp-init ()
  389.   (declare (special std-lisp-readtable))
  390.   (let ((*readtable* std-lisp-readtable))
  391.     (make-dispatch-macro-character #\# t)
  392.     (set-dispatch-macro-character #\# #\\ #'sharp-backslash)
  393.     (set-dispatch-macro-character #\# #\' #'sharp-quote)
  394.     (set-dispatch-macro-character #\# #\( #'sharp-left-paren)
  395.     (set-dispatch-macro-character #\# #\* #'sharp-star)
  396.     (set-dispatch-macro-character #\# #\: #'sharp-colon)
  397.     (set-dispatch-macro-character #\# #\. #'sharp-dot)
  398.     (set-dispatch-macro-character #\# #\R #'sharp-R)
  399.     (set-dispatch-macro-character #\# #\r #'sharp-R)
  400.     (set-dispatch-macro-character #\# #\B #'sharp-B)
  401.     (set-dispatch-macro-character #\# #\b #'sharp-B)
  402.     (set-dispatch-macro-character #\# #\O #'sharp-O)
  403.     (set-dispatch-macro-character #\# #\o #'sharp-O)
  404.     (set-dispatch-macro-character #\# #\X #'sharp-X)
  405.     (set-dispatch-macro-character #\# #\x #'sharp-X)
  406.     (set-dispatch-macro-character #\# #\A #'sharp-A)
  407.     (set-dispatch-macro-character #\# #\a #'sharp-A)
  408.     (set-dispatch-macro-character #\# #\S #'sharp-S)
  409.     (set-dispatch-macro-character #\# #\s #'sharp-S)
  410.     (set-dispatch-macro-character #\# #\= #'sharp-equal)
  411.     (set-dispatch-macro-character #\# #\# #'sharp-sharp)
  412.     (set-dispatch-macro-character #\# #\+ #'sharp-plus)
  413.     (set-dispatch-macro-character #\# #\- #'sharp-minus)
  414.     (set-dispatch-macro-character #\# #\C #'sharp-C)
  415.     (set-dispatch-macro-character #\# #\c #'sharp-C)
  416.     (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
  417.     (set-dispatch-macro-character #\# #\p #'sharp-p)
  418.     (set-dispatch-macro-character #\# #\P #'sharp-p)
  419.     (set-dispatch-macro-character #\# #\tab #'sharp-illegal)
  420.     (set-dispatch-macro-character #\# #\  #'sharp-illegal)
  421.     (set-dispatch-macro-character #\# #\) #'sharp-illegal)
  422.     (set-dispatch-macro-character #\# #\< #'sharp-illegal)
  423.     (set-dispatch-macro-character #\# #\form #'sharp-illegal)
  424.     (set-dispatch-macro-character #\# #\return #'sharp-illegal)))
  425.