home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e070 / 4.ddi / LISPLIB / DOC.LSP < prev    next >
Encoding:
Text File  |  1984-11-06  |  9.4 KB  |  288 lines
  1. ;;; (C) Copyright 1984 by Gold Hill Computers
  2.  
  3. ;;; This file contains functions that support online documentation
  4.  
  5. ;; reads a floating point number from the stream
  6. (DEFUN READ-NUM (STREAM)
  7.   (LET ((N (COERCE 0 'SHORT-FLOAT)))        ; cons a number
  8.     (MULTIPLE-VALUE-BIND (O S) (%POINTER N)
  9.       (%CONTENTS-STORE S (+ 1 O) (READ-BYTE STREAM) NIL)
  10.       (%CONTENTS-STORE S (+ 2 O) (READ-BYTE STREAM) NIL)
  11.       (%CONTENTS-STORE S (+ 3 O) (READ-BYTE STREAM) NIL)
  12.       (%CONTENTS-STORE S (+ 4 O) (READ-BYTE STREAM) NIL))
  13.     N))
  14.  
  15.  
  16. ;; The Common Lisp documentation function
  17.  
  18. (DEFUN DOCUMENTATION (SYM TYPE)
  19.   (LET ((HASH-STREAM (WITH-DISKETTE *DOCUMENT-DISKETTE*
  20.                #'HASH-TABLE-OPEN
  21.                (MERGE-PATHNAMES *DOC-FILE-PATHNAME*
  22.              *DOCUMENT-PATHNAME*))))
  23.     (UNWIND-PROTECT
  24.       (LET ((DOC (GETF (SEND HASH-STREAM :SEARCH SYM TYPE) :DOC)))
  25.         (IF (NOT (LISTP DOC))
  26.         DOC
  27.         (IF (<= (LENGTH DOC) 60)
  28.         (APPLY #'STRING-APPEND DOC)
  29.         (LET ((LEN (DO ((I DOC (CDR I))
  30.                 (SZ 0 (+ SZ (LENGTH (CAR I)))))
  31.                    ((NULL I) SZ)))
  32.                AR I)
  33.           (SETQ AR (MAKE-ARRAY LEN :ELEMENT-TYPE 'STRING-CHAR
  34.                        :FILL-POINTER 0))
  35.           (DOLIST (STRG DOC)
  36.             (DOTIMES (I (LENGTH STRG))
  37.               (VECTOR-PUSH (CHAR STRG I) AR)))
  38.           AR))))
  39.       (CLOSE HASH-STREAM))))
  40.  
  41.  
  42. ;; for retrieving a particular doc type
  43. ;; RETURN-LIST: (DOC FOUNDP)
  44. ;; If TYPE is *, the doc entry in returned, it is an alist
  45. ;; for the particular function.  The key is the type of documentation
  46. ;; and the rest is a plist of options for that doc type:
  47. ;;    ((<type1> . <doc-plist1>)
  48. ;;    eg for CAR:
  49. ;;        ((FUNCTION :ARGUMENTS (LIST) :VALUES (OBJECT) :ONLINE-DOC <string>))
  50. ;;
  51. (DEFUN DOC (X &OPTIONAL TYPE)
  52.  
  53.     ;; we open the hash table with the name on *DOC-FILE-PATHNAME*
  54.  
  55.     (LET ((HASH-STREAM (WITH-DISKETTE *DOCUMENT-DISKETTE*
  56.                  #'HASH-TABLE-OPEN
  57.              (MERGE-PATHNAMES *DOC-FILE-PATHNAME*
  58.                *DOCUMENT-PATHNAME*)))
  59.       DOC FOUNDP ARGLIST RETURN-LIST)  
  60.  
  61.       (UNWIND-PROTECT
  62.      (PROGN
  63.  
  64.        ;; we retrieve the hash table entry with only one keyword x
  65.  
  66.        (MULTIPLE-VALUE-SETQ (DOC FOUNDP)
  67.          (FUNCALL HASH-STREAM :SEARCH X))
  68.  
  69.            (IFN FOUNDP
  70.                (FORMAT T "~%No documentation found for ~A~%" X)
  71.                (IF (AND TYPE (ASSOC TYPE DOC))
  72.                    (DOC-PRINT X (ASSOC TYPE DOC))
  73.                    (DOLIST (I DOC) (DOC-PRINT X I)))
  74.                ))
  75.  
  76.      (FUNCALL HASH-STREAM :CLOSE))))
  77.  
  78.  
  79.  
  80. ;; This function examines the entry, extracts the information associated
  81. ;; with :arguments, :values and :doc of the entry.
  82.  
  83. (DEFUN DOC-PRINT (SYM ENTRY)
  84.   (LET ((TYPE (FIRST ENTRY))
  85.     (TEMP)
  86.     (*PRINT-LENGTH* NIL)
  87.     (*PRINT-LEVEL* NIL)
  88.     (DOC (REST ENTRY)))
  89.     (FORMAT T "~&~%~S is a ~S." SYM TYPE)
  90.  
  91.     (WHEN (MEMBER TYPE '(SPECIAL-FORM FUNCTION MACRO))
  92.       (IF (CONSP (SETQ TEMP (GETF DOC :ARGUMENTS)))
  93.           (WHEN (EQ (CAR (GETF DOC :ARGUMENTS)) '@TOO-LONG)
  94.             (POP TEMP))
  95.       (WHEN TEMP (SETQ TEMP (NCONS TEMP))))
  96.       (FORMAT T "~%~@[~A~]" (CONS SYM TEMP))
  97.  
  98.       (WHEN (SETQ TEMP (GETF DOC :VALUES))
  99.     (FORMAT T " -> ")
  100.         (IF (OR (ATOM TEMP) (= (LENGTH TEMP) 1))
  101.         (FORMAT T "~S" (IF (ATOM TEMP) TEMP (FIRST TEMP)))
  102.         (DOLIST (I TEMP) (FORMAT T "~S " I))))
  103.       )
  104.     
  105.     (IF (LISTP (SETQ TEMP (GETF DOC :DOC)))
  106.     (DOLIST (I TEMP) (FORMAT T "~A" I))
  107.         (FORMAT T "~A" TEMP)))
  108.   (TERPRI T))
  109.  
  110. ;; given a symbol name, we check whether it is of the functional form.
  111. ;; If yes, we will search the doc-file and returns 2 values:
  112. ;;  LAMBDA-LIST, NOT-FOUND-P
  113.  
  114. (DEFUN LAMBDA-LIST (X &OPTIONAL DONT-SEARCH &AUX I)
  115.   (COND ((NOT (FBOUNDP X)) (VALUES NIL :NOT-FOUND))
  116.  
  117.     ((LISTP (SETQ I (SYMBOL-FUNCTION X)))
  118.      (VALUES (CASE (CAR I)
  119.                (LAMBDA (CADR I))
  120.                (MACRO (CADDR I)))
  121.          NIL))
  122.     (DONT-SEARCH
  123.      (VALUES NIL :NOT-FOUND))
  124.     (T
  125.      (LET ((HASH-STREAM (WITH-DISKETTE *DOCUMENT-DISKETTE*
  126.                   #'HASH-TABLE-OPEN
  127.                   (MERGE-PATHNAMES *DOC-FILE-PATHNAME*
  128.                    *DOCUMENT-PATHNAME*)))
  129.         ARGLIST FOUNDP)
  130.  
  131.        (SETF (VALUES ARGLIST FOUNDP)
  132.          (FUNCALL HASH-STREAM :SEARCH X '(FUNCTION MACRO SPECIAL-FORM)))
  133.        (FUNCALL HASH-STREAM :CLOSE)
  134.         (IF (AND FOUNDP 
  135.             (NOT (EQ (SETQ ARGLIST (GETF ARGLIST :ARGUMENTS :NO-ARGS))
  136.                  :NO-ARGS)))
  137.            (VALUES ARGLIST NIL)
  138.            (VALUES NIL :NOT-FOUND))))))
  139.  
  140.  
  141. ;;***************************************************************************
  142. ;;
  143. ;;    VERSION 1.0  09/11/84
  144. ;;       
  145. ;;    1) HASH-TABLE-OPEN &option <file-name>
  146. ;;
  147. ;;        this procedure will open a hash table and allow user to refer
  148. ;;        the hash table as a stream.
  149. ;;        
  150. ;;        Example: (let ((hash-stream (HASH-TABLE-OPEN "personal"))
  151. ;;
  152. ;;    2) Funcall <stream-name> :SEARCH  <keyword 1> &optional <keyword 2>
  153. ;;
  154. ;;        this procedure retrieves an entry in the hash table with
  155. ;;        <keyword 1> as its key. The returned result will have 
  156. ;;              the key deleted. For more explanation see the following
  157. ;;        two cases.
  158. ;;
  159. ;;        <keyword 2> is optional. If supplied, it is used slightly  
  160. ;;        differntly in the following 2 different cases:
  161. ;;        
  162. ;;        case a)
  163. ;;            if each entry is of the form:
  164. ;;
  165. ;;              ( (<key1> <property 1> <value>...<property n> <value n>)
  166. ;;                                               :
  167. ;;                                               : 
  168. ;;             (<key m> <property 1> <value>...<property g> <value g>) )
  169. ;;
  170. ;;             <keyword 1> will be used to assoc the right list
  171. ;;             (<keyword i> <property 1> <value 1>...<prop d> <value d>)
  172. ;;             from the hash tabke entry. <keyword 2> will be used as  
  173. ;;                   the property keyword to obtain the appropiate value. The 
  174. ;;             value will be returned.     
  175. ;;
  176. ;;        case b) if each hash table entry is of the form:
  177. ;;
  178. ;;             ((<key1> (<key11> a b c...) (<key12>...) ...)
  179. ;;              (<key2> (<key21>...) (<key22>...) ...)
  180. ;;                    :
  181. ;;              (<keym> (<keym1>...) (<keym2>...) ...) )
  182. ;;
  183. ;;             and suppose <keyword 1> = <key1> and <keyword2> = <key2>
  184. ;;             the function call will return (a b c ...).
  185. ;;
  186. ;;        
  187. ;;    3) FUNCALL <stream-name> :close
  188. ;;
  189. ;;        this command will close the file associated with the hash table
  190. ;;        stream.
  191. ;;
  192. ;;*****************************************************************************
  193. ;;
  194. ;;
  195. ;;    HASH-TABLE-OPEN is used to open a hash table. The pathname the user
  196. ;;    supplies will be merged with the value of *DOCUMENT-PATHNAME*.
  197. ;;    The file stream will be used as part of the returned closure that
  198. ;;    will process subsequent commands to the hash table (e.g. :SEARCH,
  199. ;;    :CLOSE).
  200.   
  201.  
  202.  
  203. (defun HASH-TABLE-OPEN (file-name)
  204.     (let (final-pathname table-size)
  205.     
  206.     ;; we first compute the name of the hash table
  207.     
  208.     (setf final-pathname (pathname file-name))
  209.  
  210.     ;; we return the hash-stream handler with the hash-table enclosed
  211.  
  212.     (let* ((hash-stream (open final-pathname
  213.                           :element-type 'unsigned-byte
  214.                    :direction :input))
  215.            (table-size (logior (read-byte hash-stream)
  216.                 (lsh (read-byte hash-stream) 8))))
  217.  
  218.            (closure '(hash-stream table-size) 'hash-stream-handler))))
  219.  
  220.  
  221. ;;    the hash-stream-handler is called by user in the form indicated in the
  222. ;;    documentation at the beginning of the file
  223.  
  224.  
  225. (defun HASH-STREAM-HANDLER (command &optional key-1 keyword-2)  
  226.     (let (idx entry keyword-1)
  227.     (cond ((equal command :close) (close hash-stream))
  228.           ((equal command :search)
  229.            
  230.             ;; we are getting ready to read the pointer from hash table
  231.         (let (temp)
  232.            ;; due to the way BUILD-DEFINITIONS handles string key
  233.            (setf keyword-1 (if (stringp key-1) (intern key-1)
  234.                                            key-1))    
  235.            (setf temp (+ 2 (* 4 (\\ (sxhash keyword-1) table-size))))
  236.            (funcall hash-stream :set-pointer temp)
  237.                       (setf idx (read-num hash-stream))
  238.  
  239.            ;; set the stream pointer to the real entry    
  240.            (when (not (zerop idx)) (funcall hash-stream
  241.                               :set-pointer idx))
  242.            (if (zerop idx)
  243.               (values nil nil)
  244.               (progn 
  245.                    (setf entry (assoc keyword-1 (read hash-stream)))
  246.                  (if keyword-2
  247.                     (dble-srch (rest entry) keyword-2)
  248.                     (values (rest entry) (if entry t nil)))
  249.                )))))))    
  250.  
  251.  
  252. ;; dble assume that an entry has been retrieved with the encoded key deleted.
  253. ;; the routine will use the next keyword to locate the proper property or the
  254. ;; sublist mdepending on the form of the entry is of the form:
  255. ;; (property1 value1 property2 value2 ... )  or
  256. ;; ((key1 ...)  (key2 ...) ...)
  257. ;; In the second case, the second input can be either an atom or a list 
  258.   
  259. (defun dble-srch (trunc-entry keyword &aux result)
  260.    (if (null trunc-entry)
  261.        (values nil nil)
  262.        (if (atom (first trunc-entry))
  263.     
  264.      ;; in the case where the form is of the form of a property list
  265.      ;; we check whether the keyword parameter is of the form of a list
  266.        
  267.      (if (atom keyword)
  268.         
  269.         (values (setf result (getf trunc-entry keyword))
  270.             (if result t nil))
  271.  
  272.         (dolist (each-key keyword (values nil nil))
  273.            (if (setf result (getf trunc-entry each-key))
  274.              (return (values  result  t)))))
  275.  
  276.     ;; in this case,the truncated form is of the form of an a-list
  277.  
  278.     (if (atom keyword)
  279.  
  280.             (values (rest (setf result (assoc keyword trunc-entry)))
  281.                        (if result t nil))    
  282.  
  283.         (dolist (each-key keyword (values nil nil))
  284.            (if (setf result (assoc each-key trunc-entry))
  285.              (return (values (rest result) t)))))
  286.  
  287.        )))        
  288.