home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / LISP / PDLISP.ZIP / MISC.L < prev    next >
Encoding:
Text File  |  1986-04-14  |  8.8 KB  |  383 lines
  1. ; misc.l - Copyright (c) 1986 by David Morein.
  2. ;
  3. ; this file contains miscellaneous routines which
  4. ; don't belong anywhere else.
  5. ;
  6. ; note - this is an initialization file, see the manual for more info.
  7. ;
  8. ; global functions:
  9. ;
  10. (global 'add1)
  11. (global 'add-to-list)
  12. (global 'assoc)
  13. (global 'compiled-function-p)
  14. (global 'csubrp)
  15. (global 'cnsubrp)
  16. (global 'defmacro)
  17. (global 'defun)
  18. (global 'do)
  19. (global 'do*)
  20. (global 'firstn)
  21. (global 'function)
  22. (global 'gensym)
  23. (global 'implode)
  24. (global 'intern)
  25. ;(global 'if)
  26. (global 'lconc)
  27. (global 'loop)
  28. (global 'make-tconc)
  29. (global 'max)
  30. (global 'min)
  31. (global 'nsubrp)
  32. (global 'nth)
  33. (global 'nthcdr)
  34. (global 'nthelem)
  35. (global 'prog)
  36. (global 'prog*)
  37. (global 'remove-first)
  38. (global 'sprint)
  39. (global 'subrp)
  40. (global 'subst)
  41. (global 'sub1)
  42. (global 'tconc)
  43. (global 'type)
  44. (global 'unless)
  45. (global 'when)
  46. ;
  47. ; defun - Common LISP style defun
  48. ;
  49. ; this macro expands to:
  50. ; (progn
  51. ;   (putd
  52. ;     '<name>
  53. ;     '(lambda <lambda-list> (block <name> <form>)))
  54. ;  '<name>)
  55. ;
  56. (def defun (macro (name lambda-list &rest form)
  57.   (list 'progn
  58.     (list 'putd
  59.       (list 'quote name)
  60.       (list 'quote
  61.         (list 'lambda lambda-list
  62.           (list 'block name form))))
  63.     (list 'quote name))))
  64. ;
  65. ; defmacro - Common LISP style defmacro
  66. ;
  67. (def defmacro (macro (name lambda-list &rest form)
  68.   (list 'progn
  69.     (list 'putd
  70.       (list 'quote name)
  71.       (list 'quote
  72.         (list 'macro lambda-list form)))
  73.     (list 'quote name))))
  74. ;
  75. ;
  76. ; add-to-list - adds expression e to list l if it is not already present.
  77. ; this function returns the altered list as its value.
  78. ;
  79. (defun add-to-list (e l)
  80.     (cond  ((member e l) l)
  81.             (t (cons e l))))
  82. ;
  83. ;
  84. ; add1 - returns n + 1
  85. ;
  86. (defun add1 (x) (+ x 1))
  87. ;
  88. ;
  89. ; assoc - associates e with l in an association list
  90. ;
  91. (defun assoc (e l)
  92.     (cond
  93.         ((null l) nil)
  94.         ((equal e (caar l)) (car l))
  95.         (t (assoc e (cdr l)))))
  96. ;
  97. ;
  98. ; compiled-function-p - Common Lisp compatible.
  99. ;
  100. (defun compiled-function-p (x)
  101.     (or (csubrp x) (cnsubrp x) (subrp x) (nsubrp x)))
  102. ;
  103. ;
  104. ; csubrp - return T iff x is bound as a csubr
  105. ;
  106. (defun csubrp (x)
  107.     (eq (type x) 'csubr))
  108. ;
  109. ;
  110. ; cnsubrp - return T iff x is bound as a cnsubr
  111. ;
  112. (defun cnsubrp (x)
  113.     (eq (type x) 'cnsubr))
  114. ;
  115. ;
  116. ; do - structured iterative construct.
  117. ;
  118. (defmacro do (initlist term_case &rest body)
  119.   (list 'block 'nil
  120.     (list 'let initlist
  121.       (list 'loop1
  122.     (filter-nulls (mapcar 'extract-update-form initlist))
  123.         (list 'cond (list (car term_case) (list 'return (cadr term_case))))
  124.         (cons 'tagbody body)))))
  125. ;
  126. ;
  127. ; extract-update-form: extracts any update forms from
  128. ; an initialization list.
  129. ;
  130. (def extract-update-form (nlambda (initform)
  131.     (progn
  132.     (setq init_var  (car   initform))
  133.     (setq init_val  (cadr  initform))
  134.     (setq init_step (caddr initform))
  135.     (cond (init_step (list 'setq init_var initstep))
  136.           (t          nil)))))
  137. ;
  138. ; filter-nulls: filters out nulls from a list
  139. ;
  140. (defun filter-nulls (l)
  141.     (cond    ((null l)        l)
  142.         ((null (car l))        (filter-nulls (cdr l)))
  143.         (t    (cons (car l) (filter-nulls (cdr l))))))
  144. ;
  145. ; do* - structured iterative construct with parallel binding.
  146. ;
  147. (defmacro do* (initlist term_case &rest body)
  148.   (list 'block 'nil
  149.     (list 'let* initlist
  150.       (list 'loop1
  151.         (list 'cond (list (car term_case) (list 'return (cadr term_case))))
  152.         (cons 'tagbody body)))))
  153. ;
  154. ;
  155. ; firstn - returns a list of the first n elements of l.
  156. ;   (i.e., (firstn 2 '(a b c d e)) ==> (a b))
  157. ;
  158. (defun firstn (n l)
  159.     (reverse (nthcdr (- (length l) (min (length l) n)) (reverse l))))
  160. ;
  161. ;
  162. ; function - as far as the interpreter is concerned,
  163. ; this is the same as QUOTE. Lexical closures
  164. ; will be introduced in a later release.
  165. ;
  166. (def function (nlambda (x) x))
  167. ;
  168. ; gensym - creates an new, uninterned symbol.
  169. ; see the Common Lisp manual or the UNXLISP manual
  170. ; for all of the arcana associated with this function.
  171. ;
  172. (defun gensym (&optional x)
  173.     (make-symbol (genstring x)))
  174. ;
  175. ;
  176. ; the following code will be un-commented when
  177. ; the compiler is ready:
  178. ;
  179. ; if - Common compatible IF macro:
  180. ;
  181. ;(defmacro if (test result-if-true &optional result-if-false)
  182. ;    `(cond (,test ,result-if-true) (t ,result-if-false)))
  183. ;
  184. ;
  185. ; implode - implodes a list of symbols into a new
  186. ; symbol with a print-name which is the concatenation
  187. ; of all of the constituent names.
  188. ;
  189. (defun implode (x)
  190.     (intern (implode-to-string x)))
  191. ;
  192. ;
  193. ; intern - interns a symbol in a specified directory
  194. ;
  195. (defun intern (id &optional directory)
  196.     (cond
  197.         ((null directory) (internc id))
  198.         (t (progn
  199.               (pd directory)
  200.               (internc id)
  201.               (popd)))))
  202. ;
  203. ; loop - loops until an explicit return
  204. ;
  205. (defmacro loop (&rest body)
  206.     (list 'block 'nil (list 'loop1 body)))
  207. ;
  208. ; max - returns the maximum of its arguments
  209. ;
  210. (defun max (x y)
  211.     (cond ((> x y) x)
  212.         (t y)))
  213. ;
  214. ; min - returns the minimum of its arguments
  215. ;
  216. (defun min (x y)
  217.     (cond
  218.         ((< x y) x)
  219.         (t y)))
  220. ;
  221. ;
  222. ; nth - similar to Franz nth; returns the nth
  223. ; element of a list, with the first element of
  224. ; the list having an index of 0.
  225. ;
  226. (defun nth (n e)
  227.     (car (nthcdr n e)))
  228. ;
  229. ;
  230. ; nthcdr - similar to Franz nthcdr; cdrs down a list
  231. ; n times. (i.e., (nthcdr 2 '(a b c d e)) ==> (c d e)).
  232. ;
  233. (defun nthcdr (n e)
  234.     (do ((i 0))            ;initialize i to 0.
  235.         ((eql i n) e)        ;termination test.
  236.         (setq i (+ i 1))    ;increment i.
  237.         (setq e (cdr e))))    ;body of do
  238. ;                
  239. ;
  240. ; nthelem - similar to Franz nthelem; returns the nth
  241. ; element of a list, with the first element of
  242. ; the list having an index of 1.
  243. ;
  244. (defun nthelem (n e)
  245.     (car (nthcdr (- n 1) e)))
  246. ;
  247. ;
  248. ; nsubrp - return T iff x is bound as an nsubr
  249. ;
  250. (defun nsubrp (x)
  251.     (eq (type x) 'nsubr))
  252. ;
  253. ;
  254. ; prog - generalized iterative construct.
  255. ;
  256. (defmacro prog (vbl_list &rest body)
  257.     (list 'block 'nil
  258.         (list 'let vbl_list
  259.             (cons 'tagbody body))))
  260. ;
  261. ; prog* - generalized iterative construct with parallel binding.
  262. ;
  263. (defmacro prog* (vbl_list &rest body)
  264.     (list 'block 'nil
  265.         (list 'let* vbl_list
  266.             (cons 'tagbody body))))
  267. ;
  268. ; sprint - "safe" print utility, prints s-expression x
  269. ; down to level LEV. Expressions more than LEV levels
  270. ; down are printed as &.
  271. ;
  272. (defun sprint (x lev)
  273.     (cond   ((atom x) x)
  274.             ((eql 0 lev) '&)
  275.             ((and (atom (cdr x)) (cdr x)) x)
  276.             (t (cons
  277.         (sprint (car x) (sub1 lev))
  278.         (sprint (cdr x) lev)))))
  279. ;
  280. ;
  281. ; subst - substitutes a for b in c
  282. ; there are no restrictions on a, b, and c.
  283. ;
  284. ;
  285. (defun subst (a b c)
  286.     (cond
  287.         ((equal b c) a)
  288.         ((atom c) c)
  289.         (t (cons (subst a b (car c)) (subst a b (cdr c))))))
  290. ;
  291. ;
  292. ; subrp - return T iff x is bound as a subr
  293. ;
  294. (defun subrp (x)
  295.     (eq (type x) 'subr))
  296. ;
  297. ;
  298. ; sub1 - returns n - 1
  299. ;
  300. (defun sub1 (x)
  301.     (- x 1))
  302. ;
  303. ;
  304. ; make-tconc - creates a new tconc structure
  305. ;
  306. (def make-tconc (lambda ()
  307.     (cons 'nil 'nil)))
  308. ;
  309. ;
  310. ; lconc - adds an element, Y to the end of a tconc cell, X.
  311. ;
  312. (def lconc (lambda (x y)
  313.     (let ((listy (list y)))
  314. ;
  315. ; if x was empty, then y is now the
  316. ; first and last element.
  317. ;
  318.     (cond
  319.         ((null (cdr x))
  320.         (rplaca x listy)
  321.         (rplacd x listy))
  322.         (t
  323.         (rplacd (last (car x)) listy)
  324.             (rplacd x listy)))
  325.     x)))
  326. ;
  327. ; tconc - adds an element, y, to a tconc structure, x.
  328. ;          a tconc structure is a type of s-expression
  329. ;          with pointers to both the head and tail
  330. ;          of a list.
  331. ;
  332. (def tconc (lambda (x y)
  333.     (let ((listy (list y)))
  334.       (rplacd listy (car x))
  335.       (rplaca x listy)
  336.       (if (null (cdr x)) 
  337.         (rplacd x listy))
  338.       x)))
  339. ;
  340. ;
  341. ; remove-first - removes the first element from a tconc cell:
  342. ;
  343. (def remove-first (lambda (x)
  344.     (cond
  345.         ((null (car x)) 'nil)    ;return NIL if empty tconc cell.
  346.     ((null (cdar x))
  347.         (let ((element (caar x)))
  348.              (rplaca x 'nil)
  349.          (rplacd x 'nil)
  350.          element))
  351.         (t
  352.             (let ((element (caar x)))
  353.              (rplaca x (cdar x))
  354.          element))))) 
  355.  
  356. ; type - returns the type of a symbol which is bound as a function.
  357. ;
  358. (def type (lambda (x)
  359.     (cond
  360.         ((not (symbolp x))
  361.             (err "***> TYPE: arg not a symbol"))
  362.         ((not (fboundp x))
  363.             (err "***> TYPE: arg not bound as a function"))
  364.         (t 
  365.             (car (symbol-function x))))))
  366. ;
  367. ; unless - Common LISP compatible UNLESS
  368. ;
  369. (defmacro unless (test &rest forms)
  370.     `(cond
  371.         ((null ,test) (progn ,@forms))
  372.         (t nil)))
  373. ;
  374. ; when - Common LISP compatible WHEN
  375. ;
  376. (defmacro when (test &rest forms)
  377.     `(cond
  378.         ((null ,test) nil)
  379.         (t (progn ,@forms))))
  380. ;
  381. ;
  382. ; end of misc.l
  383. ;