;;******************* Copyright © 2004-2005 MathSoft, Inc. All rights reserved
;;*
;;*
;;*  Version : $Header: /MathcadClient/Trunk/eng/mctranslator/prolog/main.txt   216   2005-08-31 15:42:34-04:00   jlawrence $
;;*
;;*
;;*  Purpose : Implements much of the translation from ARL to MPL.
;;*
;;*
;;*  Comments: This file uses a tab size of 3 spaces.
;;*
;;*
;;****************************************************************************

(!include "plots-eng.txt")

;;****************************************************************************
;;* TRANS env request result
;;*
;;* Succeeds if 'result' is the translation of the request langauge form 'rl'.
;;* This is the main entry point into this ruleset.

( (trans $env (import $imports ($keyword | $form)) $res) (!)

   (tag $keyword $k $t)                               ; Split the keyword
   (trans-toplevel $env $k $t $form $tform) (!)       ; Translate the form
   (id $res (import $imports $tform))                 ; Restore the imports
   )

;;****************************************************************************
;;* TRANS-TOPLEVEL env keyword form result
;;*
;;* trans-toplevel
;;*   : define       $form
;;*   | define_tuple $form
;;*   | eval         $form
;;*   | LIT-FORM range compute or ordinary compute

( (trans-toplevel $env define: $tag $form $res) (!)

   (id $form ($lhs $rhs)) (!)
   (trans-define $env $tag $lhs $rhs $res) (!)
   )

( (trans-toplevel $env define_tuple: $tag $form $res) (!)

   (trans-tuple-define $env $tag $form $res) (!)
   )

( (trans-toplevel $env eval: $tag $form $res) (!)

   (trans-simplify $env $tag $form $res) (!)
   )

;;****************************************************************************
;;* TRANS-DEFINE env tag lhs rhs result
;;*
;;* Translate top level definitions.

( (trans-define $env $tag $lhs $rhs $res)

   (id $lhs (subscript $m $i)) (!)
   (range-matrix-def-1 $env $tag $lhs $rhs $res)
   )

( (trans-define $env $tag $lhs $rhs $res)

   (id $lhs (subscript $m $i $j))
   (range-matrix-def-2 $env $tag $lhs $rhs $res)
   )

( (trans-define $env $tag $lhs $rhs $res)

   (id $lhs (op_matcol $m $i))
   (range-matrix-def-col $env $tag $lhs $rhs $res)
   )

( (trans-define $env $tag $lhs $rhs $res)

   (id $lhs (op_matrix $rows $cols (list | $lhss)))
   (id $rhs (op_matrix $rows $cols (list | $rhss))) (!)
   (range-parallel-def $env $tag $lhs $rhs $res)
   )

( (trans-define $env $tag $lhs $rhs $res)

   (id $lhs (op_matrix $rows $cols (list | $lhss)))
   (range-destructuring-def $env $tag $lhs $rhs $res)
   )

( (trans-define $env $tag mc_ORIGIN:$t $rhs $res)(!)

   (texp $env $rhs $trhs)
   (id $res (define:$tag mc_ORIGIN:$t (iv' (as_i4:$tag $trhs))))
   )

( (trans-define $env $tag $lhs $rhs
         (define:$tag $lhs $trhs)) (!)

   (texp $env $rhs $trhs)
   )

;;****************************************************************************
;;* RANGE-MATRIX-DEF
;;*
;;* Input
;;*  $m    -- Variable being defined
;;*  $ei  -- Index expression i
;;*  $ej  -- Index expression j
;;*  $rhs -- Rhs expression
;;* Output
;;*  $res -- translatated definition

;;* Singly subscripted defintion
;;* m[ei] := e
;;* Note: this translation is appropriate for subscripted assignments
;;*       with no range variables, too.

;;*comma delimited array on RHS

( (range-matrix-def-1 $env $tag $lhs ((constant comma-array) $elem) $res)

   (!)
   (texp-each $env $elem $telem)
   (new-temp 0 $rhs-it)
   (new-temp 0 $rhs-item)

   (id $rhs (if:$tag (bv (null $rhs-it))
                     zero_
                     (let (($rhs-item (head $rhs-it)))
                           (progn (setf $rhs-it (tail $rhs-it))
                                    $rhs-item))))

   (range-matrix-def-1 $env $tag $lhs $rhs (define $mm $val))
   (id $res (define:$tag $mm (let:$tag (($rhs-it (list | $telem))) $val)))
   )

( (range-matrix-def-1 $env $tag $lhs $rhs
         $res)

   (id $lhs (subscript $m $ei))
   (tindex $env $ei _ORIGIN_i4 $ti $iv)                  ;;*translate index expression
   (texp $env $rhs $trhs)                                ;;*translate rhs expression

   (get-ranges $env $lhs $rs)                            ;;*identify range variables
   (nursery-matrix-1 $env $m $rs $ti $matexp)            ;;*construct updateable array
   (new-temp 0 $mat)                                     ;;*Give it a name
 ;;(update-1 $mat $ti $trhs $update)                     ;;*construct array update form
   (update-1 $mat $ti (bind_exit _return_ $trhs) $update);;*construct array update form

   (range-loops $tag $rs $iv $update $loop)              ;;*construct initialization loop
   (matrix-binding $env $m (as_matrix_value:$tag $mat) $matrix-bind)
   (id $res                                              ;;*embed loop in binding forms
      (define:$tag $m
            (let:$tag (($mat $matexp))                   ;;*construct MatVal
            (let:$tag ( $matrix-bind  )                  ;;*corresponding Matrix id
             (as_matrix_value (unify $mat (bind_exit _until_ $loop)))
             ))))

   )

;;* matrix-binding ENV $m $mat => BINDING-FORM
;;* Emit unrestricted binding when $m is of Matrix type
;;* Else emit subscript restricted binding.

( (matrix-binding $env $m $mat
         $res)
   (lookup-type $env $m $t)
   (strprefix $t "Matrix":)
   (id $res ($m $mat)) (!)
   )

( (matrix-binding $env $m $mat
         $res)
   (id $res (subscripted $m $mat)) (!)
   )

;;* Doubly subscripted defintion
;;* m[ei,ej] := e
;;* Note: this translation is appropriate for subscripted assignments
;;*       with no range variables, too.

;;* comma delimited array on RHS.

( (range-matrix-def-2 $env $tag $lhs ((constant comma-array) $elem) $res)

   (!)
   (texp-each $env $elem $telem)
   (new-temp 0 $rhs-it)
   (new-temp 0 $rhs-item)

   (id $rhs (if:$tag (bv (null $rhs-it))
                     zero_
                     (let (($rhs-item (head $rhs-it)))
                           (progn (setf $rhs-it (tail $rhs-it))
                                    $rhs-item))))

   (range-matrix-def-2 $env $tag $lhs $rhs (define $mm $val))
   (id $res (define:$tag $mm (let:$tag (($rhs-it (list | $telem))) $val)))
   )

( (range-matrix-def-2 $env $tag $lhs $rhs
         $res)

   (id $lhs (subscript $m $ei $ej))
   (tindex $env $ei _ORIGIN_i4 $ti $iv)                  ;;*translate index expression
   (tindex $env $ej _ORIGIN_i4 $tj $jv)                  ;;*translate index expression
   (texp $env $rhs $trhs)                                ;;*translate rhs expression

   (get-ranges $env $lhs $rs)                            ;;*identify range variables
   (nursery-matrix-2 $env $m $rs $ti $tj $matexp)        ;;*construct updateable array
   (new-temp 0 $mat)                                     ;;*Give it a name
   (update-2 $mat $ti $tj (bind_exit _return_ $trhs) 
            $update)                                     ;;*construct array update form

   (concat $iv $jv $ivars)                               ;;*integer vars
   (range-loops $tag $rs $ivars $update $loop)           ;;*construct initialization loop
   (matrix-binding $env $m (as_matrix_value:$tag $mat) $matrix-bind)
   (id $res                                              ;;*embed loop in binding forms
      (define:$tag $m
            (let:$tag (($mat $matexp))                   ;;*construct MatVal
            (let:$tag ( $matrix-bind )                   ;;*corresponding Matrix id

             (as_matrix_value (unify $mat (bind_exit _until_ $loop) ))))))

             )

;;* column subscripted definition
;;* m<ei> := e
;;* Note: this translation is appropriate for matcol assignments
;;*       with no range variables, too.

( (range-matrix-def-col $env $tag $lhs $rhs
         $res)

   (id $lhs (op_matcol $m $ei))
   (tindex $env $ei _ORIGIN_i4 $ti $iv)                     ;;*translate index expression
   (texp $env $rhs $trhs)                                   ;;*translate rhs expression

   (get-ranges $env $lhs $rs)                               ;;*identify range variables
   (nursery-matrix-2 $env $m $rs (unboxed 0) $ti $matexp)   ;;*construct updateable array
   (new-temp 0 $mat)                                        ;;*Give it a name
   (update-col $mat $ti (bind_exit _return_ $trhs) $update) ;;*construct array update form

   (range-loops $tag $rs $iv $update $loop)                 ;;*construct initialization loop
   (matrix-binding $env $m (as_matrix_value:$tag $mat) $matrix-bind)

   (id $res                                                 ;;*embed loop in binding forms
      (define:$tag $m
            (let:$tag ((_ORIGIN_i4 (as_i4 mc_ORIGIN)))
            (let:$tag (($mat $matexp))                      ;;*construct MatVal
            (let:$tag ( $matrix-bind )                      ;;*corresponding Matrix id
             (as_matrix_value (unify $mat (bind_exit _until_ $loop))))))))
   )

;;* range-parallel-def
;;*  /lhs1\    /rhs1\
;;* | lhs2 |:= | rhs2 |
;;*  \lhs3/    \rhs3/

( (range-parallel-def $env $tag $lhs $rhs $res)

   (id $lhs (op_matrix $rows $cols (list | $lhss)))
   (id $rhs (op_matrix $rows $cols (list | $rhss))) (!)
   (get-ranges $env $lhs $rs)
   (texp-parallel-option $env $tag $lhss $rhss $updates)
   (init-forms $env $rs $lhss $defined-vars $inits)
   (range-loops $tag $rs () (progn | $updates) $loop)
   (id $values (progn (bind_exit _until_ $loop) (tuple | $defined-vars)))
   (wrap-initializations $values $inits $prog)
   (id $res (define:$tag (tuple | $defined-vars) $prog))
   )


( (texp-parallel-option $env $tag $lhss $rhss 
         $updates)

   (option-12 0) (!)   ;; succeeds when multiple-assignment-option is set to Mc12 compatibility
   (texp-parallel $env $tag $lhss $rhss $tmp-bindings $lhs-bindings $tmps)
   (concat $tmp-bindings $lhs-bindings $updates)
   )

( (texp-parallel-option $env $tag $lhss $rhss
         $updates)

   (texp-sequential $env $tag $lhss $rhss $updates)
   )


( (wrap-initializations $prog () $prog) )

( (wrap-initializations $prog ($init | $inits)
         (let ($init) $inner))

   (wrap-initializations $prog $inits $inner)
   )

;;* range-destructuring-def
;;* /lhs1\
;;  |lhs2 | := e
;;* \lhs3/

( (range-destructuring-def $env $tag $lhs $rhs $res)

   (id $lhs (op_matrix $r $c (list | $lhss)))
   (get-ranges $env $lhs $rs)
   (texp $env (setf $lhs $rhs) $updates)
   (init-forms $env $rs $lhss $defined-vars $inits)
   (range-loops $tag $rs () $updates $loop)
   (id $values (progn (bind_exit _until_ $loop) (tuple | $defined-vars)))
   (wrap-initializations $values $inits $prog)
   (id $res (define:$tag (tuple | $defined-vars) $prog))
   )

;;* INIT-FORMS $env $rs $lhss
;;*   => $defined-vars $initializations)
;;*
;;* Provide list of variables defined in parallel definition
;;* and construct "preallocated" initializations for matrix
;;* definitions.

( (init-forms $env $rs ($lhs | $lhss)
         $more-vars $more-inits)

   (init-forms $env $rs $lhss $vars $inits)
   (init-form $env $rs $lhs $vars $inits $more-vars $more-inits)
   )

( (init-forms $env $rs () () ()) )

;;* submatrix assignment

( (init-form $env $rs (op_matrix $r $c (list | $lhss)) $vars $inits
         $more-vars $more-inits )

   (init-forms-alt $env $rs $lhss $vars $inits $more-vars $more-inits)
   )

;;* The cognesenti will recognize this as a difference list implementation of 
;;* init-forms wherein the components of the dl's are passed as separate variables

( (init-forms-alt $env $rs ($lhs | $lhss) $vars $inits
         $more-vars $more-inits)

   (init-forms-alt $env $rs $lhss $vars $inits
         $mvars $minits)
   (init-form $env $rs $lhs $mvars $minits
         $more-vars $more-inits)
         )

( (init-forms-alt $env $rs () $vars $inits $vars $inits) )
 
;;* singly subscripted array assignment

( (init-form $env $rs (subscript $m $ei) $vars $inits $vars $inits)

   (member $m $vars)
   )

( (init-form $env $rs (subscript $m $ei) $vars $inits
         ($m | $vars) $more-inits )

   (tidx $env $ei $ti)               ;;*translate index expression
   (nursery-matrix-1 $env $m $rs $ti $matexp)
   ;;*$matexp has a reference to $m in it which must bind to doc.m
   ;;*The Matrix value of $matexp shall be locally bound to m.
   ;;*A temporary and two initialialzation are needed to get the correct
   ;;*bindings because of Mpl's recursive let scoping rules.
   ;;*eg. in ($m (as_matrix_value $matexp)) the $m in $matexp would (recursively) bind
   ;;*to the local $m and result in a dependency cycle.
   (matrix-binding $env $m (as_matrix_value $mat) $matrix-bind)
   (new-temp 0 $mat)
   (id $more-inits (($mat $matexp) $matrix-bind | $inits))
   )

;;* doubly subscripted array assignment

( (init-form $env $rs (subscript $m $ei $ej) $vars $inits
         $vars $inits)

   (member $m $vars)
   )

( (init-form $env $rs (subscript $m $ei $ej) $vars $inits
         ($m | $vars) $more-inits )

   (tidx $env $ei $ti)                    ;;*translate index expression
   (tidx $env $ej $tj)                    ;;*translate index expression
   (nursery-matrix-2 $env $m $rs $ti $tj $matexp)
   ;;*$matexp has a reference to $m in it which must bind to doc.m
   ;;*The Matrix value of $matexp shall be locally bound to m.
   ;;*A temporary and two initialialzation are needed to get the correct
   ;;*bindings because of Mpl's recursive let scoping rules.
   ;;*eg. in ($m (as_matrix_value $matexp)) the $m in $matexp would (recursively) bind
   ;;*to the local $m and result in a dependency cycle.
   (new-temp 0 $mat)
   (matrix-binding $env $m (as_matrix_value $mat) $matrix-bind)
   (id $more-inits (($mat $matexp) $matrix-bind | $inits))
   )

;;* matcol assignment

( (init-form $env $rs (op_matcol $m $ei) $vars $inits
      $vars $inits)

   (member $m $vars)
   )

( (init-form $env $rs (op_matcol $m $ei) $vars $inits
         ($m | $vars) $more-inits )

   (tidx $env $ei $ti)                    ;;*translate index expression
   (nursery-matrix-2 $env $m $rs $ti (unboxed 0) $matexp)
   ;;*$matexp has a reference to $m in it which must bind to doc.m
   ;;*The Matrix value of $matexp shall be locally bound to m.
   ;;*A temporary and two initialialzation are needed to get the correct
   ;;*bindings because of Mpl's recursive let scoping rules.
   ;;*eg. in ($m (as_matrix_value $matexp)) the $m in $matexp would (recursively) bind
   ;;*to the local $m and result in a dependency cycle.
   (new-temp 0 $mat)
   (matrix-binding $env $m (as_matrix_value $mat) $matrix-bind)

   (id $more-inits (($mat $matexp) $matrix-bind | $inits))
   )

;;* ordinary var assignment

( (init-form $env $rs $x $vars $inits
         $vars $inits)

   (member $x $vars)
   )

( (init-form $env $rs $x $vars $inits
         ($x | $vars) $inits )
   )

;;* update $mat $i $j $rhs $update-form
;;* TO DO ** Special form for constant RHS

( (update-1 $mat $i $rhs
         (upd_1' $mat $i $rhs))
   )

( (update-2 $mat $i $j $rhs
         (upd_2' $mat $i $j $rhs))
   )

( (update-col $mat $i $rhs
         (upd_matcol $mat $i $rhs))
   )

;;****************************************************************************
;;* RANGE-LOOPS $rs $irs $body $res
;;*
;;* Input
;;*  $rs      -- list of range variables
;;*  $irs       -- list of variables required to be integral
;;*  $body     -- expresssion to iterate
;;* Output
;;*  $res       -- The loop expression

( (range-loops $tag $rs $irs $body $res)

   (make-loops $tag $rs $irs $body $loops $rngs)
   (wrap-loops $rs $rngs $loops $res)
   )

;;* for each range variable
;;*    bind the document range value to a new name ($rng)
;;*    introduce a local binding hiding the document range variable
;;* consequently all of the textual occurences of the range variable
;;* will refer to the local binding and the translated code is free to
;;* refer to the range value through the new name.

( (wrap-loops () () $loops $loops) )

( (wrap-loops ($r | $rs) ($rng | $rngs) $loops $res)

   (wrap-loops $rs $rngs $loops $inner)
   (id $res (let (($rng $r))
            (let (($r zero_))
                  $inner)))
   )

;;****************************************************************************
;;* MAKE-LOOPS $rs $irs $body $res $rngs
;;* Input
;;*  $rs       -- list of iteration variables
;;*  $irs      -- list of variables required to be integral
;;*  $body     -- expresssion to iterate
;;* Output
;;*  $loops    -- The nested loop expressions
;;*  $rngs     -- list of range values

( (make-loops $tag () $irs $body $body ()) )

( (make-loops $tag ($r | $rs) $irs $body
         $res ($rng | $rngs))

   (make-loops $tag $rs $irs $body $inner $rngs)
   (new-temp 0 $rng)
   (range-loop $tag $r $rng $irs $inner $res)
   )

;;****************************************************************************
;;* RANGE-LOOP $r $rng $irs $body => $res
;;*
;;* Construct integer or float loop

;;* Not yet used, but leave it here.
;( (range-loop $tag $r $rng $irs $body $res)
;
;   (member $r $irs) ;;*Integer range loop
;   (iterate $tag $r (forRangeVar:$tag $rng) $body $res)
;   )

( (range-loop $tag $r $rng $irs $body $res)
   (iterate $tag $r (forRangeVar:$tag $rng) $body $res)
   )

;;****************************************************************************
;;* nursery-matrix -- an updateable matrix value properly sized.
;;* This expression has type MatVal; not Matrix

;;*no ranges
( (nursery-matrix-1 $env $m () $ti
         (realloc $dm $ti (unboxed 0)))

   (init-matrix-t $env $m $dm)
   )

;;*one or more ranges
( (nursery-matrix-1 $env $m $rs $ti
         (realloc $dm ((lambda $rs $ti) | $finals) (unboxed 0)))

   (init-matrix-t $env $m $dm)
   (map-final $rs $finals)
   )

;;*no ranges
( (nursery-matrix-2 $env $m () $ti $tj
         (realloc $dm $ti $tj))

   (init-matrix-t $env $m $dm)
   )

;;*one or more ranges
( (nursery-matrix-2 $env $m $rs $ti $tj
         (realloc $dm ((lambda $rs $ti) | $finals) ((lambda $rs $tj) | $finals)))

   (init-matrix-t $env $m $dm)
   (map-final $rs $finals)
   )

;;*-------------------------------------------------------------
;;*init-matrix-t -- document value which this definition extends

;;*Use type to determine value if previous definition exists
( (init-matrix-t $env $m $res)
   (is-array $env $m)
   (id $m $res)
   )

;;*Use zero if there is no previous >>Document<< definition of this name
( (init-matrix-t $env $m $res)
   (id $res zero_)
   )

;;****************************************************************************
;;* TEXP env expression result
;;*
;;* Succeed if 'result' is the translation of the given expression, which will
;;* be one of a number of special forms identified by the initial keyword, or
;;* a function application, a variable, or a literal. We break the tag off the
;;* first element and dispatch to the 'tform' predicate, whose clauses process
;;* each such special form separately.

( (texp $env ($keyword | $form) $res)                 ; Is a compound form?

   (tag $keyword $k $t)                               ; Break off the tag
   (tform $env $k $t $form $res)                      ; Dispatch on keyword
   )

;; This handles the Mathcad rule that builtins are defined
;; in all fonts for builtins that aren't efis.
;; This fixes bug 040911-170642.
( (texp $env $name_font? $res)

   (not-bound $env $name_font?)                       ; make sure it is not bound
   (strip-font $name_font? $name_nofont)              ; strip font information
   (is-builtin $name_nofont)                          ; is it a built-in without font?
   (id $res $name_nofont) )                           ; return the name without font


( (texp $env $simple-exp $simple-exp) )               ; Variable or literal

;;* UNTIL ; we plan to move this translation into the arl parser.

( (tform $env until: $tag $form $res) (!)

   (id $form ($cond $val))
   (texp $env $cond $tcond)
   (texp $env $val $tval)
   (id $res (if:$tag (op_lt:$tag $tcond zero_)
                     (exit _until_ no_value_)
                     ($tval)))
   )

;;* SYMBOLICCB
;;*
;;* Intermediate symbolic results need to be wrapped with a call to 'result'
;;* before they are passed to symboliccb.

( (tform $env symboliccb: $tag $form $res) (!)

   (id $form ($comp $tree $expr))
   (texp $env $expr $texpr)
   (tag $texpr $_ $t)
   (wrap-result $t $texpr $r)
   (id $res (symboliccb:$tag $comp $tree $r))
   )

;;* SYMBOLIC
;;*
;;* Symbolic keywords are now translated like anything else

( (tform $env symbolic: $tag $form $res) (!)

   (id $form ($keywords $expr))
   (texp $env $expr $texpr)
   (texp-each $env $keywords $tkeywords)
   (id $res (symbolic:$tag $tkeywords $texpr))
   )

;;* EXPLICIT
;;*
;;* No need to translate masked names

( (tform $env explicit: $tag $form $res) (!)

   (id $form ($masked $expr))
   (texp $env $expr $texpr)
   (id $res (explicit:$tag $masked $texpr))
   )


;;* SUBSCRIPT
;;*
;;* Translate index expressions for subscript and matcol.

( (tform $env subscript: $tag $form $res) (!)

   (tsubscript $env $tag $form $res)
   )

;;* OP_MATCOL
;;*
;;*

( (tform $env op_matcol: $tag $form $res) (!)

   (id $form ($m $c))
   (texp $env $m $tm)
   (tidx $env $c $tc)
   (id $res (op_matcol:$tag $tm $tc))
   )

;;* SETF
;;*
;;* Translation for local subscript assignments.

( (tform $env setf: $tag $form $res) (!)

   (id $form ($lhs $rhs))
   (tsetf $env $tag $lhs $rhs $res)
   )

;;* LAMBDA
;;*
;;* No translations are performed on the bound variables of a lambda, only its
;;* body.

( (tform $env lambda: $tag $form $res) (!)

   (id $form ($bvs $body))
   (texp $env $body $tbody)
   (id $res (lambda:$tag $bvs $tbody))
   )

;;* AND
;;*
;;*

( (tform $env and: $tag $form $res) (!)

   (id $form ($x $y))
   (texp $env $x $tx)
   (texp $env $y $ty)
   (id $res (bv (and_ (as_bool:$tag $tx) (as_bool:$tag $ty))))
   )

;;* OR
;;*
;;*

( (tform $env or: $tag $form $res) (!)

   (id $form ($x $y))
   (texp $env $x $tx)
   (texp $env $y $ty)
   (id $res (bv (or_ (as_bool:$tag $tx) (as_bool:$tag $ty))))
   )

;;* AND-
;;*
;;* n-ary "and" and "or" -- Mathcad doesn't produce these,
;;* but they're useful in intermediate translations

( (tform $env and-: $tag $form $res) (!)

   (tand $env $tag $form $res)
   )

( (tform $env or-: $tag $form $res) (!)

   (tor $env $tag $form $res)
   )

;;* OP_PARENS
;;*
;;* TO DO ** Could let the general case do this? Purify will punt it anyway.

( (tform $env op_parens: $tag $form $res) (!)

   (id $form ($element))
   (texp $env $element $res)
   )

;;* FOR
;;*
;;*

( (tform $env for: $tag $form $res) (!)

   (tfor $env $tag $form $res)
   )

;;* POWER
;;*
;;* Could add a few more of these for cube, inverse, etc.

( (tform $env op_power: $tag $form $res)

   (id $form ($x 2))                                   ; This may fail
   (texp $env $x $tx)                                    ; Translate the base
   (id $res (op_sqr:$tag $tx))                           ; Use 'square' instead
   )

;;* VECTORIZE
;;*
;;* $form is an application (see ArlParser.y)

( (tform $env vectorize: $tag $form $res)

   (id $form ($expr))
   (vectorize-apply $env $tag $expr $res)
   )

;;* MC_SINC
;;* sin(x)/x
;;*

( (tform $env op_div: $tag $form $res)

   (id $form (($f $arg) $arg))

   (tag $f $sin_font $stag)
   (strip-font $sin_font  mc_sin: )                      ; strip font information
   (not-bound $env $sin_font)   (!)                      ; is it bound in the document
   (texp $env $arg $targ)
   (id $res ((qualified MC_mc mc_sinc:$tag) $targ))
   )

;;* NO-LOOP
;;*
;;*

( (tform $env (constant no-loop) $tag $form $res)

   (id ($i) $form)
   (is-range $env $i)
   (trange $i $res)
   )

( (trange $i $res)
   (is-symbolic $i)
   (id $res (numeric (make_sym_range $i)))
   )

( (trange $i $res)
   (id $res (qualified MC_doc $i))
   )

( (tform $env (constant no-loop) $tag $form $res)

   (id ($i) $form)
   (texp $env $i $res)
   )

;;* MC_ROOT
;;*
;;*

( (tform $env $root_font? $tag $form $res)

   (strip-font $root_font? $root_nofont)                 ; strip font information
   (is-root $root_nofont)                                ; is it root?
   (not-bound $env $root_font?) (!)                      ; is it bound in the document
   (troot $env $tag $form $root_font? $res)              ; Special translation
   )

;;* MC_POLYROOTS
;;*
;;* special translation for polyroots ** TO DO ** Just drop callback?

( (tform $env $poly_font? $tag $form $res)

   (strip-font $poly_font? $poly_nofont)                 ; strip font information
   (is-polyroots $poly_nofont)                           ; is it polyroots?
   (not-bound $env $poly_font?) (!)                      ; Refers to built-in?
   (id $form ($callback (unboxed $options) $v))
   (texp $env $v $tv)
   (id $res ($poly_font?:$tag (as_i4 $options) $tv))
   )

;;* MC_CREATEMESH
;;*
;;* Special translations for CreateMesh and CreateSpace

( (tform $env $mesh_font? $tag $form $res)

   (strip-font $mesh_font? mc_CreateMesh:)               ; strip font information
   (not-bound $env $mesh_font?) (!)                      ; Refers to built-in?
   (tcreatemesh $env $mesh_font? $tag $form $res)        ; Special translation
   )

;;* MC_CREATESPACE

( (tform $env $space_font? $tag $form $res)

   (strip-font $space_font? mc_CreateSpace:)             ; strip font information
   (not-bound $env $space_font?) (!)                     ; Refers to built-in?
   (tcreatespace $env $space_font? $tag $form $res)      ; Special translation
   )

;;* RELATION
;;*
;;* Translate the '(relation (operators)' special form, which yields a section
;;* over the the relation chain formed from the given relational operators.

( (tform $env relation: $tag ($op) $op) )

( (tform $env relation: $tag $ops $res)

   (new-temp 0 $y)
   (trel $ops $y $e $v)
   (texp $env (lambda ($y | $v) $e) $res)
   )

; trel (list-of-rel-ops) parameter => body (list-of-params)

( (trel ($o) $x
      ($o $x $y) ($y))
   (new-temp 0 $y)
   )

( (trel ($o | $os) $x
      (and ($o $x $y) $e)
      ($y | $v))
   (new-temp 0 $y)
   (trel $os $y $e $v)
   )

;;* AMBIGUOUS SYMBOLS
;;*
;;* Special translation for ambiguous symbols like "min" and "sec". We try to
;;* infer what the user meant by the context in which the symbol appears.

( (tform $env $name_font? $tag $args $res)

   (strip-font $name_font? $name_nofont)                    ; strip font information
   (not-bound $env $name_font?)                             ; This may fail
   (is-ambiguous $name_nofont)                              ; This may fail
   (texp-each $env $args $targs)                            ; Translate arguments
   (id $res ((qualified MC_mc $name_font?:$tag) | $targs))  ; Qualify operator
   )

;;* FUNCTION APPLICATION
;;*
;;* Anything else must be a simple function application.

( (tform $env $f $tag $args $res)

   (set-tag $f $tag $ff)                                    ; $f might be PCons, so be careful when putting a tag
   (texp-each $env ($ff | $args) $res)
   )

;;****************************************************************************
;;* GET RANGES
;;*
;;* Any other top-level expression involving ranges

( (get-ranges $env $expr $ranges)

   (gather-range-subscripts ($env 0:) $expr () $all-ranges) (!)
   (remove-duplicates $all-ranges $ranges) (!)
   )

( (gather-range-subscripts ($env $mode) (op_matrix $r $c (list | $v)) $r-accum
         $res)
   (map-accum &gather-range-subscripts-%-4 ($env 0:) $v $r-accum $res) (!)
   )

( (gather-range-subscripts ($env $mode) (subscript $e | $subs) $r-accum
         $ranges)
   (map-accum &gather-range-subscripts-%-4 ($env 1) $subs $r-accum $ranges) (!)
   )

( (gather-range-subscripts ($env $mode) (op_matcol $e | $subs) $r-accum $ranges)

   (map-accum &gather-range-subscripts-%-4 ($env 1) $subs $r-accum $ranges) (!)
   )

( (gather-range-subscripts ($env 1) $x $r-accum
         ($x | $r-accum))

   (is-range $env $x) (!) )

( (gather-range-subscripts ($env $mode) ($x | $r) $r-accum $res)

   (gather-range-subscripts ($env $mode) $r $r-accum $res1) (!)
   (gather-range-subscripts ($env $mode) $x $res1 $res) (!)
   )

( (gather-range-subscripts ($env $mode) $x $r-accum $r-accum) )

( (make-range-program $tag $ranges $vars $body $res)

    (mkrp-help $tag $ranges $vars $body () $prog $init)
    (make-inits $init $prog $res)
    )

( (make-inits () $prog $prog) )

( (make-inits ($init | $inits) $prog $res)

   (make-inits $inits $prog $inner)
   (id $res (let ($init) $inner))
   )

( (mkrp-help $tag ($r | $ranges) $vars $body $init
         $res $init1)
    (new-temp 0 $rng)

    (iterate $tag $r (forRangeVar:$tag $rng) $body $prog)

    (id $i1 (($rng $r) ($r zero_)))
    (concat $i1 $init $i2)
    (mkrp-help $tag $ranges $vars $prog $i2 $res $init1) )

( (mkrp-help $tag () $vars $body $init
         $res $init)
    (id $res (progn:$tag $body (tuple | $vars))) )

;;*-------------------------------------------------------------
;;* TINDEX
;;*
;;* Index translation
;;*
;;* (tindex $env $e $org => $te $tv)
;;* Input
;;*    $e  an index expression
;;*    $org integer expression (variable) of ORIGIN
;;* Output
;;*    $te   an integer expression
;;*    $tv   list of variables which must be integral
;;*          in order that the expression have integral value
;;*

;;* Convert $e into an integer and subtract integer form of ORIGIN
( (tindex $env $e $org
         (sub_i4 $te $org) $tv)

   (tint $env $e $te $tv)
   )

;;* simpler form of tindex which supplies the "correct" integer
;;* name of ORIGIN which is known to the purify step.

( (tidx $env $e $te)
         (tindex $env $e _ORIGIN_i4 $te $ignore)
)

;;* TINT
;;*
;;* (tint $env $e => $te $tv)
;;* Input
;;*    $e  a Mcad expression whose value should be integral
;;* Output
;;*    $te   $e converted to I4
;;*    $tv   list of variables determined to be integral

( (tint $env $i (unboxed $i) ())

   (integral $i) (!)
   )

( (tint $env $v:$t (as_i4:$t $v) ($v:$t))

   (identifier $v) (!)
   )

( (tint $env ($op $e1 $e2) ($top $te1 $te2) $tv)

   (i4op $op $top)
   (tint $env $e2 $te2 ())       ;;*integral with no assumptions about variables.
   (tint $env $e1 $te1 $tv)
   )

( (tint $env $e:$t
         (as_i4:$t $te) (Bogus) ) ;;*return a bogus list of variables so test above will fail

   (texp $env $e:$t $te)
   )

( (tint $env $e
         (as_i4 $te) (Bogus) ) ;;*return a bogus list of variables so test above will fail

   (texp $env $e $te)
   )

;;* I4OP
;;*
;;* (i4op $mcOperator $i4Operator)
;;* Input
;;*    $mcOperator  Mcad operator
;;* Output
;;*    $i4Operator  Corresponding operation on integers

( (i4op op_add add_i4) )
( (i4op op_sub sub_i4) )

;;****************************************************************************
;;* TRANS-TUPLE-DEFINE env tag form rhs result
;;*
;;* top-level simultaneous assignment, no ranges
;;* ** TO DO ** Is this correct? No need to deal with subscripted assignments in tuple variables?

( (trans-tuple-define $env $tag ((op_matrix $rows $cols (list | $lhss)) $rhs)
         (define:$tag (tuple | $lhss) $trhs))

   (texp $env $rhs $trhs)
   )

; 1-tuple definitions are the same as ordinary definitions

( (trans-tuple-define $env $tag ($lhs $rhs) $res)

   (trans-define $env $tag $lhs $rhs $res)
   )

;;****************************************************************************
;;* Handle result simplification

;; Expression with affine unit function in placeholder expression.

( (trans-simplify $env $tag ($expr $function) $res)

   (get-affine-inverse $function $inverse)               ; Get name of inverse
   (is-callable-with $env $function)                     ; Is a function?
   (is-callable-with $env $inverse  1:) (!)              ; Is a unary function?

   (trans-eval $env $tag $expr $texpr)
   (texp $env $inverse $tinverse)
   (wrap-result $tag (apply_affine_unit:$tag $texpr $tinverse) $res) (!)
   )

;; Expression with regular unit placeholder expression.

( (trans-simplify $env $tag ($expr $units) $res)

   (trans-eval $env $tag $expr $texpr)
   (texp $env $units $tunits)
   (new-temp 0 $tmp)
   (wrap-result $tag (divide_by_unit:$tag (let (($tmp $texpr)) $tmp) $tunits) $res) (!)
   )

;; Expression without unit placeholder expression.

( (trans-simplify $env $tag ($expr) $res)

   (trans-eval $env $tag $expr $texpr)
   (wrap-result $tag $texpr $res)
   )

;;****************************************************************************
;;* TRANS-EVAL env expr result
;;*
;;* Toplevel eval translation.

( (trans-eval $env $tag $expr $res)

   (find-all-ranges $env $expr $ranges) (!)     ;* identify ranges in the translation
   (texp $env $expr $texpr)                     ;* translate the expression
   (trans-range-eval $tag $texpr $ranges $res)  ;* wrap with loop if necessary
   )

;;****************************************************************************
;;* TRANS-RANGE-EVAL
;;*

( (trans-range-eval $tag $texpr () $res)        ;* No ranges
  (!)
  (id $texpr $res)                              ;* return texpr
  )

( (trans-range-eval $tag $texpr $ranges $res)   ;* Some ranges

   (new-temp 0 $result)
   (id $body (progn:$tag (setf $result (push':$tag $result $texpr)) $result))
   (make-range-program $tag $ranges ($result) $body $rprog)
   (prod-steps $ranges $nsteps)
   (id $res (progn:$tag (setf $result (set_IsRange (reserve' $nsteps)))
                        $rprog
                        (mm $result)))
   )

( (prod-steps () (unboxed 1) ) )
( (prod-steps ($r) (range_steps $r) ) )
( (prod-steps ($r | $rs)
         (mul_i4 (range_steps $r) $rest))
   (prod-steps $rs $rest) )

;;*find all ranges

( (find-all-ranges $env $expr
         $ranges)
    (frn-help $expr $env () $all-ranges) (!)
    (remove-duplicates $all-ranges $tmp) (!)
    (reverse $tmp $ranges)
    )

;;****************************************************************************
;;* REMOVE
;;*
;;* Remove 'x' from 'list' and append 'tail'

( (remove ($x | $xs) $x $tail $res)  (!)

   (remove $xs $x $tail $res)
   )

( (remove ($y | $xs) $x $tail $res)  (!)

   (remove $xs $x $tail $ys)
   (id $res ($y | $ys))
   )

( (remove () $x $tail $tail) (!) )

;;* helper

( (frn-help ($root $expr $var $a $b) $env $accum
         $res)

   (strip-font $root $root_nofont)                       ; strip font information
   (is-root $root_nofont)                                ; is it root?
   (not-bound $env $root) (!)                            ; is it bound in the document
                                                         ; Special translation
   (frn-help $expr $env () $res1)
   (remove $res1 $var $accum $res2)
   (frn-help $a $env $res2 $res3)
   (frn-help $b $env $res3 $res)
  )

( (frn-help ($f | $args) $env $accum
         $res)

   (frn-f $f $env $accum $res1)         ;* This will fail if $f == (constant no-loop)
   (frn-each $args $env $res1 $res)
   )

( (frn-help $e $env $accum $res)
   (is-range $env $e)
   (id $res ($e | $accum))
   )

( (frn-help $e $env $accum $accum) )

;* ignore ranges inside no-loop; that's its purpose, after all
( (frn-f (constant no-loop) $env $accum $res)
   (!) (fail 0)
   )

( (frn-f $f $env $accum $res)
   (frn-help $f $env $accum $res)
   )

( (frn-each ($e | $es) $env $accum $res)
   (frn-help $e $env $accum $res1)
   (frn-each $es $env $res1 $res)
   )

( (frn-each () $env $accum $accum) )

;;* translation of non-top-level expressions

( (tsubscript $env $tag ($m $s) $res)

   (texp $env $m $tm)
   (tidx $env $s $ts)
   (id $res (subscript:$tag $tm $ts))
   )

( (tsubscript $env $tag ($m $s1 $s2) $res)

   (texp $env $m $tm)
   (tidx $env $s1 $ts1)
   (tidx $env $s2 $ts2)
   (id $res (subscript:$tag $tm $ts1 $ts2))
   )

( (tsetf $env $tag (subscript:$t $m $s) $rhs
         (setf:$tag (subscript:$t $tm $ts) $trhs))

   (texp $env $m $tm)
   (texp $env $rhs $trhs)
   (tidx $env $s $ts)
   )

( (tsetf $env $tag (subscript:$t $m $s1 $s2) $rhs
         (setf:$tag (subscript:$t $tm $ts1 $ts2) $trhs))

   (texp $env $m $tm)
   (texp $env $rhs $trhs)
   (tidx $env $s1 $ts1)
   (tidx $env $s2 $ts2)
   )

;;* translation for local assignments to matcol

( (tsetf $env $tag (op_matcol:$t $m $c) $rhs
         (setf:$tag (op_matcol:$t $tm $tc) $trhs))

   (texp $env $m $tm)
   (tidx $env $c $tc)
   (texp $env $rhs $trhs)
   )

;;* local tuple assignment

( (tsetf $env $tag $lhs $rhs
         (progn:$tag | $all-bindings))

   (id $lhs (op_matrix $r $c (list | $v)))
   (id $rhs (op_matrix $r $c (list | $e)))
   (texp-parallel $env $tag $v $e $tmp-bindings $lhs-bindings $tmps)
   (new-temp 0 $resv)
   (id $res (let (($resv (op_matrix $r $c (list | $tmps)))) $resv))
   (append ($tmp-bindings $lhs-bindings ($res) ) $all-bindings)
   )

( (texp-parallel $env $tag ($lhs | $lhss) ($rhs | $rhss)
         $res1 $res2 $res3)
   (new-temp 0 $tmp)
   (texp $env (setf:$tag $tmp $rhs) $set-tmp)
   (texp $env (setf:$tag $lhs $tmp) $set-lhs)
   (texp-parallel $env $tag $lhss $rhss $more-tmps $more-lhs $tmps)
   (id $res1 ($set-tmp | $more-tmps))
   (id $res2 ($set-lhs | $more-lhs))
   (id $res3 ($tmp | $tmps))
   )

( (texp-parallel $env $tag () () () () ()) )

( (texp-sequential $env $tag ($lhs | $lhss) ($rhs | $rhss)
         $res)

   (texp $env (setf:$tag $lhs $rhs) $set-lhs)
   (texp-sequential $env $tag $lhss $rhss $more-lhs)
   (id $res ($set-lhs | $more-lhs))
   )

( (texp-sequential $env $tag () () ()) )

;;* destructuring assignment

( (tsetf $env $tag (op_matrix $rows $cols (list | $v)) $rhs $res)

   (new-temp 0 $tmp)
   (strip-to-num $rows $r)
   (strip-to-num $cols $c)
   (texp $env $rhs $trhs)
   (destructure $env $v $r $c 0: 0: $tmp $bindings)
   (id $res (progn:$tag | ((setf $tmp $trhs) | $bindings)))
   )

( (destructure $env $v $r $c $r $j $val            ;;*finished a column -- $i == $r
         $res)
   (+ $j 1: $nj)                                   ;;*nj = j + 1 -- next column
   (destructure $env $v $r $c 0: $nj $val $res)    ;;*0th row, next column
   )

( (destructure $env ($v | $vs) $r $c $i $j $val
         ($set | $more))
   (+ $i 1: $ni)                                   ;;*ni = i + 1
   (texp $env (setf $v (getm_2 $val (unboxed $i) (unboxed $j))) $set)
   (destructure $env $vs $r $c $ni $j $val $more)
   )

( (destructure $env () $r $c $i $j $val
         ($val))    ;; tack RHS onto end of bindings to represent the value of the assignment expression
   )

;;* Note: The op_parens wrapper below is necessary.
;;*      MPL disallows let expressions in certain
;;*      contexts, e.g.:
;;*
;;*   (symboliccb 414510488$ 415894864$
;;*        let
;;*        {
;;*          _val = dummy_1;
;;*        }
;;*        in (result _val (typeof _val)))
;;*
;;*      If the let is wrapped in parentheses, all is well.

( (wrap-result $tag $x
         (op_parens
            (let ((_val:$tag $x))
               (result:$tag _val (typeof _val)))))
   )

;;*translation of `for`

( (tfor $env $tag ($id $range $body) $prog)
   (get-iter $env $range $iterator)
   ;(texp $env $id $tid)
   (texp $env $body $tbody)
   (id $prog (for:$tag $id $iterator $tbody))
   )

; create an iterator from a range2
( (get-iter $env (op_range2:$t $init $end)
         $iterator)
   (texp $env $init $tinit)
   (texp $env $end $tend)
   (new-temp 0 $x)
   (new-temp 0 $y)
   (id $iterator (numapp (numeric forRange2:$t) $tinit $tend))
   )

; create an iterator from a range3
( (get-iter $env (op_range3:$t $init $next $end)
         $iterator)
   (texp $env $init $tinit)
   (texp $env $next $tnext)
   (texp $env $end $tend)
   (id $iterator (numapp (numeric forRange3:$t) $tinit $tnext $tend))
   )

( (seq-iterator $args $vec)

   (length $args $n)
   (strglue tup2vec_ $n $tup2vec)
   (id $vec (numapp (numeric forValues) (numapp (numeric $tup2vec) (tuple | $args))))
   )

( (get-iter $env (list | $vals)
         $iterator)

   (get-iters $env $vals $its)
   (seq-iterator $its $iterator)
   )

( (get-iters $env () () ) )
( (get-iters $env ($v | $vs)
         $its)

   (get-iter $env $v $it)
   (get-iters $env $vs $more)
   (id $its ($it | $more))
   )

; create an iterator from a value (scalar, vector, or matrix)
( (get-iter $env $mat
         $iterator)
   (texp $env $mat $tmat)
   ;;(find-tag $mat $t)
   (new-temp 0 $x)
   (id $iterator (numapp (numeric forValue) $tmat))
   )

; Base translation of collection iterations.
( (iterate $tag $tid $iterator $tbody   ;;*id, iterator, and body are assumed translated.
         (for:$tag $tid $iterator $tbody))
         )

;( (iterate $tag $tid $iterator $tbody   ;;*id, iterator, and body are assumed translated.
;         $prog)
;
;   (new-temp 0 $it)               ;;*iterator
;   (id $prog (progn:$tag
;                  (setf:$tag $it (numeric $iterator))
;                  (setf:$tag $tid (numeric zero_))
;                  (while:$tag (numeric (bv (not_null $it)))
;                              (progn:$tag (setf $tid (numeric (val_first $it)))
;                                          (setf $it (numeric (val_next $it)))
;                                          $tid
;                                          $tbody))))
;   )


;;*special translations for root

( (troot $env $tag ($expr $var) $root_font? $res) (!)

   (texp $env $expr $texpr)
   (id $res ($root_font?:$tag (lambda:$tag ($var) $texpr) $var))
   )

( (troot $env $tag ($expr $var $a $b) $root_font? $res) (!)

   (texp $env $expr $texpr)
   (texp $env $a $ta)
   (texp $env $b $tb)
   (strip-font $root_font? $root_nofont)
   (strcat $root_nofont _bracket_ $bracket)
   (id $res ($bracket:$tag (lambda:$tag ($var) $texpr) $ta $tb))
   )

;;* TO DO ** Note: for these to be correct translations
;;*                  all of the argument must actually have boolean type

( (tand $env $tag ($x) $tx)

   (texp $env $x $tx)
   )

( (tand $env $tag ($x | $r)
         (if:$tag $tx $tr zero_))

   (texp $env $x $tx)
   (tand $env $tag $r $tr)
   )

( (tor $env $tag ($x) $tx)

   (texp $env $x $tx)
   )

;;* TO DO ** If $x has boolean type then the setf is unnecessary: translate as (if $tx True $tr)

( (tor $env $tag ($x | $r)
       (progn:$tag (setf o_ $tx) (if:$tag o_ o_ $tr)))

   (texp $env $x $tx)
   (tor $env $tag $r $tr)
   )

;;****************************************************************************

( (tcreatemesh $env $name $tag ($f1 $f2 $f3 | $args)
         ($name:$tag (unboxed 3) $F | $targs))

   (is-callable-with $env $f1 2:)
   (is-callable-with $env $f2 2:)
   (is-callable-with $env $f3 2:) (!)
   (id $F (lambda (u v) (op_matrix (unboxed 3) (unboxed 1)
                           (list ($f1 u v) ($f2 u v) ($f3 u v)))))
   (tmesh-space-args $env $args $targs)
   )

( (tcreatemesh $env $name $tag ($F | $args)
         ($name:$tag (unboxed 0) $tF | $targs))

   (texp $env $F $tF)
   (tmesh-space-args $env $args $targs)
   )

( (tcreatespace $env $name $tag ($f1 $f2 $f3 | $args)
         ($name:$tag (unboxed 3) $F | $targs))

   (is-callable-with $env $f1 1:)
   (is-callable-with $env $f2 1:)
   (is-callable-with $env $f3 1:) (!)
   (id $F (lambda (u) (op_matrix (unboxed 3) (unboxed 1)
                           (list ($f1 u) ($f2 u) ($f3 u)))))
   (tmesh-space-args $env $args $targs)
   )

( (tcreatespace $env $name $tag ($F | $args)
         ($name:$tag (unboxed 0) $tF | $targs))

   (texp $env $F $tF)
   (tmesh-space-args $env $args $targs)
   )

( (tmesh-space-args $env $args
         $res)

   (last $args $fmap_font?)                              ; Take last argument
   (strip-font $fmap_font? $fmap)                        ; Strip the font tag
   (is-n-ary-coordinate-mapping $fmap)                   ; Is it special one?
   (not-bound $env $fmap)                                ; And not rebound?
   (rm-last $args $args1)                                ; Drop from the list
   (texp-each $env $args1 $r)                            ; Translate the list
   (id $res ((Really (lambda (x) ($fmap x))) | $r))      ; Prefix unary map
   )

( (tmesh-space-args $env $args
          $res)

   (last $args $fmap)
   (is-coordinate-mapping $env $fmap)
   (texp $env $fmap $tfmap)
   (rm-last $args $args1)
   (texp-each $env $args1 $r)
   (id $res ((Really $tfmap) | $r))
   )

( (tmesh-space-args $env $args
         (Null | $r) )

   (texp-each $env $args $r)
   )

;;****************************************************************************
;;* IS-N-ARY-COORDINATE-MAPPING name
;;*
;;* Is 'name' one of the special n-ary coordinate mapping functions that get a
;;* special translation when passed as a function argument to either the Space
;;* or Mesh  functions?

( (is-n-ary-coordinate-mapping mc_pol2xy:) )
( (is-n-ary-coordinate-mapping mc_xy2pol:) )
( (is-n-ary-coordinate-mapping mc_cyl2xyz:) )
( (is-n-ary-coordinate-mapping mc_sph2xyz:) )
( (is-n-ary-coordinate-mapping mc_xyz2cyl:) )
( (is-n-ary-coordinate-mapping mc_xyz2sph:) )

;;****************************************************************************
;;* IS-COORDINATE-MAPPING name
;;*
;;# Is 'name' a unary or ternary function?

( (is-coordinate-mapping $env $name) (is-callable-with $env $name 1:))
( (is-coordinate-mapping $env $name) (is-callable-with $env $name 3:))

;;* Is 'name' bound in either the document or static environment, and if so,
;;* is it callable with 'arity' arguments?

( (is-callable-with $env $name)
   (signature $env $name $signature)                     ; Has type signature?
   (is-function $signature)                              ; Describes function?
   )

( (is-callable-with $env $name $arity)
   (signature $env $name $signature)                     ; Has type signature?
   (accepts   $signature $arity)                         ; Callable with args?
   )

( (signature $env $name $signature)
   (lookup-type $env $name $signature) (!)               ; Is document bound?
   )

( (signature $env $name $signature)
   (lookup-sig "": $name $signature) (!)                 ; Is statically bound?
   )

( (signature $env $name_font? $signature)
   (strip-font $name_font? $name_nofont)                 ; strip font information
   (lookup-sig "": $name_nofont $signature) (!)          ; Is statically bound?
   )

;;****************************************************************************
;;*vectorization

( (vectorize-apply $env $tag ((constant | $any1) | $any2) $res)

   (texp $env ((constant | $any1) | $any2) $res)
   )

;;*vectorization of user defined functions

( (vectorize-apply $env $tag ($f | $args) $res)

   (lookup-type $env $f $_)
   (simple-vectorization $env $tag $f $args $res)
   )

;;*vectorization of builtin functions

( (vectorize-apply $env $tag ($f | $args) $res)

   (lookup-sig-t $f $_)                                  ; It's a builtin
   (!)                                                   ; no turning back.
   (tag $f $tagless $t)                                  ; Break off the tag
   (strip-font $tagless $key)                            ; and strip the font

   (builtin-vectorization $env $tag $key $f $args $res)  ; go do it.
   )

;;*the 'relation' special form looks like a function application but isn't.
( (vectorize-apply $env $tag (relation | $args) $res)

   (texp $env (relation | $args) $res)
   )

;;*vectorization of lexically bound functions

( (vectorize-apply $env $tag ($f | $args) $res)

   (!) ; must be (lexically-bound $f) ; its not document bound and not statically bound
   (simple-vectorization $env $tag $f $args $res) (!)
   )

( (simple-vectorization $env $tag $f $args
         ($vectorizer:$tag $tf | $targs) )

   (texp $env $f $tf)
   (lookup-vectorizer $args $vectorizer)
   (texp-each $env $args $targs)
   )

( (lookup-vectorizer $args $vectorizer)

   (length $args $n)
   (strglue vectorize_ $n $vectorizer)
   )

;;* builtin-vectorization
;; ENV
;; TAG   of vectorization
;; key   tagless, strip-fonted
;; NAME  The original tag'd, font'd token
;; ARGS  list of remaining args
;; RES   the output

( (builtin-vectorization $env $tag op_power: $name $args $res)

   (power-vectorization $env $tag $name $args $res)
   )

( (builtin-vectorization $env $tag op_nthroot: $name $args $res)

   (power-vectorization $env $tag $name $args $res)
   )

( (builtin-vectorization $env $tag and: $name $args $res)

   (macro-vectorization $env $tag $name $args $res)
   )

( (builtin-vectorization $env $tag or: $name $args $res)

   (macro-vectorization $env $tag $name $args $res)
   )


( (builtin-vectorization $env $tag mc_interp: $name $args $res)

   (texp-each $env $args $targs)
   (id $targs ($s $x $y $p))     ; Oh, retch, this can fail
   (new-temp 0 $sv)
   (new-temp 0 $xv)
   (new-temp 0 $yv)
   (new-temp 0 $pv)
   (id $res
      (let (($sv $s))
      (let (($xv $x))
      (let (($yv $y))
         (vectorize_1:$tag (lambda ($pv) ($name $sv $xv $yv $pv)) $p)))))

   )

( (builtin-vectorization $env $tag $key $name $args $res)

   (ignore-vectorization $key) (!)
   (texp $env ($name | $args) $res)
   )

( (builtin-vectorization $env $tag $key $name $args $res)

   (use-simple-vectorization $key) (!)
   (simple-vectorization $env $tag $name $args $res)
   )

( (builtin-vectorization $env $tag $key $name $args $res)

   (texp $env ($name | $args) $tcall)
   (id $tcall ($tf | $targs))

   (vecparams $targs $params $aargs $vargs)
   (lookup-vectorizer $params $vectorizer)

   (id $res ($vectorizer:$tag (lambda:$tag $params ($tf | $aargs) ) | $vargs))
   )

;; How might the previous variant fail?
( (builtin-vectorization $env $tag $key $name $args $res)

   (texp-each $env $args $targs)

   (vecparams $targs $params $aargs $vargs)
   (lookup-vectorizer $params $vectorizer)

   (texp $env ($name | $aargs) $tf)

   (id $res ($vectorizer:$tag (lambda:$tag $params $tf) | $vargs))
   )


( (macro-vectorization $env $tag $f $args $res)
   (texp-each $env $args $targs)

   (vecparams $targs $params $aargs $vargs)
   (lookup-vectorizer $params $vectorizer)

   (texp $env ($f | $aargs) $tf)

   (id $res ($vectorizer:$tag (lambda:$tag $params $tf) | $vargs))
   )

( (devectorize (vectorize $exp) $res) (!)

   (devectorize $exp $res)
   )

( (devectorize ($h | $t)
               ($th | $tt)) (!)

   (devectorize $h $th)
   (devectorize $t $tt)
   )

( (devectorize $e $e ) )

( (is-arith op_add)   )
( (is-arith op_sub)   )
( (is-arith op_mult) )
( (is-arith op_div)   )
( (is-arith op_negate) )

( (is-constant $env (vectorize $exp)) (!)

   (is-constant $env $exp)
   )

( (is-constant $env ($f | $args)) (!)

   (is-arith $f)
   (each-is-constant $env $args)
   )

( (is-constant $env $e)

   (lookup-type $env $e $ignore)
   (!)
   (fail 0)
   )

( (is-constant $env $e) )

( (each-is-constant $env ($h | $t))

   (is-constant $env $h)
   (each-is-constant $env $t)
   )

( (each-is-constant $env () ) )


( (power-vectorization $env $tag $func $args $res)

   (id $args ($base $exponent))
   (is-constant $env $exponent)
   (devectorize $exponent $exp)
   (texp $env $base $tbase)
   (new-temp 0 $var)
   (texp $env ($func $var $exp) $tbody)
   (id $res (vectorize_1:$tag (lambda:$tag ($var) $tbody) $tbase))
   )

;;****************************************************************************
;;* VECPARAMS args => params actual vargs
;;*

( (vecparams ($e | $es)
         $params ($e | $aargs) $vargs )

   (do-not-vectorize $e)
   (vecparams $es $params $aargs $vargs)
   )

( (vecparams ($e | $es)
         ($param | $params) ($param | $aargs) ($e | $vargs) )

   (new-temp 0 $param)
   (vecparams $es $params $aargs $vargs)
   )

( (vecparams () () () () ) )

;;****************************************************************************
;;* TEXP-EACH env exprs texprs
;;*
;;* Translate each of the given expressions in turn.

( (texp-each $env ($x | $r)
                  ($x1 | $r1))

   (texp $env $x $x1) (!)
   (texp-each $env $r $r1) (!)
   )

( (texp-each $env () ()) )

;;****************************************************************************
;;* DO-NOT-VECTORIZE name
;;*
;;* Succeed if 'name' names a function that must not be vectorized.

( (do-not-vectorize (lambda | $t)) )
( (do-not-vectorize (unboxed | $t)) )
( (do-not-vectorize (integralcb | $t)) )

;;****************************************************************************
;;* USE-SIMPLE-VECTORIZATION name
;;*
;;* Succeed if 'name' names a function that receives only simple vectorized.

( (use-simple-vectorization mc_sin:) )
( (use-simple-vectorization mc_cos:) )
( (use-simple-vectorization mc_tan:) )
( (use-simple-vectorization op_deriv_1:) )
( (use-simple-vectorization op_deriv_2:) )
( (use-simple-vectorization op_deriv_3:) )
( (use-simple-vectorization op_deriv_4:) )
( (use-simple-vectorization op_deriv_5:) )
( (use-simple-vectorization op_deriv_n:) )

;;****************************************************************************
;;* IGNORE-VECTORIZATION name
;;*
;;* Succeed if 'name' names a function that should never be vectorized.

( (ignore-vectorization integralcb:) )
( (ignore-vectorization op_cross:) )
( (ignore-vectorization op_matrix:) )
( (ignore-vectorization op_congugate:) )
( (ignore-vectorization op_transpose:) )
( (ignore-vectorization no-loop:) )
( (ignore-vectorization op_rangesum:) )
( (ignore-vectorization op_rangeproduct:) )
( (ignore-vectorization op_sigmasum:) )
( (ignore-vectorization mc_augment:) )
( (ignore-vectorization mc_bspline:) )
( (ignore-vectorization mc_Bulstoer:) )
( (ignore-vectorization mc_bulstoer:) )
( (ignore-vectorization mc_bvalfit:) )

( (ignore-vectorization mc_CFFT:) )
( (ignore-vectorization mc_cfft:) )
( (ignore-vectorization mc_cholesky:) )
( (ignore-vectorization mc_cond1:) )
( (ignore-vectorization mc_cond2:) )
( (ignore-vectorization mc_conde:) )
( (ignore-vectorization mc_condi:) )
( (ignore-vectorization mc_corr:) )
( (ignore-vectorization mc_csort:) )
( (ignore-vectorization mc_cspline:) )
( (ignore-vectorization mc_cvar:) )

( (ignore-vectorization mc_diag:) )
( (ignore-vectorization mc_eigenvals:) )
( (ignore-vectorization mc_eigenvecs:) )
( (ignore-vectorization mc_eigenvec:) )

( (ignore-vectorization mc_FFT:) )
( (ignore-vectorization mc_fft:) )

( (ignore-vectorization mc_expfit:) )
( (ignore-vectorization mc_genfit:) )
( (ignore-vectorization mc_gcd:) )
( (ignore-vectorization mc_geninv:) )
( (ignore-vectorization mc_genvals:) )
( (ignore-vectorization mc_genvecs:) )
( (ignore-vectorization mc_gmean:) )

( (ignore-vectorization mc_hist:) )
( (ignore-vectorization mc_histogram:) )
( (ignore-vectorization mc_hmean:) )

( (ignore-vectorization mc_ICFFT:) )
( (ignore-vectorization mc_icfft:) )
( (ignore-vectorization mc_IFFT:) )
( (ignore-vectorization mc_ifft:) )

( (ignore-vectorization mc_intercept:) )
( (ignore-vectorization mc_interp:) ) ;;* TO DO ** should be restricted
( (ignore-vectorization mc_iwave:) )

( (ignore-vectorization mc_ksmooth:) )
( (ignore-vectorization mc_kurt:) )

( (ignore-vectorization mc_last:) )
( (ignore-vectorization mc_lcm:) )
( (ignore-vectorization mc_length:) )
( (ignore-vectorization mc_lgsfit:))
( (ignore-vectorization mc_line:) )
( (ignore-vectorization mc_linfit:) )
( (ignore-vectorization mc_linterp:) ) ;;* TO DO ** restrict
( (ignore-vectorization mc_linfit:) )

( (ignore-vectorization mc_lnfit:) )
( (ignore-vectorization mc_loess:) )
( (ignore-vectorization mc_logfit:) )
( (ignore-vectorization mc_lookup:) ) ;;* TO DO ** wasn't listed
( (ignore-vectorization mc_lsolve:) )
( (ignore-vectorization mc_lspline:) )
( (ignore-vectorization mc_lu:) )
( (ignore-vectorization mc_max:) )
( (ignore-vectorization mc_min:) )
( (ignore-vectorization mc_mean:) )
( (ignore-vectorization mc_medfit:) )
( (ignore-vectorization mc_median:) )

( (ignore-vectorization mc_median:) ) ;;* TO DO ** Restrict
( (ignore-vectorization mc_mode:) )
( (ignore-vectorization mc_multigrid:) )

( (ignore-vectorization mc_norm1:) )
( (ignore-vectorization mc_norm2:) )
( (ignore-vectorization mc_norme:) )
( (ignore-vectorization mc_normi:) )

( (ignore-vectorization mc_polyroots:) )
( (ignore-vectorization mc_predict:) )
( (ignore-vectorization mc_pspline:) )
( (ignore-vectorization mc_norm:) )

( (ignore-vectorization mc_qr:) )
( (ignore-vectorization mc_Radau:) )
( (ignore-vectorization mc_radau:) )
( (ignore-vectorization mc_rank:) )

( (ignore-vectorization mc_recenter:) )
( (ignore-vectorization mc_regress:) )
( (ignore-vectorization mc_relax:) )
( (ignore-vectorization mc_reverse:) )

( (ignore-vectorization mc_Rkadapt:) )
( (ignore-vectorization mc_rkadapt:) )
( (ignore-vectorization mc_rkfixed:) )
( (ignore-vectorization mc_rref:) )
( (ignore-vectorization mc_rsort:) )
( (ignore-vectorization mc_sbval:) )

( (ignore-vectorization mc_sinfit:) )
( (ignore-vectorization mc_skew:) )
( (ignore-vectorization mc_slope:) )
( (ignore-vectorization mc_sort:) )

( (ignore-vectorization mc_stack:) )
( (ignore-vectorization mc_stderr:) )
( (ignore-vectorization mc_Stdev:) )
( (ignore-vectorization mc_stdev:) )

( (ignore-vectorization mc_Stiffb:) )
( (ignore-vectorization mc_stiffb:) )
( (ignore-vectorization mc_Stiffr:) )
( (ignore-vectorization mc_stiffr:) )
( (ignore-vectorization mc_submatrix:) )
( (ignore-vectorization mc_supsmooth:) )
( (ignore-vectorization mc_svd:) )
( (ignore-vectorization mc_svds:) )

( (ignore-vectorization mc_tr:) )
( (ignore-vectorization mc_Var:) )
( (ignore-vectorization mc_var:) )

( (ignore-vectorization mc_wave:) )

;;****************************************************************************
;;* IS-AMBIGUOUS name
;;*
;;* Succeed if the binding for 'name' would be ambiguous if left unqualified.

( (is-ambiguous mc_pF:) )
( (is-ambiguous mc_min:) )
( (is-ambiguous mc_sec:) )

;;****************************************************************************
;;* IS-BUILTIN name
;;*
;;* Succeed if the binding for 'name' is a name of a built-in variable.

( (is-builtin mc_FRAME:) )
( (is-builtin mc_TOL:) )
( (is-builtin mc_CTOL:) )
( (is-builtin mc_ORIGIN:) )
( (is-builtin mc_PRNPRECISION:) )
( (is-builtin mc_PRNCOLWIDTH:) )
( (is-builtin mc_CWD:) )
( (is-builtin mc_in0:) )
( (is-builtin mc_in1:) )
( (is-builtin mc_in2:) )
( (is-builtin mc_in3:) )
( (is-builtin mc_in4:) )
( (is-builtin mc_in5:) )
( (is-builtin mc_in6:) )
( (is-builtin mc_in7:) )
( (is-builtin mc_in8:) )
( (is-builtin mc_in9:) )

;;****************************************************************************
;;* IS-ROOT name
;;*
;;* Succeed if the binding for 'name' is 'mc_root' or 'sym_mc_root'.

( (is-root mc_root:) )
( (is-root sym_mc_root:) )

( (is-polyroots mc_polyroots:) )
( (is-polyroots sym_mc_polyroots:) )

;; ( (is-power op_power) )
;; ( (is-power op_nthroot) )

;; Should be named is-non-function-macro
;; ( (is-macro and) )
;; ( (is-macro or)  )

;;****************************************************************************
;;* MAP-FINAL list result
;;*

( (map-final () ()) )

( (map-final ($r | $rs)
         ((range_final $r) | $finals))

   (map-final $rs $finals)
   )

;;****************************************************************************

;;****************************************************************************
;;* IS-RANGE env name
;;*
;;* Succeed if 'name' is bound to a range in the document environment.

( (is-range $env $name)

   (lookup-type $env $name $type) (!)                    ; Find type signature
   (strprefix $type "Matrix (R":)                        ; Starts with range?
   )

;;****************************************************************************
;;* IS-BOUND env name
;;*
;;* Succeed if 'name' is bound to anything at all in the document environment.

( (is-bound $env $name)

   (lookup-type $env $name $_)                           ; Has type signature?
   )

;;****************************************************************************
;;* NOT-BOUND env name
;;*
;;* Succeed if 'name' is not bound in the document environment.

( (not-bound $env $name)

   (lookup-type $env $name $_) (!)                       ; Has type signature?
   (fail 0)                                              ; Then must be bound
   )

( (not-bound $env $name) )

;;****************************************************************************
;;* LOOKUP-SIG-T name signature
;;*
;;* Succeed if 'name' is bound to an object with the given MPL type signature
;;* in the static (import) environment.

( (lookup-sig-t (qualified $qualifier $name) $signature)

   (lookup-sig $qualifier $name $signature) (!)          ; Call the primitive
   )

( (lookup-sig-t $name $signature)

   (lookup-sig "": $name $signature) (!)                 ; Call the primitive
   )

;;****************************************************************************
;;* HAS-TYPE env name type
;;*
;;* Succeed if the given name has the given type by first checking the document
;;* environment and then the searching static environment.

( (has-type $env $name $type) (lookup-sig "": $name $type) )
( (has-type $env $name $type) (lookup-type $env $name $type) )

;;****************************************************************************
;;* GET-AFFINE-INVERSE function inverse
;;*
;;* Succeed if 'function' and 'inverse' appear to name a pair of 'affine unit'
;;* functions; that is, a function and its inverse bound in either environment
;;* whose names differ by just an initial '/' character.

( (get-affine-inverse $function:$tag $inverse:$tag)

   (strcat "mc__2F_": $t $function)                      ; strip initial 'mc_/'
   (strcat "mc_":     $t $inverse)                       ; prefix with 'mc_'
   )

( (get-affine-inverse $function:$tag $inverse:$tag)

   (strcat "mc_":     $t $function)                      ; strip initial 'mc_'
   (strcat "mc__2F_": $t $inverse)                       ; prefix with 'mc_/'
   )

;;****************************************************************************