home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 5 / FreshFish_July-August1994.bin / bbs / util / jade-3.0.lha / Jade / lisp / compiler.jl < prev    next >
Encoding:
Text File  |  1994-04-16  |  27.7 KB  |  884 lines
  1. ;;;; compiler.jl -- Simple compiler for Lisp files/forms
  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. ;;;
  21. ;;; The opcode of instructions which take an argument is:
  22. ;;; bits:
  23. ;;;   0->2 argument/type, 0->5 = literal, 6 = next byte, 7 = next 2 bytes.
  24. ;;;   3->7 opcode.
  25. ;;;
  26. ;;; If an instruction needs extra bytes only the bottom 7 bits of each are
  27. ;;; used, the top bit is always set. (This is so no \0 bytes end up in the
  28. ;;; string.)
  29. ;;;
  30. ;;; When two extra bytes are used the high 7 bits are stored first, then the
  31. ;;; low seven bits.
  32. ;;;
  33.  
  34. (provide 'compiler)
  35.  
  36. ;; Options
  37. (defvar comp-eval-constants-p t
  38.   "When t any references to variables which are marked as being constant (ie,
  39. by `defconst' or `set-constant-variable') are evaluated at compile time.")
  40.  
  41. (defvar comp-write-docs-p nil
  42.   "When t all doc-strings are appended to the doc file and replaced with
  43. their position in that file.")
  44.  
  45. ;; Opcodes
  46. (defconst op-call 0x08)            ; call (stk[n] stk[n-1] ... stk[0])
  47.                     ;pops n values, replacing the
  48.                     ;function with the result.
  49. (defconst op-push 0x10)            ; pushes constant # n
  50. (defconst op-vrefc 0x18)        ; pushes val of symbol n (in c-v)
  51. (defconst op-vsetc 0x20)        ; sets symbol n (in c-v) to stk[0],
  52.                     ;then pops the stack.
  53. (defconst op-list 0x28)            ; makes top n items into a list
  54. (defconst op-bind 0x30)            ; bind constant n to stk[0], pops stk
  55.  
  56. (defconst op-last-with-args 0x37)
  57.  
  58. (defconst op-vref 0x40)            ; replace symbol with it's value
  59. (defconst op-vset 0x41)            ; set (sym)stk[0]=stk[1], pops both
  60. (defconst op-fref 0x42)            ;  similar to vref/vset, but for
  61. (defconst op-fset 0x43)            ;function value.
  62. (defconst op-init-bind 0x44)        ; initialise a new set of bindings
  63. (defconst op-unbind 0x45)        ; unbind all bindings in the top set
  64. (defconst op-dup 0x46)            ; duplicate top of stack
  65. (defconst op-swap 0x47)            ; swap top two values on stack
  66. (defconst op-pop 0x48)            ; pops the stack
  67.  
  68. (defconst op-nil 0x49)            ; pushes nil
  69. (defconst op-t 0x4a)            ; pushes t
  70. (defconst op-cons 0x4b)
  71. (defconst op-car 0x4c)
  72. (defconst op-cdr 0x4d)
  73. (defconst op-rplaca 0x4e)
  74. (defconst op-rplacd 0x4f)
  75. (defconst op-nth 0x50)
  76. (defconst op-nthcdr 0x51)
  77. (defconst op-aset 0x52)
  78. (defconst op-aref 0x53)
  79. (defconst op-length 0x54)
  80. (defconst op-eval 0x55)
  81. (defconst op-plus-2 0x56)        ; The `-2' on the end means that it
  82. (defconst op-negate 0x57)        ;only works on 2 arguments.
  83. (defconst op-minus-2 0x58)
  84. (defconst op-product-2 0x59)
  85. (defconst op-divide-2 0x5a)
  86. (defconst op-mod-2 0x5b)
  87. (defconst op-bit-not 0x5c)
  88. (defconst op-not 0x5d)
  89. (defconst op-bit-or-2 0x5e)
  90. (defconst op-bit-and-2 0x5f)
  91. (defconst op-equal 0x60)
  92. (defconst op-eq 0x61)
  93. (defconst op-num-eq 0x62)
  94. (defconst op-num-noteq 0x63)
  95. (defconst op-gtthan 0x64)
  96. (defconst op-gethan 0x65)
  97. (defconst op-ltthan 0x66)
  98. (defconst op-lethan 0x67)
  99. (defconst op-inc 0x68)
  100. (defconst op-dec 0x69)
  101. (defconst op-lsh 0x6a)
  102. (defconst op-zerop 0x6b)
  103. (defconst op-null 0x6c)
  104. (defconst op-atom 0x6d)
  105. (defconst op-consp 0x6e)
  106. (defconst op-listp 0x6f)
  107. (defconst op-numberp 0x70)
  108. (defconst op-stringp 0x71)
  109. (defconst op-vectorp 0x72)
  110. (defconst op-catch-kludge 0x73)
  111. (defconst op-throw 0x74)
  112. (defconst op-unwind-pro 0x75)
  113. (defconst op-un-unwind-pro 0x76)
  114. (defconst op-fboundp 0x77)
  115. (defconst op-boundp 0x78)
  116. (defconst op-symbolp 0x79)
  117. (defconst op-get 0x7a)
  118. (defconst op-put 0x7b)
  119. (defconst op-error-pro 0x7c)
  120. (defconst op-signal 0x7d)
  121.  
  122. (defconst op-set-current-buffer 0xb0)
  123. (defconst op-swap-buffer 0xb1)        ; switch to buffer stk[0], stk[0]
  124.                     ;becomes old buffer.
  125. (defconst op-current-buffer 0xb2)
  126. (defconst op-bufferp 0xb3)
  127. (defconst op-mark-p 0xb4)
  128. (defconst op-windowp 0xb5)
  129. (defconst op-swap-window 0xb6)
  130.  
  131. (defconst op-last-before-jmps 0xfa)
  132.  
  133. ;; All jmps take two-byte arguments
  134. (defconst op-jmp 0xfb)            ; jmp to x
  135. (defconst op-jmp-nil 0xfc)        ; pop the stack, if nil, jmp x
  136. (defconst op-jmp-t 0xfd)        ; pop the stack, if t, jmp x
  137. (defconst op-jmp-nil-else-pop 0xfe)    ; if stk[0] nil, jmp x, else pop
  138. (defconst op-jmp-t-else-pop 0xff)    ; if stk[0] t, jmp x, else pop
  139.  
  140. (defconst comp-max-1-byte-arg 5)    ; max arg held in 1-byte instruction
  141. (defconst comp-max-2-byte-arg 0x7f)    ; max arg held in 2-byte instruction
  142. (defconst comp-max-3-byte-arg 0x3fff)    ; max arg help in 3-byte instruction
  143.  
  144. (defvar comp-constant-alist nil)    ; list of (VALUE . INDEX)
  145. (defvar comp-constant-index 0)        ; next free constant index number
  146. (defvar comp-current-stack 0)        ; current stack requirement
  147. (defvar comp-max-stack 0)        ; highest possible stack
  148. (defvar comp-output nil)        ; list of (BYTE . INDEX)
  149. (defvar comp-output-pc 0)        ; INDEX of next byte
  150. (defvar comp-macro-env nil)        ; alist of (NAME . MACRO-DEF)
  151.  
  152. (defun compile-file (file-name)
  153.   "(compile-file FILE-NAME)
  154. Compiles the file of jade-lisp code FILE-NAME into a new file called
  155. `(concat FILE-NAME ?c)' (ie, `foo.jl' => `foo.jlc')."
  156.   (let*
  157.       (src-file dst-file form comp-macro-env)
  158.     (when (and (setq src-file (open file-name "r"))
  159.       (setq dst-file (open (concat file-name ?c) "w")))
  160.       (error-protect
  161.     (unwind-protect
  162.       (progn
  163.         (title-now (concat "Compiling file " file-name "..."))
  164.         (while (not (file-eof-p src-file))
  165.           (when (setq form (comp-compile-file-form (read src-file)))
  166.         (print form dst-file)
  167.         (write dst-file ?\n))))
  168.       (close dst-file)
  169.       (close src-file))
  170.     (error
  171.       ;; Be sure to remove any partially written dst-file. Also, signal
  172.       ;; the error again so that the user sees it.
  173.       (let
  174.           ((fname (concat file-name ?c)))
  175.         (when (file-exists-p fname)
  176.           (delete-file fname)))
  177.       (funcall 'signal (car error-info) (cdr error-info))))
  178.       t)))
  179.  
  180. (defun compile-directory (dir-name &optional force-p)
  181.   "(compile-directory DIRECTORY-NAME [FORCE-P])
  182. Compiles all jade-lisp files in the directory DIRECTORY-NAME whose object
  183. files are either older than their source file or don't exist. If FORCE-P
  184. is non-nil every lisp file is recompiled."
  185.   (let
  186.       ((dir (directory-files dir-name)))
  187.     (while (consp dir)
  188.       (when (regexp-match "\\.jl$" (car dir))
  189.     (let*
  190.         ((file (file-concat dir-name (car dir)))
  191.          (cfile (concat file ?c)))
  192.       (when (file-newer-than-file-p file cfile)
  193.         (compile-file file))))
  194.       (setq dir (cdr dir)))
  195.     t))
  196.  
  197. (defun compile-lisp-lib (&optional force-p)
  198.   "(compile-lisp-lib [FORCE-P])
  199. Recompile all out of date files in the lisp library directory. If FORCE-P
  200. is non-nil it's as though all files were out of date.
  201. This makes sure that all doc strings are written to their special file."
  202.   (let
  203.       ((comp-write-docs-p t))
  204.     (compile-directory lisp-lib-dir force-p)))
  205.  
  206. (put 'compile-error 'error-message "Compilation mishap")
  207. (defun comp-error (&rest data)
  208.   (signal 'compile-error data))
  209.  
  210. (defun comp-compile-file-form (form)
  211.   (if (not (consp form))
  212.       form
  213.     (let
  214.     ((fun (car form)))
  215.       (cond
  216.     ((eq fun 'defun)
  217.       (let
  218.           ((tmp (assq (nth 1 form) comp-macro-env)))
  219.         (when tmp
  220.           (rplaca tmp nil)
  221.           (rplacd tmp nil)))
  222.       (cons 'defun
  223.         (cons (nth 1 form)
  224.           (cdr (comp-compile-lambda (cons 'lambda (nthcdr 2 form)))))))
  225.     ((eq fun 'defmacro)
  226.       (let
  227.           ((code (comp-compile-lambda (cons 'lambda (nthcdr 2 form))))
  228.            (tmp (assq (nth 1 form) comp-macro-env)))
  229.         (if tmp
  230.         (rplacd tmp code)
  231.           (setq comp-macro-env (cons (cons (nth 1 form) code) comp-macro-env)))
  232.         (cons 'defmacro (cons (nth 1 form) (cdr code)))))
  233.     ((or (eq fun 'defconst) (eq fun 'defvar))
  234.       (let
  235.           ((doc (nth 3 form)))
  236.         (when (and comp-write-docs-p (stringp doc))
  237.           (rplaca (nthcdr 3 form) (add-doc-string doc))))
  238.       form)
  239.     ((eq fun 'require)
  240.       (eval form)
  241.       form)
  242.     (t
  243.       form)))))
  244.  
  245. (defun compile-top-level-form (form)
  246.   (let*
  247.       (comp-constant-alist
  248.        (comp-constant-index 0)
  249.        (comp-current-stack 0)
  250.        (comp-max-stack 0)
  251.        comp-output
  252.        (comp-output-pc 0))
  253.     (comp-compile-form form)
  254. ;; Don't bother with rts, '\0' at end of string does the same.
  255. ;;  (comp-write-op op-rts)
  256.     (when comp-output
  257.       (list 'lisp-code (comp-make-code-string) (comp-make-const-vec)
  258.         comp-max-stack))))
  259.  
  260. (defun comp-make-code-string ()
  261.   (let
  262.       ((code-string (make-string comp-output-pc ?*))
  263.        (data comp-output))
  264.     (while (consp data)
  265.       (aset code-string (cdr (car data)) (car (car data)))
  266.       (setq data (cdr data)))
  267.     code-string))
  268.  
  269. (defun comp-make-const-vec ()
  270.   (let
  271.       ((vec (make-vector comp-constant-index))
  272.        (consts comp-constant-alist))
  273.     (while (consp consts)
  274.       (aset vec (cdr (car consts)) (car (car consts)))
  275.       (setq consts (cdr consts)))
  276.     vec))
  277.  
  278. (defun comp-inc-stack ()
  279.   (when (> (setq comp-current-stack (1+ comp-current-stack)) comp-max-stack)
  280.     (setq comp-max-stack comp-current-stack)))
  281.  
  282. (defmacro comp-dec-stack (&optional n)
  283.   (list 'setq 'comp-current-stack 
  284.     (if n
  285.         (list '- 'comp-current-stack n)
  286.       (list '1- 'comp-current-stack))))
  287.  
  288. (defun comp-compile-form (form)
  289.   (cond
  290.     ((eq form nil)
  291.       (comp-write-op op-nil)
  292.       (comp-inc-stack))
  293.     ((eq form t)
  294.       (comp-write-op op-t)
  295.       (comp-inc-stack))
  296.     ((symbolp form)
  297.       (if (and comp-eval-constants-p (const-variable-p form))
  298.       (comp-write-op op-push (comp-add-constant (symbol-value form)))
  299.     (comp-write-op op-vrefc (comp-add-constant form)))
  300.       (comp-inc-stack))
  301.     ((consp form)
  302.       (let
  303.       (fun)
  304.     (if (and (symbolp (car form)) (setq fun (get (car form) 'compile-fun)))
  305.         (funcall fun form)
  306.       (setq form (macroexpand form comp-macro-env))
  307.       (if (and (symbolp (car form))
  308.            (setq fun (get (car form) 'compile-fun)))
  309.           (funcall fun form)
  310.         (setq fun (car form))
  311.         (cond
  312.           ((symbolp fun)
  313.         (comp-compile-constant fun))
  314.           ((and (consp fun) (eq (car fun) 'lambda))
  315.         (comp-compile-constant (comp-compile-lambda fun)))
  316.           (t
  317.         (comp-error "Bad function name" fun)))
  318.         (setq form (cdr form))
  319.         (let
  320.         ((i 0))
  321.           (while (consp form)
  322.         (comp-compile-form (car form))
  323.         (setq
  324.           i (1+ i)
  325.           form (cdr form)))
  326.           (comp-write-op op-call i)
  327.           (comp-dec-stack i))))))
  328.     (t
  329.       (comp-compile-constant form))))
  330.  
  331. (defun comp-compile-constant (form)
  332.   (comp-write-op op-push (comp-add-constant form))
  333.   (comp-inc-stack))
  334.  
  335. (defun comp-add-constant (const)
  336.   (unless (cdr (assoc const comp-constant-alist))
  337.     (setq
  338.       comp-constant-alist (cons (cons const comp-constant-index) comp-constant-alist)
  339.       comp-constant-index (1+ comp-constant-index))
  340.     (1- comp-constant-index)))
  341.  
  342. (defun comp-compile-body (body)
  343.   (if (null body)
  344.       (progn
  345.     (comp-write-op op-nil)
  346.     (comp-inc-stack))
  347.     (while (consp body)
  348.       (comp-compile-form (car body))
  349.       (when (cdr body)
  350.     (comp-write-op op-pop)
  351.     (comp-dec-stack))
  352.       (setq body (cdr body)))))
  353.  
  354. (defun comp-compile-lambda (list)
  355.   ;; from LIST, `(lambda (args) [docstring] body...)' returns a new list of,
  356.   ;; `(lambda (args) [docstring] (lisp-code ...))'
  357.   (let
  358.       ((body (nthcdr 2 list))
  359.        new-head)
  360.     (cond
  361.       ((stringp (car body))
  362.     (setq
  363.      body (cdr body)
  364.      new-head (list 'lambda (nth 1 list)
  365.             (if comp-write-docs-p
  366.                 (add-doc-string (nth 2 list))
  367.               (nth 2 list)))))
  368.       (t
  369.     (setq new-head (list 'lambda (nth 1 list)))))
  370.     (nconc new-head (cons (compile-top-level-form (cons 'progn body)) nil))))
  371.  
  372. (defmacro comp-make-label ()
  373.   ;; a label is, (PC-OF-LABEL . (LIST-OF-PC-REFERENCES))
  374.   '(cons nil nil))
  375.  
  376. (defun comp-compile-jmp (opcode label)
  377.   (comp-byte-out opcode)
  378.   (cond
  379.     ((numberp (car label))
  380.       ;; we know the final offset of this label so use it
  381.       (comp-byte-out (bit-or 0x80 (lsh (car label) -7)))
  382.       (comp-byte-out (bit-or 0x80 (bit-and (car label) 0x7f))))
  383.     (t
  384.       ;; offset unknown, show we need it patched in later
  385.       (rplacd label (cons comp-output-pc (cdr label)))
  386.       (setq comp-output-pc (+ comp-output-pc 2)))))
  387.  
  388. (defun comp-set-label (label)
  389.   (when (> comp-output-pc comp-max-3-byte-arg)
  390.     (comp-error "Jump destination overflow!"))
  391.   (rplaca label comp-output-pc)
  392.   (setq label (cdr label))
  393.   (while (consp label)
  394.     (setq comp-output
  395.       (cons
  396.     (cons
  397.       (bit-or 0x80 (lsh comp-output-pc -7))
  398.       (car label))
  399.     (cons
  400.       (cons
  401.         (bit-or 0x80 (bit-and comp-output-pc 0x7f))
  402.         (1+ (car label)))
  403.       comp-output)))
  404.     (setq label (cdr label))))
  405.  
  406. (defun comp-write-op (opcode &optional arg)
  407.   (cond
  408.     ((null arg)
  409.       (comp-byte-out opcode))
  410.     ((<= arg comp-max-1-byte-arg)
  411.       (comp-byte-out (+ opcode arg)))
  412.     ((<= arg comp-max-2-byte-arg)
  413.       ;; 2-byte instruction
  414.       (comp-byte-out (+ opcode 6))
  415.       (comp-byte-out (bit-or 0x80 arg)))
  416.     ((<= arg comp-max-3-byte-arg)
  417.       ;; 3-byte instruction
  418.       (comp-byte-out (+ opcode 7))
  419.       (comp-byte-out (bit-or 0x80 (lsh arg -7)))
  420.       (comp-byte-out (bit-or 0x80 (bit-and arg 0x7f))))
  421.     (t
  422.       (comp-error "Opcode overflow!"))))
  423.  
  424. (defun comp-byte-out (byte)
  425.   (setq
  426.     comp-output (cons (cons byte comp-output-pc) comp-output)
  427.     comp-output-pc (1+ comp-output-pc)))
  428.  
  429. ;;;
  430. ;;; functions which compile non-standard functions (ie special-forms)
  431. ;;;
  432.  
  433. (put 'if 'compile-fun 'comp-compile-if)
  434. (defun comp-compile-if (form)
  435.   (comp-compile-form (nth 1 form))
  436.   (if (= (length form) 3)
  437.       (let*
  438.       ((end-label (comp-make-label)))
  439.     (comp-compile-jmp op-jmp-nil-else-pop end-label)
  440.     (comp-dec-stack)
  441.     (comp-compile-form (nth 2 form))
  442.     (comp-set-label end-label))
  443.     (let*
  444.     ((end-label (comp-make-label))
  445.      (else-label (comp-make-label)))
  446.       (comp-compile-jmp op-jmp-nil else-label)
  447.       (comp-dec-stack)
  448.       (comp-compile-form (nth 2 form))
  449.       (comp-compile-jmp op-jmp end-label)
  450.       (comp-set-label else-label)
  451.       (comp-dec-stack)
  452.       (comp-compile-body (nthcdr 3 form))
  453.       (comp-set-label end-label))))
  454.  
  455. (put 'when 'compile-fun 'comp-compile-when)
  456. (defun comp-compile-when (form)
  457.   (comp-compile-form (nth 1 form))
  458.   (let
  459.       ((end-label (comp-make-label)))
  460.     (comp-compile-jmp op-jmp-nil-else-pop end-label)
  461.     (comp-dec-stack)
  462.     (comp-compile-body (nthcdr 2 form))
  463.     (comp-set-label end-label)))
  464.  
  465. (put 'unless 'compile-fun 'comp-compile-unless)
  466. (defun comp-compile-unless (form)
  467.   (comp-compile-form (nth 1 form))
  468.   (let
  469.       ((end-label (comp-make-label)))
  470.     (comp-compile-jmp op-jmp-t-else-pop end-label)
  471.     (comp-dec-stack)
  472.     (comp-compile-body (nthcdr 2 form))
  473.     (comp-set-label end-label)))
  474.  
  475. (put 'quote 'compile-fun 'comp-compile-quote)
  476. (defun comp-compile-quote (form)
  477.   (comp-compile-constant (car (cdr form))))
  478.  
  479. (put 'function 'compile-fun 'comp-compile-function)
  480. (defun comp-compile-function (form)
  481.   (setq form (car (cdr form)))
  482.   (if (symbolp form)
  483.       (comp-compile-constant form)
  484.     (comp-compile-constant (comp-compile-lambda form))))
  485.  
  486. (put 'while 'compile-fun 'comp-compile-while)
  487. (defun comp-compile-while (form)
  488.   (let*
  489.       ((tst-label (comp-make-label))
  490.        (end-label (comp-make-label)))
  491.     (comp-set-label tst-label)
  492.     (comp-compile-form (nth 1 form))
  493.     (comp-compile-jmp op-jmp-nil-else-pop end-label)
  494.     (comp-dec-stack)
  495.     (comp-compile-body (nthcdr 2 form))
  496.     (comp-write-op op-pop)
  497.     (comp-dec-stack)
  498.     (comp-compile-jmp op-jmp tst-label)
  499.     (comp-set-label end-label)
  500.     (comp-inc-stack)))
  501.  
  502. (put 'progn 'compile-fun 'comp-compile-progn)
  503. (defun comp-compile-progn (form)
  504.   (comp-compile-body (cdr form)))
  505.  
  506. (put 'prog1 'compile-fun 'comp-compile-prog1)
  507. (defun comp-compile-prog1 (form)
  508.   (comp-compile-form (nth 1 form))
  509.   (comp-compile-body (nthcdr 2 form))
  510.   (comp-write-op op-pop)
  511.   (comp-dec-stack))
  512.  
  513. (put 'prog2 'compile-fun 'comp-compile-prog2)
  514. (defun comp-compile-prog2 (form)
  515.   (comp-compile-form (nth 1 form))
  516.   (comp-write-op op-pop)
  517.   (comp-dec-stack)
  518.   (comp-compile-form (nth 2 form))
  519.   (comp-compile-body (nthcdr 3 form))
  520.   (comp-write-op op-pop)
  521.   (comp-dec-stack))
  522.  
  523. (put 'setq 'compile-fun 'comp-compile-setq)
  524. (defun comp-compile-setq (form)
  525.   (setq form (cdr form))
  526.   (while (and (consp form) (consp (cdr form)))
  527.     (comp-compile-form (car (cdr form)))
  528.     (unless (consp (nthcdr 2 form))
  529.       (comp-write-op op-dup)
  530.       (comp-inc-stack))
  531.     (comp-write-op op-vsetc (comp-add-constant (car form)))
  532.     (comp-dec-stack)
  533.     (setq form (nthcdr 2 form))))
  534.  
  535. (put 'set 'compile-fun 'comp-compile-set)
  536. (defun comp-compile-set (form)
  537.   (comp-compile-form (nth 2 form))
  538.   (comp-write-op op-dup)
  539.   (comp-inc-stack)
  540.   (comp-compile-form (nth 1 form))
  541.   (comp-write-op op-vset)
  542.   (comp-dec-stack 2))
  543.  
  544. (put 'fset 'compile-fun 'comp-compile-fset)
  545. (defun comp-compile-fset (form)
  546.   (comp-compile-form (nth 2 form))
  547.   (comp-write-op op-dup)
  548.   (comp-inc-stack)
  549.   (comp-compile-form (nth 1 form))
  550.   (comp-write-op op-fset)
  551.   (comp-dec-stack 2))
  552.  
  553. (put 'let* 'compile-fun 'comp-compile-let*)
  554. (defun comp-compile-let* (form)
  555.   (let
  556.       ((list (car (cdr form))))
  557.     (comp-write-op op-init-bind)
  558.     (while (consp list)
  559.       (cond
  560.     ((consp (car list))
  561.       (let
  562.           ((tmp (car list)))
  563.         (comp-compile-body (cdr tmp))
  564.         (comp-write-op op-bind (comp-add-constant (car tmp)))))
  565.     (t
  566.       (comp-write-op op-nil)
  567.       (comp-inc-stack)
  568.       (comp-write-op op-bind (comp-add-constant (car list)))))
  569.       (comp-dec-stack)
  570.       (setq list (cdr list)))
  571.     (comp-compile-body (nthcdr 2 form))
  572.     (comp-write-op op-unbind)))
  573.  
  574. (put 'let 'compile-fun 'comp-compile-let)
  575. (defun comp-compile-let (form)
  576.   (let
  577.       ((list (car (cdr form)))
  578.        (sym-stk nil))
  579.     (comp-write-op op-init-bind)
  580.     (while (consp list)
  581.       (cond
  582.     ((consp (car list))
  583.       (setq sym-stk (cons (car (car list)) sym-stk))
  584.       (comp-compile-body (cdr (car list))))
  585.     (t
  586.       (setq sym-stk (cons (car list) sym-stk))
  587.       (comp-write-op op-nil)
  588.       (comp-inc-stack)))
  589.       (setq list (cdr list)))
  590.     (while (consp sym-stk)
  591.       (comp-write-op op-bind (comp-add-constant (car sym-stk)))
  592.       (comp-dec-stack)
  593.       (setq sym-stk (cdr sym-stk)))
  594.     (comp-compile-body (nthcdr 2 form))
  595.     (comp-write-op op-unbind)))
  596.  
  597. (put 'defun 'compile-fun 'comp-compile-defun)
  598. (defun comp-compile-defun (form)
  599.   (comp-compile-constant (nth 1 form))
  600.   (comp-write-op op-dup)
  601.   (comp-inc-stack)
  602.   (comp-compile-constant (comp-compile-lambda (cons 'lambda (nthcdr 2 form))))
  603.   (comp-write-op op-swap)
  604.   (comp-write-op op-fset)
  605.   (comp-dec-stack 2))
  606.  
  607. (put 'defmacro 'compile-fun 'comp-compile-defmacro)
  608. (defun comp-compile-defmacro (form)
  609.   (comp-compile-constant (nth 1 form))
  610.   (comp-write-op op-dup)
  611.   (comp-inc-stack)
  612.   (comp-compile-constant (cons 'macro (comp-compile-lambda (cons 'lambda (nthcdr 2 form)))))
  613.   (comp-write-op op-swap)
  614.   (comp-write-op op-fset)
  615.   (comp-dec-stack 2))
  616.  
  617. (put 'cond 'compile-fun 'comp-compile-cond)
  618. (defun comp-compile-cond (form)
  619.   (let
  620.       ((end-label (comp-make-label)))
  621.     (setq form (cdr form))
  622.     (while (consp form)
  623.       (let
  624.       ((subl (car form))
  625.        (next-label (comp-make-label)))
  626.     (comp-compile-form (car subl))
  627.     (comp-dec-stack)
  628.     (cond
  629.       ((consp (cdr subl))
  630.         (comp-compile-jmp op-jmp-nil next-label)
  631.         (comp-compile-body (cdr subl))
  632.         (comp-dec-stack)
  633.         (comp-compile-jmp op-jmp end-label)
  634.         (comp-set-label next-label))
  635.       (t
  636.         (comp-compile-jmp op-jmp-t-else-pop end-label)))
  637.     (setq form (cdr form))))
  638.     (comp-write-op op-nil)
  639.     (comp-inc-stack)
  640.     (comp-set-label end-label)))
  641.  
  642. (put 'or 'compile-fun 'comp-compile-or)
  643. (defun comp-compile-or (form)
  644.   (let
  645.       ((end-label (comp-make-label)))
  646.     (setq form (cdr form))
  647.     (while (consp form)
  648.       (comp-compile-form (car form))
  649.       (comp-dec-stack)
  650.       (when (cdr form)
  651.     (comp-compile-jmp op-jmp-t-else-pop end-label))
  652.       (setq form (cdr form)))
  653.     (comp-inc-stack)
  654.     (comp-set-label end-label)))
  655.  
  656. (put 'and 'compile-fun 'comp-compile-and)
  657. (defun comp-compile-and (form)
  658.   (let
  659.       ((end-label (comp-make-label)))
  660.     (setq form (cdr form))
  661.     (while (consp form)
  662.       (comp-compile-form (car form))
  663.       (comp-dec-stack)
  664.       (when (cdr form)
  665.     (comp-compile-jmp op-jmp-nil-else-pop end-label))
  666.       (setq form (cdr form)))
  667.     (comp-inc-stack)
  668.     (comp-set-label end-label)))
  669.  
  670. (put 'catch 'compile-fun 'comp-compile-catch)
  671. (defun comp-compile-catch (form)
  672.   (comp-compile-constant (compile-top-level-form (cons 'progn (nthcdr 2 form))))
  673.   (comp-compile-constant (nth 1 form))
  674.   (comp-write-op op-catch-kludge)
  675.   (comp-dec-stack))
  676.  
  677. (put 'unwind-protect 'compile-fun 'comp-compile-unwind-pro)
  678. (defun comp-compile-unwind-pro (form)
  679.   (comp-compile-constant (compile-top-level-form (cons 'progn (nthcdr 2 form))))
  680.   (comp-write-op op-unwind-pro)
  681.   (comp-dec-stack)
  682.   (comp-compile-form (nth 1 form))
  683.   (comp-write-op op-un-unwind-pro))
  684.  
  685. (put 'error-protect 'compile-fun 'comp-compile-error-protect)
  686. (defun comp-compile-error-protect (form)
  687.   (let
  688.       ((i 0))
  689.     (setq form (cdr form))
  690.     (unless (consp form)
  691.       (comp-error "No FORM to `error-protect'" form))
  692.     (comp-compile-constant (compile-top-level-form (car form)))
  693.     (setq form (cdr form))
  694.     (while (consp form)
  695.       (let
  696.       ((handler (car form)))
  697.     (unless (consp handler)
  698.       (comp-error "Badly formed handler to `error-protect'" form))
  699.     (comp-compile-constant (list (car handler) (compile-top-level-form (cons 'progn (cdr handler)))))
  700.     (setq
  701.       form (cdr form)
  702.       i (1+ i))))
  703.     (comp-compile-constant (1+ i))
  704.     (comp-write-op op-error-pro)
  705.     (comp-dec-stack i)))
  706.  
  707. (put 'list 'compile-fun 'comp-compile-list)
  708. (defun comp-compile-list (form)
  709.   (let
  710.       ((count 0))
  711.     (setq form (cdr form))
  712.     (while (consp form)
  713.       (comp-compile-form (car form))
  714.       (setq
  715.        count (1+ count)
  716.        form (cdr form)))
  717.     (comp-write-op op-list count)
  718.     (comp-dec-stack (1- count))))
  719.  
  720. (put 'with-buffer 'compile-fun 'comp-compile-with-buffer)
  721. (defun comp-compile-with-buffer (form)
  722.   (comp-compile-form (nth 1 form))
  723.   (comp-write-op op-swap-buffer)
  724.   (comp-compile-body (nthcdr 2 form))
  725.   (comp-write-op op-swap)
  726.   (comp-write-op op-swap-buffer)
  727.   (comp-write-op op-pop)
  728.   (comp-dec-stack))
  729.  
  730. (put 'with-window 'compile-fun 'comp-compile-with-window)
  731. (defun comp-compile-with-window (form)
  732.   (comp-compile-form (nth 1 form))
  733.   (comp-write-op op-swap-window)
  734.   (comp-compile-body (nthcdr 2 form))
  735.   (comp-write-op op-swap)
  736.   (comp-write-op op-swap-window)
  737.   (comp-write-op op-pop)
  738.   (comp-dec-stack))
  739.  
  740. (put '- 'compile-fun 'comp-compile-minus)
  741. (put '- 'compile-opcode op-minus-2)
  742. (defun comp-compile-minus (form)
  743.   (if (/= (length form) 2)
  744.       (comp-compile-binary-op form)
  745.     (comp-compile-form (car (cdr form)))
  746.     (comp-write-op op-negate)))
  747.  
  748. (defun comp-compile-0-args (form)
  749.   (comp-write-op (get (car form) 'compile-opcode) 0)
  750.   (comp-inc-stack))
  751.  
  752. (defun comp-compile-1-args (form)
  753.   (comp-compile-form (nth 1 form))
  754.   (comp-write-op (get (car form) 'compile-opcode) 0))
  755.  
  756. (defun comp-compile-2-args (form)
  757.   (comp-compile-form (nth 1 form))
  758.   (comp-compile-form (nth 2 form))
  759.   (comp-write-op (get (car form) 'compile-opcode) 0)
  760.   (comp-dec-stack))
  761.  
  762. (defun comp-compile-3-args (form)
  763.   (comp-compile-form (nth 1 form))
  764.   (comp-compile-form (nth 2 form))
  765.   (comp-compile-form (nth 3 form))
  766.   (comp-write-op (get (car form) 'compile-opcode) 0)
  767.   (comp-dec-stack 2))
  768.  
  769. (defun comp-compile-binary-op (form)
  770.   (let
  771.       ((opcode (get (car form) 'compile-opcode)))
  772.     (setq form (cdr form))
  773.     (unless (>= (length form) 2)
  774.       (comp-error "Too few args to binary operator" form))
  775.     (comp-compile-form (car form))
  776.     (setq form (cdr form))
  777.     (while (consp form)
  778.       (comp-compile-form (car form))
  779.       (comp-write-op opcode)
  780.       (comp-dec-stack)
  781.       (setq form (cdr form)))))
  782.  
  783. (put 'cons 'compile-fun 'comp-compile-2-args)
  784. (put 'cons 'compile-opcode op-cons)
  785. (put 'car 'compile-fun 'comp-compile-1-args)
  786. (put 'car 'compile-opcode op-car)
  787. (put 'cdr 'compile-fun 'comp-compile-1-args)
  788. (put 'cdr 'compile-opcode op-cdr)
  789. (put 'rplaca 'compile-fun 'comp-compile-2-args)
  790. (put 'rplaca 'compile-opcode op-rplaca)
  791. (put 'rplacd 'compile-fun 'comp-compile-2-args)
  792. (put 'rplacd 'compile-opcode op-rplacd)
  793. (put 'nth 'compile-fun 'comp-compile-2-args)
  794. (put 'nth 'compile-opcode op-nth)
  795. (put 'nthcdr 'compile-fun 'comp-compile-2-args)
  796. (put 'nthcdr 'compile-opcode op-nthcdr)
  797. (put 'aset 'compile-fun 'comp-compile-3-args)
  798. (put 'aset 'compile-opcode op-aset)
  799. (put 'aref 'compile-fun 'comp-compile-2-args)
  800. (put 'aref 'compile-opcode op-aref)
  801. (put 'length 'compile-fun 'comp-compile-1-args)
  802. (put 'length 'compile-opcode op-length)
  803. (put 'eval 'compile-fun 'comp-compile-1-args)
  804. (put 'eval 'compile-opcode op-eval)
  805. (put '+ 'compile-fun 'comp-compile-binary-op)
  806. (put '+ 'compile-opcode op-plus-2)
  807. (put '* 'compile-fun 'comp-compile-binary-op)
  808. (put '* 'compile-opcode op-product-2)
  809. (put '/ 'compile-fun 'comp-compile-binary-op)
  810. (put '/ 'compile-opcode op-divide-2)
  811. (put 'mod 'compile-fun 'comp-compile-binary-op)
  812. (put 'mod 'compile-opcode op-mod-2)
  813. (put 'bit-not 'compile-fun 'comp-compile-1-args)
  814. (put 'bit-not 'compile-opcode op-bit-not)
  815. (put 'not 'compile-fun 'comp-compile-1-args)
  816. (put 'not 'compile-opcode op-not)
  817. (put 'bit-or 'compile-fun 'comp-compile-binary-op)
  818. (put 'bit-or 'compile-opcode op-bit-or-2)
  819. (put 'bit-and 'compile-fun 'comp-compile-binary-op)
  820. (put 'bit-and 'compile-opcode op-bit-and-2)
  821. (put 'equal 'compile-fun 'comp-compile-2-args)
  822. (put 'equal 'compile-opcode op-equal)
  823. (put 'eq 'compile-fun 'comp-compile-2-args)
  824. (put 'eq 'compile-opcode op-eq)
  825. (put '= 'compile-fun 'comp-compile-2-args)
  826. (put '= 'compile-opcode op-num-eq)
  827. (put '/= 'compile-fun 'comp-compile-2-args)
  828. (put '/= 'compile-opcode op-num-noteq)
  829. (put '> 'compile-fun 'comp-compile-2-args)
  830. (put '> 'compile-opcode op-gtthan)
  831. (put '< 'compile-fun 'comp-compile-2-args)
  832. (put '< 'compile-opcode op-ltthan)
  833. (put '>= 'compile-fun 'comp-compile-2-args)
  834. (put '>= 'compile-opcode op-gethan)
  835. (put '<= 'compile-fun 'comp-compile-2-args)
  836. (put '<= 'compile-opcode op-lethan)
  837. (put '1+ 'compile-fun 'comp-compile-1-args)
  838. (put '1+ 'compile-opcode op-inc)
  839. (put '1- 'compile-fun 'comp-compile-1-args)
  840. (put '1- 'compile-opcode op-dec)
  841. (put 'lsh 'compile-fun 'comp-compile-2-args)
  842. (put 'lsh 'compile-opcode op-lsh)
  843. (put 'zerop 'compile-fun 'comp-compile-1-args)
  844. (put 'zerop 'compile-opcode op-zerop)
  845. (put 'null 'compile-fun 'comp-compile-1-args)
  846. (put 'null 'compile-opcode op-null)
  847. (put 'atom 'compile-fun 'comp-compile-1-args)
  848. (put 'atom 'compile-opcode op-atom)
  849. (put 'consp 'compile-fun 'comp-compile-1-args)
  850. (put 'consp 'compile-opcode op-consp)
  851. (put 'listp 'compile-fun 'comp-compile-1-args)
  852. (put 'listp 'compile-opcode op-listp)
  853. (put 'numberp 'compile-fun 'comp-compile-1-args)
  854. (put 'numberp 'compile-opcode op-numberp)
  855. (put 'stringp 'compile-fun 'comp-compile-1-args)
  856. (put 'stringp 'compile-opcode op-stringp)
  857. (put 'vectorp 'compile-fun 'comp-compile-1-args)
  858. (put 'vectorp 'compile-opcode op-vectorp)
  859. (put 'throw 'compile-fun 'comp-compile-2-args)
  860. (put 'throw 'compile-opcode op-throw)
  861. (put 'fboundp 'compile-fun 'comp-compile-1-args)
  862. (put 'fboundp 'compile-opcode op-fboundp)
  863. (put 'boundp 'compile-fun 'comp-compile-1-args)
  864. (put 'boundp 'compile-opcode op-boundp)
  865. (put 'symbolp 'compile-fun 'comp-compile-1-args)
  866. (put 'symbolp 'compile-opcode op-symbolp)
  867. (put 'get 'compile-fun 'comp-compile-2-args)
  868. (put 'get 'compile-opcode op-get)
  869. (put 'put 'compile-fun 'comp-compile-3-args)
  870. (put 'put 'compile-opcode op-put)
  871. (put 'signal 'compile-fun 'comp-compile-2-args)
  872. (put 'signal 'compile-opcode op-signal)
  873.  
  874. (put 'set-current-buffer 'compile-fun 'comp-compile-2-args)
  875. (put 'set-current-buffer 'compile-opcode op-set-current-buffer)
  876. (put 'current-buffer 'compile-fun 'comp-compile-1-args)
  877. (put 'current-buffer 'compile-opcode op-current-buffer)
  878. (put 'bufferp 'compile-fun 'comp-compile-1-args)
  879. (put 'bufferp 'compile-opcode op-bufferp)
  880. (put 'mark-p 'compile-fun 'comp-compile-1-args)
  881. (put 'mark-p 'compile-opcode op-mark-p)
  882. (put 'windowp 'compile-fun 'comp-compile-1-args)
  883. (put 'windowp 'compile-opcode op-windowp)
  884.