home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 4 / FreshFish_May-June1994.bin / bbs / may94 / util / edit / jade.lha / Jade / lisp / compiler.jl < prev    next >
Lisp/Scheme  |  1994-04-16  |  28KB  |  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 fo