home *** CD-ROM | disk | FTP | other *** search
/ Mac Mania 2 / MacMania 2.toast / Demo's / Tools&Utilities / Programming / PowerLisp 1.1 / examples / sample.lisp < prev   
Encoding:
Text File  |  1992-12-10  |  7.1 KB  |  227 lines  |  [TEXT/ROSA]
  1. ;    File:        sample.lisp
  2. ;    Contents:    sample lisp function definition.
  3. ;
  4.  
  5. ;
  6. ; rev function
  7. ; reverses a list recursively
  8. ;
  9. (defun rev (l)
  10.     (cond
  11.         ((null l) nil)
  12.         ((append (rev (cdr l)) (list (car l))))))
  13.  
  14. ;
  15. ; fast-rev function
  16. ; reverses a list iteratively
  17. ;
  18. (defun fast-rev (list)
  19.     (let ((result nil)) 
  20.         (dolist (i list result) 
  21.             (push i result))))
  22.  
  23.  
  24. ;
  25. ; define alphabet just for something to manipulate
  26. ;
  27. (setq alpha '(a b c d e f g h i j k l m n o p q r s t u v w x y z))
  28.  
  29. (defun vector-start (stream char)
  30.     (apply #'vector (read-delimited-list #\])))
  31. (defun vector-end (stream char) nil)
  32. (set-macro-character #\[ #'vector-start)
  33. (set-macro-character #\] #'vector-end)
  34.  
  35. ;
  36. ;    Function 'write-chars'
  37. ;    Writes n characters to std output
  38. ;
  39. (defun write-chars (c n &optional stream) 
  40.     "write-chars char num
  41.     Usage: (write-chars char numchars)
  42.     Writes characters to standard output by default,
  43.     or to any supplied stream."
  44.     (do 
  45.         ((i 0 (+ i 1))) 
  46.         ((>= i n) nil) 
  47.         (if stream
  48.             (write-char c stream)
  49.             (write-char c))))
  50.  
  51. ;
  52. ;    Function 'dump-file 
  53. ;
  54. (defun dump-file (filename)
  55.     "Usage: (dump-file FILENAME)
  56.     Writes the contents of a file to standard output."
  57.     (let ((stream (open filename)) c)
  58.         (loop 
  59.             (setq c (read-char stream))
  60.             (if (eq c 'Eof) (return))
  61.             (write-char c))))
  62.     
  63.     
  64. ;
  65. ;    read-function is useful for reading a specific named function from
  66. ;    a file when you don't want to load the whole file
  67. ;
  68. (defun read-function (func &optional stream)
  69.     "read-function (function-name &optional stream)
  70.     Usage: (read-function func-name (open \"filename\"))
  71.     This causes the function 'func-name' to be read from the file 'filename'.
  72.     Returns the function definition, or NIL if not found. It is the responsibility
  73.     of the caller to evaluate it, in order to create the function.
  74.     i.e. (eval (read-function func-name stream))"
  75.     (do ((in)) ((eq in 'Eof))
  76.         (if stream (setq in (read stream)) (setq in (read)))
  77.         (if (eq in 'Eof) (return nil))
  78.         (if (and (listp in) (eq (car in) 'defun) (eq (cadr in) func)) (return in))))
  79.  
  80. ;--------------------------------------------------------------------------
  81. ;
  82. ;    print-function
  83. ;    This function is useful for printing out a readable definition of a function.
  84. ;    It is printed in the context of the function's own package, so that package
  85. ;    qualifiers are not printed before private variables.
  86. ;
  87. (defun print-function (a &optional stream) 
  88.     "print-function (function-name &optional stream)
  89.     Usage: (print-function func-name (open \"filename\"))
  90.     This causes the function 'func-name' to be printed to the file 'filename'.
  91.     Omitting the stream argument causes the function to be printed to the
  92.     screen.
  93.     Returns NIL."
  94.  
  95.     (let ((save-package (package-name *package*)) 
  96.             (save-print-escape *print-escape*)
  97.             (funcdef (function-definition (eval (list 'function a)))))
  98.         (in-package (package-name (symbol-package a)))
  99.         (setq *print-escape* t)
  100.  
  101.         ;    replace "macro" with "defmacro name"
  102.         ;     and "lambda" with "defun name"
  103.         (if (and (symbolp a) funcdef (consp funcdef))
  104.             (if (eq (car funcdef) 'macro)
  105.                 (setq funcdef (cons 'defmacro (cons a (cdr funcdef))))
  106.                 (if (eq (car funcdef) 'lambda)
  107.                     (setq funcdef (cons 'defun (cons a (cdr funcdef)))))))
  108.  
  109.         (if stream 
  110.             (progn 
  111.                 (print (list 'in-package (package-name (symbol-package a))) stream)
  112.                 (print funcdef stream))
  113.             (progn
  114.                 (print (list 'in-package (package-name (symbol-package a))))
  115.                 (print funcdef)))
  116.         (in-package save-package)
  117.         (setq *print-escape* save-print-escape)
  118.     nil))
  119.  
  120. ;--------------------------------------------------------------------------
  121. ;
  122. ;    dump-hash-table is useful for printing out the contents of a hash table
  123. ;
  124. (defun dump-hash-table (table)
  125.     "dump-hash-table (hash-table)
  126.     Usage: (dump-hash-table hash-table)"
  127.     (maphash #'(lambda (key val) 
  128.                     (write "pair: ")
  129.                     (write key)
  130.                     (write " ")
  131.                     (write val)
  132.                     (terpri)) table))
  133.  
  134. ;--------------------------------------------------------------------------
  135. ;
  136. ;    show-lisp-symbols is useful for printing out the names of all the common
  137. ;    lisp symbols
  138. ;
  139. (defun show-lisp-symbols ()
  140.     "Usage: (show-lisp-symbols)
  141.     Displays all the symbols in the COMMON-LISP package."
  142.     (dump-hash-table (package-hash-table (find-package "COMMON-LISP"))))
  143. ;
  144. ;    read-function is useful for reading a specific named function from
  145. ;    a file when you don't want to load the whole file
  146. ;
  147. (defun read-function (func &optional stream)
  148.     "read-function (function-name &optional stream)
  149.     Usage: (read-function func-name (open \"filename\"))
  150.     This causes the function 'func-name' to be read from the file 'filename'.
  151.     Returns the function definition, or NIL if not found. It is the responsibility
  152.     of the caller to evaluate it, in order to create the function.
  153.     i.e. (eval (read-function func-name stream))"
  154.     (do ((in)) ((eq in 'Eof))
  155.         (if stream (setq in (read stream)) (setq in (read)))
  156.         (if (eq in 'Eof) (return nil))
  157.         (if (and (listp in) (eq (car in) 'defun) (eq (cadr in) func)) (return in))))
  158.  
  159. ;--------------------------------------------------------------------------
  160. ;
  161. ;    print-function
  162. ;    This function is useful for printing out a readable definition of a function.
  163. ;    It is printed in the context of the function's own package, so that package
  164. ;    qualifiers are not printed before private variables.
  165. ;
  166. (defun print-function (a &optional stream) 
  167.     "print-function (function-name &optional stream)
  168.     Usage: (print-function func-name (open \"filename\"))
  169.     This causes the function 'func-name' to be printed to the file 'filename'.
  170.     Omitting the stream argument causes the function to be printed to the
  171.     screen.
  172.     Returns NIL."
  173.  
  174.     (let ((save-package (package-name *package*)) 
  175.             (save-print-escape *print-escape*)
  176.             (funcdef (function-definition (eval (list 'function a)))))
  177.         (in-package (package-name (symbol-package a)))
  178.         (setq *print-escape* t)
  179.  
  180.         ;    replace "macro" with "defmacro name"
  181.         ;     and "lambda" with "defun name"
  182.         (if (and (symbolp a) funcdef (consp funcdef))
  183.             (if (eq (car funcdef) 'macro)
  184.                 (setq funcdef (cons 'defmacro (cons a (cdr funcdef))))
  185.                 (if (eq (car funcdef) 'lambda)
  186.                     (setq funcdef (cons 'defun (cons a (cdr funcdef)))))))
  187.  
  188.         (if stream 
  189.             (progn 
  190.                 (print (list 'in-package (package-name (symbol-package a))) stream)
  191.                 (print funcdef stream))
  192.             (progn
  193.                 (print (list 'in-package (package-name (symbol-package a))))
  194.                 (print funcdef)))
  195.         (in-package save-package)
  196.         (setq *print-escape* save-print-escape)
  197.     nil))
  198.  
  199. ;--------------------------------------------------------------------------
  200. ;
  201. ;    dump-hash-table is useful for printing out the contents of a hash table
  202. ;
  203. (defun dump-hash-table (table)
  204.     "dump-hash-table (hash-table)
  205.     Usage: (dump-hash-table hash-table)"
  206.     (maphash #'(lambda (key val) 
  207.                     (write "pair: ")
  208.                     (write key)
  209.                     (write " ")
  210.                     (write val)
  211.                     (terpri)) table))
  212.  
  213. ;--------------------------------------------------------------------------
  214. ;
  215. ;    show-lisp-symbols is useful for printing out the names of all the common
  216. ;    lisp symbols
  217. ;
  218. (defun show-lisp-symbols ()
  219.     "Usage: (show-lisp-symbols)
  220.     Displays all the symbols in the COMMON-LISP package."
  221.     (dump-hash-table (package-hash-table (find-package "COMMON-LISP"))))
  222.  
  223. ; print n spaces to standard output
  224. (defun spaces (n) 
  225.     (dotimes (i n) (write " ")))
  226.  
  227.