(comment "%W% %G%")

(defun c:get-tlab (jmp lab)
   (cond ((or (atom jmp) (null (car jmp))) lab) (t (car jmp))))

(defun c:get-flab (jmp lab)
   (cond ((or (atom jmp) (null (cdr jmp))) lab) (t (cdr jmp))))

(comment defun c:local-tlab (jmp lab) (or (null jmp) (neq (car jmp) lab)))

(comment defun c:local-flab (jmp lab) (or (null jmp) (neq (cdr jmp) lab)))

(defun c:make-jmp-t (jmp tlab)
   (cond ((null jmp) `(,tlab))
	 ((null (car jmp)) `(,tlab . ,(cdr jmp)))
	 (t jmp)))

(defun c:make-jmp-f (jmp flab)
   (cond ((null jmp) `(nil . ,flab))
	 ((null (cdr jmp)) `(,(car jmp) . ,flab))
	 (t jmp)))

(defmacro c:make-jmp-tf (jmp tlab flab)
   `(c:make-jmp-f (c:make-jmp-t ,jmp ,tlab) ,flab))

(defnprop and
   (lambda (args loc jmp)
    (cond ((atom args) (c:symbol t loc jmp))
          (t (do ((l args (cdr l))
                  (codes)
                  (tlab (gensym "andtlab"))
                  (flab (gensym "andflab")))
                 ((atom (cdr l))
                  (c:gen (c:form (car l) loc (c:make-jmp-tf jmp tlab tlab))
			 `(label ,flab)
			 (c:symbol nil loc jmp)
			 `(label ,tlab))
                  (c:make-begin codes))
                 (c:gen-form (car l) nil `(nil . ,flab))))))
   inline)

(defnprop or
   (lambda (args loc jmp)
    (cond ((atom args) (c:symbol nil loc jmp))
          (t (do ((l args (cdr l))
                  (codes)
		  (a (c:get-cvar))
                  (tlab (gensym "ortlab"))
                  (flab (gensym "orflab")))
                 ((atom (cdr l))
                  (c:gen (c:form (car l) loc (c:make-jmp-tf jmp flab flab))
			 `(label ,tlab)
			 (c:final a loc jmp)
			 `(label ,flab))
                  (c:make-begin codes))
                 (c:gen-form (car l) a `(,tlab . nil))))))
   inline)

(defnprop cond
   (lambda (args loc jmp)
    (do ((l args (cdr l))
         (codes)
         (tlab (gensym "condtlab"))
         (flab (gensym "condflab") (gensym "condflab")))
        ((atom l)
         (c:gen (c:symbol nil loc jmp) `(label ,tlab))
         (c:make-begin codes))
        (match (car l)
           ((pred . body) 
            (cond ((atom body) (c:gen-form pred loc `(,tlab . ,flab)))
                  ((and (c:constantp pred) (c:constant-value pred))
                   (c:gen-progn body loc jmp))
                  (t (c:gen (c:form pred nil `(nil . ,flab))
                            (c:progn body loc jmp))))
            (c:gen `(goto ,tlab) `(label ,flab)))
           (x (c:error "illegal cond clause" x)))))
   inline)

(defnprop selectq
   (lambda (args loc jmp)
    (match args
       ((key . clauses) 
        (lets ((a (c:get-cvar)))
         `(begin ,(c:form key a nil) ,(c:selq-clause a clauses loc jmp))))
       (t (c:argerr args))))
   inline)

(defun c:selq-clause (key clauses loc jmp)
   (and clauses
        (match (car clauses)
           ((pat . body) 
            (cond ((eq pat t) (c:progn body loc jmp))
                  (t `(if ,(c:selq-cond key pat)
                          ,(c:progn body loc jmp)
                          ,(c:selq-clause key (cdr clauses) loc jmp)))))
           (x (c:error "illegal selectq clause" x)))))

(defun c:selq-cond (key pat)
   (cond ((atom pat) `(== ,key ,(c:atom-literal pat)))
         (t `(|| . 
              ,(mapcar pat
                  (function (lambda (x) `(== ,key ,(c:atom-literal x)))))))))

(defnprop comment (lambda (args loc jmp) (c:symbol nil loc jmp)) inline)

(defnprop progn (lambda (args loc jmp) (c:progn args loc jmp)) inline)

(defnprop prog1
   (lambda (args loc jmp)
    (and (< (length args) 1) (c:argerr args))
    (cond ((null loc) (c:progn args loc jmp))
          (t (lets ((sp sp) (codes))
              (c:gen (c:form (car args) (incr sp 1) nil)
                     (c:progn (cdr args) nil nil)
                     (c:final sp loc jmp))
              (c:make-begin codes)))))
   inline)

(defnprop prog2
   (lambda (args loc jmp)
    (and (< (length args) 2) (c:argerr args))
    (cond ((null loc) (c:progn args loc jmp))
          (t (lets ((sp sp) (codes))
              (c:gen (c:form (first args) nil nil)
                     (c:form (second args) (incr sp 1) nil)
                     (c:progn (cddr args) nil nil)
                     (c:final sp loc jmp))
              (c:make-begin codes)))))
   inline)

(defnprop match
   (lambda (args loc jmp)
    (and (atom args) (c:argerr args))
    (lets ((local-save local-vars) (special-save special-vars) (spsave sp) 
           (a (c:get-cvar)) (bs (c:get-cvar)) (codes))
     (c:gen-form (car args) a nil)
     (do ((l (cdr args) (cdr l))
          (local-vars local-save local-save)
          (special-vars special-save special-save)
          (x)
          (special-flag nil (or special-flag (neq special-vars special-save)))
          (sp spsave spsave)
          (suc (gensym "match") (gensym "match"))
          (fail (gensym "unmatch") (gensym "unmatch"))
          (endmatch (gensym "endmatch"))
          (undo '(for (nil (< bstack bs) ((= bstack (/+ bstack 2))))
                      (= (value (star (/+ bstack 1))) (star bstack)))))
         ((atom l)
          (c:gen (c:symbol nil a jmp)
                 `(label ,endmatch)
                 (and special-flag (copy undo))
                 (c:final a loc jmp))
          (cond (special-flag
                   `(block 
                     ,(copy '(("WORD *" bs))) 
                     (= bs bstack) . 
                     ,(nreverse codes)))
                (t (c:make-begin codes))))
         (and (atom (setq x (car l))) (c:argerr args))
         (c:gen (c:match (car x) a suc fail)
                `(label ,suc)
                (c:progn (cdr x) a nil)
                `(goto ,endmatch)
                `(label ,fail)
                (and (neq special-vars special-save) (copy undo))))))
   inline)

(defun c:match (pat key suc fail)
   (cond ((null pat) `(if (== ,key nil) (goto ,suc) (goto ,fail)))
         ((symbolp pat)
          `(begin ,(cond ((c:specialp pat) (c:bind-special pat key))
                         (t (c:push-local pat (incr sp 1)) (c:assign sp key)))
                  (goto ,suc)))
         ((atom pat)
          `(if (== ,key ,(c:atom-literal pat)) (goto ,suc) (goto ,fail)))
         ((and (eq (car pat) 'quote) (consp (cdr pat)))
          `(if (== ,key ,(c:special-sym (second pat)))
               (goto ,suc)
               (goto ,fail)))
         (t (lets ((matchcdr (gensym "matchcdr")))
             `(begin (if (atom ,key) (goto ,fail))
                     ,(c:match (car pat) `(car ,key) matchcdr fail)
                     (label ,matchcdr)
                     ,(c:match (cdr pat) `(cdr ,key) suc fail))))))

(defnprop prog
   (lambda (args loc jmp)
    (and (/0= (length args)) (c:argerr args))
    (lets ((local-vars local-vars) (special-vars special-vars) 
           (prog-tags prog-tags) (prog-exit-label (gensym "progend")) 
           (prog-special-vars special-vars) (prog-value (c:get-cvar)) (sp sp) 
           (spsave sp) (codes))
     (do ((l (car args) (cdr l)) (sym) (body) (a))
         ((atom l))
         (setq sym (car l))
         (cond ((atom sym)
                (c:check-var sym)
                (cond ((c:specialp sym) (c:gen (c:bind-special sym nil)))
                      (t (c:push-local sym (incr sp 1))
                         (c:gen (c:assign sp nil)))))
               (t (setq sym (car sym) body (cdr sym))
                  (c:check-var sym)
                  (setq a (c:get-cvar))
                  (cond ((c:specialp sym)
                         (c:gen (c:progn body a nil) (c:bind-special sym a)))
                        (t (c:push-local sym (incr sp 1))
                           (c:gen-progn body sp nil))))))
     (do ((l (cdr args) (cdr l)) (tags) (x))
         ((atom l) (setq prog-tags (nconc tags prog-tags)))
         (setq x (car l))
         (cond ((atom x)
                (and (assq x tags) (c:error "duplicate tag in prog" x))
                (push `(,x ,(gensym "progtag") ,special-vars) tags))))
     (do ((l (cdr args) (cdr l)) (tags prog-tags) (x) (tag))
         ((atom l))
         (setq x (car l))
         (cond ((atom x)
                (setq tag (assq x tags))
                (c:gen `(label ,(second tag))))
               (t (c:gen-form x nil nil))))
     (c:gen (c:undo-special prog-special-vars)
            (c:assign prog-value nil)
            `(label ,prog-exit-label)
            (c:final prog-value loc jmp))
     (c:make-block nil codes)))
   inline)

(defnprop go
   (lambda (args loc jmp)
    (and (<> (length args) 1) (c:argerr args))
    (lets ((tag (assq (car args) prog-tags)))
     (cond ((null prog-exit-label) (c:error "go outside prog" `(go ,tag)))
           ((null tag) (c:error "go tag not found" tag))
           (t `(begin ,(c:undo-special (third tag)) (goto ,(second tag)))))))
   inline)

(defnprop return
   (lambda (args loc jmp)
    (cond ((null prog-value) (c:error "return outside prog" `(return . ,args)))
          (t `(begin ,(c:progn args prog-value nil)
                     ,(c:undo-special prog-special-vars)
                     (goto ,prog-exit-label)))))
   inline)

(defnprop push
   (lambda (args loc jmp)
    (match args
       ((item sym)
        (or (symbolp sym) (c:typerr sym))
        (lets ((a (c:get-cvar)) (d (c:get-cvar)))
         `(block nil
                 ,(c:form (car args) a nil)
                 ,(c:symbol sym d nil)
                 (= ,a (alcons ,a ,d (dis ,sp)))
                 ,(c:set-value sym a)
                 ,(c:final a loc jmp))))
       (t (c:argerr args))))
   inline)

(defnprop pop
   (lambda (args loc jmp)
    (match args
       ((sym)
        (or (symbolp sym) (c:typerr sym))
        (lets ((a (c:get-cvar)) (d (c:get-cvar)))
         `(begin ,(c:symbol sym a nil)
                 (if (atom ,a) (parerr))
                 (= ,d (car ,a))
                 ,(c:set-value sym `(cdr ,a))
                 ,(c:final d loc jmp))))
       (t (c:argerr args))))
   inline)

(defnprop setq
   (lambda (args loc jmp)
    (match args
       ((sym val)
        (lets ((a (c:get-cvar)))
         (c:check-var sym)
         `(begin ,(c:form val a nil)
                 ,(c:set-value sym a)
                 ,(c:final a loc jmp))))
       ((sym1 val1 sym2 val2)
        (lets ((r1) (r2) (nsp))
         (c:check-var sym1)
         (c:check-var sym2)
         `(begin ,(c:eval-twoargs val1 val2)
                 ,(c:set-value sym1 r1)
                 ,(c:set-value sym2 r2)
                 ,(c:final r2 loc jmp))))
       (args (cond ((oddp (length args)) (c:argerr args))
                   ((atom args) (c:symbol nil loc jmp))
                   (t (do ((l args (cddr l))
                           (syms)
                           (a (c:get-cvar))
                           (sp sp (/1+ sp))
                           (spsave sp)
                           (codes))
                          ((atom l)
                           (do ((sp spsave (/1+ sp))
                                (syms (nreverse syms) (cdr syms)))
                               ((atom (cdr syms))
                                (c:gen (c:assign a (/1+ sp))
                                       (c:set-value (car syms) a)
                                       (c:final a loc jmp))
                                (c:make-begin codes))
                               (c:gen (c:set-value (car syms) (/1+ sp)))))
                          (c:check-var (car l))
                          (push (car l) syms)
                          (c:gen-form (second l) (/1+ sp) nil)))))))
   inline)

(defnprop loop
   (lambda (args loc jmp)
    (lets ((loop-exit-label (gensym "exit")) (loop-special-vars special-vars) 
           (loop-value (c:get-cvar)))
     `(begin (while 1 ,(c:progn args nil nil))
             (label ,loop-exit-label)
             ,(c:final loop-value loc jmp))))
   inline)

(defnprop exit
   (lambda (args loc jmp)
    (and (null loop-exit-label) (c:error "exit outside loop" `(exit . ,args)))
    `(begin ,(c:progn args loop-value nil)
            ,(c:undo-special loop-special-vars)
            (goto ,loop-exit-label)))
   inline)

(defnprop quote
   (lambda (args loc jmp)
    (cond ((<> (length args) 1) (c:argerr args)) (t (setq args (car args))))
    (cond ((symbolp args)
           (cond ((c:in-root args) (c:final args loc jmp))
                 (t (c:final (c:special-sym args) loc jmp))))
          ((atom args) (c:atom args loc jmp))
          (t (c:cons args loc jmp))))
   inline)

(defnprop function
   (lambda (args loc jmp)
    (and (<> (length args) 1) (c:argerr args))
    (match (car args)
       (('lambda formals . body)
        (c:compile-function nil formals body hstream cstream)
        (c:make-code (c:post-incr ncodepieces) loc jmp))
       (('macro 'lambda formals . body)
        (c:compile-macro nil formals body hstream cstream)
        (c:make-code (c:post-incr ncodepieces) loc jmp))
       (sym (or (symbolp sym) (c:typerr sym))
            (cond ((c:in-root sym) (c:final sym loc jmp))
                  (t (c:final (c:special-sym sym) loc jmp))))))
   inline)

(defnprop catch
   (lambda (args loc jmp)
    (and (/0= (length args)) (c:argerr args))
    (lets ((a (c:get-cvar)) (throwlab (gensym "throw")) 
           (catch-tags
              (and (c:constantp (car args))
                   `((,(c:constant-value (car args)) . ,throwlab) . 
                     ,catch-tags))))
     `(block ((jmp_buf env)
              ("WORD *" bstacksave)
              ("WORD *" cstacksave)
              ("struct lispenv *" estacksave))
             (= bstacksave bstack)
             (= cstacksave cstack)
             (= estacksave estack)
             (if (_setjmp env)
                 (begin ,(and catch-tags `(label ,throwlab))
                        (while (< bstack bstacksave)
                               (= ,a (popb))
                               (= (value (popb)) ,a))
                        (= cstack cstacksave)
                        (= estack estacksave)
                        ,(c:final 'catchval loc jmp))
                 (begin (if (< /--estack estacktop) (exit 1))
                        ,(c:form (car args) a nil)
                        (= estack->envobj ,a)
                        (= estack->envtag CATCHENV)
                        (= estack->envbuf (cast (jmp_buf *) env))
                        ,(c:progn (cdr args) a jmp)
                        (/+= estack 1)
                        ,(c:final a loc jmp))))))
   inline)

(defnprop lcatch
   (lambda (args loc jmp)
    (match args
       ((('quote tag) . body)
        (lets ((a (c:get-cvar)) (throwlab (gensym "throw")) 
               (catch-tags `((,tag . ,throwlab) . catch-tags)))
	 `(block (("WORD *" bstacksave))
	     (= bstacksave bstack)
	     ,(c:progn body 'catchval nil)
	     (label ,throwlab)
             (while (< bstack bstacksave) (= ,a (popb)) (= (value (popb)) ,a))
	     ,(c:final 'catchval loc jmp))))
       (args (c:argerr args))))
   inline)

(defnprop throw
   (lambda (args loc jmp)
    (and (/0= (length args)) (c:argerr args))
    (lets ((a (c:get-cvar)) (sp sp) (p))
     (cond ((and (c:constantp (car args))
                 (setq p (assq (c:constant-value (car args)) catch-tags)))
            `(begin ,(c:progn (cdr args) 'catchval nil) (goto ,(cdr p))))
           (t `(block (("struct lispenv *" envp))
                      ,(c:form (car args) a nil)
                      (for (((= envp estack))
                            (< envp estackbottom)
                            ((/+= envp 1)))
                           (if (&& (== envp->envtag CATCHENV)
                                   (== envp->envobj ,a))
                               (begin ,(c:progn (cdr args) 'catchval nil)
                                      (= estack envp)
                                      (_longjmp "*(envp->envbuf)" 1))))
                      (reterr ,a fp))))))
   inline)

(defnprop lets
   (lambda (args loc jmp) (c:form `((lambda . ,args)) loc jmp))
   inline)

(defnprop let
   (lambda (args loc jmp)
    (do ((a (car args) (cdr a)) (x) (formals) (actuals))
        ((atom a)
         (c:form `((lambda ,(nreverse formals) . ,(cdr args)) . 
                   ,(nreverse actuals))
                 loc
                 jmp))
        (setq x (car a))
        (or (consp x) (consp (cdr x)) (c:argerr (car args)))
        (push (first x) formals)
        (push (second x) actuals)))
   inline)

