home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / ilisp / clisp.lisp < prev    next >
Encoding:
Text File  |  1992-06-29  |  12.6 KB  |  399 lines
  1. ;;;
  2. ;;; Common Lisp initializations 
  3. ;;; Author: Chris McConnell, ccm@cs.cmu.edu
  4. ;;;
  5. #+allegro-v4.0 (setq excl:*cltl1-in-package-compatibility-p* t)
  6. (in-package "ILISP" :use '("LISP"))
  7.  
  8. ;;;
  9. (defvar *ilisp-old-result* nil "Used for save/restore of top level values.")
  10.  
  11. ;;;
  12. (defmacro ilisp-handler-case (expression &rest handlers)
  13.   "Evaluate EXPRESSION using HANDLERS to handle errors."
  14.   handlers
  15.   (if (macro-function 'handler-case)
  16.       `(handler-case ,expression ,@handlers)
  17.       #+allegro `(excl::handler-case ,expression ,@handlers)
  18.       #+lucid `(lucid::handler-case ,expression ,@handlers)
  19.       #-(or allegro lucid) expression))
  20.  
  21. ;;;
  22. (defun ilisp-readtable-case (readtable)
  23.   (if (fboundp 'readtable-case)
  24.       (funcall 'readtable-case readtable)
  25.       #+allegro (case excl:*current-case-mode*
  26.           (:case-insensitive-upper :upcase)
  27.           (:case-insensitive-lower :downcase)
  28.           (otherwise :preserve))
  29.       #-allegro :upcase))
  30.  
  31. ;;;
  32. (defmacro ilisp-errors (form)
  33.   "Handle errors when evaluating FORM."
  34.   `(let ((*standard-output* *terminal-io*)
  35.      (*error-output* *terminal-io*))
  36.      (princ " ")            ;Make sure we have output
  37.      (ilisp-handler-case
  38.       ,form    
  39.       (error (error)
  40.        (with-output-to-string (string)
  41.      (format string "ILISP: ~A" error))))))
  42.  
  43. ;;;
  44. (defun ilisp-save ()
  45.   "Save the current state of the result history."
  46.   (declare (special / // /// + ++ +++))
  47.   (unless *ilisp-old-result*
  48.     (setq *ilisp-old-result* (list /// // +++ ++ + /))))
  49.  
  50. ;;;
  51. (defun ilisp-restore ()
  52.   "Restore the old result history."
  53.   (declare (special / // /// + ++ +++ * ** -))
  54.   (setq // (pop *ilisp-old-result*)
  55.     ** (first //)
  56.     /  (pop *ilisp-old-result*)
  57.     *  (first /)
  58.     ++  (pop *ilisp-old-result*)
  59.     +   (pop *ilisp-old-result*)
  60.     -   (pop *ilisp-old-result*))
  61.   (values-list (pop *ilisp-old-result*)))
  62.   
  63. ;;;
  64. (defun ilisp-symbol-name (symbol-name)
  65.   "Return SYMBOL-NAME with the appropriate case as a symbol."
  66.   (case (ilisp-readtable-case *readtable*)
  67.     (:upcase (string-upcase symbol-name))
  68.     (:downcase (string-downcase symbol-name))
  69.     (:preserve symbol-name)))
  70.   
  71. ;;;
  72. (defun ilisp-find-package (package-name)
  73.   "Return package PACKAGE-NAME or the current package."
  74.   (if (string-equal package-name "nil")
  75.       *package*
  76.       (or (find-package (ilisp-symbol-name package-name))
  77.       (error "Package ~A not found" package-name))))
  78.  
  79. ;;;
  80. (defun ilisp-find-symbol (symbol-name package-name)
  81.   "Return the symbol associated with SYMBOL-NAME in PACKAGE-NAME trying to
  82. handle case issues intelligently."
  83.   (find-symbol (ilisp-symbol-name symbol-name)
  84.            (ilisp-find-package package-name)))
  85.  
  86. ;;;
  87. (defun ilisp-eval (form package filename)
  88.   "Evaluate FORM in PACKAGE recording FILENAME as the source file."
  89.   (princ " ")
  90.   (let* ((*package* (ilisp-find-package package))
  91.      #+allegro (excl::*source-pathname* filename)
  92.      #+allegro (excl::*redefinition-warnings* nil)
  93.      #+lucid (lucid::*source-pathname*
  94.           (if (probe-file filename)
  95.               (truename filename)
  96.               (merge-pathnames filename)))
  97.      #+lucid (lucid::*redefinition-action* nil)
  98.      )
  99.     filename
  100.     (eval (read-from-string form))))
  101.  
  102. ;;;
  103. (defun ilisp-compile (form package filename)
  104.   "Compile FORM in PACKAGE recording FILENAME as the source file."
  105.   (princ " ")
  106.   ;; This makes sure that function forms are compiled
  107.   #-lucid
  108.   (ilisp-eval
  109.     (format nil "(funcall (compile nil '(lisp:lambda () ~A)))"
  110.         form)
  111.     package
  112.     filename)
  113.   #+lucid
  114.   (labels ((compiler (form env)
  115.          (if (and (consp form)
  116.               (eq (first form) 'function)
  117.               (consp (second form)))
  118.          #-LCL3.0
  119.          (evalhook `(compile nil ,form) nil nil env)
  120.          #+LCL3.0
  121.          ;; If we have just compiled a named-lambda, and the
  122.          ;; name didn't make it in to the procedure object,
  123.          ;; then stuff the appropriate symbol in to the
  124.          ;; procedure object.
  125.          (let* ((proc (evalhook `(compile nil ,form) nil nil env))
  126.             (old-name (and proc (sys:procedure-ref proc 1)))
  127.             (lambda (second form))
  128.             (name (and (eq (first lambda) 'lucid::named-lambda)
  129.                    (second lambda))))
  130.            (when (or (null old-name)
  131.                  (and (listp old-name) (eq :internal (car old-name))))
  132.              (setf (sys:procedure-ref proc 1) name))
  133.            proc)
  134.          (evalhook form #'compiler nil env))))
  135.       (let ((*evalhook* #'compiler))
  136.         (ilisp-eval form package filename))))
  137.  
  138. ;;;
  139. (defun ilisp-describe (sexp package)
  140.   "Describe SEXP in PACKAGE."
  141.   (ilisp-errors
  142.    (let ((*package* (ilisp-find-package package)))
  143.      (describe (eval (read-from-string sexp))))))
  144.  
  145. ;;;
  146. (defun ilisp-inspect (sexp package)
  147.   "Inspect SEXP in PACKAGE."
  148.   (ilisp-errors
  149.    (let ((*package* (ilisp-find-package package)))
  150.      (inspect (eval (read-from-string sexp))))))
  151.  
  152. ;;;
  153. (defun ilisp-arglist (symbol package)
  154.   "Return the argument list of SYMBOL from PACKAGE."
  155.   (ilisp-errors
  156.    (let ((real-symbol (ilisp-find-symbol symbol package))
  157.      (*print-length* nil)
  158.      (*print-level* nil)
  159.      (*package* (ilisp-find-package package)))
  160.      (if (and real-symbol (fboundp real-symbol))
  161.      (pprint (let* ((function (symbol-function real-symbol))
  162.             (generic-p
  163.              (find-symbol "GENERIC-FUNCTION-P"
  164.                       (or (find-package "PCL")
  165.                       *package*))))
  166.            (if (and (fboundp generic-p) (funcall generic-p function))
  167.                (funcall
  168.             (find-symbol "GENERIC-FUNCTION-PRETTY-ARGLIST"
  169.                      (or (find-package "PCL") *package*))
  170.             function)
  171.                #+allegro (excl::arglist real-symbol)
  172.                #+lucid (lucid::arglist real-symbol)
  173.                #+(or ibcl kcl) (help real-symbol)
  174.                #-(or allegro lucid kcl ibcl)
  175.                (documentation real-symbol 'function))))
  176.      (format t "~A is not a function" symbol)))))
  177.  
  178. ;;;
  179. (defun ilisp-documentation (symbol package type)
  180.   "Return the TYPE documentation for SYMBOL in PACKAGE.  If TYPE is
  181. \(qualifiers* (class ...)), the appropriate method will be found."
  182.   (ilisp-errors
  183.    (let* ((real-symbol (ilisp-find-symbol symbol package))
  184.       (type (if (and (not (zerop (length type)))
  185.              (eq (elt type 0) #\())
  186.             (let ((*package* (ilisp-find-package package)))
  187.               (read-from-string type))
  188.             (ilisp-find-symbol type package))))
  189.      (when (listp type)
  190.        (setq real-symbol
  191.          (funcall
  192.           (find-symbol "FIND-METHOD" (or (find-package "CLOS")
  193.                          (find-package "PCL")
  194.                          *package*))
  195.           (symbol-function real-symbol)
  196.           (reverse
  197.            (let ((quals nil))
  198.          (dolist (entry type quals)
  199.            (if (listp entry)
  200.                (return quals)
  201.                (setq quals (cons entry quals))))))
  202.           (reverse
  203.            (let ((types nil))
  204.          (dolist (class (first (last type)) types)
  205.            (setq types
  206.              (cons (funcall
  207.                 (find-symbol "FIND-CLASS"
  208.                          (or (find-package "CLOS")
  209.                          (find-package "PCL")
  210.                          *package*))
  211.                 class) types))))))))
  212.      (if real-symbol
  213.      (if (symbolp real-symbol)
  214.          (documentation real-symbol type)
  215.          ;; Prevent compiler complaints
  216.          (eval `(documentation ,real-symbol)))
  217.      (format nil "~A has no ~A documentation" symbol type)))))
  218.  
  219. ;;;
  220. (defun ilisp-macroexpand (expression package)
  221.   "Macroexpand EXPRESSION as long as the top level function is still a
  222. macro." 
  223.   (ilisp-errors
  224.    (let ((*print-length* nil)
  225.      (*print-level* nil)
  226.      (*package* (ilisp-find-package package)))
  227.      (pprint (#-allegro macroexpand #+allegro excl::walk
  228.             (read-from-string expression))))))
  229.  
  230. ;;;
  231. (defun ilisp-macroexpand-1 (expression package)
  232.   "Macroexpand EXPRESSION once."
  233.   (ilisp-errors
  234.    (let ((*print-length* nil)
  235.      (*print-level* nil)
  236.      (*package* (ilisp-find-package package)))
  237.      (pprint (macroexpand-1 (read-from-string expression))))))
  238.  
  239. ;;;
  240. (defun ilisp-trace (symbol package)
  241.   "Trace SYMBOL in PACKAGE."
  242.   (ilisp-errors
  243.    (let ((real-symbol (ilisp-find-symbol symbol package)))
  244.      (when real-symbol (eval `(trace ,real-symbol))))))
  245. (defun ilisp-untrace (symbol package)
  246.   "Untrace SYMBOL in PACKAGE."
  247.   (ilisp-errors
  248.    (let ((real-symbol (ilisp-find-symbol symbol package)))
  249.      (when real-symbol (eval `(untrace ,real-symbol))))))
  250.    
  251. ;;;
  252. (defun ilisp-compile-file (file extension)
  253.   "Compile FILE putting the result in FILE+EXTENSION."
  254.   (ilisp-errors
  255.    (compile-file file
  256.          :output-file 
  257.          (merge-pathnames (make-pathname :type extension) file))))
  258.  
  259. ;;;
  260. (defun ilisp-casify (pattern string lower-p upper-p)
  261.   "Return STRING with its characters converted to the case of PATTERN,
  262. continuing with the last case beyond the end."
  263.   (cond (lower-p (string-downcase string))
  264.     (upper-p (string-upcase string))
  265.     (t
  266.      (let (case)
  267.        (concatenate
  268.         'string
  269.         (map 'string
  270.          #'(lambda (p s)
  271.              (setq case (if (upper-case-p p)
  272.                     #'char-upcase
  273.                     #'char-downcase))
  274.              (funcall case s))
  275.          pattern string)
  276.         (map 'string case (subseq string (length pattern))))))))
  277.  
  278. ;;;
  279. (defun ilisp-words (string)
  280.   "Return STRING broken up into words.  Each word is (start end
  281. delimiter)."
  282.   (do* ((length (length string))
  283.     (start 0)
  284.     (end t)
  285.     (words nil))
  286.        ((null end) (nreverse words))
  287.     (if (setq end (position-if-not #'alphanumericp string :start start))
  288.     (setq words (cons (list end (1+ end) t)
  289.               (if (= start end)
  290.                   words
  291.                   (cons (list start end nil) words)))
  292.           start (1+ end))
  293.     (setq words (cons (list start length nil) words)))))
  294.  
  295. ;;;
  296. (defun ilisp-match-words (string pattern words)
  297.   "Match STRING to PATTERN using WORDS."
  298.   (do* ((strlen (length string))
  299.     (words words (cdr words))
  300.     (word (first words) (first words))
  301.     (start1 (first word) (first word))
  302.     (end1 (second word) (second word))
  303.     (delimiter (third word) (third word))
  304.     (len (- end1 start1) (and word (- end1 start1)))
  305.     (start2 0)
  306.     (end2 len))
  307.        ((or (null word) (null start2)) start2)
  308.     (setq end2 (+ start2 len)
  309.       start2
  310.       (if delimiter
  311.           (position (elt pattern start1) string :start start2)
  312.           (when (and (<= end2 strlen)
  313.              (string= pattern string
  314.                   :start1 start1 :end1 end1
  315.                   :start2 start2 :end2 end2))
  316.         (1- end2))))
  317.     (when start2 (incf start2))))
  318.  
  319. ;;;
  320. (defun ilisp-matching-symbols (string package &optional (function-p nil)
  321.                       (external-p nil)
  322.                       (prefix-p nil))
  323.   "Return a list of the symbols that have STRING as a prefix in
  324. PACKAGE. FUNCTION-P indicates that only symbols with a function value
  325. should be considered.  EXTERNAL-P indicates that only external symbols
  326. should be considered.  PREFIX-P means that partial matches should not
  327. be considered.  The returned strings have the same case as the
  328. original string."
  329.   (ilisp-errors
  330.    (let* ((lower-p (notany #'upper-case-p string))
  331.       (upper-p (notany #'lower-case-p string))
  332.       (no-casify (eq (ilisp-readtable-case *readtable*) :preserve))
  333.       (symbol-string (ilisp-symbol-name string))
  334.       (length (length string))
  335.       (results nil)
  336.       (*print-length* nil)
  337.       (*package* (ilisp-find-package package)))
  338.      (labels
  339.      (
  340.       ;; Check SYMBOL against PATTERN
  341.       (check-symbol (symbol pattern)
  342.         (let ((name (symbol-name symbol)))
  343.           (when (and (or (not function-p) (fboundp symbol))
  344.              (>= (length name) length)
  345.              (string= pattern name :end2 length))
  346.         (push (list (if no-casify
  347.                 name
  348.                 (ilisp-casify pattern name lower-p upper-p)))
  349.               results))))
  350.       ;; Check SYMBOL against PATTERN using WORDS 
  351.       (check-symbol2 (symbol pattern words)
  352.         (let ((name (symbol-name symbol)))
  353.           (when (and (or (not function-p) (fboundp symbol))
  354.              (ilisp-match-words name pattern words))
  355.         (push (list (if no-casify
  356.                 name
  357.                 (ilisp-casify pattern name lower-p upper-p)))
  358.               results)))))
  359.        (if external-p
  360.        (do-external-symbols (symbol *package*)
  361.          (check-symbol symbol symbol-string))
  362.        (progn
  363.          ;; KCL does not go over used symbols.
  364.          #+(or kcl ibcl)
  365.          (dolist (used-package (package-use-list *package*))
  366.            (do-external-symbols (symbol used-package)
  367.          (check-symbol symbol symbol-string)))
  368.          (do-symbols (symbol *package*)
  369.            (check-symbol symbol symbol-string))))
  370.        (unless (or results prefix-p)
  371.      (let ((words (ilisp-words symbol-string)))
  372.        (if external-p
  373.            (do-external-symbols (symbol *package*)
  374.          (check-symbol2 symbol symbol-string words))
  375.            (progn
  376.          ;; KCL does not go over used symbols.
  377.          #+(or kcl ibcl)
  378.          (dolist (used-package (package-use-list *package*))
  379.            (do-external-symbols (symbol used-package)
  380.              (check-symbol2 symbol symbol-string words)))
  381.          (do-symbols (symbol *package*)
  382.            (check-symbol2 symbol symbol-string words))))))
  383.        (prin1 results)
  384.        nil))))
  385.  
  386. ;;; Make sure that functions are exported
  387. (dolist (symbol '(ilisp-errors ilisp-save ilisp-restore
  388.           ilisp-symbol-name ilisp-find-symbol ilisp-find-package
  389.           ilisp-eval ilisp-compile
  390.           ilisp-describe ilisp-inspect
  391.           ilisp-arglist ilisp-documentation
  392.           ilisp-macroexpand ilisp-macroexpand-1
  393.           ilisp-trace ilisp-untrace
  394.           ilisp-compile-file ilisp-casify
  395.           ilisp-matching-symbols))
  396.   (export symbol))
  397. (unless (compiled-function-p #'ilisp-matching-symbols)
  398.   (format t "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\""))
  399.