home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 5 / FreshFish_July-August1994.bin / bbs / util / jade-3.0.lha / Jade / lisp / lisp.jl < prev    next >
Encoding:
Text File  |  1994-04-19  |  6.0 KB  |  182 lines
  1. ;;;; lisp.jl -- Some Lispy functions
  2. ;;;  Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (defmacro defvar (symbol init-value &optional doc-string)
  21.   "(defvar NAME DEFAULT-VALUE [DOC-STRING]) <MACRO>
  22. Define a variable called NAME whose standard initial-value is DEFAULT-
  23. VALUE. If NAME is already bound to a value it is left as it is."
  24.   (list 'progn
  25.     (list
  26.       'unless
  27.       (list 'boundp (list 'quote symbol))
  28.       (list 'setq symbol init-value))
  29.     (list 'when
  30.       doc-string
  31.       (list 'put (list 'quote symbol) ''variable-documentation doc-string))
  32.     (list 'quote symbol)))
  33.  
  34. (defmacro defconst (symbol init-value &optional doc-string)
  35.   "(defconst NAME DEFAULT-VALUE [DOC-STRING]) <MACRO>
  36. Define a constant NAME whose standard value is DEFAULT-VALUE.
  37. If NAME is already bound to a value it is left untouched."
  38.   (list 'progn
  39.     (list
  40.       'unless
  41.       (list 'boundp (list 'quote symbol))
  42.       (list 'setq symbol init-value))
  43.     (list 'set-const-variable (list 'quote symbol))
  44.     (list 'when
  45.       (list 'stringp doc-string)
  46.       (list 'put (list 'quote symbol) ''variable-documentation doc-string))
  47.     (list 'quote symbol)))
  48.  
  49. (setq features ())
  50. (defun require (feature)
  51.   (unless (member feature features)
  52.     (load (format-string "%s" feature))))
  53. (defun provide (feature)
  54.   (unless (member feature features)
  55.       (setq features (cons feature features))))
  56. (defun featurep (feature)
  57.   (member feature features))
  58.  
  59. (defun add-hook (hook-sym new-func &optional at-end)
  60.   "(add-hook HOOK-SYMBOL FUNCTION-NAME [AT-END])
  61. Arrange it so that FUNCTION-NAME is added to the hook-list stored in
  62. symbol, HOOK-SYMBOL. It will added at the head of the list unless AT-END
  63. is non-nil in which case it is added at the end."
  64.   (unless (boundp hook-sym)
  65.     (set hook-sym nil))
  66.   (if at-end
  67.       (set hook-sym (nconc (symbol-value hook-sym) (cons new-func nil)))
  68.     (set hook-sym (cons new-func (symbol-value hook-sym)))))
  69.  
  70. (defun remove-hook (hook-sym old-func)
  71.   "(remove-hook HOOK-SYMBOL FUNCTION-NAME)
  72. Remove FUNCTION-NAME from the hook HOOK-SYMBOL."
  73.   (set hook-sym (delete old-func (symbol-value hook-sym))))
  74.  
  75. (defun documentation (symbol &optional use-var-doc &aux doc)
  76.   "(documentation SYMBOL [IS-VARIABLE])
  77. Returns the documentation-string for SYMBOL. If IS-VARIABLE is t the
  78. documentation for the variable stored in SYMBOL is returned, else
  79. the function doc is provided."
  80.   (when (symbolp symbol)
  81.     (if use-var-doc
  82.     (setq doc (get symbol 'variable-documentation))
  83.       (setq symbol (symbol-function symbol))
  84.       (cond
  85.     ((subr-p symbol)
  86.       (setq doc (subr-documentation symbol)))
  87.     ((or (eq 'macro (car symbol)) (eq 'special (car symbol)))
  88.       (setq doc (nth 3 symbol)))
  89.     (t
  90.       (setq doc (nth 2 symbol)))))
  91.     (when (numberp doc)
  92.       (setq doc (get-doc-string doc)))
  93.     (when (stringp doc)
  94.       doc)))
  95.  
  96. (defun document-var (symbol doc-string)
  97.   "(document-var SYMBOL DOC-STRING)
  98. Sets the `variable-documentation' property of SYMBOL to DOC-STRING."
  99.   (put symbol 'variable-documentation doc-string)
  100.   symbol)
  101.  
  102. (defun format-string (&rest args)
  103.   (car (apply 'format (cons "") args)))
  104.  
  105. (defun read-from-string (string &optional start)
  106.   "(read-from-string STRING [START])
  107. Reads an object from STRING, starting at character number START (default
  108. is 0)."
  109.   (read (cons (if (numberp start) start 0) string)))
  110.  
  111. (defun autoload (symbol file)
  112.   "(autoload SYMBOL FILE)
  113. Tell the evaluator that the function value of SYMBOL will be initialised
  114. when the FILE is loaded."
  115.   (fset symbol (list 'autoload file)))
  116.  
  117. (defmacro setcar (&rest args)
  118.   (cons 'rplaca args))
  119. (defmacro setcdr (&rest args)
  120.   (cons 'rplacd args))
  121. (defmacro eql (&rest args)
  122.   (cons 'eq args))
  123. (defmacro string= (&rest args)
  124.   (cons 'equal args))
  125. (fset 'string-equal-p (symbol-function 'string=))
  126. (defmacro string< (&rest args)
  127.   (cons '< args))
  128. (fset 'string-less-p (symbol-function 'string<))
  129.  
  130. (defun set-variable ()
  131.   "(set-variable)
  132. Prompts for a variable and a value to set it to."
  133.   (let
  134.       ((var (prompt-for-variable "Variable name: ")))
  135.     (when var
  136.       (let
  137.       ((val (lisp-prompt "Value: ")))
  138.     (when (and val (setq val (read-from-string val)))
  139.       (set var val))))))
  140.  
  141. (defun show-variable ()
  142.   "(show-variable)
  143. Prompts for a variable and returns its value."
  144.   (let
  145.       ((var (prompt-for-variable "Variable name: ")))
  146.     (when var
  147.       (symbol-value var))))
  148.  
  149. (defun error (&rest args)
  150.   (signal 'error (list (apply 'format-string args))))
  151.  
  152. ;;; Command interface to Lisp functions
  153.  
  154. (defvar command-arg-list nil
  155.   "List of arguments to next `command-prompt' function")
  156.  
  157. (defun add-command-arg (&optional arg)
  158.   "(add-command-arg [ARG])
  159. Add ARG (will prompt if not given) to the list of arguments to be given to
  160. the next command invoked by `command-prompt'."
  161.   (unless arg
  162.     (setq arg (eval (read-from-string (prompt2 'prompt-complete-symbol
  163.                            "Enter next argument:")))))
  164.   (when arg
  165.     (setq command-arg-list (nconc command-arg-list (cons arg nil)))))
  166.  
  167. (defun clear-command-args ()
  168.   "(clear-command-args)
  169. Discard any arguments to be used by `command-prompt'."
  170.   (setq command-arg-list nil))
  171.  
  172. (defun command-prompt (&optional title)
  173.   "(command-prompt [TITLE])
  174. Prompt for the name of a function then invoke it with the contents of
  175. `command-arg-list' as arguments."
  176.   (let
  177.       ((res (apply (prompt-for-function (if title title "Enter command name:"))
  178.            command-arg-list)))
  179.     (setq command-arg-list nil)
  180.     (prin1 res t)
  181.     res))
  182.