home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 1 / 1615 / compile.w next >
Encoding:
Text File  |  1990-12-28  |  1.8 KB  |  78 lines
  1. ; LISP subset compiler
  2. ;
  3. ; compiles function applications with constant
  4. ; or nested function call arguments
  5. ;
  6. ; see B.A. Pumplin, "Compiling LISP Procedures"
  7. ; ACM SIGART Newsletter 99, January, 1987
  8.  
  9. ; primary functions
  10.  
  11. (set 'compexp
  12.     '(lambda (exp)
  13.     (cond ((isconst exp) (list (mksend 1 exp)))
  14.         (t (compapply (func exp)
  15.             (complis (arglist exp))
  16.             (length (arglist exp)))))))
  17.  
  18. (set 'complis
  19.     '(lambda (u)
  20.     (cond ((null u) '())
  21.         ((null (rest u)) (compexp (first u)))
  22.         (t (append-3 (compexp (first u))
  23.             (list (mkalloc 1))
  24.             (complis (rest u)))))))
  25.  
  26. (set 'compapply
  27.     '(lambda (fn vals n)
  28.     (append-3 vals (mklink n) (list (mkcall fn)))))
  29.  
  30.  
  31. ; recognizer function
  32.  
  33. (set 'isconst
  34.     '(lambda (x)
  35.     (or (numberp x) (eq x t) (eq x nil)
  36.         (and (not (atom x)) (eq (first x) 'quote)))))
  37.  
  38.  
  39. ; selector functions
  40. (set 'func '(lambda (x) (first x)))
  41. (set 'arglist '(lambda (x) (rest x)))
  42.  
  43.  
  44. ; constructor functions
  45. ; (code generator)
  46. (set 'mksend '(lambda (dest val) (list 'MOVEI dest val)))
  47. (set 'mkalloc '(lambda (dest) (list 'PUSH 'sp dest)))
  48. (set 'mkcall '(lambda (fn) (list 'CALL fn)))
  49. (set 'mklink
  50.     '(lambda (n) 
  51.     (cond ((eqn n 1) '())
  52.         (t (concat (mkmove n 1) (mklink1 (sub1 n)))))))
  53. (set 'mklink1
  54.     '(lambda (n)
  55.     (cond ((zerop n) '())
  56.         (t (concat (mkpop n) (mklink1 (sub1 n)))))))
  57. (set 'mkpop '(lambda (n) (list 'POP 'sp n)))
  58. (set 'mkmove '(lambda (dest val) (list 'MOVE dest val)))
  59.  
  60.  
  61. ; auxiliary functions
  62. (set 'first '(lambda (x) (car x)))
  63. (set 'rest '(lambda (x) (cdr x)))
  64. (set 'concat
  65.     '(lambda (element sequence)
  66.     (cond ((listp sequence) (cons element sequence))
  67.         (t '()))))
  68. (set 'append-3
  69.     '(lambda (l1 l2 l3)
  70.     (append l1 (append l2 l3))))
  71. (set 'listp
  72.     '(lambda (x)
  73.     (cond ((consp x) t) ((null x) t) (t nil))))
  74.  
  75. ; not built in to walk
  76. (set 'consp '(lambda (e) (not (atom e))))
  77. (set 'eqn '(lambda (x y) (eq x y)))
  78.