home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 4 / FreshFish_May-June1994.bin / bbs / may94 / util / edit / jade.lha / Jade / lisp / compiler.jlc < prev    next >
Text File  |  1994-04-20  |  21KB  |  549 lines
  1.  
  2. (provide (quote compiler))
  3.  
  4. (defvar comp-eval-constants-p t 60339)
  5.  
  6. (defvar comp-write-docs-p nil 60487)
  7.  
  8. (defconst op-call 8)
  9.  
  10. (defconst op-push 16)
  11.  
  12. (defconst op-vrefc 24)
  13.  
  14. (defconst op-vsetc 32)
  15.  
  16. (defconst op-list 40)
  17.  
  18. (defconst op-bind 48)
  19.  
  20. (defconst op-last-with-args 55)
  21.  
  22. (defconst op-vref 64)
  23.  
  24. (defconst op-vset 65)
  25.  
  26. (defconst op-fref 66)
  27.  
  28. (defconst op-fset 67)
  29.  
  30. (defconst op-init-bind 68)
  31.  
  32. (defconst op-unbind 69)
  33.  
  34. (defconst op-dup 70)
  35.  
  36. (defconst op-swap 71)
  37.  
  38. (defconst op-pop 72)
  39.  
  40. (defconst op-nil 73)
  41.  
  42. (defconst op-t 74)
  43.  
  44. (defconst op-cons 75)
  45.  
  46. (defconst op-car 76)
  47.  
  48. (defconst op-cdr 77)
  49.  
  50. (defconst op-rplaca 78)
  51.  
  52. (defconst op-rplacd 79)
  53.  
  54. (defconst op-nth 80)
  55.  
  56. (defconst op-nthcdr 81)
  57.  
  58. (defconst op-aset 82)
  59.  
  60. (defconst op-aref 83)
  61.  
  62. (defconst op-length 84)
  63.  
  64. (defconst op-eval 85)
  65.  
  66. (defconst op-plus-2 86)
  67.  
  68. (defconst op-negate 87)
  69.  
  70. (defconst op-minus-2 88)
  71.  
  72. (defconst op-product-2 89)
  73.  
  74. (defconst op-divide-2 90)
  75.  
  76. (defconst op-mod-2 91)
  77.  
  78. (defconst op-bit-not 92)
  79.  
  80. (defconst op-not 93)
  81.  
  82. (defconst op-bit-or-2 94)
  83.  
  84. (defconst op-bit-and-2 95)
  85.  
  86. (defconst op-equal 96)
  87.  
  88. (defconst op-eq 97)
  89.  
  90. (defconst op-num-eq 98)
  91.  
  92. (defconst op-num-noteq 99)
  93.  
  94. (defconst op-gtthan 100)
  95.  
  96. (defconst op-gethan 101)
  97.  
  98. (defconst op-ltthan 102)
  99.  
  100. (defconst op-lethan 103)
  101.  
  102. (defconst op-inc 104)
  103.  
  104. (defconst op-dec 105)
  105.  
  106. (defconst op-lsh 106)
  107.  
  108. (defconst op-zerop 107)
  109.  
  110. (defconst op-null 108)
  111.  
  112. (defconst op-atom 109)
  113.  
  114. (defconst op-consp 110)
  115.  
  116. (defconst op-listp 111)
  117.  
  118. (defconst op-numberp 112)
  119.  
  120. (defconst op-stringp 113)
  121.  
  122. (defconst op-vectorp 114)
  123.  
  124. (defconst op-catch-kludge 115)
  125.  
  126. (defconst op-throw 116)
  127.  
  128. (defconst op-unwind-pro 117)
  129.  
  130. (defconst op-un-unwind-pro 118)
  131.  
  132. (defconst op-fboundp 119)
  133.  
  134. (defconst op-boundp 120)
  135.  
  136. (defconst op-symbolp 121)
  137.  
  138. (defconst op-get 122)
  139.  
  140. (defconst op-put 123)
  141.  
  142. (defconst op-error-pro 124)
  143.  
  144. (defconst op-signal 125)
  145.  
  146. (defconst op-set-current-buffer 176)
  147.  
  148. (defconst op-swap-buffer 177)
  149.  
  150. (defconst op-current-buffer 178)
  151.  
  152. (defconst op-bufferp 179)
  153.  
  154. (defconst op-mark-p 180)
  155.  
  156. (defconst op-windowp 181)
  157.  
  158. (defconst op-swap-window 182)
  159.  
  160. (defconst op-last-before-jmps 250)
  161.  
  162. (defconst op-jmp 251)
  163.  
  164. (defconst op-jmp-nil 252)
  165.  
  166. (defconst op-jmp-t 253)
  167.  
  168. (defconst op-jmp-nil-else-pop 254)
  169.  
  170. (defconst op-jmp-t-else-pop 255)
  171.  
  172. (defconst comp-max-1-byte-arg 5)
  173.  
  174. (defconst comp-max-2-byte-arg 127)
  175.  
  176. (defconst comp-max-3-byte-arg 16383)
  177.  
  178. (defvar comp-constant-alist nil)
  179.  
  180. (defvar comp-constant-index 0)
  181.  
  182. (defvar comp-current-stack 0)
  183.  
  184. (defvar comp-max-stack 0)
  185.  
  186. (defvar comp-output nil)
  187.  
  188. (defvar comp-output-pc 0)
  189.  
  190. (defvar comp-macro-env nil)
  191.  
  192. (defun compile-file (file-name) 60586 (lisp-code "DI0I1I2I3†\nF þ€Ÿ‡ˆ\n‰\nF!þ€«Š‹Œ|HJE" [src-file dst-file form comp-macro-env open file-name "r" concat 99 "w" (lisp-code "u \tH†‡\t]þ€´ˆ‰‡\t\tF&Šþ€°‹ŠŒ\nHŒŽ\nHû€Šv" [(lisp-code "\tH\t" [close dst-file src-file] 2) title-now concat "Compiling file " file-name "..." file-eof-p src-file comp-compile-file-form read form print dst-file write 10] 5) (error (lisp-code "D\n3\tþ€\tEH†‡ˆLˆM " [concat file-name 99 fname file-exists-p delete-file funcall signal error-info] 4)) 2] 4))
  193.  
  194. (defun compile-directory (dir-name &optional force-p) 60733 (lisp-code "D\t2nþ€¼L\nþ€³DL\n6†‡†ˆ\n6‰Š†‰\nþ€²‹†\tEHMF\"Hû€…HJE" [directory-files dir-name dir regexp-match "\\.jl$" file-concat file concat 99 cfile file-newer-than-file-p compile-file] 3))
  195.  
  196. (defun compile-lisp-lib (&optional force-p) 60967 (lisp-code "DJ0\nE" [comp-write-docs-p compile-directory lisp-lib-dir force-p] 3))
  197.  
  198. (put (quote compile-error) (quote error-message) "Compilation mishap")
  199.  
  200. (defun comp-error (&rest data) (lisp-code "}" [compile-error data] 2))
  201.  
  202. (defun comp-compile-file-form (form) (lisp-code "n]ü€ŠûËDL1aü€ÁDP\n6††þ€«†INH†IOEHP‡ˆ‰QK\tMKKûÊŠaüƒD‡ˆ‰QK\tP\n6†6‹†ü€ê†‹Oû€ôP‹KKF%HŠP‹MKKEûÊŒaÿŽaü³DŽP6þ qþ­ŽQ‘\tNEHûÊ’aüÁUHûÊJüÉûÊIE" [form fun defun assq 1 comp-macro-env tmp comp-compile-lambda lambda 2 defmacro code defconst defvar 3 doc comp-write-docs-p add-doc-string require] 6))
  203.  
  204. (defun compile-top-level-form (form) (lisp-code "DI0234I56†‡ˆ\tHþ€¢‰Š‹,E" [comp-constant-alist 0 comp-constant-index comp-current-stack comp-max-stack comp-output comp-output-pc comp-compile-form form lisp-code comp-make-code-string comp-make-const-vec] 4))
  205.  
  206. (defun comp-make-code-string nil (lisp-code "D\nnþ€žLMLLRHMF$Hû€ˆHE" [make-string comp-output-pc 42 comp-output data code-string] 3))
  207.  
  208. (defun comp-make-const-vec nil (lisp-code "D\t34nþ€LMLLRHMF#Hû€‡HE" [make-vector comp-constant-index comp-constant-alist consts vec] 3))
  209.  
  210. (defun comp-inc-stack nil (lisp-code "hF dþ€ŒF!" [comp-current-stack comp-max-stack] 2))
  211.  
  212. (defmacro comp-dec-stack (&optional n) (lisp-code "ü€+û€*+" [setq comp-current-stack n - 1-] 5))
  213.  
  214. (defun comp-compile-form (form) (lisp-code "Iaü€\tHû‚‘Jaü€ž\tHû‚‘yü€Êþ€«†\tü€¼‡ˆ‰\t\t\nû€ÄŠˆ\t\nHû‚‘nü‚…DI6‹Lyþ€áLŒzF&‹ü€í‹\nû‚Ž\nF HLyþ„LŒzF&‹ü‹\nû‚LF&‹H‹yü¤‹\tûÍ‹nþ°‹L‘aü¾’‹\t\tûÍJüÌ“”‹\nûÍIHMF HD•6–nþð—L\tH–h&–MF HûØH˜–\nH™–XF&™EEû‚‘Jü‚\tû‚‘I" [form comp-write-op 73 comp-inc-stack 74 comp-eval-constants-p const-variable-p 16 comp-add-constant symbol-value 24 fun compile-fun funcall macroexpand comp-macro-env comp-compile-constant lambda comp-compile-lambda comp-error "Bad function name" 0 i comp-compile-form 8 comp-current-stack] 5))
  215.  
  216. (defun comp-compile-constant (form) (lisp-code "\t\nH" [comp-write-op 16 comp-add-constant form comp-inc-stack] 4))
  217.  
  218. (defun comp-add-constant (const) (lisp-code "\nMÿ€•KK\"hF#Hi" [assoc const comp-constant-alist comp-constant-index] 3))
  219.  
  220. (defun comp-compile-body (body) (lisp-code "lü€Ž\tHû€°nþ€°L\tHMþ€§\tH†iF&†HMF Hû€Ž" [body comp-write-op 73 comp-inc-stack comp-compile-form 72 comp-current-stack] 2))
  221.  
  222. (defun comp-compile-lambda (list) (lisp-code "DQI23Lqü€«M#P†ü€¢‡P\tû€¥P+F\"û€ºJü€¹P*F\"û€ºIHˆ‰ŠK\tIK\nE" [2 list new-head body lambda 1 comp-write-docs-p add-doc-string nconc compile-top-level-form progn] 5))
  223.  
  224. (defmacro comp-make-label nil (lisp-code "" [(cons nil nil)] 1))
  225.  
  226. (defun comp-compile-jmp (opcode label) (lisp-code "\tHLpü€žLj^\tHL_^\tû€¶Jü€µ†MKOH†‡VF&†û€¶I" [comp-byte-out opcode label 128 -7 127 comp-output-pc 2] 4))
  227.  
  228. (defun comp-set-label (label) (lisp-code "dþ€‰\tHNHMF$Hnþ€»†j^LK‡_^LhKˆKKF&ˆHMF$Hû€“" [comp-output-pc 16383 comp-error "Jump destination overflow!" label 128 -7 127 comp-output] 4))
  229.  
  230. (defun comp-write-op (opcode &optional arg) (lisp-code "lü€‹\tû€Þgü€™V\tû€Þgü€®V\tH†^\tû€Þ‡gü€ÑˆV\tH†‰j^\tH†_^\tû€ÞJü€ÝŠ‹\tû€ÞI" [arg comp-byte-out opcode 5 127 6 128 16383 7 -7 comp-error "Opcode overflow!"] 4))
  231.  
  232. (defun comp-byte-out (byte) (lisp-code "KK\"hF!" [byte comp-output-pc comp-output] 2))
  233.  
  234. (put (quote if) (quote compile-fun) (quote comp-compile-if))
  235.  
  236. (defun comp-compile-if (form) (lisp-code "P\tHTbü€®DIIK4†\nH‡iF&‡HˆP\tH‰\tEû€ìDIIK4IIK6Š‹Š\nH‡iF&‡HˆP\tHŒ\nH‰Š\tH‡iF&‡HQ\tH‰\tE" [comp-compile-form 1 form 3 end-label comp-compile-jmp 254 comp-current-stack 2 comp-set-label else-label 252 251 comp-compile-body] 3))
  237.  
  238. (put (quote when) (quote compile-fun) (quote comp-compile-when))
  239.  
  240. (defun comp-compile-when (form) (lisp-code "P\tHDIIK3\nH†iF&†H‡ˆQ\tH‰\tE" [comp-compile-form 1 form end-label comp-compile-jmp 254 comp-current-stack comp-compile-body 2 comp-set-label] 3))
  241.  
  242. (put (quote unless) (quote compile-fun) (quote comp-compile-unless))
  243.  
  244. (defun comp-compile-unless (form) (lisp-code "P\tHDIIK3\nH†iF&†H‡ˆQ\tH‰\tE" [comp-compile-form 1 form end-label comp-compile-jmp 255 comp-current-stack comp-compile-body 2 comp-set-label] 3))
  245.  
  246. (put (quote quote) (quote compile-fun) (quote comp-compile-quote))
  247.  
  248. (defun comp-compile-quote (form) (lisp-code "ML\t" [comp-compile-constant form] 2))
  249.  
  250. (put (quote function) (quote compile-fun) (quote comp-compile-function))
  251.  
  252. (defun comp-compile-function (form) (lisp-code "MLF Hyü€‘\tû€–\t\t" [form comp-compile-constant comp-compile-lambda] 3))
  253.  
  254. (put (quote