;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.

(use goo/boot)

;; (ct (seq (dv fab-setter-name make-setter-name) (dv cat-sym make-sym)))

;; TODO: Fix next-method to do a normal call with a next-method instead of
;;       apply, as apply is not necessary, and slow.

(df @checked-next-methods (met nxt-mets args|...)
  (if nxt-mets 
      (if (@== nxt-mets '())
          (no-next-methods-error met args)
          nxt-mets)
      (no-next-methods-error met args)))

(ds sup (,@args)
  `(let ((next-mets (@checked-next-methods (%fun-reg) (%next-methods) ,@args)))
     (napp (head next-mets) (tail next-mets) ,@args '())))

(ds app-sup (,@args)
  `(let ((next-mets (@checked-next-methods (%fun-reg) (%next-methods) ,@args)))
     (napp (head next-mets) (tail next-mets) ,@args)))

(ds app (,f ,@args)
  `(napp ,f #f ,@args))

(ds renew (,x ,@prop-inits)
  (let ((var  (gensym))
        (sets (rep loop ((sets '()) (inits prop-inits))
                (if (nul? inits)
                    (rev! sets)
                    (let ((val (head (tail inits))))
                      (loop (pair `(set (,(head inits) ,var) ,val) sets)
                            (tail (tail inits))))))))
    `(let ((,var ,x)) ,@sets ,var)))

(ct-also

  ;; Lift subforms out of a place form.  Return a series of gensym bindings
  ;; and a new place form which uses them instead of the original
  ;; expressions.  This can be used to prevent multiple evaluation when
  ;; expanding incf, decf, and similar macros.  For example:
  ;;   '(foo x y z) =>
  ;;       (tup '((g1 x) (g2 y) (g3 z)) '(foo g1 g2 g3))
  ;;   'bar => (tup '() 'bar)
  (df lift-place-subforms (place => (tup g-decls|<lst> g-place|<any>))
    (loc ((munch ((subforms <lst>) => (tup g-decls|<lst> g-args|<lst>))
            (if (nul? subforms)
                (tup '() '())
                (let (((tup g-decls g-args) (munch (tail subforms)))
                      (subform (head subforms)))
                  (if (isa? subform <lst>)
                      (let ((g (gensym)))
                        (tup (pair `(,g ,subform) g-decls)
                             (pair g g-args)))
                      (tup g-decls (pair subform g-args)))))))
      (if (isa? place <sym>)
          (tup '() place)
          (let (((tup g-decls g-args) (munch (tail place))))
            (tup g-decls `(,(head place) ,@g-args))))))

  )
           
(ds incf (,place ,@amount)
  (let (((tup g-decls g-place) (lift-place-subforms place))
        (amount (mif ((,amount) amount) amount 1)))
    `(let (,@g-decls)
       (set ,g-place (+ ,g-place ,amount)))))

(ds decf (,place ,@amount)
  (let (((tup g-decls g-place) (lift-place-subforms place))
        (amount (mif ((,amount) amount) amount 1)))
    `(let (,@g-decls)
       (set ,g-place (- ,g-place ,amount)))))

(ds pushf (,place ,value)
  (let (((tup g-decls g-place) (lift-place-subforms place)))
    `(let (,@g-decls)
       (set ,g-place (push! ,g-place ,value)))))

(ds swapf (,x ,y)
  (let (((tup xg-decls xg-place) (lift-place-subforms x))
        ((tup yg-decls yg-place) (lift-place-subforms y))
        (tmp (gensym)))
    `(let (,@xg-decls ,@yg-decls (,tmp ,xg-place))
       (set ,xg-place ,yg-place)
       (set ,yg-place ,tmp))))

(ds rotf (,x ,y ,@zs)
  (let ((places `(,x ,y ,@zs))
        (tmps   (map (fun (x) (gensym)) places))
        (ps     (map lift-place-subforms places))
        (decls  (map 1st ps))
        (places (map 2nd ps)))
    `(let (,@(app cat decls) ,@(map2 (fun (t p) `(,t ,p)) tmps places))
       ,@(map2 (fun (p t) `(set ,p ,t)) places (tail tmps))
       (set ,(last places) ,(1st tmps)))))

(ds popf (,place)
  (let (((tup g-decls g-place) (lift-place-subforms place))
        (new-col (gensym))
        (val (gensym)))
    `(let (,@g-decls
           ((tup ,new-col ,val) (pop! ,g-place)))
       (set ,g-place ,new-col)
       ,val)))

(ds opf (,place ,call)
  (let (((tup g-decls g-place) (lift-place-subforms place)))
    `(let (,@g-decls (_ ,g-place))
       (set ,g-place ,call))))

(ds or/set (,place ,value)
  (let (((tup g-decls g-place) (lift-place-subforms place)))
    `(let (,@g-decls (_ ,g-place))
       (or ,g-place (set ,g-place ,value)))))

(ds unless (,test ,@body)
  `(if (not ,test) (seq ,@body)))

(ds when (,test ,@body)
  `(if ,test (seq ,@body)))

(ds or (,@rest)
  (mif ((,x ,@rest) rest)
       (mif (() rest)
            x
            `(let ((tmp ,x))
               (if tmp tmp (or ,@rest))))
       #f))

(ds and (,@rest)
  (mif ((,x ,@rest) rest)
       (mif (() rest)
            x
            `(if ,x (and ,@rest) #f))
       #t))

(ds cond (,@cases)
  (if (nul? cases)
      #f
      (mif ((,cond ,@body) (head cases))
           `(if ,cond
                (seq ,@body)
                (cond ,@(tail cases)))
           (syntax-error "bad case %=" (head cases)))))

(ct-also
  (df do-case-by (val tst cases)
    (if (nul? cases)
        #f
        (mif ((,cond ,@body) (head cases))
             (if (== cond #t)
                 `(seq ,@body)
                 (mif ((,@values) cond)
                      `(if (or ,@(map (fun (x) `(,tst ,val ,x)) values))
                           (seq ,@body)
                           ,(do-case-by val tst (tail cases)))
                      (syntax-error "bad case %=" (head cases))))
             (syntax-error "bad case %=" (head cases))))))

(ds case-by (,val ,tst ,@cases)
  (let ((val-var (gensym)) (tst-var (gensym)))
    `(let ((,val-var ,val) (,tst-var ,tst))
       ,(do-case-by val-var tst-var cases))))

(ds case (,val ,@cases)
  `(case-by ,val == ,@cases))

(ds match (,exp ,@cases)
  (mif (() cases)
       `(syntax-error "failed to match.")
       (mif (((,pat ,@then) ,@rest) cases)
            (if (== pat #t)
                `(seq ,@then)
                (let ((var (gensym)))
                  `(let ((,var ,exp))
                     (mif (,pat ,var) 
                          (seq ,@then)
                          (match ,var ,@rest)))))
            (syntax-error "invalid match syntax."))))

(ds assert (,cond ,message ,@args)
  `(if (not ,cond) (assert-error ,message ,@args)))

(ds for ((,@clauses) ,@body)
  (rep grok ((clauses clauses) (inits '()) (preds '()) (nows '()) (nexts '()))
    (if (nul? clauses)
        (let ((loop (gensym)))
          `(rep ,loop ,inits
             (unless (or ,@preds)
               (let ,nows ,@body (,loop ,@nexts)))))
        (let ((clause (head clauses)))
          (mif ((,var ,exp) clause)
            (let ((state (gensym)))
              (grok (tail clauses)
                    (pair `(,state (enum ,exp)) inits)
                    (pair `(fin? ,state) preds)
                    (pair (mif ((tup ,key ,val) var)
                               `((tup ,key ,val) 
                                 (tup (now-key ,state) (now ,state))) 
                               `(,var (now ,state)))
                          nows)
                    (pair `(nxt ,state) nexts))))))))

(ds while (,test ,@body)
  `(rep _loop ()
     (when ,test ,@body (_loop))))

(ds until (,test ,@body)
  `(rep _loop ()
     (unless ,test ,@body (_loop))))

(ds dlet (,places ,@body)
  (match places
    (() 
     `(seq ,@body))
    (((,place ,value) ,@rest)
     (let (((tup g-decls g-place) (lift-place-subforms place))
           (old-value (gensym)))
       `(let (,@g-decls (,old-value ,g-place))
          (fin (seq (set ,g-place ,value)
                    (dlet (,@rest) ,@body))
               (set ,g-place ,old-value)))))
    (#t (syntax-error "Bad dlet places %=" places))))

(ds def-fun-var (,var ,value)
  (let ((nam (var-name var))
        (typ (var-type var))
        (vnam (cat-sym "*" nam "*")))
    `(seq (dv ,vnam ,value)
          (dm ,nam (=> ,typ) ,vnam)
          (dm ,(fab-setter-name nam) ((z ,typ)) (set ,vnam z)))))

(ds without-prop-unbound-errors (,@body)
  `(dlet ((*report-prop-unbound-errors?* #f))
     ,@body))

;; This macro allows you to declare "forward" references between modules.
;; It may or may not remain part of the language in the long run, but we
;; need it to modularize the existing code base.
;; TODO - Move this macro into boot.goo along with AND, OR, WHEN, UNLESS.
(ds need-implementation (,@names)
  (if (nul? names)
      #f
      `(seq (and #f ,(head names))
            (export ,(head names))
            (need-implementation ,@(tail names)))))

(ds pub (,@def)
  (let ((defs (match def
                ;; ((dp ,name ,@rest)
                ;;  `(,def (export ,name) (export ,(fab-setter-name name))))
                ((dp ,name ,@rest)
                  `(,def (export ,name)))
                ((dp! ,name ,@rest)
                  `(,def (export ,name) (export ,(fab-setter-name name))))
                ((df ,name ,@rest)
                 `(,name (export ,name)))
                ((dv ,name ,@rest)
                 `(,def (export ,name)))
                ((d. ,name ,@rest)
                 `(,def (export ,name)))
                ((dg ,name ,@rest)
                 `(,def (export ,name)))
                ((dc ,name ,@rest)
                 `(,def (export ,name)))
                ((,name)
                 (if (isa? name <sym>)
                     `(,name (export ,name))
                     '())))))
    `(seq ,@defs)))

(ds exported (,@defs)
  `(seq ,@(map (fun (x) (def x (if (isa? x <lst>) x (lst x))) `(pub ,@x)) defs)))


;;;;=======================================================================
;;;;  Public API
;;;;=======================================================================

;;; These bindings are defined in the runtime module.
(need-implementation
  ==
  do
  rev!
  cat
  elt 1st 2nd last
  nul?
  error
  gensym
  fab-setter-name
  cat-sym
  map map2
  match-atom
  match-nul-list
  match-sublist
  match-unquote
  pair
  tup
  var-name
  var-type
  napp
  macro-error)

(export
  app
  sup 
  app-sup
  renew
  incf
  decf
  pushf
  popf
  opf
  swapf
  rotf
  or/set
  unless
  when
  or
  and
  cond
  case case-by
  match
  assert
  for
  while until
  dlet
  def-fun-var
  need-implementation
  pub exported
  lift-place-subforms
  without-prop-unbound-errors
)

(export ;; hygiene
  @checked-next-methods
  )
