goo 0.155-13 / usr / lib / goo / mods / eval / syntax.goo

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

(use goo)
(use goo/boot)
(use goo/cols/lst)

;;  Self-evaluating entities
(dm sexpr-self-evaluating? (exp => <log>)
  (or (isa? exp <num>)
      (isa? exp <chr>)
      (== exp #t)
      (== exp #f)
      (isa? exp <str>)
      (isa? exp <vec>)
      (isa? exp <tup>)))

;;  Our prompt (viz., "EVAL==> ") is a string.
;;  Variables
(dm sexpr-variable? (exp => <log>)
  (isa? exp <sym>))

;;  SPECIAL FORMS (IN GENERAL)

(dm sexpr-tagged-list? (exp tag => <log>)
  (and (isa? exp <lst>) (== (head exp) tag)))

;;  QUOTATIONS

(dv $sexpr-quote-tag 'quote)

(dm sexpr-quoted? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-quote-tag))

(dm sexpr-make-quote (exp => <lst>)
  (lst $sexpr-quote-tag exp))

(dm sexpr-text-of-quotation (quot => <any>)
  (2nd quot))

;;  ASSIGNMENT--- SET!

(dv $sexpr-set-tag 'set)

(dm sexpr-assignment? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-set-tag))

(dm sexpr-assignment-variable (assn|<lst> => <any>)
  (2nd assn))

(dm sexpr-assignment-value (assn|<lst> => <any>)
  (3rd assn))

;; VARIABLE

(dm sexpr-variable-name (exp|<lst> => <any>)
  (1st exp))

(dm sexpr-variable-name (exp => <any>)
  exp)

(dm sexpr-variable-type (exp|<lst> => <any>)
  (2nd exp))

(dm sexpr-variable-type (exp => <any>)
  '<Any>)

;; DEFINITIONS -- (DEFINE foo ...)

(dv $sexpr-define-constant-tag 'd.)

(dm sexpr-define-constant? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-define-constant-tag))

(dv $sexpr-define-tag 'dv)

(dm sexpr-definition? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-define-tag))

(dv $sexpr-quasiquote-tag 'quasiquote)

(dm sexpr-definition-variable (defn|<lst> => <any>)
  (2nd defn))

(dm sexpr-definition-value (defn => <any>)
  (3rd defn))

(dv $sexpr-define-syntax-tag 'ds)

(dm sexpr-syntax-definition? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-define-syntax-tag))

(dv $sexpr-macro-tag 'mac)

(dm sexpr-syntax-definition-variable (defn|<lst> => <sym>)
  (2nd defn))

(dm sexpr-syntax-definition-value (defn => <any>)
  (def var (2nd defn))
  ;; (ds foo (p ...) b...)
  `(,$sexpr-macro-tag (,var ,@(3rd defn)) ,@(tail (tail (tail defn)))))

(dv $sexpr-define-function-tag 'df)

(dm sexpr-function-definition? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-define-function-tag))

(dv $sexpr-define-method-tag 'dm)

(dm sexpr-method-definition? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-define-method-tag))

(dv $sexpr-define-generic-tag 'dg)

(dm sexpr-generic-definition? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-define-generic-tag))

;; (df foo (x ...) form ...)
;; (df (foo adjectives ...) (x ...) form ...)
(dm sexpr-function-definition-variable (defn|<lst> => <any>)
  (def var (2nd defn))
  (if (isa? var <lst>)
      (head var)
      var))

(dm sexpr-function-definition-adjectives (defn|<lst> => <any>)
  (def var (2nd defn))
  (if (isa? var <lst>)
      (tail var)
      '()))

(dm sexpr-forward-primitive? (defn|<lst> => <log>)
  (= (len defn) 2))

(dm sexpr-signature-parameters (signature|<lst> => <lst>)
  (def values-spec-index (pos signature '=>))
  (if values-spec-index
      (sub signature 0 values-spec-index)
      signature))

(dm sexpr-value-type (x|<lst> => <any>) (2nd x))

(dm sexpr-value-type (x|<any> => <any>) x)

(dm sexpr-signature-value (signature|<lst> => <any>)
  (def values-spec-index (pos signature '=>))
  (and values-spec-index
       (let ((value (elt signature (+ values-spec-index 1))))
         (if (sexpr-tagged-list? value 'tup)
             `(t* ,@(map sexpr-value-type (tail value)))
             value))))
              
(df as-signature (sig|<lst> => <lst>)
  sig)
              
(dm sexpr-function-signature (defn => <lst>)
  (as-signature (3rd defn)))

(dm sexpr-function-parameters (defn => <lst>)
  (sexpr-signature-parameters (sexpr-function-signature defn)))

(dm sexpr-function-value (defn => <any>)
  (sexpr-signature-value (sexpr-function-signature defn)))

(dm sexpr-function-body (defn => <any>)
  (tail (tail (tail defn))))

(dv $sexpr-method-tag 'fun)

;; (df foo (x ...) form ...)
(dm sexpr-function-definition-value (defn => <any>)
  (line-pair $sexpr-method-tag 
             (pair (3rd defn) (tail (tail (tail defn))))
             (line-of defn)))

;;  METHOD -- (METHOD (p...) b...)

(dm sexpr-method? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-method-tag))

(dm sexpr-method-signature (method-exp|<lst> => <lst>)
  (as-signature (2nd method-exp)))

(dm sexpr-method-parameters (method-exp|<lst> => <lst>)
  (sexpr-signature-parameters (sexpr-method-signature method-exp)))

(dm sexpr-method-value (method-exp|<lst> => <any>)
  (sexpr-signature-value (sexpr-method-signature method-exp)))

(dm sexpr-method-body (method-exp|<lst> => <lst>)
  (tail (tail method-exp)))

;; TODO: RENAME LIST TO LST

(dm sexpr-make-anonymous-method 
    (parameters|<lst> body|<lst> => <lst>)
  (line-list-of (if (isa? parameters <line-list>) parameters body)
    (cat (lst $sexpr-method-tag) (lst parameters) body)))

(dm sexpr-make-method (name parameters|<lst> body|<lst> => <lst>)
  (line-list-of (if (isa? parameters <line-list>) parameters body)
    (cat (lst $sexpr-define-method-tag name parameters) body)))

;;  IF CONDITIONALS

(dv $sexpr-if-tag 'if)

(dm sexpr-if? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-if-tag))

(dm sexpr-if-test (exp|<lst> => <any>)
  (2nd exp))

(dm sexpr-if-then (exp|<lst> => <any>)
  (3rd exp))

(dm sexpr-if-else (exp|<lst> => <any>)
  (if (nul? (tail (tail (tail exp)))) ;;cdddr
      #f
      (head (tail (tail (tail exp)))))) ;;cadddr

(dm sexpr-make-if (test then else => <lst>)
  (lst $sexpr-if-tag test then else))

;;  BLOCK

(dv $sexpr-bind-exit-tag 'esc)

(dm sexpr-block? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-bind-exit-tag))

;; TODO: perhaps second should be 2nd

(dm sexpr-block-name (exp|<lst> => <any>)
  (2nd exp))

(dm sexpr-block-body (exp|<lst> => <lst>)
  (tail (tail exp)))

;;  UNWIND-PROTECT

(dv $sexpr-unwind-protect-tag 'fin)

(dm sexpr-unwind-protect? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-unwind-protect-tag))

(dm sexpr-unwind-protect-protected-form (exp|<lst> => <any>)
  (2nd exp))

(dm sexpr-unwind-protect-cleanup-forms (exp|<lst> => <any>)
  (tail (tail exp)))

;;  MONITOR

(dv $sexpr-monitor-tag 'try)

(dm sexpr-monitor? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-monitor-tag))

(dm sexpr-monitor-expand (exp|<lst>)
  (mif ((TRY ,options ,handler ,@body) exp)
       (let ((options (if (isa? options <sym>) `((type ,options)) options)))
         (tup (sexpr-monitor-type options)
              (sexpr-monitor-info options)
              (sexpr-monitor-test options)
              handler
              (sexpr-monitor-body body)))
       (syntax-error "Malformed TRY expression: ~=" exp)))

;;; Find an option.  Given '((foo 1) (bar 2)) and 'foo, return '(1).
(df find-option (options|<lst> option|<sym> default => <any>)
  (cond
    ((nul? options) default)
    ((== option (head (1st options))) (tail (1st options)))
    (#t (find-option (tail options) option default))))

(dm sexpr-monitor-type (options|<lst> => <any>)
  (def type-list (find-option options 'type '(<condition>)))
  (mif ((,type) type-list)
       type
       (syntax-error "Malformed TRY condition type: %=" type-list)))

;; Build an expression which returns an appropriate <handler-info>.
(dm sexpr-monitor-info (options|<lst> => <any>)
  (def info        (find-option options 'info #f))
  (def description (find-option options 'description #f))
  (cond
    ((and info description)
     (syntax-error "TRY may only have one of INFO or DESCRIPTION: %=" options))
    ;; TODO - Do we want to keep the 'info' option?
    (info
     (mif ((,info-expr) info)
          info-expr
          (syntax-error "Malformed TRY info expression: %=" info)))
    (description
     (mif ((,message ,@arguments) description)
          `(new <simple-handler-info>
             handler-info-message ,message
             handler-info-arguments (lst ,@arguments))
          (syntax-error "Malformed TRY description: %=" description)))
    (#t '$default-handler-info)))

(dm sexpr-monitor-test (options|<lst> => <lst>)
  (def test-body (find-option options 'test '(#t)))
  (sexpr-make-anonymous-method '() test-body))

(dm sexpr-monitor-body (body|<lst> => <lst>)
  (sexpr-make-anonymous-method '() body))

;;  BEGIN expressions (a.k.a. sequences)

(dv $sexpr-begin-tag 'seq)

(dm sexpr-begin? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-begin-tag))

(dm sexpr-begin-actions (begin-exp => <lst>)
  (tail begin-exp))

(dm sexpr-last-exp? (seq|<lst> => <log>)
  (nul? (tail seq)))

(dm sexpr-first-exp (seq|<lst> => <any>)
  (head seq))

(dm sexpr-rest-exps (seq|<lst> => <lst>)
  (tail seq))

(dm sexpr-sequence->begin (seq|<lst> => <any>)
  (if (nul? seq)
      seq
      (if (sexpr-last-exp? seq)
          (sexpr-first-exp seq)
          (sexpr-make-begin seq))))

(dm sexpr-make-begin (exp|<lst> => <lst>)
  (pair $sexpr-begin-tag exp))

;;  Procedure applications -- NO-ARGS? and LAST-OPERAND? added
(dm sexpr-application? (exp => <log>)
  (and (isa? exp <lst>) (not (nul? exp))))

(dm sexpr-operator (app|<lst> => <any>)
  (head app))

(dm sexpr-operands (app|<lst> => <lst>)
  (tail app))

(dm sexpr-no-operands? (args|<lst> => <log>)
  (nul? args))

(dm sexpr-first-operand (args|<lst> => <any>)
  (head args))

(dm sexpr-rest-operands (args|<lst> => <lst>)
  (tail args))

(dm sexpr-make-application (f operands|<lst> => <lst>)
  (cat (lst f) operands))

(dv *unique-name-counter* 0)

(dm sexpr-new-unique-name-counter! (=> <int>)
  ;; without-interrupts
  (set *unique-name-counter* (+ *unique-name-counter* 1))
  *unique-name-counter*)

(dv <name> <any>) ;; TODO: (union <str> <sym>)

(dm sexpr-unique-name (prefix|<name> => <sym>)
  (as <sym> (cat (as <str> prefix)
                 (num-to-str (sexpr-new-unique-name-counter!)))))

;;  LET -- (let ((var value) ...) form ...)
;;         var:        simple-var | (tup tup-var ...)
;;         tup-var:    simple-var | (name "...")
;;         simple-var: name | (name type)

(dv $sexpr-def-tag 'def)

(dm sexpr-def? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-def-tag))

(dm sexpr-def-variable (exp|<lst>) (2nd exp))

(dm sexpr-def-value (exp|<lst>) (3rd exp))

(dv $sexpr-let-tag 'let)

(dm sexpr-let? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-let-tag))

(dm sexpr-let-bound-variables (let-exp|<lst> => <lst>)
  (map (fun (x) (1st (as-signature x))) (2nd let-exp))))

(dm sexpr-let-values (let-exp|<lst> => <lst>)
  (map (fun (x) (2nd (as-signature x))) (2nd let-exp)))

(dm sexpr-let-body (let-exp|<lst> => <any>)
  (sexpr-sequence->begin (tail (tail let-exp))))

(dm sexpr-let-names+values
    (names|<lst> vals|<lst> => (tup names|<lst> values|<lst>))
  (rep loop ((rnames '()) (rvalues '()) (names names) (vals vals))
    (if (nul? names)
        (tup (rev! rnames) (rev! rvalues))
        (let ((name  (head names))
              (value (head vals)))
          (if (and (isa? name <lst>) (== (head name) 'tup))
              (let ((tupname
                     (sexpr-unique-name "tup"))
                    ((tup rtnames rtvalues)
                     (rep inner
                         ((rtnames (lst tupname)) (rtvalues (lst value))
                          (index 0) (tnames (tail name)))
                       (if (nul? tnames)
                           (tup rtnames rtvalues)
                           (let ((name (head tnames)))
                             (if (and (isa? name <lst>) 
                                      (== (head (tail name)) '...))
                                 (inner (pair (lst (head name) '<lst>)
                                              rtnames)
                                        (pair (lst 'sub tupname index 
                                                   (lst 'len tupname)) 
                                              rtvalues)
                                        (+ index 1) (tail tnames))
                                 (inner (pair name rtnames)
                                        (pair (lst 'elt tupname index)
                                              rtvalues)
                                        (+ index 1) (tail tnames))))))))
                (loop (cat rtnames rnames) (cat rtvalues rvalues)
                      (tail names) (tail vals)))
              (loop (pair name rnames) (pair value rvalues)
                    (tail names) (tail vals)))))))

(dm sexpr-let->combination (let-exp|<lst> => <any>)
  (def onames             (sexpr-let-bound-variables let-exp))
  (def ovalues            (sexpr-let-values let-exp))
  (def body               (sexpr-let-body let-exp))
  (def (tup names values) (sexpr-let-names+values onames ovalues))
  (rep col ((names names) (values values))
    (if (nul? names)
        body
        (pair (lst $sexpr-method-tag (lst (head names))
                   (col (tail names) (tail values)))
              (lst (head values))))))

;;  LOC -- (loc ((?var (?param ...) ?body) ...) ?body)

(dv $sexpr-locals-tag 'loc)

(dm sexpr-loc? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-locals-tag))

(dm sexpr-loc-bound-names (loc-exp|<lst> => <lst>)
  (map 1st (2nd loc-exp)))

(dm sexpr-loc-bound-signatures (loc-exp|<lst> => <lst>)
  (map (fun (x) (as-signature (2nd x))) (2nd loc-exp)))

;; COMPOSE DEFINED

(dm sexpr-loc-bound-bodies (loc-exp|<lst> => <lst>)
  (map (compose tail tail) (2nd loc-exp)))

(dm sexpr-loc-raw-body (loc-exp|<lst> => <lst>)
  (tail (tail loc-exp)))

(dm sexpr-loc-body (loc-exp|<lst> => <any>)
  (sexpr-sequence->begin (sexpr-loc-raw-body loc-exp)))

(dv $sexpr-iterate-tag 'rep)

;; ITERATE expressions (REP ?name ((?var ?init) ...) ?body)
(dm sexpr-iterate? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-iterate-tag))

(dm sexpr-iterate-name (rep-exp|<lst> => <sym>)
  (2nd rep-exp))

(dv $sexpr-values-tag '=>)

(dm sexpr-iterate-signature (rep-exp|<lst> => <lst>)
  (def sig (3rd rep-exp))
  (cat (map (fun (x) (1st (as-signature x)))
            (sexpr-signature-parameters sig))
       (if (sexpr-signature-value sig)
           '()
           (lst $sexpr-values-tag))
       (lst (sexpr-signature-value sig))))

(dm sexpr-iterate-inits (rep-exp|<lst> => <lst>)
  (map (fun (x) (2nd (as-signature x))) (3rd rep-exp)))

(dm sexpr-iterate-body (rep-exp|<lst> => <lst>)
  (tail (tail (tail rep-exp))))

(dm sexpr-iterate->loc (rep-exp|<lst> => <lst>)
  (def name  (sexpr-iterate-name rep-exp))
  (def sig   (sexpr-iterate-signature rep-exp))
  (def body  (sexpr-iterate-body rep-exp))
  (def inits (sexpr-iterate-inits rep-exp))
  (line-list-of rep-exp
    (lst $sexpr-locals-tag
         (lst (cat (lst name sig) body))
         (cat (lst name) inits))))

;;  ISA

(dv $sexpr-isa-tag 'isa)

(dm sexpr-isa? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-isa-tag))

(dm sexpr-isa-parent (exp|<lst> => <any>)
  (2nd exp))

(dm sexpr-isa-prop-inits (exp|<lst> => <lst>)
  (tail (tail exp)))

(dm sexpr-isa-init-props (exp|<lst> => <lst>)
  (map 2nd exp))

(dm sexpr-isa-init-values (exp|<lst> => <lst>)
  (map 3rd exp))

;;  DC

(dv $sexpr-define-class-tag 'dc)

(dm sexpr-define-class? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-define-class-tag))

(dm sexpr-define-class-parents (exp|<lst> => <lst>)
  (3rd exp))

;;  PROP

;; (dp point-x (<point> => <int>) 0)

(dv $sexpr-prop-tag 'dp)

(dv $sexpr-prop!-tag 'dp!)

(dm sexpr-prop!? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-prop!-tag))

(dm sexpr-prop? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-prop-tag))

(dm sexpr-prop-name (exp|<lst> => <sym>)
  (2nd exp))

(dm sexpr-prop-owner (exp|<lst> => <any>)
  (def param (1st (sexpr-function-parameters exp)))
  (if (isa? param <lst>)
      (2nd param)
      param))

(dm sexpr-prop-init-var (exp|<lst> => <any>)
  (def param (1st (sexpr-function-parameters exp)))
  (if (isa? param <lst>)
      (1st param)
      '_x))

(dm sexpr-prop-type (exp|<lst> => <any>)
  (sexpr-function-value exp))

(dm sexpr-prop-init? (exp|<lst> => <log>)
  (= (len exp) 4))

(dm sexpr-prop-init (exp|<lst> => <any>)
  (elt exp 3))

(dm sexpr-fab-getter (name type line => <lst>)
  (sexpr-make-method 
   name (line-list line (lst '_x type)) 
   (lst (lst 'prop-value '_x name))))

(dm sexpr-fab-setter (name type prop-type line => <lst>)
  (sexpr-make-method
    (sexpr-fab-setter-name name)
    (line-list line (lst '_z prop-type) (lst '_x type))
    (lst (lst 'prop-value-setter '_z '_x name))))

(dm sexpr-fab-setter-name (name => <sym>)
  (cat-sym name "-setter"))

;; BACKQUOTE

(dm sexpr-macro? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-macro-tag))

(dv $sexpr-macro-expand-tag 'macro-expand)

(dm sexpr-macro-expand? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-macro-expand-tag))

(dv $sexpr-syntax-if-tag 'mif)

(dm sexpr-make-syntax-if 
    (pat exp then else => <lst>)
  (lst $sexpr-syntax-if-tag (lst pat exp) then else))

;; (dv *comma*          'unquote)
(dv *comma-atsign*   'comma-atsign)
(dv *bq-list*        'bq-list)
(dv *bq-list**       'bq-list*)
(dv *bq-append*      'bq-append)
(dv *bq-nconc*       'bq-nconc)
(dv *bq-clobberable* 'bq-clobberable)
(dv *bq-quote*       'bq-quote)

(df sexpr-expand-backquote (x|<lst> => <lst>)
  (eval (sexpr-build-backquote-expander x) 'goo))

(dm sexpr-build-backquote-expander (x|<lst> => <lst>)
  (def raw-result (bq-process x))
  (def res        (bq-remove-tokens raw-result))
  ;; (msg-out "RES = %=\n" res)
  res)

(dm sexpr-unquote? (x => <log>)
  (sexpr-tagged-list? x 'unquote))

(dm sexpr-unquote-splicing? (x => <log>)
  (sexpr-tagged-list? x 'unquote-splicing))

(dm sexpr-backquote? (x => <log>)
  (sexpr-tagged-list? x $sexpr-quasiquote-tag))

(dm sexpr-atom? (x => <log>)
  (or (not (isa? x <lst>)) (nul? x)))

(dm nreconc (x|<lst> y|<lst> => <lst>)
  (cat! (rev! x) y))

(dm bq-process (x => <any>)
  (cond ((sexpr-atom? x)
         (lst *bq-quote* x))
        ((sexpr-backquote? x)
         (bq-process (sexpr-build-backquote-expander (head (tail x)))))
        ((sexpr-unquote? x)
         (head (tail x)))
        ((sexpr-unquote-splicing? x)
         (syntax-error "UNQUOTE-SPLICING %= AFTER BQ" (head (tail (x)))))
        (#t
         (esc return
           (rep loop ((p x) (q '()))
             (if (sexpr-atom? p)
                 (return (pair *bq-append*
                               (nreconc q (lst (lst *bq-quote* p)))))
                 (seq (when (sexpr-unquote? p)
                        (unless (nul? (tail (tail p)))
                          (syntax-error "Malformed ,%=" p))
                        (return 
                         (pair *bq-append* 
                               (nreconc q (lst (head (tail p)))))))
                      (when (== (tail p) *comma-atsign*)
                        (syntax-error "Dotted ,@%=" p))
                      (loop (tail p) (pair (bracket (head p)) q)))))))))

(dm bracket (x => <any>)
  (cond ((sexpr-atom? x)
         (lst *bq-list* (bq-process x)))
        ((sexpr-unquote? x)
         (lst *bq-list* (head (tail x))))
        ((sexpr-unquote-splicing? x)
         (lst *bq-clobberable* (head (tail x))))
        (#t
         (lst *bq-list* (bq-process x)))))

(dm map-tree (fn|<fun> x => <any>)
  (if (sexpr-atom? x)
      (fn x)
      (let ((a (fn (head x)))
            (d (map-tree fn (tail x))))
        (if (and (= a (head x)) (= d (tail x)))
            x
            (pair a d)))))

(dm bq-remove-tokens (x)
  (cond ((== x *bq-list*)   'lst)
        ((== x *bq-append*) 'cat)
        ((== x *bq-nconc*)  'cat!)
        ((== x *bq-list**)  'list*)
        ((== x *bq-quote*)  'quote)
        ((sexpr-atom? x)    x)
        ((== (head x) *bq-clobberable*)
         (bq-remove-tokens (head (tail x))))
        ((and (== (head x) *bq-list**)
              (not (nul? (tail (tail x))))
              (nul? (tail (tail (tail x)))))
         (pair 'pair (map-tree bq-remove-tokens (tail x))))
        (#t
         (map-tree bq-remove-tokens x))))

;;/ SEXPR-IF -- (sexpr-if (pattern expression) then [ else ])

(dm sexpr-syntax-if? (exp => <log>)
  (sexpr-tagged-list? exp $sexpr-syntax-if-tag))

(dm sexpr-syntax-if-value (exp|<lst> => <any>)
  (2nd (2nd exp)))

(dm sexpr-syntax-if-pattern (exp|<lst> => <any>)
  (1st (2nd exp)))

(dm sexpr-syntax-if-then (exp|<lst> => <any>)
  (3rd exp))

;; TODO: DEFAULT ON ELT

(dm sexpr-syntax-if-else (exp|<lst> => <any>)
  (elt-or exp 3 #f))

(dm sexpr-pattern-variable? (pat => <log>)
  (or (sexpr-unquote? pat) (sexpr-unquote-splicing? pat)))

(dm sexpr-pattern-variable-name (pat|<lst> => <any>)
  (2nd pat))

(dm sexpr-bind-pattern-variables (pat|<lst> => <lst>)
  (del-dups
    (rep col ((pat pat))
      (if (or (not (isa? pat <lst>)) (nul? pat))
          '()
          (let ((x (head pat)))
            (if (sexpr-pattern-variable? x)
                (pair (sexpr-pattern-variable-name x) (col (tail pat)))
                (cat (col (head pat)) (col (tail pat)))))))))

;; MACROS

;;; TODO: GENSYM 'EXP
(dm sexpr-make-macro-function (name exp|<lst> => <any>)
  (def mif  (sexpr-make-syntax-if
             (sexpr-method-parameters exp) 'exp
             (sexpr-sequence->begin (sexpr-method-body exp)) 
             `(macro-error ',name exp)))
  (def func (sexpr-make-anonymous-method (lst 'exp) (lst mif)))
  func)

(need-implementation
  eval)

(export
  sexpr-assignment-value
  sexpr-assignment-variable
  $sexpr-begin-tag
  $sexpr-bind-exit-tag
  sexpr-bind-pattern-variables
  sexpr-block-body
  sexpr-block-name
  $sexpr-define-function-tag
  $sexpr-define-generic-tag
  $sexpr-define-method-tag
  $sexpr-define-syntax-tag
  $sexpr-define-class-tag
  sexpr-define-class?
  sexpr-define-class-parents
  $sexpr-define-tag
  $sexpr-define-constant-tag
  sexpr-definition-value
  sexpr-definition-variable
  sexpr-expand-backquote
  sexpr-forward-primitive?
  sexpr-function-body
  sexpr-function-definition-value
  sexpr-function-definition-variable
  sexpr-function-definition-adjectives
  sexpr-function-signature
  sexpr-if-else
  $sexpr-if-tag
  sexpr-if-test
  sexpr-if-then
  sexpr-isa-init-props
  sexpr-isa-init-values
  sexpr-isa-parent
  sexpr-isa-prop-inits
  $sexpr-isa-tag
  sexpr-iterate->loc
  $sexpr-iterate-tag
  $sexpr-def-tag
  sexpr-def?
  sexpr-def-variable
  sexpr-def-value
  $sexpr-let-tag
  sexpr-let->combination
  sexpr-loc-bound-bodies
  sexpr-loc-bound-names
  sexpr-loc-bound-signatures
  sexpr-loc-raw-body
  $sexpr-locals-tag
  $sexpr-macro-expand-tag
  sexpr-make-anonymous-method
  sexpr-make-application
  sexpr-make-begin
  sexpr-fab-getter
  sexpr-make-macro-function
  sexpr-make-method
  sexpr-fab-setter
  sexpr-fab-setter-name
  sexpr-method-body
  sexpr-method-signature
  $sexpr-method-tag
  sexpr-monitor-expand
  $sexpr-monitor-tag
  sexpr-operands
  sexpr-operator
  $sexpr-quasiquote-tag
  $sexpr-quote-tag
  sexpr-sequence->begin
  $sexpr-set-tag
  sexpr-signature-parameters
  sexpr-signature-value
  sexpr-prop-init-var
  sexpr-prop-init?
  sexpr-prop-init
  sexpr-prop-name
  sexpr-prop-owner
  sexpr-prop-type
  $sexpr-prop-tag
  $sexpr-prop!-tag
  sexpr-syntax-definition-value
  sexpr-syntax-definition-variable
  sexpr-syntax-if-else
  sexpr-syntax-if-pattern
  $sexpr-syntax-if-tag
  sexpr-syntax-if-then
  sexpr-syntax-if-value
  sexpr-text-of-quotation
  sexpr-unquote?
  sexpr-unquote-splicing?
  sexpr-unwind-protect-cleanup-forms
  sexpr-unwind-protect-protected-form
  $sexpr-unwind-protect-tag
  sexpr-variable?
  sexpr-variable-name
  sexpr-variable-type)