home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / apteryx / compile.lsp < prev    next >
Lisp/Scheme  |  1994-06-25  |  41KB  |  1,095 lines
  1. ; Copyright 1994 Apteryx Lisp Ltd
  2.  
  3. (defmacro progv (symbols values &rest stmts)
  4.   (let ( (unbound-value (gensym))
  5.          (symbols2 (gensym))
  6.          (rest-values (gensym))
  7.          (old-value (gensym))
  8.          (old-values (gensym))
  9.          (result (gensym)) )
  10.     `(let* ( (,unbound-value (gensym))
  11.              (,symbols2 ,symbols)
  12.              (,rest-values ,values)
  13.              ,old-value ,result
  14.              (,old-values (mapcar #'(lambda (sym)
  15.                                       (if (boundp sym)
  16.                                         (symbol-value sym)
  17.                                         ,unbound-value) )
  18.                             ,symbols2) ) )
  19.        (unwind-protect
  20.          (progn
  21.            (dolist (sym ,symbols2)
  22.              (if ,rest-values
  23.                (progn
  24.                  (set sym (car ,rest-values))
  25.                  (setq ,rest-values  (cdr ,rest-values)) )
  26.                (makunbound sym) ) )
  27.            (setq ,result (progn ,@stmts)) )
  28.          (dolist (sym ,symbols2)
  29.            (setq ,old-value (car ,old-values))
  30.            (setq ,old-values (cdr ,old-values))
  31.            (if (eq ,old-value ,unbound-value)
  32.              (makunbound sym)
  33.              (set sym ,old-value) ) )
  34.          ,result) ) ) )
  35.  
  36. ;;; position
  37.  
  38.  
  39. (defun position (ob list &key (test #'eql))
  40.   (let ( (rest list) (found nil) (pos 0))
  41.     (while (and (not found) (consp rest) )
  42.       (if (funcall test (car rest) ob)
  43.         (setq found t)
  44.         (progn
  45.           (setq rest (cdr rest))
  46.           (setq pos (1+ pos)) ) ) )
  47.     (if found
  48.       pos
  49.       nil) ) )  
  50.  
  51. (defun mapcan (fun list1 &rest lists)
  52.   (apply #'nconc (apply #'mapcar (cons fun (cons list1 lists)))) )
  53.  
  54.  
  55. ;;; setf macros
  56.  
  57. (defmacro appendf (place &rest lists)
  58.   `(setf ,place (append ,place ,@lists)) )
  59.  
  60. (defmacro incf (place)
  61.   `(setf ,place (1+ ,place)) )
  62.  
  63. (defmacro addf (place n)
  64.   `(setf ,place (+ ,place ,n)) )
  65.  
  66. (defmacro decf (place)
  67.   `(setf ,place (1- ,place)) )
  68.  
  69. (defmacro subf (place n)
  70.   `(setf ,place (- ,place ,n)) )
  71.  
  72. (defmacro pushf (place x)
  73.   `(setf ,place (cons ,x ,place)) )
  74.  
  75. (defun list-to-vector (list)
  76.   (let* ( (len (length list))
  77.           (pos 0) 
  78.           (vec (make-array len)) )
  79.     (dolist (elt list vec)
  80.       (setf (aref vec pos) elt)
  81.       (incf pos) ) ) )
  82.  
  83. (defmacro with-open-file (name stream direc &rest exprs)
  84.   `(let ((,stream (open ,name :direction ,direc)))
  85.      (if ,stream
  86.        (unwind-protect
  87.          (progn ,@exprs)
  88.          (close ,stream) )
  89.        (error "Failure to open file" name) ) ) )
  90.  
  91. (defmacro compilef (code expr env height)
  92.   `(setf ,code (_compile ,code ,expr ,env ,height)) )
  93.  
  94. (defmacro instrf (code &rest instrs)
  95.   (cons 'progn
  96.     (mapcar #'(lambda (instr) `(setf ,code (cons ,instr ,code)))
  97.       instrs) ) )
  98.  
  99. (defun _compile-function (code fun args env height)
  100.   (let ( (argnum1 1))
  101.     (cond 
  102.       ((symbolp fun)
  103.         (instrf code `(push-fun ,fun)) )
  104.       ((consp fun)
  105.         (if (and (eq 'setf (car fun)) (true-listp fun)
  106.               (= (length fun) 2) (symbolp (second fun)))
  107.           (instrf code `(push-setf-fun ,(second fun))) 
  108.           (error "Invalid function name" fun) ) )
  109.       (t (instrf code `(setit ,fun) '(pushit))) )
  110.     (dolist (arg args)
  111.       (compilef code arg (cons argnum1 env) (+ argnum1 height))
  112.       (instrf code '(pushit))
  113.       (incf argnum1) )
  114.     (_env-height-checked (+ argnum1 height))
  115.     (instrf code `(call-with-num-args ,(length args))) ) )
  116.  
  117. (defun _compile-list (code expr env height)
  118.   (let* ( (head (car expr))
  119.           (args (cdr expr))
  120.           (compiler (if (symbolp head) (get head '_compiler) nil)) )
  121.     (if compiler
  122.       (apply compiler (cons code (cons env (cons height args))))
  123.       (_compile-function code head args env height)) ) )
  124.  
  125. (defun _compile (code expr env height)
  126.   '(format t "Compiling ~A ...~%" expr)
  127.   (cond
  128.     ((keywordp expr) (_compile-constant code expr))
  129.     ((symbolp expr)
  130.       (if (and (constantp expr)
  131.             (not (eq (type-of (symbol-value expr)) 'constant)) )
  132.         (_compile-constant code (symbol-value expr))
  133.         (_compile-symbol code expr env) ) )
  134.     ((consp expr) (_compile-list code expr env height))
  135.     (t (_compile-constant code expr)) ) )
  136.  
  137. (setq _*code-marker* (make-symbol "code"))
  138. (defun _is-code (ob)
  139.   (and (consp ob) (eq _*code-marker* (car ob)) ) )
  140. (defun _make-code (ob)
  141.   (cons _*code-marker* ob) )
  142.  
  143. (defun _compile-constant (code expr)
  144.   (instrf code `(setit ,expr)) )
  145.  
  146. (defmacro def-compile (name args &rest stmts)
  147.   `(progn
  148.      (setf (get ',name '_compiler)
  149.        #'(lambda ,args ,@stmts) )
  150.      (list 'def-compile ',name) ) )
  151.  
  152. (defun _env-height-checked (height)
  153.   (if (> height *max-env-height*)
  154.     (setq *max-env-height* height) )
  155.   height)
  156.  
  157. (defun _search-env-elt (var-name env-elt depth)
  158.   (let ( (var nil) )
  159.     (case (car env-elt)
  160.       (field
  161.         (let ( (pos (position var-name (second env-elt))) )
  162.           (if pos
  163.             (setq var (cons 'field (cons depth pos))) ) ) )
  164.       ((stack heap readonly)
  165.         (if (eq var-name (second env-elt))
  166.           (setq var (list (car env-elt) depth)) ) )
  167.       (copied
  168.         (setq var (_search-env-elt var-name (second env-elt) depth)) )
  169.       (uncopied)
  170.       (t (error "Invalid environment element" env-elt)) )
  171.     var) )
  172.  
  173. (defun _search-env (var-name env)
  174.   (let ( (rest env) (depth 0) (var nil) env-elt)
  175.     (while (and rest (not var))
  176.       (setq env-elt (car rest))
  177.       (if (integerp env-elt)
  178.         (addf depth env-elt)
  179.         (progn
  180.           (incf depth)
  181.           (if (not (consp env-elt))
  182.             (error "Invalid environment element" env-elt) )
  183.           (setq var (_search-env-elt var-name env-elt depth))
  184.           (if (eq (car env-elt) 'uncopied) (decf depth)) ) )
  185.       (setq rest (cdr rest)) )
  186.     (if (not var)
  187.       (list 'global var-name)
  188.       var) ) )
  189.  
  190. (defun _env-elt-matches (var-name env-elt)
  191.   (case (car env-elt)
  192.     (field
  193.       (member var-name (second env-elt)) )
  194.     ((stack heap readonly)
  195.       (eq var-name (second env-elt)) )
  196.     ((copied uncopied)
  197.       (_env-elt-matches var-name (second env-elt)) )
  198.     (t (error "Invalid environment element" env-elt)) ) )
  199.  
  200. (defun _search-env-for-usage (var-name env)
  201.   (let ( (rest env) env-elt (matching-elt nil))
  202.     (while (and rest (not matching-elt))
  203.       (setq env-elt (car rest))
  204.       (if (consp env-elt)
  205.         (if (_env-elt-matches var-name env-elt)
  206.           (setq matching-elt env-elt) ) )
  207.       (setq rest (cdr rest)) )
  208.     matching-elt) )
  209.  
  210. (defun _get-instruction (var)
  211.   (case (car var)
  212.     (stack (list 'stack-get (second var)))
  213.     (heap (list 'heap-get (second var)))
  214.     (readonly (list 'stack-get (second var)))
  215.     (global (list 'global-get (second var)))
  216.     (field (list 'field-get (cdr var))) ) )
  217.  
  218. (defun _change-to-used (instr)
  219.   (case (car instr)
  220.     (dont-save
  221.       (setf (car instr) 'save) )
  222.     (t (error "Don't know how to _change-to-used" instr)) ) )
  223.  
  224. (defun _notify-get-usage (env-elt)
  225.   (case (car env-elt)
  226.     (uncopied 
  227.       (setf (car env-elt) 'copied)
  228.       (_notify-get-usage (second env-elt))
  229.       (_change-to-used (third env-elt)) ) ) )
  230.  
  231.  
  232. (defun _compile-symbol (code sym env)
  233.   (let ((env-elt (_search-env-for-usage sym env)))
  234.     (if env-elt
  235.       (_notify-get-usage env-elt) ) )
  236.   (instrf code `(get ,sym ,env)) )
  237.  
  238. (defun _set-instruction (var)
  239.   (case (car var)
  240.     (stack (list 'stack-set (second var)))
  241.     (heap (list 'heap-set (second var)))
  242.     (readonly (error "Can't change value of " var))
  243.     (global (list 'global-set (second var)))
  244.     (field (list 'field-set (cdr var)))) )
  245.  
  246. (defun _change-stack-to-heap-instr (instr)
  247.   (case (car instr)
  248.     (push-stack-var
  249.       (setf (car instr) 'push-heap-var) )
  250.     (leave-on-stack
  251.       (setf (car instr) 'put-on-heap) )
  252.     (t (error "Don't know how to stack-to-heap" instr)) ) )
  253.  
  254. (defun _notify-set-copied-usage (env-elt)
  255.   (case (car env-elt)
  256.     (stack
  257.       (setf (car env-elt) 'heap)
  258.       (_change-stack-to-heap-instr (third env-elt)) )
  259.     (uncopied 
  260.       (setf (car env-elt) 'copied)
  261.       (_notify-set-copied-usage (second env-elt))
  262.       (_change-to-used (third env-elt)) ) ) )
  263.  
  264. (defun _notify-set-usage (env-elt)
  265.   (case (car env-elt)
  266.     (uncopied 
  267.       (setf (car env-elt) 'copied)
  268.       (_notify-set-copied-usage (second env-elt))
  269.       (_change-to-used (third env-elt)) )
  270.     (copied 
  271.       (_notify-set-copied-usage (second env-elt)) ) ) )
  272.  
  273. (defun _compile-set-symbol (code sym env)
  274.   (let ((env-elt (_search-env-for-usage sym env)))
  275.     (if env-elt
  276.       (_notify-set-usage env-elt) ) )
  277.   (instrf code `(set ,sym ,env)) )
  278.       
  279. (defun _env-position (elt env)
  280.   (let ( (position 0) (found nil) (rest-env env) env-elt)
  281.     (while (and (consp rest-env) (not found))
  282.       (setq env-elt (car rest-env))
  283.       (if (eq elt env-elt)
  284.         (setq found t)
  285.         (progn
  286.           (if (integerp env-elt)
  287.             (addf position env-elt)
  288.             (incf position) )
  289.           (setq rest-env (cdr rest-env)) ) ) )
  290.     (if found position nil) ) )
  291.  
  292. (defun _resolved-save-env (saves env)
  293.   (let ( (positions nil) )
  294.     (dolist (save saves)
  295.       (if (eq (car save) 'save)
  296.         (let ( (pos (_env-position (second save) env)) )
  297.           (if pos
  298.             (pushf positions (1+ pos)) ) ) ) )
  299.     (list-to-vector positions) ) )
  300.  
  301. (defun _resolve-var-ref (instr)
  302.   (let ( (new-instr
  303.            (case (first instr)
  304.              (set (_set-instruction (_search-env (second instr)
  305.                                      (third instr))))
  306.              (get (_get-instruction (_search-env (second instr)
  307.                                      (third instr))))
  308.              (save-env
  309.                `(save-env ,(_resolved-save-env (second instr) (third instr))) ) ) ) )
  310.     (setf (car instr) (car new-instr))
  311.     (setf (cdr instr) (cdr new-instr)) ) )
  312.  
  313. ;;; def-compiles
  314.  
  315. (defun _check-var-name (name)
  316.   (if (not (symbolp name))
  317.     (error "Invalid argument variable name" name) )
  318.   (if (constantp name)
  319.     (error "Invalid variable name - is a constant" name) ) )
  320.  
  321. (defmacro compile-stmts (prog stmts env height)
  322.   (let ( (stmt (gensym)) )
  323.     `(if (null ,stmts)
  324.        (instrf ,prog '(setit nil))
  325.        (dolist (,stmt ,stmts ,prog)
  326.          (compilef ,prog ,stmt ,env ,height) ) ) ) )
  327.  
  328. (def-compile progn (code env height &rest stmts)
  329.   (compile-stmts code stmts env height) )
  330.  
  331. (def-compile prog1 (code env height stmt1 &rest stmts)
  332.   (compilef code stmt1 env height)
  333.   (instrf code '(pushit))
  334.   (compile-stmts code stmts (cons 1 env)
  335.     (_env-height-checked (1+ height)) )
  336.   (instrf code '(popit)) )
  337.  
  338. (def-compile prog2 (code env height stmt1 stmt2 &rest stmts)
  339.   (compilef code stmt1 env height)
  340.   (compilef code stmt2 env height)
  341.   (instrf code '(pushit))
  342.   (compile-stmts code stmts (cons 1 env)
  343.     (_env-height-checked (1+ height)))
  344.   (instrf code '(popit)) )
  345.  
  346. (def-compile if (code env height cond then-stmt &optional else-stmt)
  347.   (let ( (not-true-label (gensym)) (end-label (gensym)) )
  348.     (compilef code cond env height)
  349.     (instrf code `(jump-not-true ,not-true-label))
  350.     (compilef code then-stmt env height)
  351.     (instrf code
  352.       `(jump ,end-label)
  353.       not-true-label)
  354.     (compilef code else-stmt env height)
  355.     (instrf code end-label) ) )
  356.  
  357. (def-compile when (code env height cond &rest stmts)
  358.   (_compile-list code `(if ,cond (progn ,@stmts)) env height) )
  359.  
  360. (def-compile unless (code env height cond &rest stmts)
  361.   (_compile-list code `(if (not ,cond) (progn ,@stmts)) env height) )
  362.  
  363. (def-compile quote (code env height value)
  364.   (instrf code `(setit ,value)) )
  365.  
  366. (def-compile dotimes (code env height counter-limit &rest stmts)
  367.   (let ( counter limit result
  368.          (loop (gensym)) (end (gensym)) )
  369.     (if (true-listp counter-limit)
  370.       (case (length counter-limit)
  371.         (2 (setq result nil))
  372.         (3 (setq result (third counter-limit)))
  373.         (t (error "Invalid counter-limit" counter-limit)) )
  374.       (error "Invalid counter-limit" counter-limit) )
  375.     (setq counter (first counter-limit))
  376.     (_check-var-name counter)
  377.     (setq limit (second counter-limit))
  378.     (compilef code limit env height)
  379.     (instrf code
  380.       '(pushit) '(setit 0) '(pushit) loop
  381.       '(check-counter-finished) `(jump-true ,end) )
  382.     (let ( (new-env `((readonly ,counter) 1 ,@env)) )
  383.       (compile-stmts code stmts new-env (_env-height-checked (+ 2 height))) )
  384.     (instrf code
  385.       '(inc-counter) `(jump ,loop) end '(pop-discard 2))
  386.     (compilef code result env height) ) )
  387.  
  388. (def-compile dolist (code env height elt-list &rest stmts)
  389.   (let ( elt list result
  390.          (loop (gensym)) (end (gensym)) )
  391.     (if (true-listp elt-list)
  392.       (case (length elt-list)
  393.         (2 (setq result nil))
  394.         (3 (setq result (third elt-list)))
  395.         (t (error "Invalid element-list" elt-list)) )
  396.       (error "Invalid element-list" elt-list) )
  397.     (setq elt (first elt-list))
  398.     (_check-var-name elt)
  399.     (setq list (second elt-list))
  400.     (compilef code list env height)
  401.     (instrf code
  402.       '(pushit) '(dupl) '(pushit) loop '(check-rest-is-cons)
  403.       `(jump-not-true ,end) )
  404.     (let ( (new-env `((readonly ,elt) 2 ,@env)) )
  405.       (instrf code '(get-next-list-elt))
  406.       (compile-stmts code stmts new-env (_env-height-checked (+ 3 height))) )
  407.     (instrf code
  408.       `(jump ,loop) end '(check-rest-is-nil)
  409.       '(pop-discard 3) )
  410.     (compilef code result env height) ) )
  411.  
  412. (def-compile while (code env height cond &rest stmts)
  413.   (let ( (loop (gensym)) (end (gensym)))
  414.     (instrf code loop)
  415.     (compilef code cond env height)
  416.     (instrf code `(jump-not-true ,end) )
  417.     (compile-stmts code stmts env height)
  418.     (instrf code `(jump ,loop) end) ) )
  419.  
  420. (def-compile cond (code env height &rest clauses)
  421.   (let ( (end (gensym)) )
  422.     (instrf code '(setit nil))
  423.     (dolist (clause clauses)
  424.       (let ( (cond (car clause))
  425.              (stmts (cdr clause)) (next (gensym)) )
  426.         (compilef code cond env height)
  427.         (instrf code `(jump-not-true ,next) )
  428.         (if (not (null stmts))
  429.           (compile-stmts code stmts env height) )
  430.         (instrf code `(jump ,end) next) ) )
  431.     (instrf code end) ) )
  432.  
  433. (def-compile case (code env height key-expr &rest clauses)
  434.   (let ( (end (gensym)) 
  435.          (new-env (cons 1 env)) 
  436.          (new-height (_env-height-checked (1+ height))) )
  437.     (instrf code '(setit nil))
  438.     (compilef code key-expr env height)
  439.     (instrf code '(pushit))
  440.     (dolist (clause clauses)
  441.       (let ( (keys (car clause))
  442.              (stmts (cdr clause))
  443.              (next (gensym)) (start (gensym)) )
  444.         (unless (eq keys t)
  445.           (if (not (consp keys))
  446.             (setq keys (list keys)) )
  447.           (dolist (key keys)
  448.             (instrf code
  449.               `(eql-key ,key) `(jump-true ,start) ) )
  450.           (instrf code `(jump ,next) start) )
  451.         (compile-stmts code stmts new-env new-height)
  452.         (instrf code `(jump ,end) next) ) )
  453.     (instrf code end '(pop-discard 1)) ) )
  454.  
  455. (def-compile and (code env height &rest exprs)
  456.   (let ( (end (gensym)))
  457.     (instrf code '(setit t)) 
  458.     (dolist (expr exprs)
  459.       (compilef code expr env height)
  460.       (instrf code `(jump-not-true ,end)) )
  461.     (instrf code end) ) )
  462.  
  463. (def-compile or (code env height &rest exprs)
  464.   (let ( (end (gensym)))
  465.     (instrf code '(setit nil)) 
  466.     (dolist (expr exprs)
  467.       (compilef code expr env height)
  468.       (instrf code `(jump-true ,end)) )
  469.     (instrf code end) ) )
  470.  
  471. (def-compile let (code env height decls &rest stmts)
  472.   (let ( (new-env env)
  473.          (new-height height)
  474.          (numvars 0) )
  475.     (dolist (decl decls)
  476.       (let (var init var-creator)
  477.         (if (symbolp decl)
  478.           (progn (setq var decl) (setq init nil))
  479.           (progn (setq var (first decl)) (setq init (second decl))) )
  480.         (_check-var-name var)
  481.         (setq var-creator (list 'push-stack-var)) ; note: must use list
  482.         (compilef code init (cons numvars env) new-height)
  483.         (instrf code var-creator)
  484.         (incf numvars)
  485.         (pushf new-env (list 'stack var var-creator))
  486.         (incf new-height) ) )
  487.     (compile-stmts code stmts new-env (_env-height-checked new-height))
  488.     (instrf code `(pop-discard ,numvars)) ) )
  489.  
  490. (def-compile let* (code env height decls &rest stmts)
  491.   (let ( (new-env env)
  492.          (new-height height)
  493.          (numvars 0) )
  494.     (dolist (decl decls)
  495.       (let (var init var-creator)
  496.         (if (symbolp decl)
  497.           (progn (setq var decl) (setq init nil))
  498.           (progn (setq var (first decl)) (setq init (second decl))) )
  499.         (_check-var-name var)
  500.         (setq var-creator (list 'push-stack-var)) ; note: must use list
  501.         (compilef code init new-env new-height)
  502.         (instrf code var-creator)
  503.         (pushf new-env (list 'stack var var-creator))
  504.         (incf new-height)
  505.         (incf numvars) ) )
  506.     (compile-stmts code stmts new-env (_env-height-checked new-height))
  507.     (instrf code `(pop-discard ,numvars)) ) )
  508.  
  509. (def-compile setq (code env height &rest args)
  510.   (let ( (is-var t) var value)
  511.     (if (null args)
  512.       (instrf code '(setit nil)) )
  513.     (dolist (arg args)
  514.       (if is-var
  515.         (setq var arg)
  516.         (progn
  517.           (setq value arg)
  518.           (compilef code value env height)
  519.           (setf code (_compile-set-symbol code var env)) ) )
  520.       (setq is-var (not is-var)) )
  521.     (if (not is-var)
  522.       (error "Odd number of args to setq") )
  523.     code) )
  524.  
  525. (def-compile psetq (code env height &rest args)
  526.   (let ( (is-var t) (numvalues 0)
  527.          value (vars nil) )
  528.     (if (null args)
  529.       (instrf code '(setit nil)) )
  530.     (dolist (arg args)
  531.       (if is-var
  532.         (pushf vars arg)
  533.         (progn
  534.           (setq value arg)
  535.           (compilef code value (cons numvalues env) (+ numvalues height))
  536.           (instrf code '(pushit))
  537.           (incf numvalues) ) )
  538.       (setq is-var (not is-var)) )
  539.     (_env-height-checked (+ numvalues height))
  540.     (if (not is-var)
  541.       (error "Odd number of args to psetq") )
  542.     (dolist (var vars)
  543.       (instrf code '(popit))
  544.       (decf numvalues)
  545.       (setf code (_compile-set-symbol code var (cons numvalues env))) )
  546.     code) )
  547.  
  548. (def-compile defun (code env height name args &rest stmts)
  549.   (_compile code
  550.     `(progn
  551.        ((setf symbol-function) ',name #'(lambda ,args ,@stmts))
  552.        ',name) env height) )
  553.  
  554. (def-compile defmacro (code env height name args &rest stmts)
  555.   (_compile code
  556.     `(progn
  557.        ((setf symbol-function) ',name (macro-of-function #'(lambda ,args ,@stmts)))
  558.        ',name) env height) )
  559.  
  560. (def-compile defsetf (code env height name fun)
  561.   (instrf code `(interpret (defsetf ,name ,fun))) )
  562.  
  563. (def-compile defconstant (code env height name value)
  564.   (_env-height-checked 2)
  565.   (compilef code value env height)
  566.   (instrf code '(pushit)
  567.     `(setit ,name) '(pushit) '(defconstant) ) )
  568.  
  569. (def-compile defstruct (code env height name &rest fields)
  570.   (instrf code `(interpret (defstruct ,name ,@fields)) ) )
  571.  
  572. (def-compile with-struct (code env height type-and-struct &rest stmts)
  573.   (let* ( (type (first type-and-struct)) (struct (second type-and-struct))
  574.           (new-env `((field ,(struct-fields type)) ,@env))
  575.           (new-height (_env-height-checked (1+ height))) )
  576.     (compilef code struct env height)
  577.     (instrf code `(check-struct ,type) '(pushit))
  578.     (compile-stmts code stmts new-env new-height)
  579.     (instrf code '(pop-discard 1)) ) )
  580.  
  581. (defun _bq-is-const (expr depth)
  582.   (if (and (true-listp expr) (= (length expr) 2))
  583.     (case (car expr)
  584.       (backquote (_bq-is-const (second expr) (1+ depth)))
  585.       ((comma comma-at)
  586.         (if (= depth 0)
  587.           nil
  588.           (_bq-is-const (second expr) (1- depth)) ) )
  589.       (t (and (_bq-is-const (car expr) depth)
  590.            (_bq-is-const (cdr expr) depth) )) )
  591.     (if (consp expr)
  592.       (and (_bq-is-const (car expr) depth)
  593.         (_bq-is-const (cdr expr) depth) )
  594.       t) ) )
  595.  
  596. (defun _backquote-expand-cons (expr depth)
  597.   (let ( (expanded-head (_backquote-expand1 (car expr) depth))
  598.          (expanded-tail (_backquote-expand1 (cdr expr) depth)) )
  599.     (if (eq (car expanded-tail) 'splice)
  600.       (error "Invalid position for comma-at" expr) )
  601.     (if (eq (car expanded-head) 'splice)
  602.       `(eval (append ,(second expanded-head) ,(second expanded-tail)))
  603.       `(eval (cons ,(second expanded-head) ,(second expanded-tail))) ) ) )
  604.  
  605.  
  606. (defun _backquote-expand1 (expr depth)
  607.   (if (_bq-is-const expr depth)
  608.     `(eval (quote ,expr))
  609.     (let ( (is-2-long (= (length expr) 2))
  610.            (head (car expr)) )
  611.       (cond
  612.         ((and is-2-long (eq head 'backquote))
  613.           (_backquote-expand-cons expr (1+ depth)) )
  614.         ((and is-2-long (eq head 'comma))
  615.           (if (= depth 0)
  616.             (list 'eval (second expr))
  617.             (_backquote-expand-cons expr (1- depth)) ) )
  618.         ((and is-2-long (eq head 'comma-at))
  619.           (if (= depth 0)
  620.             (list 'splice (second expr))
  621.             (_backquote-expand-cons expr (1- depth)) ) )
  622.         (t (_backquote-expand-cons expr depth)) ) ) ) )
  623.  
  624. (defun _backquote-expand (expr)
  625.   (let ( (result (_backquote-expand1 expr 0)) )
  626.     (case (car result)
  627.       (eval (second result))
  628.       (splice (error "Invalid position for comma-at" expr)) ) ) )
  629.  
  630.  
  631. (def-compile backquote (code env height expr)
  632.   (compilef code (_backquote-expand expr) env height) )
  633.  
  634. (def-compile catch (code env height tag-expr &rest forms)
  635.   (compilef code tag-expr env height)
  636.   (instrf code '(pushit)
  637.     `(catch ,(_make-code (_compile nil `(progn ,@forms) (cons 2 env)
  638.                           (_env-height-checked (1+ height)) )) ) ) )
  639.  
  640. (def-compile unwind-protect (code env height expr &rest forms)
  641.   (let ( (inner-env (cons 2 env))
  642.          (inner-height (+ height 2))
  643.          (unwind-env (cons 3 env))
  644.          (unwind-height (_env-height-checked (+ height 3))) )
  645.     (instrf code
  646.       `(setit ,(_make-code (_compile nil expr inner-env inner-height )))
  647.       '(pushit)
  648.       `(unwind-protect ,(_make-code (_compile nil `(progn ,@forms) 
  649.                                      unwind-env unwind-height)) ) ) ) )
  650.  
  651. (def-compile with-dc (code env height expr &rest forms)
  652.   (compilef code expr env height)
  653.   (instrf code '(pushit)
  654.     `(with-dc ,(_make-code (_compile nil `(progn ,@forms) (cons 2 env) 
  655.                             (_env-height-checked (+ height 2)))) ) ) )
  656.  
  657. (def-compile with-continuous-gc (code env height &rest forms)
  658.   (instrf code
  659.     `(with-continuous-gc ,(_make-code (_compile nil `(progn ,@forms)
  660.                                        (cons 1 env) 
  661.                                        (_env-height-checked 
  662.                                          (1+ height) ) )) ) ) )
  663.  
  664. (def-compile with-selected-objects (code env height expr &rest forms)
  665.   (compilef code expr env height)
  666.   (instrf code '(pushit)
  667.     `(with-selected-objects 
  668.        ,(_make-code (_compile nil `(progn ,@forms)
  669.                      (cons 2 env) 
  670.                      (_env-height-checked 
  671.                        (+ height 2)))) ) ) )
  672.  
  673. (def-compile with-select (code env height objects &rest forms)
  674.   (compilef code `(with-selected-objects
  675.                     (list ,@objects)
  676.                     ,@forms) env height) )
  677.  
  678. (def-compile cons (code env height arg1 arg2)
  679.   (compilef code arg1 env height)
  680.   (instrf code '(pushit))
  681.   (compilef code arg2 (cons 1 env) 
  682.     (_env-height-checked (1+ height)))
  683.   (instrf code '(pushit) '(cons)) )
  684.  
  685. ;;; post-compilation
  686.  
  687. (setq _*jump-ops* '(jump jump-true jump-not-true))
  688.  
  689. (defun _resolve-labels (instructions)
  690.   (let ( (pos 0)
  691.          (labels nil)
  692.          (new-instructions nil) )
  693.     (dolist (instr instructions)
  694.       (if (symbolp instr)
  695.         (pushf labels (cons instr pos))
  696.         (progn
  697.           (incf pos)
  698.           (if (not (true-listp instr))
  699.             (error "Invalid instruction" instr) )
  700.           (pushf new-instructions instr) ) ) )
  701.     (setq new-instructions (reverse new-instructions))
  702.     (setq pos 0)
  703.     (dolist (instr new-instructions)
  704.       (if (member (car instr) _*jump-ops*)
  705.         (let ( (jump-pos (assoc (second instr) labels)) )
  706.           (if (null jump-pos)
  707.             (error "Jump to non-existent label" (second instr)) )
  708.           (setf (second instr) (* 2 (- (cdr jump-pos) (1+ pos))) ) ) )
  709.       (incf pos) )
  710.     new-instructions) )
  711.      
  712. (defun _is-noop (instr)
  713.   (and (consp instr) (member (car instr) '(leave-on-stack))) )
  714.  
  715. (defun _push-version (instr)
  716.   (let ( (pair (assoc (car instr)
  717.                  '( (setit . push-arg) 
  718.                     (stack-get . stack-get-pushit)
  719.                     (call-with-num-args . call-and-pushit) ) ) ) )
  720.     (if (consp pair)
  721.       (cons (cdr pair) (rest instr))
  722.       nil) ) )
  723.  
  724. (defun _reverse-and-optimize (compiled)
  725.   (let ( (new-compiled nil) (pending-pushit nil) (push-version nil))
  726.     (dolist (instr compiled)
  727.       (when (not (_is-noop instr))
  728.         (if pending-pushit
  729.           (progn
  730.             (if (consp instr)
  731.               (setq push-version (_push-version instr))
  732.               (setq push-version nil) )
  733.             (if push-version
  734.               (setq new-compiled (cons push-version new-compiled))
  735.               (setq new-compiled (cons instr (cons '(pushit) new-compiled))) )
  736.             (setq pending-pushit nil) )
  737.           (progn
  738.             (setq pending-pushit (equal instr '(pushit)))
  739.             (if (not pending-pushit)
  740.               (setq new-compiled (cons instr new-compiled)) ) ) ) ) )
  741.     (if pending-pushit
  742.       (setq new-compiled (cons '(pushit) new-compiled)) )
  743.     new-compiled) )
  744.  
  745. (defun _make-exec-code (instrs)
  746.   (let ( (opcode-args nil) )
  747.     (dolist (instr instrs)
  748.       (case (length instr)
  749.         (1 (setq opcode-args (cons nil (cons (first instr) opcode-args))))
  750.         (2 (setq opcode-args (cons (second instr)
  751.                                (cons (first instr) opcode-args))))
  752.         (t (error "Invalid instruction" instr)) ) )
  753.     (array-to-code (list-to-vector (reverse opcode-args))) ) )
  754.  
  755. (defun _post-compile (compiled)
  756.   (instrf compiled '(exit))
  757.   (dolist (instr compiled)
  758.     (if (consp instr)
  759.       (cond
  760.         ((and (member (car instr) '(set get save-env)))
  761.           (_resolve-var-ref instr) )
  762.         ((and (= (length instr) 2) (_is-code (second instr)))
  763.           (setf (second instr) (_post-compile (cdr (second instr)))) ) ) ) )
  764.   (let* ( (compiled-with-exit (_reverse-and-optimize compiled))
  765.           (resolved (_resolve-labels compiled-with-exit)) )
  766.     (_make-exec-code resolved) ) )
  767.  
  768. (defun _compile-toplevel (expr)
  769.   (progv '(*max-env-height*) '(0)
  770.     (let* ( (stack-checker (list 'check-stack 0))
  771.             (code (_compile (list stack-checker) (full-macroexpand expr) nil 0)) )
  772.       (setf (second stack-checker) *max-env-height*)
  773.       (_post-compile code) ) ) )
  774.  
  775. ;;; lambda expr compilation
  776.  
  777. (defstruct _arglist args canonical-arglist varlist num-vars)
  778.  
  779. (defstruct _canonical-arglist 
  780.   pos-args opt-args rest-arg kwd-args
  781.   allow-other-keys num-pos-args num-opt-args num-kwd-args
  782.   num-opt-vars num-kwd-vars opt-var-gaps kwd-list)
  783.  
  784. (defun _var-list (canonical-arglist)
  785.   (let ( (list nil) )
  786.     (with-struct (_canonical-arglist canonical-arglist)
  787.       (dolist (arg pos-args)
  788.         (pushf list arg) )
  789.       (dolist (arg opt-args)
  790.         (if (consp (first arg))
  791.           (progn
  792.             (pushf list (car (first arg)))
  793.             (pushf list (cdr (first arg))) )
  794.           (pushf list (first arg)) ) )
  795.       (dolist (arg rest-arg)
  796.         (rest (pushf list arg)) )
  797.       (dolist (arg kwd-args)
  798.         (if (consp (second arg))
  799.           (progn
  800.             (pushf list (car (second arg)))
  801.             (pushf list (cdr (second arg))) )
  802.           (pushf list (second arg)) ) ) )
  803.     (reverse list) ) )
  804.  
  805. (defun _analyze-args (arglist)
  806.   (let ( (state-pos -1)
  807.          (last-kwd '&positional)
  808.          (canonical-arglist (make-_canonical-arglist
  809.                               :pos-args nil :opt-args nil
  810.                               :rest-arg nil :kwd-args nil :kwd-list nil
  811.                               :num-opt-vars 0 :num-kwd-vars 0
  812.                               :opt-var-gaps nil) )
  813.          (lambda-kwd-list '(&optional &rest &key &allow-other-keys))
  814.          canonical-arg)
  815.     (if (not (true-listp arglist))
  816.       (error "Invalid argument list" arglist) )
  817.     (with-struct (_canonical-arglist canonical-arglist)
  818.       (setq allow-other-keys nil)
  819.       (dolist (arg arglist)
  820.         (let ( (kwd-pos (position arg lambda-kwd-list)) )
  821.           (if kwd-pos
  822.             (progn
  823.               (if (<= kwd-pos state-pos)
  824.                 (error "Argument list keyword in wrong order" arg) )
  825.               (setq state-pos kwd-pos)
  826.               (setq last-kwd arg)
  827.               (if (eq arg '&allow-other-keys)
  828.                 (if (and kwd-args rest-arg)
  829.                   (setq allow-other-keys t)
  830.                   (error "Can't have &allow-other-keys without &rest and &keys" arglist) ) ) )
  831.             (case last-kwd
  832.               (&positional
  833.                 (_check-var-name arg)
  834.                 (pushf pos-args arg) )
  835.               (&optional
  836.                 (if (true-listp arg)
  837.                   (let ( (arg-len (length arg))
  838.                          arg-name arg-names suppliedp-arg (default nil))
  839.                     (if (or (< arg-len 1) (> arg-len 3))
  840.                       (error "Invalid optional arg" arg) )
  841.                     (setq arg-name (first arg))
  842.                     (incf num-opt-vars)
  843.                     (_check-var-name arg-name)
  844.                     (if (>= arg-len 2)
  845.                       (setq default (second arg)) )
  846.                     (if (= arg-len 3)
  847.                       (progn
  848.                         (pushf opt-var-gaps 2)
  849.                         (setq suppliedp-arg (third arg))
  850.                         (incf num-opt-vars)
  851.                         (_check-var-name suppliedp-arg)
  852.                         (setq arg-names (cons arg-name suppliedp-arg)) )
  853.                       (progn
  854.                         (setq arg-names arg-name) 
  855.                         (if opt-var-gaps (pushf opt-var-gaps 1)) ) )
  856.                     (setq canonical-arg (list arg-names default)) )
  857.                   (progn
  858.                     (_check-var-name arg)
  859.                     (incf num-opt-vars)
  860.                     (if opt-var-gaps (pushf opt-var-gaps 1))
  861.                     (setq canonical-arg (list arg nil)) ) )
  862.                 (pushf opt-args canonical-arg) )
  863.               (&rest
  864.                 (if rest-arg
  865.                   (error "More than one &rest arg in arg list" arglist) )
  866.                 (_check-var-name arg)
  867.                 (setq rest-arg (list arg)) )
  868.               (&key
  869.                 (setq allow-other-keys nil)
  870.                 (let (kwd var 
  871.                        (has-suppliedp-var nil)
  872.                        (suppliedp-var nil)
  873.                        (default nil) )
  874.                   (if (true-listp arg)
  875.                     (let ( (arg-len (length arg)) )
  876.                       (if (or (< arg-len 1) (> arg-len 3))
  877.                         (error "Invalid keyword arg" arg) )
  878.                       (let ( (arg-1 (first arg)) )
  879.                         (if (and (true-listp arg-1) (= (length arg-1) 2))
  880.                           (progn
  881.                             (setq kwd (first arg-1))
  882.                             (setq var (second arg-1)) )
  883.                           (progn
  884.                             (_check-var-name arg-1)
  885.                             (setq kwd (keyword-of arg-1))
  886.                             (setq var arg-1) ) ) )
  887.                       (if (>= arg-len 2)
  888.                         (setq default (second arg)) )
  889.                       (when (>= arg-len 3)
  890.                         (setq suppliedp-var (third arg))
  891.                         (setq has-suppliedp-var t)
  892.                         )
  893.                       )
  894.                     (progn
  895.                       (_check-var-name arg)
  896.                       (setq kwd (keyword-of arg))
  897.                       (setq var arg)
  898.                       ) )
  899.                   (_check-var-name var)
  900.                   (pushf kwd-list (cons kwd num-kwd-vars))
  901.                   (incf num-kwd-vars)
  902.                   (when has-suppliedp-var
  903.                     (_check-var-name suppliedp-var)
  904.                     (incf num-kwd-vars) )
  905.                   (if has-suppliedp-var
  906.                     (setq canonical-arg
  907.                       (list kwd (cons var suppliedp-var) default) )
  908.                     (setq canonical-arg
  909.                       (list kwd var default) ) ) )
  910.                 (pushf kwd-args canonical-arg) )
  911.               (&allow-other-keys
  912.                 (error "Can't have args following &allow-other-keys" arg) )
  913.               (t (error "Invalid last argument list keyword" last-kwd)) ) ) ) )
  914.       (setq pos-args (reverse pos-args))
  915.       (setq num-pos-args (length pos-args))
  916.       (setq opt-args (reverse opt-args))
  917.       (setq num-opt-args (length opt-args))
  918.       (setq kwd-args (reverse kwd-args))
  919.       (setq num-kwd-args (length kwd-args))
  920.       (setq kwd-list (reverse kwd-list)) )
  921.     (let ( (result 
  922.              (make-_arglist 
  923.                :args arglist :canonical-arglist canonical-arglist ) ) )
  924.       (with-struct (_arglist result)
  925.         (setf varlist (_var-list canonical-arglist))
  926.         (setf num-vars (length varlist)) )
  927.       result) ) )
  928.  
  929. (defun _arg-env (varlist)
  930.   (let ( (offset 1) (env nil) )
  931.     (dolist (var (reverse varlist))
  932.       (pushf env (list 'stack var (list 'leave-on-stack offset)))
  933.       (incf offset) )
  934.     (reverse env)) )
  935.  
  936. (defun _copy-env (env)
  937.   (let ( (new-env nil) )
  938.     (dolist (elt env)
  939.       (if (consp elt)
  940.         (pushf new-env (list 'uncopied elt (list 'dont-save elt))) ) )
  941.     (reverse new-env) ) )
  942.  
  943. (defun _compile-args-expander (code arglist)
  944.   (with-struct (_arglist arglist)
  945.     (with-struct (_canonical-arglist canonical-arglist)
  946.       (let ( (is-simple (not (or rest-arg kwd-args opt-args))) )
  947.         (if is-simple
  948.           (instrf code `(check-num-args ,num-pos-args))
  949.           (progn
  950.             (instrf code `(set-num-vars ,num-vars) `(check-min-num-args ,num-pos-args))
  951.             (if (not (or rest-arg kwd-args))
  952.               (instrf code `(check-max-num-args ,(+ num-pos-args num-opt-args))) )
  953.             (if (or rest-arg kwd-args)
  954.               (instrf code 
  955.                 `(shift-rest-args ,(+ num-pos-args num-opt-args)) ) )
  956.             (when opt-args
  957.               (instrf code
  958.                 `(fill-out-opt-args ,(+ num-pos-args num-opt-args)) )
  959.               (when opt-var-gaps
  960.                 (instrf code
  961.                   `(set-opt-vars-top ,(+ num-pos-args num-opt-vars)) )
  962.                 (dolist (opt-var-gap opt-var-gaps)
  963.                   (instrf code
  964.                     `(set-opt-var ,opt-var-gap) ) ) ) )
  965.             (if rest-arg
  966.               (instrf code
  967.                 `(get-rest-arg ,(+ num-pos-args num-opt-vars)) ) )
  968.             (when kwd-args
  969.               (instrf code
  970.                 `(init-kwd-args ,num-kwd-vars) )
  971.               (if allow-other-keys
  972.                 (instrf code '(allow-other-keys)) )
  973.               (instrf code
  974.                 `(get-kwd-args ,kwd-list) ) )
  975.             (instrf code `(reset-arg-stack)) ) ) ) ) )
  976.   code)
  977.  
  978. (defun _compile-opt-default-getter (code opt-arg arg-env saved-env height)
  979.   (let ( (arg-names (first opt-arg))
  980.          (default (second opt-arg))
  981.          var
  982.          (end (gensym)) )
  983.     (if (consp arg-names)
  984.       (setq var (car arg-names))
  985.       (setq var arg-names) )
  986.     (instrf code `(get ,var ,arg-env) '(test-suppliedp)
  987.       `(jump-true ,end) )
  988.     (compilef code default saved-env height)
  989.     (instrf code `(set ,var ,arg-env) end) ) )
  990.  
  991.  
  992. (defun _compile-kwd-default-getter (code opt-arg arg-env saved-env height)
  993.   (let ( (arg-names (second opt-arg))
  994.          (default (third opt-arg))
  995.          var suppliedp-var
  996.          (middle (gensym)) (end (gensym)) )
  997.     (if (consp arg-names)
  998.       (progn
  999.         (setq var (car arg-names))
  1000.         (setq suppliedp-var (cdr arg-names))
  1001.         (instrf code
  1002.           `(get ,var ,arg-env) '(test-suppliedp)
  1003.           `(jump-true ,middle) )
  1004.         (compilef code default saved-env height)
  1005.         (instrf code `(set ,var ,arg-env)
  1006.           '(setit nil) `(set ,suppliedp-var ,arg-env)
  1007.           `(jump ,end)
  1008.           middle
  1009.           '(setit t) `(set ,suppliedp-var ,arg-env) end) )
  1010.       (progn
  1011.         (setq var arg-names)
  1012.         (instrf code 
  1013.           `(get ,var ,arg-env) '(test-suppliedp)
  1014.           `(jump-true ,end) )
  1015.         (compilef code default saved-env height)
  1016.         (instrf code
  1017.           `(set ,var ,arg-env) end) ) ) ) )
  1018.  
  1019.  
  1020. (defun _compile-defaults-getters (code canonical-arglist arg-env saved-env height)
  1021.   (with-struct (_canonical-arglist canonical-arglist)
  1022.     (dolist (opt-arg opt-args)
  1023.       (setf code (_compile-opt-default-getter code opt-arg 
  1024.                       arg-env saved-env height)) )
  1025.     (dolist (kwd-arg kwd-args)
  1026.       (setf code (_compile-kwd-default-getter code kwd-arg
  1027.                       arg-env saved-env height)) kwd-args)
  1028.     code) )
  1029.  
  1030. (defun _compile-lambda-function (code args body env height)
  1031.   (if (not (true-listp args))
  1032.     (error "Invalid function argument list" args) )
  1033.   (if (not (true-listp body))
  1034.     (error "Invalid function body" body) )
  1035.   (let* ( (arglist (_analyze-args args))
  1036.           (varlist (_arglist-varlist arglist))
  1037.           (arg-env (_arg-env varlist))
  1038.           (saved-env (_copy-env env))
  1039.           (save-list (mapcar #'third saved-env))
  1040.           (new-env (append arg-env saved-env)) 
  1041.           (new-height (+ height (length varlist)))
  1042.           (function-code nil)
  1043.           (stack-checker (list 'check-stack 0)) )
  1044.     (with-struct (_arglist arglist)
  1045.       (progv '(*max-env-height*) (list new-height)
  1046.         (setf function-code (_compile-args-expander function-code arglist))                               
  1047.         (instrf function-code 
  1048.           `(dump-info ,(cons (length varlist) (cons nil varlist)))
  1049.           stack-checker)
  1050.         (setf function-code (_compile-defaults-getters function-code
  1051.                               canonical-arglist arg-env
  1052.                               (cons num-vars saved-env) new-height) )
  1053.         (dolist (arg arg-env)
  1054.           (instrf function-code (third arg)) )
  1055.         (compilef function-code `(progn ,@body) new-env new-height)
  1056.         (instrf function-code '(undump-info))
  1057.         (setf (second stack-checker) *max-env-height*) )
  1058.       (setq function-code (_make-code function-code))
  1059.       (if saved-env
  1060.         (instrf code `(save-env ,save-list ,env) `(make-closure ,function-code))
  1061.         (instrf code `(setit ,function-code)) ) ) ) )
  1062.  
  1063. (def-compile function (code env height expr)
  1064.   (if (symbolp expr)
  1065.     (instrf code `(get-fun-with-name ,expr))
  1066.     (progn
  1067.       (if (not (true-listp expr))
  1068.         (error "Invalid arg to function, not a list or symbol" expr) )
  1069.       (if (not (eq (car expr) 'lambda))
  1070.         (error "Invalid arg to function, list is not a lambda expression"
  1071.           expr) )
  1072.       (if (< (length expr) 2)
  1073.         (error "Invalid lambda list, has no arguments") )
  1074.       (setf code
  1075.         (_compile-lambda-function code (second expr) (cddr expr) env height) ) ) ) )
  1076.  
  1077. ;;; file compilation
  1078.  
  1079. (defun compile-and-load (infile-name outfile-name)
  1080.   (let ( (the-compiler (the-compiler)) )
  1081.     (if (null the-compiler)
  1082.       (error "the-compiler is undefined") )
  1083.     (with-open-file infile-name infile :input
  1084.       (with-open-file outfile-name outfile :output
  1085.         (while (not (eofp infile))
  1086.           (let* ( (expr (read infile))
  1087.                   (compiled-expr (funcall the-compiler expr)) )
  1088.             (format t "Compiled ~A~%" expr)
  1089.             (print compiled-expr outfile)
  1090.             (eval compiled-expr) ) ) ) ) )
  1091.   outfile-name)
  1092.  
  1093. (setf (the-compiler) #'_compile-toplevel)
  1094.  
  1095.