;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; LUSH Lisp Universal Shell
;;;   Copyright (C) 2002 Leon Bottou, Yann Le Cun, AT&T Corp, NECI.
;;; Includes parts of TL3:
;;;   Copyright (C) 1987-1999 Leon Bottou and Neuristique.
;;; Includes selected parts of SN3.2:
;;;   Copyright (C) 1991-2001 AT&T Corp.
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; $Id: dh-macro.lsh,v 1.50 2006/11/07 20:31:49 leonb Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;; ------------------------------------------------------------------------
;;; ------------------------------------------------------------------------
;;;                  D   H   M       S   E   C   T   I   O  N
;;; ------------------------------------------------------------------------
;;; ------------------------------------------------------------------------


(libload "dh-util")



;;; ------------------------------------------------------------------------
;;; ERASE PREVIOUS DHMS
;;; ------------------------------------------------------------------------

(when dhc-debug-flag
  (when (is-of-class |*PROPERTIES| |HTABLE|)
    (let ((lambda-t (get-dhm-t lambda))
          (lambda-c (get-dhm-c lambda)) )
      (|*PROPERTIES| 'dhm-t ())
      (|*PROPERTIES| 'dhm-c ())
      (|*PROPERTIES| 'dhm-p ()) 
      (putp lambda 'dhm-t lambda-t)
      (putp lambda 'dhm-c lambda-c) ) ) )


;;; ------------------------------------------------------------------------
;;; DHM FOR TYPE DECLARATIONS AND CONVERSIONS
;;; ------------------------------------------------------------------------

(defvar dhc-type-to-dht-alist
  (append (mapfor (i 0 15)
            (list (eval `:,(named (sprintf "-idx%d-" i))) 'dht-idx i) )
          (list (list -bool-   'dht-bool)
                (list -ubyte-  'dht-ubyte)
                (list -byte-   'dht-byte)
                (list -int-    'dht-int)
                (list -short-  'dht-short)
                (list -flt-    'dht-flt)
                (list -real-   'dht-real)  
                (list -str-    'dht-str)
                (list -obj-    'dht-obj)
                (list -list-   'dht-list)
                (list -gptr-   'dht-gptr) ) ) )

(de dhc-format-to-t-node(source)
  (let* ((target (get-dhm-target source))
         (dhassoc (assoc target dhc-type-to-dht-alist))
         (dhtype (when dhassoc (cadr dhassoc)))
         (resultant ()) )
    (when (not dhtype)
      (dhc-error "Unrecognized type specifier" source) )
    (cond
     ;; GPTR
     ((= dhtype 'dht-gptr)
      (setq resultant
            (new t-node () 
                 (new dhc-type dhtype
                      (cond
                       ((stringp (cadr source))
                        (cadr source) )
                       ((cadr source)
                        (sprintf "struct CClass_%s*"
                                 (dhc-lisp-to-c-name (nameof (caadr source))) ) ) ) )
                 (car source)))
      (new t-node (list resultant)
           (==> :resultant:type copy) ()))
     ;; SIMPLE
     ((member dhtype dhc-simple-types)
      (setq resultant
            (new t-node () 
                 (new dhc-type dhtype)
                 (car source)))
      (new t-node (list resultant)
           (==> :resultant:type copy) ()))
     ;; IDX
     ((= dhtype 'dht-idx)
      (let* ((ndim (caddr dhassoc))
             (type-t-node (dhc-format-to-t-node (cadr source)))
             (idx-type (new dhc-type 'dht-ptr
                            (new dhc-type 'dht-idx ndim
                                 (new dhc-type 'dht-srg
                                      (==> :type-t-node:type copy))))))
        (new t-node (list (new t-node () (==> idx-type copy) (car source))
                          type-t-node) 
             (==> idx-type copy)
             ())))
     ;; STR
     ((= dhtype 'dht-str)
      (new t-node ()
           (new dhc-type 'dht-ptr (new dhc-type 'dht-str))
           source ) )
     ;; LIST
     ((= dhtype 'dht-list)
      (let* ((types-t-nodes (all ((arg (cdr source))) (dhc-format-to-t-node arg)))
             (types (all ((tn types-t-nodes)) :tn:type))
             (list-type (new dhc-type 'dht-ptr (new dhc-type 'dht-list types))))
        (new t-node (cons (new t-node () (==> list-type copy) (car source))
                          types-t-nodes) 
             (==> list-type copy) 
             () ) ) )
     ;; OBJECT
     ((= dhtype 'dht-obj)
      (new t-node ()
           (new dhc-type 'dht-ptr (dhc-obj-type-from-class (caadr source))) 
           source ) )
     ;; ERROR 
     (t 
      (dhc-error "declaration type not implemented" (car source)) ) ) ) )


(dhm-p declare(source)
  (if (not (consp (cdr source)))
      source
    (cons (car source)
          (cons (cadr source)
                (dhc-pp-all (cddr source)) ) ) ) )

(dhm-t declare(source)
  (let ((format (cadr source))
        (args (cddr source))
        (args-t-nodes ())
        (format-t-node ())
        (format-dhc-type ())
        (dhc-declaration-mode t))
    (each ((arg args))
      (when ~(symbolp arg) (dhc-error "Not a symbol" arg)))
    (on-error
        (dhc-error "declaration format error" source)
      (verify-type-decl-format format))
    (setq format-t-node (dhc-format-to-t-node format))
    (setq format-dhc-type :format-t-node:type)
    (setq args-t-nodes (dhc-parse-progn-t args))
    (all ((rn :args-t-nodes:tn-list))
	 (dhc-unify-types :rn:type (==> format-dhc-type copy)))
    (new t-node (cons format-t-node (all ((a :args-t-nodes:tn-list)) a))
         (==> format-dhc-type copy) source)))

(dhm-c declare (source treetype retplace)
       (dhc-parse-progn-c (cddr source) (cddr :treetype:tn-list) retplace) )



;;; ------------------------------------------------------------------------

(de dhc-cast-t (source type allowed)
  (if (<> (length source) 2)
      (dhc-error "takes one arg" (car source)))
  (let* ((tn (dhc-parse-expr-t (cadr source) ignore))
         (typename (unode-val (scope :tn:type u-tclass))))
    (if ~(member typename allowed)
      (dhc-error (sprintf "Casting to %s.  One of %s expected: %s found"
                          (pname (dht-short type))
                          (pname allowed)
                          (pname (dht-short typename))))
      (new t-node (list tn) (new dhc-type type) ()))))

(de dhc-cast-c (source stype treetype retplace)
  (concat "(" stype ")(" 
          (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list) ())
          ")" ))

(dhm-t to-number(source)
  (dhc-cast-t source 'dht-number (cons 'dht-dc dhc-number-types)))
(dhm-c to-number(source treetype retplace)
  (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list) retplace) )

(dhm-t to-flt(source)
  (dhc-cast-t source 'dht-flt (cons 'dht-dc dhc-number-types)))
(dhm-c to-flt(source treetype retplace)
  (dhc-cast-c source "flt" treetype retplace))

(dhm-t to-int(source)
  (dhc-cast-t source 'dht-int (cons 'dht-dc dhc-number-types)))
(dhm-c to-int(source treetype retplace)
  (dhc-cast-c source "int" treetype retplace))

(dhm-t to-real(source)
  (dhc-cast-t source 'dht-real (cons 'dht-dc dhc-number-types)))
(dhm-c to-real(source treetype retplace)
  (dhc-cast-c source "real" treetype retplace))

(dhm-t to-bool(source)
  (dhc-cast-t source 'dht-bool (cons 'dht-dc dhc-number-types)))
(dhm-c to-bool(source treetype retplace)
  (dhc-cast-c source "char" treetype retplace))


(dhm-t int(source)
  (dhc-cast-t source 'dht-int (cons 'dht-dc dhc-number-types)))
(dhm-c int(source treetype retplace)
  (concat "((int)floor((double)"
          (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list) retplace)
          "))" ) )

(dhm-t to-gptr(source)
  (dhc-cast-t source 'dht-gptr '(dht-gptr dht-ptr dht-nil dht-func dht-dc)) )

(dhm-c to-gptr(source treetype retplace)
  (let ((argtype :(cadr :treetype:tn-list):type))
    (if (<> (dhu-tclass argtype) 'dht-func)
        ;; simple cast
        (dhc-cast-c source "gptr" treetype retplace)
      ;; function cast
      (let* ((name (cadr source))
             (symbol (dhc-search-symtable name global-table))
             (cfunc ()) )
        (cond
         (symbol
          (setq cfunc (concat "C_" :symbol:c-name)) )
         ((symbolp name)
          (setq cfunc (car (dhinfo-c (eval `:,name)))) )
         (t
          (setq cfunc (car (dhinfo-c name))) ) )
        ;; extern
        (dhc-add-c-externs
         (concat "extern_c " (dhc-compose-prototype argtype cfunc) ";") )
        (sprintf "(gptr)&(%s)" cfunc) ) ) ) )



;;; ------------------------------------------------------------------------
;;; DHM FOR PARSING SPECIAL STRUCTURES
;;; ------------------------------------------------------------------------

(dhm-t progn(source)
  (dhc-parse-progn-t (cdr source)))

(dhm-c progn(source treetype retplace)
  (dhc-parse-progn-c (cdr source) (cdr :treetype:tn-list) retplace))

(dhm-t prog1(source)
  (setq source (cdr source))
  (if (consp source)
      (let ((treetype-list 
             (append (list (dhc-parse-expr-t (car source) ignore))
                     (all ((so (cdr source)))
                       (dhc-parse-expr-t so t)))))
        (new t-node treetype-list :(car treetype-list):type () ()))
    ;; empty prog1
    (new t-node () (new dhc-type 'dht-nil) ())))

(dhm-c prog1(source treetype retplace)
  (let ((source (cdr source))
        (treetype-list (cdr :treetype:tn-list))
        (ret ()))
    (if ~(consp source)
      "0"
      (when (and ~retplace ~:treetype:ignore)
        (setq retplace (dhc-declare-temp-var :treetype:type "_prog1ret")))
      (setq ret (dhc-parse-expr-c (car source) (car treetype-list)
                                  retplace))
      (each ((so (cdr source)) (ty (cdr treetype-list)))
        (dhc-parse-expr-c so ty ()))
      ret)))

(dhm-t setq(source)
  (let ((tn ())
        (cast ())
        (source (cdr source)) )
    (when ~(and (consp source) 
                (consp (cdr source)) (not (cddr source)))
          (dhc-error "Setq takes two arguments" ) )
    ;; scope syntax
    (if (and (consp (car source))
             (= 'scope (car (car source))))
        (let ((sym (dhc-parse-expr-t (car source)))
              (expr (dhc-parse-expr-t (cadr source))))
          (let ((objtype (dhu-type :(last :sym:tn-list):type)))
            (==> objtype access 'write) )
          (setq cast (dhc-ptr-cast () :sym:type :expr:type)) 
          (dhc-assign-unify :sym:type :expr:type)
          (setq tn (new t-node (list sym expr) :sym:type ())) )
      ;; regular syntax
      (let* ((sym (dhc-check-symbol (car source)))
             (expr (dhc-parse-expr-t (cadr source))) )
        (setq cast (dhc-ptr-cast () :sym:type :expr:type))        
        (dhc-assign-unify :sym:type :expr:type)
        (setq tn (new t-node 
                      (list (new t-node () :sym:type (car source) sym) expr)
                      :sym:type) ) ) )
    (setq :tn:transfer cast)
    tn ) )

(dhm-c setq(source treetype retplace)
  ;; scope syntax
  (if (and (consp (cadr source))
           (= 'scope (car (cadr source))))
      (let ((src (dhc-parse-expr-c (cadr source)
                                   (cadr :treetype:tn-list) ()))
            (expr (dhc-parse-expr-c (caddr source)
                                    (caddr :treetype:tn-list) ())) )
        (dhc-add-c-statements
         (if (not :treetype:transfer)
             (sprintf "%s = %s;" src expr)
           (sprintf "%s = %s(%s);" src :treetype:transfer expr) ) )
        src)
    ;; regular syntax
    (let ((src :(cadr :treetype:tn-list):symbol:c-name))
      (if (not :treetype:transfer)
          (dhc-parse-expr-c (caddr source) 
                            (caddr :treetype:tn-list) src)
        (dhc-add-c-statements
         (sprintf "%s = %s(%s);" src :treetype:transfer
                  (dhc-parse-expr-c (caddr source) 
                                    (caddr :treetype:tn-list) () ) ) ) )
      src ) ) )

(dhm-t print(source)
  (if (consp source)
      (let ((treetype-list
             (all ((so (cdr source)))
               (if (stringp so)
                   (new t-node () (new dhc-type 'dht-ptr (new dhc-type 'dht-str)) so ()) 
                 (dhc-parse-expr-t so) ) ) ))
        (if (not (stringp (last source)))
            (new t-node treetype-list :(last treetype-list):type () ())
          (let* ((str-type (new dhc-type 'dht-str))
                 (rettype (new dhc-type 'dht-ptr str-type))
                 (str-symb 
                  (new dhc-symbol 
                       (named (sprintf "%d_srg" tmpnames-seed)) lex-level))
                 (tret 
                  (new t-node treetype-list rettype ())))
            (incr tmpnames-seed)
            (dhc-unify-types :str-symb:type str-type)
            (setq bump-list (append bump-list (list str-symb)))
            (setq :str-symb:no-declare (cons 'no-declare tret))
            (setq :tret:transfer (list str-symb))
            tret)))
    (new t-node () (new dhc-type 'dht-nil) () ())))

;; should be expanded to matrices, etc.
(de dhc-print-c(item treetype)
  (let ((type :treetype:type))
    (dhc-add-c-statements
     (cond ((==> type is-a-bool)
            (sprintf "printf(\"%%s \", (%s==0) ? \"()\" : \"t\");" item))
           ((==> type is-an-integer)
            (sprintf "printf(\"%%ld \", (long)(%s));" item))
           ((==> type is-a-number)
            (sprintf "printf(\"%%g \", (real)(%s));"  item))
           ((==> type is-a-strptr)
            (sprintf "printf(\"\\\"%%s\\\"\", (%s)->data);" item))
           ((==> type is-a-ptr)
            (sprintf "printf(\"%%x \", %s);" retplace))
           (t
            (dhc-error "can't print this this object's type"
                       :treetype:symbol:lisp-name) ) ) ) ) )

(dhm-c print(source treetype retplace)
  (if ~(consp (cdr source))
    "0"
    (each ((ty (dhc-nolast (cdr :treetype:tn-list)))
           (so (dhc-nolast (cdr source))))
      (if (stringp so)
          (dhc-add-c-statements
           (sprintf "printf(\"%%s\", %l);" (pname so)) )
        (dhc-print-c (dhc-parse-expr-c so ty ()) ty)))
    ;; in case the expr being printed returns "inline".
    (let ((ret ()))
      ;; HACK for STRINGS
      (if (stringp (last source))
          (progn (dhc-add-c-statements
                  (sprintf "printf(\"%%s\", %l);"
                           (pname (last source)) ) )
                 (when ~:treetype:ignore
                   (dhc-add-c-statements
                    (sprintf "Msrg_resize(%s,%d+1);"
                             :(last :treetype:transfer):c-name
                             (len (last source))) )
                   (dhc-add-c-statements 
                    (sprintf "strcpy((char*)(%s->data),%l);"
                             :(last :treetype:transfer):c-name
                             (last source) ) )
                   (setq ret :(last :treetype:transfer):c-name))
                 "0")
        (setq ret (dhc-parse-expr-for-multi-use-c 
                   (last source) (last :treetype:tn-list) retplace))
        (dhc-print-c ret (last :treetype:tn-list)))
      (when (getp (get-dhm-target source) 'dharg)
        (dhc-add-c-statements "printf(\"\\n\");"))
      ret)))

(putp print 'dharg t)
(dhm-t-declare print prin)
(dhm-c-declare print prin)


(dhm-t error(source)
  (when (or (cddr source) (not (stringp (cadr source))))
    (dhc-error "bad error statement"))
  ;; can't parse string arg
  ;; don't know what will be returned
  (new t-node (list (new t-node () (new dhc-type 'dht-unk) (cadr source)))
       (new dhc-type 'dht-dc)))

(dhm-c error(source treetype retplace)
  (dhc-add-c-statements (sprintf "run_time_error(\"%s\");" (cadr source)))
  (if (and (==> :treetype:type is-a-simple)
           ~(==> :treetype:type is-a-dhm))
      "0" ;; good for numbers, bools, etc
    (dhc-error "error statement's return value conflicts" source)))


(de dhc-for-declare-var-t(dcl)
  (when (or (> (length dcl) 4) (< (length dcl) 3))
    (dhc-error "Bad 'for' arguments" dcl) )
  (when ~(symbolp (car dcl))
        (dhc-error "Not a symbol" (car dcl)))
  (let* ((loop (new dhc-symbol (car dcl) lex-level))
         (start (dhc-parse-expr-t (cadr dcl)))
         (end (dhc-parse-expr-t (caddr dcl)))
         (step (when (= (length dcl) 4) (dhc-parse-expr-t (nth 3 dcl))))
         (tlist (if step (list start end step) (list start end)))
         (treetype (new t-node
                        (cons (new t-node () :loop:type (car dcl) loop)
                              tlist)
                        (new dhc-type 'dht-unk))))
    (dhc-unify-types :start:type :end:type)
    (when step (dhc-unify-types :start:type :step:type))
    (dhc-assign-unify :loop:type :start:type)
    (setq bump-list (append bump-list (list loop)))
    (setq :treetype:ignore t)
    (setq new-symbol-table 
          (dhc-add-to-symtable new-symbol-table loop))
    treetype))

(dhm-t for(source)
  (when (or (< (length source) 2)
            ~(consp (cadr source)))
    (dhc-error "for : Bad 'for' construction"))
  (let ((tn ())
        (tn2 ()))
    (dhc-push-scope-t
     (setq tn2 (dhc-for-declare-var-t (cadr source)))
     (setq symbol-table new-symbol-table)
     (setq tn (dhc-parse-progn-t (cddr source)))
     (setq :tn:tn-list (cons tn2 :tn:tn-list))
     (setq :tn:transfer ignore)
     tn)))

(dhm-c for(source treetype retplace)
  (let (( (loop start end &optional step) (cadr source))
        ( (loopT startT endT &optional stepT)
          :(cadr :treetype:tn-list):tn-list)
        (loopN ())
        (endN ())
        (stepN ()))
    (when ~step
      (setq step 1)
      (setq stepT (dhc-parse-expr-t 1)))
    
    (dhc-push-scope-c 
     treetype retplace
     (setq endN (dhc-parse-expr-for-multi-use-c end endT ()))
     (setq stepN (dhc-parse-expr-for-multi-use-c step stepT ()))
     (setq loopN (scope :loopT:symbol c-name))
     (dhc-parse-expr-for-multi-use-c start startT loopN)
     (if (not (or dhc-unprotect :treetype:transfer))
         (dhc-add-c-statements
          (sprintf "RTERR_RTYPE(!((%s>0)?(%s<=%s):(%s>=%s)));\n"
                   stepN loopN endN loopN endN)))
     (dhc-add-c-statements
      (sprintf "for(;")
      (sprintf "((%s>0)?(%s<=%s):(%s>=%s));"
               stepN loopN endN loopN endN )
      (sprintf "(%s)+=%s ) {" loopN stepN )
      )
     (setq retplace (dhc-parse-progn-c (cddr source)
                                       (cddr :treetype:tn-list)
                                       retplace))
     (dhc-add-c-statements "}")
     retplace )))

(dhm-t-declare progn protect unprotect)

(dhm-c protect(source treetype retplace)
       (let ((dhc-unprotect ()))
	 (dhc-parse-progn-c (cdr source)
			    (cdr :treetype:tn-list) retplace)))

(dhm-c unprotect(source treetype retplace)
       (let ((dhc-unprotect t))
	 (dhc-parse-progn-c (cdr source)
			    (cdr :treetype:tn-list) retplace)))

(dhm-t breakp(source)
  (when (<> 1 (length source))
    (dhc-error "breakp takes no arguments!"))
  (new t-node () (new dhc-type 'dht_nil)))

(dhm-c breakp(source treetype retplace)
  (dhc-add-c-statements 
   "if(break_attempt) run_time_error(\"breakp in compiled code\");")
  "0")


;;; ------------------------------------------------------------------------
;;; DHM FOR DIRECT CALL OF C FUNCTION
;;; ------------------------------------------------------------------------

(dhm-t ccall(source)
  (when (< (length source) 2)
    (dhc-error "one or more args expected"))
  (new t-node (append (list (new t-node () (new dhc-type 'dht-unk) (cadr source)))
                      (all ((so (cddr source))) (dhc-parse-expr-t so)))
       (new dhc-type 'dht-dc)))

(dhm-c ccall(source treetype retplace)
  (let ((name (cadr source))
        (args (all ((so (cddr source)) (tn (cddr :treetype:tn-list)))
                (dhc-parse-expr-for-multi-use-c so tn ()))))
    ;; is not typed, so we can't create a retplace
    ;; if return value is not ignored, we must return inline
    (if ~:treetype:ignore
        (sprintf "%s(%s)" name (dhc-insert-op args ","))
      (dhc-add-c-statements
       (sprintf "%s(%s);" name (dhc-insert-op args ",")))
      "" )))

(dhm-t cinline(source)
  (when (< (length source) 2)
    (dhc-error "one or more args expected"))
  (new t-node (append (list (new t-node () (new dhc-type 'dht-unk) (cadr source)))
                      (all ((so (cddr source))) (dhc-parse-expr-t so)))
       (new dhc-type 'dht-dc)))

(dhm-c cinline(source treetype retplace)
  (let ((fmt (cadr source))
        (args (all ((so (cddr source)) (tn (cddr :treetype:tn-list)))
                (dhc-parse-expr-for-multi-use-c so tn ())))
        (line ()))
    (setq line (apply 'sprintf (cons fmt args)))
    ;; is not typed, so we can't create a retplace
    ;; if return value is not ignored, we must return inline
    (if ~:treetype:ignore
        line
      (if (not (regex-match ".*(;|}|\n#[^\n]*)[ \n]*$" line))
          (setq line (concat line ";")) )
      (dhc-add-c-statements line)
      "" )))

(dhm-t cheader (source)
  (when (< (length source) 2)
    (dhc-error "one or more args expected"))
  (each ((s (cdr source)))
    (if ~(stringp s)
      (dh-error "string expected" s)))
  (new t-node (all ((so (cdr source))) 
                (new t-node () (new dhc-type 'dht-unk)))
       (new dhc-type 'dht-dc)))

(dhm-c cheader (source treetype-list retplace)
  (dhc-add-c-header (cdr source)))

(de cpheader (name . args)
  (error NIL "cpheader can only be called in a compiled function"))

(dhm-t cpheader (source)
  (when (< (length source) 2)
    (dhc-error "one or more args expected"))
  (each ((s (cdr source)))
    (if ~(stringp s)
      (dh-error "string expected" s)))
  (new t-node (all ((so (cdr source))) 
                (new t-node () (new dhc-type 'dht-unk)))
       (new dhc-type 'dht-dc)))

(dhm-c cpheader (source treetype-list retplace)
  (dhc-add-c-pheader (cdr source)))

(dhm-t cidx-bloop(source)
  (when ~(cddr source)
        (dhc-error "cidx-bloop syntax error"))
  (let ((vars ())
        (ignore t)
        (vars-t ())
        (inds ())
        (inds-t ())
        (tn ())
        (ret ()))
    (each ((truc (cadr source)))
      (if ~(stringp truc)
        (progn
          (if (or (<> (length truc) 2) ~(stringp (car truc)))
              (dhc-error
               (sprintf 
                "syntax error in decls: expecting (\"cvar\" lvar)%l"
                truc)))
          (setq inds (nconc1 inds truc)))
        (if inds
            (dhc-error
             (sprintf 
              "syntax error in decls: expecting (\"cvar\" lvar): %l" 
              truc)))
        (setq vars (nconc1 vars truc))))
    ;; parse loop indices
    (if ~vars
        (dhc-error
         "syntax error in decls: no looping string integer index found"))
    (setq vars-t (all ((var vars)) 
                   (new t-node () 
                        (new dhc-type 'dht-ptr (new dhc-type 'dht-str)) 
                        var)))
    (when (> (length vars) 8)
      (dhc-error "Cannot loop on idx with more than 8 dimensions"))
    ;; parse idxes
    (if ~inds
        (dhc-error
         "syntax error in decls: no idx to loop on found"))
    (setq inds-t 
          (all ((ind inds))
            (let ((cname (new t-node () 
                              (new dhc-type 'dht-ptr (new dhc-type 'dht-str))
                              (car ind)))
                  (lvar (dhc-parse-expr-t (cadr ind))))
              (if ~(==> :lvar:type is-an-idxptr)
                (dhc-error
                 (sprintf "syntax error in decls: idx expected: %l"
                          (cadr ind))))
              (if (< (==> :lvar:type is-an-idxptr) (length vars))
                  (dhc-error
                   (sprintf "idx does not have enough dimensions: %l"
                            (cadr ind))))
              (new t-node (list cname lvar) (new dhc-type 'dht-nil)))))
    (setq tn (new t-node (append vars-t inds-t) (new dhc-type 'dht-nil)))
    (setq ret (dhc-parse-progn-t (cddr source)))
    (setq :ret:tn-list (cons tn :ret:tn-list))
    (setq :ret:type :(cadr :(last inds-t):tn-list):type)
    ret)))

(dhm-c cidx-bloop(source treetype retplace)
  (let ((inames ())
        (cnames ())
        (idxs ())
        (idxs-names ())
        (idxtypes ())
        (ret-expr ())
        (indices ())
        (matrices ())
        (idxi ())
        (n ()))
    (each ((so (cadr source)) (tn :(cadr :treetype:tn-list):tn-list))
      (if (stringp so)
          (setq inames (nconc1 inames so))
        (setq cnames (nconc1 cnames (car so)))
        (setq idxs (nconc1 idxs
                           (dhc-parse-expr-c (cadr so) 
                                             (cadr :tn:tn-list) ())))
        (setq idxtypes (nconc1 idxtypes (==> :(cadr :tn:tn-list):type
                                             get-element-decl)))))
    (setq idxi (length inames))
    (setq n (length cnames))
    (setq idxs-names (mapcar (lambda (x) (regex-subst "&|->" "_" x))
                             idxs))
    (dhc-add-c-statements "{")
    (for (i 0 (1- idxi))
         (dhc-add-c-statements (sprintf "int _%s_max = (%s)->dim[%d];"
                                        (nth i inames) (car idxs) i))
         (for (j 0 (1- n))
              (dhc-add-c-statements 
               (sprintf "int _%s_mod%d = (%s)->mod[%d];" 
                        (nth j idxs-names) i (nth j idxs) i))))
    
    (for (i 0 (1- idxi))
         (for (j 1 (1- n))
              (dhc-add-c-statements
               (sprintf "if(_%s_max != (%s)->dim[%d])"
                        (nth i inames) (nth j idxs) i)
               (sprintf 
                (concat "run_time_error(\"idx %s's dim %d "
                        "doesn't match idx %s's dim %d\");")
                (nth j idxs) i (car idxs) i))))
    (dhc-add-c-statements "{")
    (for (i 0 (1- idxi))
         (dhc-add-c-statements (sprintf "int %s;" (nth i inames)))
         (for (j 0 (1- n))
              (dhc-add-c-statements 
               (concat (sprintf "%s " (nth j idxtypes))
                       (if (= i (- idxi 1))
                           (sprintf "*%s = " (nth j cnames))
                         (sprintf "*_%s_loop_%s = " (nth j idxs-names)
                                  (nth i inames)))
                       (if (= i 0)
                           (sprintf "IDX_PTR((%s),%s);"
                                    (nth j idxs) (nth j idxtypes))
                         (sprintf "_%s_loop_%s;" (nth j idxs-names)
                                  (nth (1- i) inames))))))
         (dhc-add-c-statements (sprintf "for (%s=0; %s<_%s_max; %s++) {"
                                        (nth i inames) (nth i inames)
                                        (nth i inames) (nth i inames))))
    (dhc-parse-progn-c (cddr source) (cddr :treetype:tn-list) ())
    (for (i 0 (1- idxi))
         (for (j 0 (1- n))
              (dhc-add-c-statements
               (concat 
                (if (= i 0) 
                    (sprintf "%s" (nth j cnames))
                  (sprintf "_%s_loop_%s" (nth j idxs-names)
                           (nth (1- (- idxi i))
                                inames)))
                " += " (sprintf "_%s_mod%d;" (nth j idxs-names)
                                (1- (- idxi i))))))
         (dhc-add-c-statements "}"))
    (dhc-add-c-statements "}}")
    (last idxs)))


;;; ------------------------------------------------------------------------
;;; functions for parsing TESTS
;;; ------------------------------------------------------------------------

(dhm-t and(source)
  (let ((ands (reverse (cdr source)))
        (expr '(progn t)))
    (while ands    
      (setq expr `(if ,(car ands) ,expr ()))
      (setq ands (cdr ands)))
    (dhc-parse-replacement-source-t source expr)))

(dhm-t or(source)
  (let ((ors (reverse (cdr source)))
        (expr '(progn ())))
    (while ors    
      (setq expr `(if ,(car ors) t ,expr))
      (setq ors (cdr ors)))
    (dhc-parse-replacement-source-t source expr)))

(dhm-t not(source)
  (when (<> 2 (length source))
    (dhc-error "'not' takes one argument"))
  (let ((tn (dhc-parse-expr-t (cadr source))))
    (when (<> 'dht-gptr (dhu-tclass :tn:type))
      (dhc-unify-types :tn:type (new dhc-type 'dht-bool)) )
    (new t-node (list tn) (new dhc-type 'dht-bool))))

(dhm-c not(source treetype retplace)
  (sprintf  "!(%s)"
            (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list)
                              retplace)))

;; also uses source
(de dhc-comparison-t(cop)
  (when (<> 3 (length source))
    (dhc-error "this operator takes two arguments"))
  (let* ((r1 (dhc-parse-expr-t (cadr source)))
         (r2 (dhc-parse-expr-t (caddr source)))
         (t1 :r1:type)
         (t2 :r2:type))   
    (when (and ~(and (==> t1 is-a-number) (==> t2 is-a-number))
               ~(and (==> t1 is-a-bool) (==> t2 is-a-bool))
               ~(and (==> t1 is-a-gptr) (==> t2 is-a-gptr))
               ~(and (==> t1 is-a-strptr) (==> t2 is-a-strptr))
               ~(and (==> t1 is-an-objptr) (==> t2 is-an-objptr) 
                     (or (= cop "==") (= cop "!="))) )
      (dhc-error "illegal type(s) for test expression" t1))
    ;; (dhc-unify-types (==> t1 copy) (==> t2 copy))
    (new t-node (list r1 r2) (new dhc-type 'dht-bool))))

;; also uses source treetype retplace
(de dhc-comparison-c(cop)
  ;; if ~ignore unify bool ??
  (let ((e1 (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list) ()))
        (e2 (dhc-parse-expr-c (caddr source) (caddr :treetype:tn-list) ())))
    (cond
     ((==> :(cadr :treetype:tn-list):type is-a-strptr)
      (sprintf "(strcmp((%s)->data, (%s)->data) %s 0)" 
               e1 e2 cop) )
     ((==> :(cadr :treetype:tn-list):type is-an-objptr)
      (sprintf "(memcmp((%s), (%s), sizeof(*(%s))) == 0)" e1 e2 e1) )
     (t
      (concat "(" e1 cop e2 ")" ) ) ) ) )


(dhm-t =(source)                   (dhc-comparison-t "=="))
(dhm-c =(source treetype retplace) (dhc-comparison-c "=="))

(dhm-t <>(source)                   (dhc-comparison-t "!="))
(dhm-c <>(source treetype retplace) (dhc-comparison-c "!="))

(dhm-t <(source)                   (dhc-comparison-t "<"))
(dhm-c <(source treetype retplace) (dhc-comparison-c "<"))

(dhm-t >(source)                   (dhc-comparison-t ">"))
(dhm-c >(source treetype retplace) (dhc-comparison-c ">"))

(dhm-t <=(source)                   (dhc-comparison-t "<="))
(dhm-c <=(source treetype retplace) (dhc-comparison-c "<="))

(dhm-t >=(source)                   (dhc-comparison-t ">="))
(dhm-c >=(source treetype retplace) (dhc-comparison-c ">="))


(dhm-t ==(source)
   (when (<> 3 (length source))
     (dhc-error "this operator takes two arguments"))
   (let* ((r1 (dhc-parse-expr-t (cadr source)))
          (r2 (dhc-parse-expr-t (caddr source)))
          (t1 :r1:type)
          (t2 :r2:type))   
     (when (and ~(and (==> t1 is-a-number) (==> t2 is-a-number))
                ~(and (==> t1 is-a-bool) (==> t2 is-a-bool))
                ~(and (==> t1 is-a-gptr) (==> t2 is-a-gptr))
                ~(and (==> t1 is-a-ptr) (==> t2 is-a-ptr)) )
       (dhc-error "illegal type(s) for test expression" t1))
    (new t-node (list r1 r2) (new dhc-type 'dht-bool)) ) )

(dhm-c ==(source treetype retplace)
  (let ((e1 (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list) ()))
        (e2 (dhc-parse-expr-c (caddr source) (caddr :treetype:tn-list) ())))
    (concat "(" e1 "==" e2 ")" ) ) )


;;; ------------------------------------------------------------------------
;;; DHM for parsing conditional structures if, when while....
;;; ------------------------------------------------------------------------

(dhm-t if(source)
  (when (< (length source) 3)
    (dhc-error (sprintf "bad '%l' construction:" (car source)) source))
  (let ((test (dhc-parse-expr-t (cadr source)))
        (true (dhc-parse-expr-t (caddr source) ignore))
        (false (when (> (length source) 3)
                 (dhc-parse-progn-t (nthcdr 3 source))))
        (rettype (new dhc-type 'dht-unk)))
    (when (<> 'dht-gptr (dhu-tclass :test:type))
      (dhc-unify-types :test:type (new dhc-type 'dht-bool)) )
    (when ~ignore
      (if false
          (progn 
            (dhc-assign-unify rettype :true:type)
            (dhc-assign-unify rettype :false:type))
        (dhc-unify-types :true:type (new dhc-type 'dht-bool))
        (dhc-unify-types rettype (new dhc-type 'dht-bool))))
    (new t-node (if false (cons test (cons true :false:tn-list))
                  (list test true))
         rettype () ())))

;; NOTE 'if' can produce empty 'then' and 'else' blocks if ignore is set
;; (progn (if t 1 2) 3)
;; this is true in sn3.0, if the user codes it...
(dhm-c if(source treetype retplace)
  (when (and ~retplace ~:treetype:ignore)
    (setq retplace (dhc-declare-temp-var :treetype:type)))
  (let (((ift testtn . bodytn) :treetype:tn-list)
        ((ifs testso . bodyso) source))
    (when (and ~:treetype:ignore
               (or (= ifs 'when) (= (length bodyso) 1)))
      (dhc-add-c-statements (sprintf "%s = 0;" retplace)))
    (let ((testc (dhc-parse-expr-c testso testtn () )))
      (dhc-add-c-statements (concat " if (" testc ") { " )))
    (when (= (get-dhm-target source) :if)
      (dhc-parse-expr-c (car bodyso) (car bodytn) retplace)
      (setq bodyso (cdr bodyso))
      (setq bodytn (cdr bodytn))
      (when (> (length bodyso) 0)
        (dhc-add-c-statements " } else { ")))
    (when (> (length bodyso) 0)
      (dhc-parse-progn-c bodyso bodytn retplace))
    (dhc-add-c-statements " } ")
    retplace ) )

(dhm-t when(source)
  (when (< (length source) 3)
    (dhc-error (sprintf "bad '%l' construction:" (car source)) source))
  (let ((test (dhc-parse-expr-t (cadr source)))
        (true (dhc-parse-progn-t (cddr source))))
    (when (<> 'dht-gptr (dhu-tclass :test:type))
      (dhc-unify-types :test:type (new dhc-type 'dht-bool)) )
    (when ~ignore
      (dhc-unify-types :true:type (new dhc-type 'dht-bool)))
    (new t-node (cons test :true:tn-list)
         :true:type () ())))

(dhm-c-declare if when)

(dhm-t cond(source)
  (if (or ~(cdr source) (apply or (mapcar null (cdr source))))
      (dhc-error "cond : Bad 'cond' construction"))
  (let ((conds (reverse (cdr source)))
        (expr (if ~ignore '(error "one condition of the cond must be true") ())))
    (while conds    
      (setq expr `(if ,(caar conds) ,(cons 'progn (cdar conds)) ,expr))
      (setq conds (cdr conds)))
    (dhc-parse-replacement-source-t source expr)))

(dhm-t selectq(source)
  (when (or ~(cdr source) ~(cddr source)
            (apply or (mapcar null (cddr source))))                     
    (dhc-error "selectq : Bad 'selectq' construction"))
  (let ((conds (reverse (cddr source)))
        (expr (if ~ignore '(error "one condition of the selectq must be true") ())) )
    (while conds  
      (setq expr `(if ,(if (= t (caar conds)) t
                         (if (or (numberp (caar conds))
                                 (stringp (caar conds)) )
                             `(= selectQTMP ,(caar conds))
                           (cons 'or (mapcar (lambda (x)
                                               `(= selectQTMP ,x))
                                             (caar conds)))))
                      ,(cons 'progn (cdar conds)) ,expr))
      (setq conds (cdr conds)))
    (setq expr `(let ((selectQTMP ,(cadr source))) ,expr))
    (dhc-parse-replacement-source-t source expr)))

(dhm-t while(source)
  (when (< (length source) 2)
    (dhc-error "while : Bad 'while' construction"))
  (let ((tn (dhc-parse-progn-t (cddr source)))
        (tn2 (dhc-parse-expr-t (cadr source))))
    (when (<> 'dht-gptr (dhu-tclass :tn2:type))
      (dhc-unify-types :tn2:type (new dhc-type 'dht-bool)) )
    (setq :tn:tn-list (cons tn2 :tn:tn-list))
    tn))

(dhm-c while(source treetype retplace)
  (when ~:treetype:ignore
    (when ~retplace
      (setq retplace (dhc-declare-temp-var :treetype:type)))
    (dhc-add-c-statements (sprintf "%s = 0;" retplace)))
  (let ((test (cadr source))
        (testT (cadr :treetype:tn-list))
        (label1 (sprintf "L_%d" (dhc-postincr label-seed)))
        (label2 (sprintf "L_%d" (dhc-postincr label-seed)))
        (ret ()))
    (dhc-add-c-statements
     (concat "/* While loop */\n"
             (sprintf "goto %s;\n" label2)
             (sprintf "%s:\n" label1)
             "{"
             ))
    (setq ret (dhc-parse-progn-c (cddr source) (cddr :treetype:tn-list)
                                 retplace))
    (dhc-add-c-statements (concat "}\n"
                                  "/* While loop test*/\n"
                                  (sprintf "%s:\n" label2)
                                  "{"))
    ;; assumes anything returned inline is a C expression (teste)
    (let ((teste (dhc-parse-expr-c test testT ())))
      (dhc-add-c-statements (concat (sprintf "if (%s) goto %s;\n"
					     teste label1 ))
			    "}"))
    ret))



;;; ------------------------------------------------------------------------
;;; DHM for parsing LET and LET* ...
;;; ------------------------------------------------------------------------

(de dhc-let-declare-var-t(dcl)
    (when ~(and (consp dcl) (consp (cdr dcl)) (null (cddr dcl)))
	  (dhc-error "Syntax error" dcl) )
    (when ~(symbolp (car dcl))
	  (dhc-error "Not a symbol" (car dcl)))
    
    (let* ((sym (new dhc-symbol (car dcl) lex-level))
	   (ini (cadr dcl))
	   (node (dhc-parse-expr-t ini))
	   (symb-ini ())
	   (treetype (new t-node
			  (list (new t-node () :sym:type (car dcl) sym)
				node)
			  (new dhc-type 'dht-unk))))

      (dhc-assign-unify :sym:type :node:type)
      (setq :sym:type:u-access :node:type:u-access)

      ;; For name replacement.  It set no-declare to the alternate name
      (when (symbolp ini)
	    (setq symb-ini (dhc-search-symtable ini symbol-table))
	    (if symb-ini
		(setq :sym:no-declare symb-ini)))

      (setq bump-list (append bump-list (list sym)))
      (setq :treetype:ignore t)
      (setq new-symbol-table 
	    (dhc-add-to-symtable new-symbol-table sym))
      treetype))

(dhm-t let(source)
       (when ~(cddr source)
	     (dhc-error "'let syntax error"))
       (let ((tn ())
	     (ret ()))
	 (dhc-push-scope-t 
	  (setq tn (new t-node (all ((dcl (cadr source)))
                                 (dhc-let-declare-var-t dcl))
			(new dhc-type 'dht-unk)))
	  (setq symbol-table new-symbol-table)
	  (setq ret (dhc-parse-progn-t (cddr source)))
	  (setq :ret:tn-list (cons tn :ret:tn-list))
	  ret)))

(dhm-c let(source treetype retplace)
  (dhc-push-scope-c 
   treetype retplace
   (all ((decl (cadr source)) 
         (decl-type :(cadr :treetype:tn-list):tn-list))
     (dhc-parse-expr-c (cadr decl) (cadr :decl-type:tn-list)
                       :(car :decl-type:tn-list):symbol:c-name))
   (dhc-parse-progn-c (cddr source) (cddr :treetype:tn-list) retplace)))

(dhm-t let*(source)
  (when ~(cddr source)
        (dhc-error "'let syntax error"))
  (let ((tn ())
        (ret ()))
    (setq ret (dhc-push-scope-t 
               (setq tn (new t-node 
                             (all ((dcl (cadr source)))
                               (prog1
                                   (dhc-let-declare-var-t dcl)
                                 (setq symbol-table new-symbol-table)))
                             (new dhc-type 'dht-unk)))
               (dhc-parse-progn-t (cddr source))))
    (setq :ret:tn-list (cons tn :ret:tn-list))
    ret))

(dhm-c-declare let let*)





;;; ------------------------------------------------------------------------
;;; DHM FOR PARSING NUMBER OPERATIONS
;;; ------------------------------------------------------------------------

#? (process-numerical-args-t <arglist> <rettype>)
;; Process the arguments of a numerical expression, and determine the type of
;; the returned value. The arguments are passed in <arglist>, and the
;; type of the return value in <rettype>.
;;
(de process-numerical-args-t (arglist &optional forcertyp)
  ;; determin the natural type of each arglist, except if rettype is
  (let* ((types (all ((x arglist)) (dhc-parse-expr-t x)))
         (rtyp (1+ (length dhc-number-types))))
    ;; determine return type of arglist. Casting is: number->int ->flt ->real
    ;; use priority order determined by dhc-number-types
    (each ((y types) (x arglist)) 
      (if (not (==> :y:type is-a-number)) 
          (dhc-error "not a numerical expression" x))
      (let ((prio (length (member (dhu-tclass :y:type) dhc-number-types))))
        (setq rtyp (min rtyp prio)) ) )
    (setq rtyp (or forcertyp (nth (1- rtyp) (reverse dhc-number-types))))
    (new t-node types (new dhc-type rtyp))))

(de process-numerical-args-c (source treetype func-string)
  (concat "(" (dhc-insert-op 
               (all ((so (cdr source)) (ty (cdr :treetype:tn-list)))
                 (dhc-parse-expr-c so ty ()))
               func-string) ")"))

(de process-numerical-args-with-cast-c (source treetype cast func-string)
  (concat "(" (dhc-insert-op 
               (all ((so (cdr source)) (ty (cdr :treetype:tn-list)))
                 (concat "((" cast ")" (dhc-parse-expr-c so ty ()) ")") )
               func-string) ")"))


;;; N-ADIC FUNCTIONS
;;; -----------------

(dhm-t +(source)
       (process-numerical-args-t (cdr source)))

(dhm-c +(source treetype retplace)
       (process-numerical-args-c source treetype "+"))

(dhm-t *(source)
       (process-numerical-args-t (cdr source)))

(dhm-c *(source treetype retplace)
       (process-numerical-args-c source treetype "*"))

;;; DIADIC FUNCTIONS
;;; -----------------
(dhm-t -(source)
  (when (and (<> 2 (length source)) (<> 3 (length source)) )
	(dhc-error "wrong number of arguments"))
  (process-numerical-args-t (cdr source)))

(dhm-c -(source treetype retplace)
   (let ((arg1 (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list) ())))
     (if (= (length source) 2)
	 (concat "(-" arg1 ")")
       (concat "(" arg1 "-" (dhc-parse-expr-c (caddr source) 
					      (caddr :treetype:tn-list)
					      ()) ")"))))

(dhm-t /(source)
  (when (and (<> 2 (length source)) (<> 3 (length source)) )
	(dhc-error "wrong number of arguments"))
  (let ((tnode (process-numerical-args-t (cdr source))))
    ;; integer division in C isn't used
    (when (==> :tnode:type is-an-int)
      (setq :tnode:type (new dhc-type 'dht-real)))
    tnode))

(de dhc-c-cast (type)
    (if (==> type is-a-real) "(real)"
      (if (==> type is-a-flt) "(flt)" "")))

(dhm-c /(source treetype retplace)
       (let ((arg1 (dhc-parse-expr-c (cadr source) 
				     (cadr :treetype:tn-list) ())))
	 (if (= (length source) 2)
	     (sprintf "(1/%s%s)" (dhc-c-cast :treetype:type) 
		      arg1)
	   (sprintf "(%s/%s%s)" 
		    arg1 (dhc-c-cast :treetype:type)
		    (dhc-parse-expr-c (caddr source) 
				      (caddr :treetype:tn-list)
				      ())))))

(dhm-t div(source)
  (when (<> 3 (length source))
	(dhc-error "wrong number of arguments"))
  (process-numerical-args-t (cdr source) 'dht-int))

(dhm-c div(source treetype retplace)
  (process-numerical-args-with-cast-c source treetype "int" "/") )

(dhm-t mod(source)
  (when (<> 3 (length source))
	(dhc-error "wrong number of arguments"))
  (process-numerical-args-t (cdr source) 'dht-int))

(dhm-c mod(source treetype retplace)
  (process-numerical-args-with-cast-c source treetype "int" "%") )

(dhm-t bitand(source)
  (process-numerical-args-t (cdr source) 'dht-int))

(dhm-c bitand(source treetype retplace)
  (process-numerical-args-with-cast-c source treetype "int" "&"))

(dhm-t bitor(source)
  (process-numerical-args-t (cdr source) 'dht-int))

(dhm-c bitor(source treetype retplace)
  (process-numerical-args-with-cast-c source treetype "int" "|"))

(dhm-t bitxor(source)
  (process-numerical-args-t (cdr source) 'dht-int))

(dhm-c bitxor(source treetype retplace)
  (process-numerical-args-with-cast-c source treetype "int" "^"))

(dhm-t bitshl(source)
  (when (<> 3 (length source))
    (dhc-error "wrong number of arguments"))
  (process-numerical-args-t (cdr source) 'dht-int))

(dhm-c bitshl(source treetype retplace)
  (process-numerical-args-with-cast-c source treetype "int" "<<") )

(dhm-t bitshr(source)
  (when (<> 3 (length source))
    (dhc-error "wrong number of arguments"))
  (process-numerical-args-t (cdr source) 'dht-int))

(dhm-c bitshr(source treetype retplace)
  (process-numerical-args-with-cast-c source treetype "int" ">>") )

(dhm-t **(source)
  (when (<> 3 (length source)) (dhc-error "wrong number of arguments"))
  (process-numerical-args-t (cdr source)))

(dhm-c **(source treetype retplace)
  (concat "pow((double)(" 
          (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list) ())
	  "),(double)("
          (dhc-parse-expr-c (caddr source) (caddr :treetype:tn-list) ())
	  "))"))

(dhm-t max(source)
  (when (<> 3 (length source)) (dhc-error "two arguments expected"))
  (dhc-parse-replacement-source-t
   source
   `(let ((a ,(cadr source)) (b ,(caddr source)))
      (if (,(if (= (get-dhm-target source) :max) '> '<) a b) a b))))

(dhm-t-declare max min)


;;; MONADIC FUNCTIONS
;;; -----------------


;; if argument is an int, but fop is defined, cast int to real and return real

(de generate-monadic (symb dop fop iop)
  ;; generate the dhm-t
  (eval `(dhm-t ,symb (source)
           (if (<> (length source) 2)
               (dhc-error "one argument expected"))
           (let* ((arg-treetype (dhc-parse-expr-t (cadr source)))
                  (arg-type :arg-treetype:type)
                  (ret-type arg-type))
             (when (or ,@(when (not iop) '((==> arg-type is-an-int)))
                       ,@(when (not fop) '((==> arg-type is-an-flt))) )
               (setq ret-type (new dhc-type 'dht-real)) )
             (new t-node (list arg-treetype) ret-type) ) ))
  ;; generate the dhm-c
  (eval `(dhm-c ,symb (source treetype retplace)
           (let* ((ret-type :treetype:type)
                  (arg-source (cadr source))
                  (arg-treetype (cadr :treetype:tn-list))
                  (arg-type :arg-treetype:type)
                  (ret-decl (dhc-type-to-c-decl ret-type))
                  (arg-decl (dhc-type-to-c-decl arg-type)) 
                  (rez (dhc-parse-expr-c arg-source arg-treetype ())))
             (when (<> ret-decl arg-decl)
               (setq rez (sprintf "(%s)(%s)" ret-decl rez)) )
             (cond
              ((and (==> ret-type is-a-flt) ,fop)
               (sprintf ,fop rez))
              ((and (==> ret-type is-a-real) ,dop)
               (sprintf ,dop rez))
              ((and (==> ret-type is-an-int) ,iop)
               (sprintf ,iop rez))
              (t 
               (dhc-error "no function for that type") ) ) ) )) )


(generate-monadic 'sgn "Dsgn(%s)" "Fsgn(%s)" "((%s)<0)?-1:1)")
(generate-monadic 'abs "Dabs(%s)" "Fabs(%s)" "abs(%s)")
(generate-monadic 'sqrt "Dsqrt(%s)" "Fsqrt(%s)" ())
(generate-monadic '0-x-1 "Dpiece(%s)" "Fpiece(%s)" ())
(generate-monadic '0-1-0 "Drect(%s)" "Frect(%s)" ())
(generate-monadic 'sin "Dsin(%s)" "Fsin(%s)" ())
(generate-monadic 'cos "Dcos(%s)" "Fcos(%s)" ())
(generate-monadic 'tan "Dtan(%s)" "Ftan(%s)" ())
(generate-monadic 'asin "Dasin(%s)" "Fasin(%s)" ())
(generate-monadic 'acos "Dacos(%s)" "Facos(%s)" ())
(generate-monadic 'atan "Datan(%s)" "Fatan(%s)" ())
(generate-monadic 'exp "Dexp(%s)" "Fexp(%s)" ())
(generate-monadic 'exp-1 "Dexpm1(%s)" "Fexpm1(%s)" ())
(generate-monadic 'log "Dlog(%s)" "Flog(%s)" ())
(generate-monadic 'log1+ "Dlog1p(%s)" "Flog1p(%s)" ())
(generate-monadic 'tanh "Dtanh(%s)" "Ftanh(%s)" ())
(generate-monadic 'cosh "Dcosh(%s)" "Fcosh(%s)" ())
(generate-monadic 'sinh "Dsinh(%s)" "Fsinh(%s)" ())
(generate-monadic 'qtanh "DQtanh(%s)" "FQtanh(%s)" ())
(generate-monadic 'qdtanh "DQDtanh(%s)" "FQDtanh(%s)" ())
(generate-monadic 'qstdsigmoid "DQstdsigmoid(%s)" "FQstdsigmoid(%s)" ())
(generate-monadic 'qdstdsigmoid "DQDstdsigmoid(%s)" "FQDstdsigmoid(%s)" ())
(generate-monadic 'atanh "Datanh(%s)" "Fatanh(%s)" ())
(generate-monadic 'qexpmx "DQexpmx(%s)" "FQexpmx(%s)" ())
(generate-monadic 'qdexpmx "DQDexpmx(%s)" "FQDexpmx(%s)" ())
(generate-monadic 'qexpmx2 "DQexpmx2(%s)" "FQexpmx2(%s)" ())
(generate-monadic '1+ "((%s)+1)" "((%s)+1)" "((%s)+1)")
(generate-monadic '1- "((%s)-1)" "((%s)-1)" "((%s)-1)")
(generate-monadic '2* "((%s)*2)" "((%s)*2)" "((%s)*2)")
(generate-monadic '2/ "((%s)/2.0)" "((%s)/2.0f)" ())

(dhm-t seed(source)
  (if (<> (length source) 2)
      (dhc-error "one argument expected"))
  (let ((treetype (dhc-parse-expr-t (cadr source))))
    (new t-node (list treetype) (new dhc-type 'dht-real)) ))

(dhm-c seed (source treetype retplace)
  (let* ((treetype (cadr :treetype:tn-list))
         (source (cadr source))
         (rettype :treetype:type)
         (rez (dhc-parse-expr-c source treetype ())) )
    (dhc-add-c-statements
     (sprintf "Fseed(%s);" rez))
    "0"))

(dhm-t gauss(source)
  (when (> (length source) 3)
    (dhc-error "Takes zero, one, or two arguments" (car source)))
  (setq source (cdr source))
  (let ((tns (all ((arg source)) (dhc-parse-expr-t arg))))
    (each ((tn tns))
      (when ~(==> :tn:type is-a-number)
            (dhc-error "not a numerical expression")))
    (new t-node tns (new dhc-type 'dht-flt))) )

(dhm-c gauss(source treetype retplace)
  (if :treetype:ignore
      (progn (dhc-add-c-statements "Fgauss(); /* state advance */" ) "")
    (when ~retplace
      (setq retplace (dhc-declare-temp-var :treetype:type "_gauss")))
    (dhc-add-c-statements
     (sprintf "%s = %s;" retplace
              (selectq (length (cdr source))
                (0 "Fgauss()")
                (1 (sprintf "((%s) * Fgauss())"
                            (dhc-parse-expr-c (cadr source)
                                              (cadr :treetype:tn-list) ())))
                (2 (sprintf "((%s) * Fgauss() + (%s))"
                            (dhc-parse-expr-c (caddr source)
                                              (caddr :treetype:tn-list) ())
                            (dhc-parse-expr-c (cadr source)
                                              (cadr :treetype:tn-list) ())))
                )))
    retplace))

(dhm-t-declare gauss rand)

(dhm-c rand(source treetype retplace)
  ;; if ignored still do Frand() because of state machine properties
  ;;  but skip the spreading
  (if :treetype:ignore
      (progn (dhc-add-c-statements "Frand(); /* state advance */" ) "")
    (when ~retplace
      (setq retplace (dhc-declare-temp-var :treetype:type "_rand")))
    (dhc-add-c-statements
     (sprintf "%s = %s;" retplace
              (selectq (length (cdr source))
                (0 "Frand()")
                (1 (let ((a1 (dhc-parse-expr-for-multi-use-c
                              (cadr source) (cadr :treetype:tn-list) ())))
                     (sprintf "((%s) * 2 * Frand() - (%s))" a1 a1)))
                (2 (let ((a1 (dhc-parse-expr-for-multi-use-c
                              (cadr source) (cadr :treetype:tn-list) ()))
                         (rettype :treetype:type))
                     (sprintf "(((%s) - (%s)) * Frand() + (%s))"
                              (dhc-parse-expr-c (caddr source)
                                                (caddr :treetype:tn-list) ())
                              a1 a1)))
                )))
    retplace))

(dhm-t incr(source)
  (when (or (> (length source) 3) (< (length source) 2))
    (dhc-error "incr takes one or two arguments"))
  (let (((incrsymb symbo &optional incrval) source))
    (dhc-parse-replacement-source-t
     source
     (list 'setq symbo (list '+ symbo (if incrval incrval 1))))))




;;; ------------------------------------------------------------------------
;;; DHM for querying/changing dimensions on idx.
;;; ------------------------------------------------------------------------


(dhm-t idx-ndim(source)
  (when (<> 2 (length source))
    (dhc-error "one argument expected"))
  (let* ((tn (dhc-parse-expr-t (cadr source)))
         (n (==> :tn:type is-an-idxptr)))
    (if ~n
        (dhc-error "argument must be an idx")
      (new t-node (list tn) (new dhc-type 'dht-int)))))

(dhm-c idx-ndim(source treetype retplace)
  (sprintf "(%d)" (==> :(cadr :treetype:tn-list):type is-an-idxptr)))

(dhm-t idx-modulo(source)
  (when (<> 3 (length source))
    (dhc-error "two arguments expected"))
  (let* ((tn (dhc-parse-expr-t (cadr source)))
         (tn2 (dhc-parse-expr-t (caddr source)))
         (ndim (==> :tn:type is-an-idxptr)))
    (dhc-unify-types :tn2:type (new dhc-type 'dht-number))
    (if (numberp (caddr source))
        (if (or (< (caddr source) 0) (>= (caddr source) ndim))
            (dhc-error "Illegal dimension for idx") (cadr source)))
    (if ~ndim
        (dhc-error "first argument must be an idx")
      (new t-node (list tn tn2) (new dhc-type 'dht-int)))))

(dhm-c idx-modulo(source treetype retplace)
  (let ((mat (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list) ()))
        (dim (dhc-parse-expr-for-multi-use-c 
              (caddr source) (caddr :treetype:tn-list) ()))
        (ndim (==> :(cadr :treetype:tn-list):type is-an-idxptr))
        (memb (if (= (get-dhm-target source) :idx-modulo) "mod" "dim")))
    (if ~(numberp (caddr source))
      (if ~dhc-unprotect 
          (dhc-add-c-statements
           (sprintf "RTERR_DIM(%s < 0 || %s >= %d);"
                    dim dim ndim))))
    (sprintf "(%s)->%s[%s]" mat memb dim)))

(dhm-t-declare idx-modulo idx-dim)
(dhm-c-declare idx-modulo idx-dim)

(dhm-t idx-offset(source)
  (when (<> 2 (length source))
    (dhc-error "one arguments expected"))
  (let* ((tn (dhc-parse-expr-t (cadr source)))
         (ndim (==> :tn:type is-an-idxptr)))
    (if ~ndim
        (dhc-error "first argument must be an idx")
      (new t-node (list tn) (new dhc-type 'dht-int)))))

(dhm-c idx-offset(source treetype retplace)
  (let ((mat (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list)())))
    (sprintf "(%s)->offset" mat)))

(dhm-t contiguousp(source)
  (when (<> 2 (length source))
    (dhc-error "one argument expected"))
  (let* ((tn (dhc-parse-expr-t (cadr source)))
         (ndim (==> :tn:type is-an-idxptr)))
    (if ~ndim
        (dhc-error "first argument must be an idx")
      (new t-node (list tn) (new dhc-type 'dht-bool)))))

(dhm-c contiguousp(source treetype retplace)
  (let ((mat (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list)())))
    (if :treetype:ignore ""
      (when ~retplace
        (setq retplace (dhc-declare-temp-var :treetype:type "_contigue")))
      (dhc-add-c-statements
       (sprintf "Midx_contiguep%d(%s,%s);"
                (==> :(cadr :treetype:tn-list):type is-an-idxptr)
                mat retplace))
      retplace)))

(dhm-t idx-size(source)
  (when (<> 2 (length source))
    (dhc-error "one argument expected"))
  (let* ((tn (dhc-parse-expr-t (cadr source)))
         (ndim (==> :tn:type is-an-idxptr)))
    (if ~ndim
        (dhc-error "argument must be an idx")
      (new t-node (list tn) (new dhc-type 'dht-int)))))

(dhm-c idx-size(source treetype retplace)
  (let ((mat (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list) ()))
	     (mattype :(cadr :treetype:tn-list):type))
    (if :treetype:ignore
        ""
      (when ~retplace
        (setq retplace (dhc-declare-temp-var :treetype:type)))
      (dhc-add-c-statements
       ;; EXTRACTS ELEMENT SIZE FROM SRG
       (sprintf "(%s) = sizeof(%s);"
                retplace (==> mattype get-element-decl))
       "{int i;\n"
       (sprintf "for(i= %d-1;i>=0;i--) {\n"
                (==> mattype is-an-idxptr))
       (sprintf "(%s) *= (%s)->dim[i];\n}\n}" retplace mat))
      retplace)))

(dhm-t idx-storage(source)
  (when (<> 2 (length source))
    (dhc-error "two arguments expected"))
  (let* ((tn (dhc-parse-expr-t (cadr source)))
         (idx-type :tn:type))
    (if ~(==> idx-type is-an-idxptr)
      (dhc-error "not an idx" (cadr source)))
    (new t-node (list tn) (new dhc-type 'dht-ptr
                               (unode-val :(unode-val 
                                            :idx-type:u-type):u-type)))))

(dhm-c idx-storage(source treetype retplace)
  (let* ((mattn (cadr :treetype:tn-list))
         (mat (dhc-parse-expr-for-multi-use-c (cadr source) mattn ())))
    (sprintf "((%s)->srg)" mat)))

(dhm-t idx-ptr(source)
  (when (<> 2 (length source))
    (dhc-error "one argument expected"))
  (let* ((tn (dhc-parse-expr-t (cadr source))))
    (if (not (==> :tn:type is-an-idxptr))
        (dhc-error "argument must be an idx")
      (let* ((stype (dhu-type (dhu-type (dhu-type :tn:type))))
             (ctype (concat (dhc-type-to-c-decl stype) "*")) )
        (new t-node (list tn) (new dhc-type 'dht-gptr ctype)) ) ) ) )

(dhm-c idx-ptr(source treetype retplace)
  (let* ((mattn (cadr :treetype:tn-list))
         (mat (dhc-parse-expr-for-multi-use-c (cadr source) mattn ()))
         (stype (dhu-type (dhu-type (dhu-type :mattn:type)))) )
    (sprintf "IDX_PTR((%s),%s)" mat (dhc-type-to-c-decl stype)) ) )

(dhm-t new-index(source)
  (when (<> 3 (length source))
    (dhc-error "two arguments expected"))
  (let* ((tn (dhc-parse-expr-t (cadr source)))
         (dim-list (caddr source))
         (symbol-idx (new dhc-symbol
                          (named
                           (sprintf "%d_new_idx"(dhc-postincr tmpnames-seed)))
                          lex-level))
         (ndim 0) (dim-tn ()) (rettype ()) (ret-tn ())
         (srg-type (==> :tn:type is-a-srgptr)))
    (if ~srg-type
        (dhc-error "not a storage" (cadr source)))
    (if ~(listp dim-list)
      (dhc-error "Second argument is not a list" dim-list))
    (if ~(or (= (car dim-list) 'list) (= (car dim-list) 'quote)
             ~(car dim-list))
      (dhc-error 
       "lists are not fully implemented yet.  Use (list 3 4) or '(3 4))"
       dim-list))
    (setq dim-tn
          (if (= (car dim-list) 'list)
              (let ((tnl (all ((so (cdr dim-list))) 
                           (let ((tn (dhc-parse-expr-t so)))
                             (if ~(==> :tn:type is-a-number)
                               (dhc-error "number expected" so))
                             tn))))
                (setq ndim (length (cdr dim-list)))
                (new t-node (cons (new t-node () 
                                       (new dhc-type 'dht-dhm)
                                       'list)
                                  tnl)
                     (new dhc-type 'dht-unk)))
            (let ((tnl (all ((num (cadr dim-list)))
                         (if ~(numberp num)
                           (dhc-error "number expected"
                                      num))
                         (new t-node () 
                              (new dhc-type 'dht-number)
                              num))))
              (setq ndim (length (cadr dim-list)))
              (new t-node (list (new t-node () 
                                     (new dhc-type 'dht-dhm)
                                     'quote)
                                (new t-node tnl
                                     (new dhc-type 'dht-unk)))
                   (new dhc-type 'dht-unk)))))
    (setq rettype (new dhc-type 'dht-ptr 
                       (new dhc-type 'dht-idx ndim 
                            (unode-val :tn:type:u-type))))
    (dhc-unify-types :symbol-idx:type (unode-val :rettype:u-type))
    (setq ret-tn (new t-node (list tn dim-tn) rettype))
    (setq bump-list (append bump-list (list symbol-idx)))
    (setq :ret-tn:transfer symbol-idx)
    ret-tn))

(dhm-c new-index(source treetype retplace)
  (let* ((idx-symb :treetype:transfer)
         (idx :idx-symb:c-name)
         (mattn (cadr :treetype:tn-list))
         (mat (dhc-parse-expr-for-multi-use-c (cadr source) mattn ()))
         (tn-of-list (caddr :treetype:tn-list))
         (dim-list-source (caddr source))
         (is-a-quote (= :(car :tn-of-list:tn-list):source 'quote))
         (dims-so-l (if is-a-quote (cadr dim-list-source)
                      (cdr dim-list-source)))
         (dims-type-l (if is-a-quote 
                          :(cadr :tn-of-list:tn-list):tn-list
                          (cdr :tn-of-list:tn-list)))
         (list-of-dims-expr 
          (all ((so dims-so-l) (ty dims-type-l)
                (i (if dims-so-l (range 0 (1- (length dims-so-l))))))
            (dhc-parse-expr-c so ty (sprintf "%s->dim[%d]" idx i)))))
    (dhc-add-c-statements (sprintf "%s->srg = %s;" idx mat))
    (dhc-add-c-statements (sprintf "%s->ndim = %d;" idx 
                                   (==> :treetype:type is-an-idxptr)))
    (dhc-add-c-statements (sprintf "%s->flags = 0;" idx))
    (dhc-add-c-statements (sprintf "%s->offset = 0;" idx))
    (dhc-add-c-statements (sprintf "Midx_update_mod_from_dim(%s);" idx))
    idx))

(dhm-t idx-changedim(source)
  (when (<> (if (= (get-dhm-target source) :idx-changeoffset) 3 4) (length source))
    (dhc-error "three arguments expected"))
  (let* ((tnl (all ((so (cdr source))) (dhc-parse-expr-t so)))
         (ndim (==> :(car tnl):type is-an-idxptr))
         (tn ()))
    (if (<> (get-dhm-target source) :idx-changeoffset)
        (if (numberp (caddr source))
            (if (or (< (caddr source) 0) (>= (caddr source) ndim))
                (dhc-error "illegal dimension for idx") (cadr source))))
    (when ~ndim (dhc-error "first argument must be an idx"))
    (all ((tn (cdr tnl)))
      (dhc-unify-types :tn:type (new dhc-type 'dht_number)))
    (new t-node tnl (new dhc-type 'dht-nil))))


(putp idx-changedim 'cname "dim")
(putp idx-changemod 'cname "mod")
(putp idx-changeoffset 'cname "offset")


(dhm-c idx-changedim(source treetype retplace)
  (let* ((mattn (cadr :treetype:tn-list))
         (lname (get-dhm-target source))
         (mat (dhc-parse-expr-for-multi-use-c (cadr source) mattn ()))
         (cname (or (getp (get-dhm-target source) 'cname)
                    (dhc-error "Cannot compile this function (no cname)") ) )
         (faccess (concat "Midx_" cname (sprintf "(%s" mat)))
         (cnames (all ((so (cddr source)) (tn (cddr :treetype:tn-list)))
                   (concat "((int)"
                           (dhc-parse-expr-for-multi-use-c so tn ())
                           ")")))
         (ndim (==> :mattn:type is-an-idxptr))
         (el-decl (==> :mattn:type get-element-decl)) )
    (if (<> lname :idx-changeoffset)
        (setq faccess (concat faccess "," (car cnames) ")"))
      (setq faccess (concat faccess ")")))
    (if dhc-unprotect
        (dhc-add-c-statements (concat faccess " = " (last cnames) ";"))
      (if (<> (get-dhm-target source) :idx-changeoffset)
          (if ~(numberp (caddr source))
            (dhc-add-c-statements
             (sprintf "RTERR_DIM(%s < 0 || %s >= %d);"
                      (car cnames) (car cnames) ndim))))
      (dhc-add-c-statements 
       (sprintf "{ int old_val=%s, min_size, max_size;" faccess)
       (if (= (get-dhm-target source) :idx-changedim)
           (sprintf "RTERR_RANGE(%s < 0);" (cadr cnames)))
       (concat faccess " = " (last cnames) ";")
       (sprintf "SRG_BOUNDS(%s,%d,min_size, max_size);" mat ndim)
       (sprintf "if(min_size < 0 || max_size >= (%s)->srg->size) {" mat)
       (concat faccess "= old_val;")
       "RTERR_SRG_OVERFLOW;}}"))
    "0"))

(dhm-t-declare idx-changedim idx-changemod idx-changeoffset)
(dhm-c-declare idx-changedim idx-changemod idx-changeoffset)



;;; ------------------------------------------------------------------------
;;; DHM for matrix creation and cloning functions
;;; ------------------------------------------------------------------------

(defvar dhc-type-to-matrix-name 
  '((dht-ubyte ubyte-matrix-nc ubyte-matrix)
    (dht-byte byte-matrix-nc byte-matrix)
    (dht-int int-matrix-nc int-matrix)
    (dht-short short-matrix-nc short-matrix)
    (dht-flt float-matrix-nc float-matrix)
    (dht-real double-matrix-nc double-matrix)
    (dht-gptr gptr-matrix-nc gptr-matrix) ) )

(defvar dhc-type-to-matrix 
  (mapcar (lambda ((x y z)) (cons x (eval `(list :,y :,z))))
          dhc-type-to-matrix-name ) )
(defvar dhc-matrix-to-type
  (apply append
         (mapcar (lambda ((x y z)) (eval `(list (cons :,y x) (cons :,z x))))
                 dhc-type-to-matrix-name ) ) )

(dhm-t float-matrix-nc(source)
  (let* ((arglist (cdr source))
         (types (all ((x arglist)) (dhc-parse-expr-t x)))
         (mtype (cdr (assoc (get-dhm-target source) dhc-matrix-to-type)))
         (srg-type (new dhc-type 'dht-srg (new dhc-type mtype)))
         (idx-type (new dhc-type 'dht-idx (length arglist) srg-type))
         (rettype (new dhc-type 'dht-ptr idx-type))
         (symbol-idx (new dhc-symbol (named (sprintf "%d_matrix" 
                                                     tmpnames-seed))
                          lex-level))
         (symbol-srg (new dhc-symbol (named (sprintf "%d_srg" 
                                                     tmpnames-seed))
                          lex-level))
         (tn (new t-node types rettype ())))
    (incr tmpnames-seed)
    (each ((y types) (x arglist))
      (if (not (==> :y:type is-a-number)) 
          (dhc-error "not a numerical expression" x)))
    (dhc-unify-types :symbol-idx:type idx-type)
    (dhc-unify-types :symbol-srg:type srg-type)
    (setq bump-list (append bump-list (list symbol-idx symbol-srg)))
    (setq :tn:transfer (list symbol-idx symbol-srg))
    tn))

(dhm-t-declare float-matrix-nc ubyte-matrix-nc byte-matrix-nc short-matrix-nc 
	       int-matrix-nc double-matrix-nc gptr-matrix-nc
	       ubyte-matrix byte-matrix short-matrix int-matrix 
               float-matrix double-matrix gptr-matrix )

(dhm-c float-matrix-nc(source treetype retplace)
  (let (((idx-symb srg-symb) :treetype:transfer)
        (ndim (1- (length source)))
        (srg-type (unode-val :(unode-val 
                               :(unode-val 
                                 (scope :treetype:type
                                        u-type)):u-type):u-type)))
    (dhc-add-c-statements (sprintf "(%s)->srg = %s;"
                                   :idx-symb:c-name :srg-symb:c-name))
    (if (= 0 ndim)
        (dhc-add-c-statements (sprintf "Midx_init_dim%d(%s);"
                                       ndim
                                       :idx-symb:c-name))
      (dhc-add-c-statements (sprintf "Midx_init_dim%d(%s, %s);"
                                     ndim
                                     :idx-symb:c-name
                                     (dhc-insert-op 
                                      (all ((so (cdr source)) 
                                            (ty (cdr :treetype:tn-list))
                                            (i (range 0 (1- ndim))))
                                        (dhc-parse-expr-c so ty ()))
                                      ",")))
      (for (i 0 (1- ndim))
	   (dhc-add-c-statements (sprintf "RTERR_DIM(%s->dim[%d]<=0);"
                                     :idx-symb:c-name i )) ) )
    (if (member (get-dhm-target source)
                (list ubyte-matrix byte-matrix short-matrix int-matrix 
                      float-matrix double-matrix gptr-matrix ) )
        (dhc-add-c-statements (sprintf "Midx_maclear(%s, %s);"
                                       :idx-symb:c-name
                                       (dhc-type-to-c-decl srg-type))))
    (sprintf "%s" :idx-symb:c-name)))

(dhm-c-declare float-matrix-nc ubyte-matrix-nc byte-matrix-nc short-matrix-nc 
	       int-matrix-nc double-matrix-nc gptr-matrix-nc
	       ubyte-matrix byte-matrix short-matrix int-matrix 
               float-matrix double-matrix gptr-matrix )

(dhm-t idx-clone(source)
  (when (<> 2 (length source))
    (dhc-error "one argument expected"))
  (let* ((tnl (all ((so (cdr source))) (dhc-parse-expr-t so)))
         (ndim (==> :(car tnl):type is-an-idxptr))
         (rettype (==> :(car tnl):type copy))
         (symbol-idx (new dhc-symbol
                          (named
                           (sprintf "%d_clone" (dhc-postincr tmpnames-seed)))
                          lex-level))
         (tn (new t-node tnl rettype)))
    (when ~ndim (dhc-error "argument must be an idx"))
    (dhc-unify-types :symbol-idx:type (unode-val :rettype:u-type))
    ;; cause the storage to be bumped if idx is returned
    (dhc-unify-types (unode-val :(unode-val 
                                  :(car tnl):type:u-type):u-type)
                     (unode-val :(unode-val :rettype:u-type):u-type))
    (setq bump-list (append bump-list (list symbol-idx)))
    (setq :tn:transfer symbol-idx)
    tn))

(dhm-c idx-clone(source treetype retplace)
  (let* ((idx-symb :treetype:transfer)
         (mattn (cadr :treetype:tn-list))
         (mat (dhc-parse-expr-for-multi-use-c (cadr source) mattn ())))
    (dhc-add-c-statements
     (sprintf "Midx_clone%d(%s, %s);"
              (dhu-ndim (dhu-type :mattn:type))
              :idx-symb:c-name mat))
    :idx-symb:c-name))

(dhm-t clone-matrix(source)
  (when (<> 2 (length source))
    (dhc-error "one argument expected"))
  (let* ((mat (dhc-parse-expr-t (cadr source)))
         (ndims (==> :mat:type is-an-idxptr))
         (newsrc (mapfor (i 0 (1- ndims))
                   (list 'idx-dim (cadr source) i))))
    (when ~(==> :mat:type is-an-idxptr)
          (dhc-error "argument must be an idx"))
    (setq newsrc (cons (cadr (assoc (==> :mat:type get-element-type)
                                    dhc-type-to-matrix-name))
                       newsrc))
    (dhc-parse-replacement-source-t source newsrc)))

(dhm-t copy-matrix(source)
  (let (((func mat &optional to-mat more) source))
    (if more
        (dhc-error "one or two arguments expected")
      (if (not to-mat)
          (dhc-parse-replacement-source-t 
           source `(let ((m ,mat)) (copy-matrix m (clone-matrix m))) )
        (let ((tn-in (dhc-parse-expr-t mat))
              (tn-out (dhc-parse-expr-t to-mat)))
          (when (not (==> :tn-in:type is-an-idxptr))
            (dhc-error "Not a matrix" mat) )
          (when (not (==> :tn-out:type is-an-idxptr))
            (dhc-error "Not a matrix" to-mat) )
          (==> (unode-val :(unode-val :tn-out:type:u-type):u-type)
               access 'write)
          (new t-node (list tn-in tn-out) :tn-out:type () ()) ) ) ) ) )

(dhm-c copy-matrix(source treetype retplace)
  (let* ((idx-type-in :(cadr :treetype:tn-list):type)
         (idx-type-out :(caddr :treetype:tn-list):type)
         (srg-type-in (new dhc-type (==> idx-type-in get-element-type)))
         (srg-type-out (new dhc-type (==> idx-type-out get-element-type)))
         (c1 (dhc-parse-expr-c (cadr source)(cadr :treetype:tn-list)()))
         (ret-string (dhc-parse-expr-c (last source)
                                       (last :treetype:tn-list)
                                       ())))
    (if ~dhc-unprotect
        (dhc-add-c-statements
         (sprintf "check_main_maout_any(%s,%s);" c1 ret-string)))
    (dhc-add-c-statements
     (sprintf "Midx_macopy(%s,%s,%s,%s);"
              c1 ret-string
              (dhc-type-to-c-decl srg-type-in)
              (dhc-type-to-c-decl srg-type-out)))
    ret-string ) )



;;; ------------------------------------------------------------------------
;;; DHM for index manipulations (unfold, select, narrow, etc...)
;;; ------------------------------------------------------------------------


;;; We have UNFOLD but not IDX-UNFOLD,
;;; because idx-unfold would change the type of an idx.
(dhm-t unfold(source)
  (when (<> 5 (length source))
    (dhc-error "four arguments expected"))
  (let* ((tnl (all ((so (cdr source))) (dhc-parse-expr-t so)))
         (ndim (==> :(car tnl):type is-an-idxptr))
         (rettype (==> :(car tnl):type copy 1))
         (symbol-idx (new dhc-symbol
                          (named
                           (sprintf "%d_unfold" (dhc-postincr tmpnames-seed)))
                          lex-level))
         (tn (new t-node tnl rettype)) )
    (when ~ndim (dhc-error "first argument must be an idx"))
    (when (numberp (caddr source))
      (if (or (< (caddr source) 0) (>= (caddr source) ndim))
          (dhc-error "Illegal dimension for idx") (cadr source))
      (if (>= (1+ (caddr source)) 8)
          (dhc-error "Too many dimensions") (cadr source)))
    (if (and (numberp (nth 3 source)) (numberp (nth 4 source)))
        (if (or (< (nth 3 source) 1) (< (nth 4 source) 1))
            (dhc-error "Illegal dimension ksize or step"
                       (cdddr source))))
    (all ((tn (cdr tnl)))
      (dhc-unify-types :tn:type (new dhc-type 'dht_number)))
    (dhc-unify-types :symbol-idx:type (unode-val :rettype:u-type))
    (setq bump-list (append bump-list (list symbol-idx)))
    (dhc-unify-types (unode-val :symbol-idx:type:u-type)
                     (unode-val :(unode-val 
                                  :(car tnl):type:u-type):u-type))
    (setq :tn:transfer symbol-idx)
    tn))

(dhm-c unfold(source treetype retplace)
  (let* ((idx-symb :treetype:transfer)
         (mattn (cadr :treetype:tn-list))
         (cnames (all ((so (cdr source)) (tn (cdr :treetype:tn-list)))
                   (dhc-parse-expr-for-multi-use-c so tn ())))
         (idx :idx-symb:c-name)
         (mat (nth 0 cnames))
         (d (concat "((int)" (nth 1 cnames) ")"))
         (sz (concat "((int)" (nth 2 cnames) ")"))
         (st (concat "((int)" (nth 3 cnames) ")"))
         (ndim (==> :mattn:type is-an-idxptr))
         (el-decl (==> :mattn:type get-element-decl))
         (temp (dhc-declare-temp-var (new dhc-type 'dht_int))) )
    (dhc-add-c-statements
     (sprintf "Midx_clone%d(%s, %s);"
              (dhu-ndim (dhu-type :mattn:type))
              idx mat))
    (when ~dhc-unprotect
      (if ~(numberp (caddr source))
        (dhc-add-c-statements
         (sprintf "RTERR_DIM(%s < 0 || %s >= %d);"
                  d d ndim)))
      (if (or ~(numberp (nth 3 source)) 
              ~(numberp (nth 4 source)))
          (dhc-add-c-statements
           (sprintf "RTERR_GEN((%s<1 || %s<1), %s);"
                    sz st
                    "\"illegal 'size' or 'step'\""))))
    (dhc-add-c-statements
     (sprintf "%s = 1+ ((%s)->dim[%s]-%s)/%s;"
              temp idx d sz st))
    (when ~dhc-unprotect
      (dhc-add-c-statements
       (sprintf 
        "RTERR_GEN((%s<=0 || (%s)->dim[%s]!=%s*(%s-1)+%s), %s);"
        temp idx d st temp sz
        "\"Index dimension does not match size and step\""))
      (if ~(numberp (caddr source))
        (dhc-add-c-statements
         (sprintf "RTERR_GEN((%d +1 >= MAXDIMS), %s);"
                  ndim
                  "\"Too many dimensions\""))))
    (dhc-add-c-statements
     (sprintf "Midx_unfold(%s,%s,%s,%s,%s);"
              idx d sz st el-decl))
    idx))

;;; We have SELECT but not IDX-SELECT
;;; because idx-select would change the type of an idx.
(dhm-t select(source)
  (when (<> 4 (length source))
    (dhc-error "three arguments expected"))
       (let* ((tnl (all ((so (cdr source))) (dhc-parse-expr-t so)))
	      (ndim (==> :(car tnl):type is-an-idxptr))
	      (rettype (==> :(car tnl):type copy -1))
	      (symbol-idx (new dhc-symbol
			       (named
				(sprintf "%d_select" (dhc-postincr tmpnames-seed)))
			       lex-level))
	      (tn (new t-node tnl rettype)) )
         (when ~ndim (dhc-error "first argument must be an idx"))
         (when (numberp (caddr source))
           (if (or (< (caddr source) 0) (>= (caddr source) ndim))
               (dhc-error "Illegal dimension for idx") (cadr source)))
         (if (numberp (nth 3 source))
             (if (< (nth 3 source) 0)
                 (dhc-error "Illigal dimension selection") (cadr source)))
         (all ((tn (cdr tnl)))
           (dhc-unify-types :tn:type (new dhc-type 'dht_number)))
         (dhc-unify-types :symbol-idx:type (unode-val :rettype:u-type))
         (setq bump-list (append bump-list (list symbol-idx)))
         (dhc-unify-types (unode-val :symbol-idx:type:u-type)
                          (unode-val :(unode-val 
                                       :(car tnl):type:u-type):u-type))
         (setq :tn:transfer symbol-idx)
         tn))

(dhm-c select(source treetype retplace)
  (let* ((idx-symb :treetype:transfer)
         (mattn (cadr :treetype:tn-list))
         (cnames (all ((so (cdr source)) (tn (cdr :treetype:tn-list)))
                   (dhc-parse-expr-for-multi-use-c so tn ())))
         (idx :idx-symb:c-name)
         (mat (nth 0 cnames))
         (d (concat "((int)" (nth 1 cnames) ")"))
         (x (concat "((int)" (nth 2 cnames) ")"))
         (ndim (==> :mattn:type is-an-idxptr))
         (el-decl (==> :mattn:type get-element-decl)) )
    (when ~dhc-unprotect
      (if ~(numberp (caddr source))
        (dhc-add-c-statements
         (sprintf "RTERR_DIM(%s < 0 || %s >= %d);"
                  d d ndim)))
      (if ~(numberp (nth 3 source))
        (dhc-add-c-statements
         (sprintf "RTERR_GEN((%s<0), %s);"
                  x
                  "\"illegal parameter\"")))
      (dhc-add-c-statements
       (sprintf "RTERR_GEN((%s >= (%s)->dim[%s]), %s);"
                x mat d
                "\"specified subscript is too large\"")))
    (dhc-add-c-statements
     (sprintf "Midx_select(%s,%s,%s,%s,%s);"
              idx mat d x el-decl))
    idx))

;; We have DIAGONAL but not IDX-DIAGONAL
;; because idx-diagonal would change the type of an idx.
(dhm-t diagonal(source)
  (when (<> 3 (length source))
    (dhc-error "two arguments expected"))
  (let* ((tnl (all ((so (cdr source))) (dhc-parse-expr-t so)))
         (ndim (==> :(car tnl):type is-an-idxptr))
         (targ ())
         (rettype ())
         (symbol-idx (new dhc-symbol
                          (named
                           (sprintf "%d_diag" (dhc-postincr tmpnames-seed)))
                          lex-level))
         (tn ()) )
    (when ~ndim (dhc-error "first argument must be an idx"))
    (when (or ~(numberp (caddr source))
              (< (caddr source) 2)
              (> (caddr source) ndim))
      (dhc-error "2nd arg must be a compile time constant integer 2 <= d <= ndim"))
    (dhc-unify-types :(cadr tnl):type (new dhc-type 'dht_number))
    ;; creates a matrix with "d-1 dims less than the original"
    (setq targ (- ndim (1- (caddr source))))
    (setq rettype (==> :(car tnl):type copy (- targ ndim)))
    (setq tn (new t-node tnl rettype))
    (dhc-unify-types :symbol-idx:type (unode-val :rettype:u-type))
    (setq bump-list (append bump-list (list symbol-idx)))
    (dhc-unify-types (unode-val :symbol-idx:type:u-type)
                     (unode-val :(unode-val 
                                  :(car tnl):type:u-type):u-type))
    (setq :tn:transfer symbol-idx)
    tn))

(dhm-c diagonal(source treetype retplace)
  (let* ((idx-symb :treetype:transfer)
         (mattn (cadr :treetype:tn-list))
         (cnames (all ((so (cdr source)) (tn (cdr :treetype:tn-list)))
                   (dhc-parse-expr-for-multi-use-c so tn ())))
         (idx :idx-symb:c-name)
         (mat (nth 0 cnames))
         (d (nth 1 cnames))
         (ndim (==> :mattn:type is-an-idxptr))
         (el-decl (==> :mattn:type get-element-decl)) )
    (dhc-add-c-statements
     (concat
      (sprintf "{ int i,m,n; m = %d - %s; n = (%s)->dim[m];" ndim d mat)
      (sprintf " for (i=1;i<(int)%s;i++)" d)
      (if ~dhc-unprotect
          (sprintf "   RTERR_GEN(((%s)->dim[m+i] != n), %s);" mat
                   "\"The last dimensions should have the same size\"")
        "")
      "}") )
    (dhc-add-c-statements
     (sprintf "Midx_diagclone(%s,%s,(int)%s,%s);"
              idx mat d el-decl))
    idx))

;; We have IDX-NARROW and NARROW is a macro.
(dhm-t idx-narrow(source)
  (when (<> 5 (length source))
    (dhc-error "four arguments expected"))
  (let* ((tnl (all ((so (cdr source)))
                (dhc-parse-expr-t so)))
         (ndim (==> :(car tnl):type is-an-idxptr))
         (tn :(car tnl):type) )
    (if ~ndim
        (dhc-error "first argument must be an idx"))
    (when (numberp (caddr source))
      (if (or (< (caddr source) 0) (>= (caddr source) ndim))
          (dhc-error "Illegal dimension for idx") (cadr source)))
    (if (and (numberp (nth 3 source)) (numberp (nth 4 source)))
        (if (or (< (nth 3 source) 1) (< (nth 4 source) 0))
            (dhc-error "Illegal dimension size or offset"
                       (cdddr source))))
    (all ((tn (cdr tnl)))
      (dhc-unify-types :tn:type (new dhc-type 'dht_number)))
    (new t-node tnl (new dhc-type 'dht-bool))))

(dhm-c idx-narrow(source treetype retplace)
  (let* ((idxtn (cadr :treetype:tn-list))
         (cnames (all ((so (cdr source)) (tn (cdr :treetype:tn-list)))
                   (dhc-parse-expr-for-multi-use-c so tn ())))
         (mat (nth 0 cnames))
         (d (concat "((int)" (nth 1 cnames) ")")) 
         (sz (concat "((int)" (nth 2 cnames) ")"))
         (st (concat "((int)" (nth 3 cnames) ")"))
         (ndim (==> :idxtn:type is-an-idxptr))
         (el-decl (==> :idxtn:type get-element-decl)) )
    (when ~dhc-unprotect
      (if ~(numberp (caddr source))
        (dhc-add-c-statements
         (sprintf "RTERR_DIM(%s < 0 || %s >= %d);"
                  d d ndim)))
      (if (or ~(numberp (nth 3 source)) ~(numberp (nth 4 source)))
          (dhc-add-c-statements
           (sprintf "RTERR_GEN((%s<1 || %s<0), %s);"
                    sz st
                    "\"illegal 'size' or 'offset'\"")))
      (dhc-add-c-statements
       (sprintf "RTERR_GEN((%s+%s > (%s)->dim[%s]), %s);"
                st sz mat d
                "\"specified interval is too large\"")))
    (dhc-add-c-statements
     (sprintf "Midx_narrow(%s,%s,%s,%s,%s);"
              mat d sz st el-decl))
    "0"))

;; handles quoted list for idx-transclone
;;   (idx-transclone a '(1 2 3 0))
;;   could be expanded to handle (idx-transclone a (list 1 2 3 0))
;;   but would need runtime permtable check
(de dhc-parse-permlist-t (source ndim)
  (let ((x (car source))
        (lst (cdr source))
        (tnl ())
        (tn ())
        (tn2 ())
        (got-these (float-matrix ndim)) )
    (when (or ~(consp source) (<> x 'quote))
      (dhc-error "permutation list syntax error" source))
    (when (or (<> 1 (length lst)) ~(consp (car lst)))
      (dhc-error "permutation list syntax error" source))
    (setq lst (car lst))
    (when (<> ndim (length lst))
      (dhc-error "wrong # of dims in permlist" lst))
    (setq tnl (all ((so lst))
                (when (or ~(numberp so)
                          (<> so (int so))
                          (< so 0) (>= so ndim)
                          (0<> (got-these so)))
                  (dhc-error "bad permutation list" lst))
                (got-these so 1)
                (dhc-parse-number-t so)))
    (setq tn (new t-node tnl (new dhc-type 'dht-dhm) lst))
    (setq :tn:tn-list tnl)
    (setq tnl (list tn))
    (setq tn2 (new t-node tnl (new dhc-type 'dht-dhm) source))
    tn2))

(de dhc-parse-permlist-c (source treetype rettype)
  (let ((plist (all ((so (cadr source)) (ty :(car :treetype:tn-list):tn-list))
                 (dhc-parse-expr-for-multi-use-c so ty ()))))
    (dhc-add-c-statements
     "static int permlist[] = {"
     (dhc-insert-op plist ", ")
     "};")
    "permlist"))

(dhm-t idx-transclone(source)
  (when (<> 3 (length source))
    (dhc-error "two arguments expected"))
  (let* ((mat (dhc-parse-expr-t (cadr source)))
         (ndim (==> :mat:type is-an-idxptr))
         (bogus (when ~ndim (dhc-error "first argument must be an idx")))
         (tnl (list mat (dhc-parse-permlist-t (caddr source) ndim)))
         (rettype (==> :(car tnl):type copy))
         (symbol-idx (new dhc-symbol
                          (named
                           (sprintf "%d_tclone" (dhc-postincr tmpnames-seed)))
                          lex-level))
         (tn (new t-node tnl rettype)))
    (dhc-unify-types :symbol-idx:type (unode-val :rettype:u-type))
    ;; cause the storage to be bumped if idx is returned
    (dhc-unify-types (unode-val :(unode-val :(car tnl):type:u-type):u-type)
                     (unode-val :(unode-val :rettype:u-type):u-type))
    (setq bump-list (append bump-list (list symbol-idx)))
    (setq :tn:transfer symbol-idx)
    tn))

(dhm-c idx-transclone(source treetype retplace)
  (let* ((idx-symb :treetype:transfer)
         (mattn (cadr :treetype:tn-list))
         (mat (dhc-parse-expr-for-multi-use-c (cadr source) mattn ()))
         (plist ()))
    (dhc-add-c-statements "{")
    (setq plist (dhc-parse-permlist-c (caddr source)
                                      (caddr :treetype:tn-list) ()))
    (dhc-add-c-statements
     (sprintf "Midx_transclone(%s, %s, %s, %s);"
              :idx-symb:c-name mat plist
              (==> :mattn:type get-element-decl))
     "}")
    :idx-symb:c-name))

(dhm-t idx-transpose(source)
  (when (<> 3 (length source))
    (dhc-error "three arguments expected"))
  (let* ((mat (dhc-parse-expr-t (cadr source)))
         (ndim (==> :mat:type is-an-idxptr))
         (bogus (when ~ndim (dhc-error "first argument must be an idx")))
         (tnl (list mat (dhc-parse-permlist-t (caddr source) ndim))))
    (new t-node tnl (new dhc-type 'dht-bool)) ) )

(dhm-c idx-transpose(source treetype retplace)
  (let* ((mattn (cadr :treetype:tn-list))
         (mat (dhc-parse-expr-c (cadr source) mattn ()))
         (plist ()))
    (dhc-add-c-statements "{")
    (setq plist (dhc-parse-permlist-c (caddr source)
                                      (caddr :treetype:tn-list) ()))
    (dhc-add-c-statements
     (sprintf "Midx_transpose(%s, %s, %s);"
              mat plist (==> :mattn:type get-element-decl) ) )
    (dhc-add-c-statements "}")
    "0" ) )

(dhm-t idx-transpose2(source)
  (when (<> 4 (length source))
    (dhc-error "two arguments expected"))
  (let* ((tnl (all ((so (cdr source))) (dhc-parse-expr-t so)))
	 (mat (car tnl))
         (ndim (==> :mat:type is-an-idxptr)) )
    (when (not ndim)
      (dhc-error "first argument must be an idx"))
    (each ((n (cddr source)))
      (when (numberp n)
	(if (or (< n 0) (>= n ndim))
	    (dhc-error "Illegal dimension for idx" n) ) ) )
    (all ((tn (cdr tnl)))
      (dhc-unify-types :tn:type (new dhc-type 'dht_number)))
    (new t-node tnl (new dhc-type 'dht-bool)) ) )

(dhm-c idx-transpose2(source treetype retplace)
  (let* ((cexps (all ((tn (cdr :treetype:tn-list))
		      (so (cdr source)) )
		  (dhc-parse-expr-c so tn ()) ))
	 (mattn (cadr :treetype:tn-list))
	 (mat (car cexps)) 
	 (ndim (==> :mattn:type is-an-idxptr)) )
    (when (not dhc-unprotect)
      (each ((so (cddr source))
	     (cexp (cdr cexps)) )
	(when (not (numberp so))
	  (dhc-add-c-statements
	   (sprintf "RTERR_DIM(%s < 0 || %s >= %d);" 
		    cexp cexp (==> :mattn:type is-an-idxptr) ) ) ) ) )
    (dhc-add-c-statements    
     (sprintf "Midx_transpose2(%s, %s, %s, %s);"
              mat (cadr cexps) (caddr cexps) 
	      (==> :mattn:type get-element-decl) ) )
    "0" ) )

(dhm-t submatrix(source)
  (let (((func mat . dims) source)
        (expr ())
        (cur ())
        (taken-dim 0))
    (setq expr mat)
    (for (i 0 (1- (length dims)))
         (setq cur (nth i dims))
         (cond ((null cur))
               ((and (listp cur) (= (car cur) 'list) (= (length cur) 3))
                (setq expr `(narrow 
                             ,expr ,(- i taken-dim) 
                             (1+ (- ,(caddr cur)
                                    ,(cadr cur)))
                             ,(cadr cur)) ))
               ((and (listp cur) (= (car cur) 'quote))
                (setq cur (cadr cur))
                (if (not (and (numberp (car cur)) (numberp (cadr cur))
                              (null (cddr cur))))
                    (dhc-error "submatrix: bad argument" cur))
                (setq expr `(narrow 
                             ,expr ,(- i taken-dim) 
                             (1+ (- ,(cadr cur) ,(car cur)))
                             ,(car cur))))
               (t
                (setq expr (list 'select expr
                                 (- i taken-dim) cur))
                (incr taken-dim))))
    (dhc-parse-replacement-source-t source expr) ) )





;;; ------------------------------------------------------------------------
;;; DHM FOR PARSING IDX LOOPS
;;; ------------------------------------------------------------------------

(de dhc-idxloop-declare-var-t(dcl)
  (when ~(and (consp dcl) (consp (cdr dcl)) (null (cddr dcl)))
        (dhc-error "Syntax error" dcl) )
  (when ~(symbolp (car dcl))
        (dhc-error "Not a symbol" (car dcl)))
  (let* ((sym (new dhc-symbol (car dcl) lex-level))
         (ini (cadr dcl))
         (node (dhc-parse-expr-t ini))
         (ndim (==> :node:type is-an-idxptr)))
    (when ~ndim
      (dhc-error (sprintf "Not an index: %l" ini)))
    (when (= 0 ndim)
      (dhc-error "Can't loop over a 0D matrix."))
    (let* ((ptr-type (==> :node:type copy -1))
           (treetype (new t-node
                          (list (new t-node () :sym:type (car dcl) sym)
                                node)
                          (new dhc-type 'dht-unk))))
      (dhc-assign-unify :sym:type ptr-type)
      ;; loop var is not returnable!
      ;; (setq bump-list (append bump-list (list sym)))
      (setq :treetype:ignore t)
      (setq new-symbol-table 
            (dhc-add-to-symtable new-symbol-table sym))
      treetype)))

(dhm-t idx-bloop(source)
  (when ~(cddr source)
        (dhc-error "idx-[be]loop syntax error"))
  (when (> (length (cadr source)) 12)
    (dhc-error "Cannot loop on more than 12 indexes"))
  (let ((li ())
        (tn ())
        (ret ())
        (ignore t)					;; changed-returning 0
        (tmp ()))
    (dhc-push-scope-t
     (setq li (all ((dcl (cadr source)))
                (dhc-idxloop-declare-var-t dcl)))
     (setq symbol-table new-symbol-table)
     (setq tn (new t-node li (new dhc-type 'dht-unk)))
     (setq ret (dhc-parse-progn-t (cddr source)))
     (setq :ret:tn-list (cons tn :ret:tn-list))
     (setq :ret:type :(cadr :(last li):tn-list):type)
     ret)))

;; lays down a run-time check that the dim dimensions of
;; the elements in tnlist are equal
;; if dim < 0, take it as a delta from ndim
(de dhc-rt-dim-check (namelist tnlist dim)
  (when (> (length tnlist) 1)
    (let* ((arglist ())
           (getdim (lambda (ty d)
                     (if (>= d 0) d (+ (==> ty is-an-idxptr) d))))
           (arg1str (sprintf "(%s)->dim[%d]"
                             (car namelist)
                             (getdim :(car tnlist):type dim) ))
           (arglist (all ((tn (cdr tnlist)) (nm (cdr namelist)))
                      (sprintf "%s != (%s)->dim[%d]"
                               arg1str nm
                               (getdim :tn:type dim)))) )
      (setq arglist (dhc-insert-op arglist " || "))
      (if ~dhc-unprotect
          (dhc-add-c-statements (sprintf "RTERR_LOOPDIM(%s);" arglist))) )))

(dhm-c idx-bloop(source treetype retplace)
  (let* ((arglist "")
         (el-types ())
         (ini-names ())
         (ini-tnl ())
         (ret-expr ())
         (str (if  (= (get-dhm-target source) :idx-bloop) "b" "e"))
         (check-dim (if (= str "b") 0 -1)) )
    (dhc-push-scope-c
     treetype retplace
     (each ((decl (cadr source))
            (decltype :(cadr :treetype:tn-list):tn-list))
       (let* ((sym-tn (car :decltype:tn-list))
              (ini-tn (cadr :decltype:tn-list))
              (sym :(car :decltype:tn-list):symbol )
              (ini (dhc-parse-expr-for-multi-use-c
                    (cadr decl) ini-tn ())))
         (setq arglist (concat arglist :sym:c-name ", " ini ","))
         ;; HACK for bloop speed up -- see idxmac.h
         (setq :sym:c-name (concat "&" :sym:c-name))
         ;; collect element types
         (setq el-types (cons (==> :sym-tn:type get-element-type) el-types))
         ;; collect ini names an types for rt dim check
         (setq ini-names (cons ini ini-names))
         (setq ini-tnl (cons ini-tn ini-tnl))
         (setq ret-expr ini)))
     ;; rt check of loop dims 
     (dhc-rt-dim-check ini-names ini-tnl check-dim)
     ;; extracts element size from srg!
     (setq arglist (concat arglist (dhc-type-to-c-decl
                                    (new dhc-type (car el-types)))))
     (dhc-add-c-statements
      (sprintf "Midx_begin_%sloop%d(%s) {"
               str
               (length (cadr source)) arglist))
     (dhc-parse-progn-c (cddr source)
                        (cddr :treetype:tn-list) ())
     (dhc-add-c-statements
      (sprintf "} Midx_end_%sloop%d(%s);"
               str
               (length (cadr source)) arglist))
     ret-expr)))

(dhm-t-declare idx-bloop idx-eloop)
(dhm-c-declare idx-bloop idx-eloop)




;;; ------------------------------------------------------------------------
;;; DHM for parsing TL3/SN2 matrix operations
;;; ------------------------------------------------------------------------

;;; These are defined in compat.lsh

(when (functionp m*m)
  (dhm-t m*m(source)
    (let (((func a b &optional c) source)
          (atype ())
          (btype ())
          (ndima ())
          (ndimb ())
          (expr ()))
      (setq atype :(dhc-parse-expr-t a):type)
      (setq btype :(dhc-parse-expr-t b):type)
      (setq ndima (==> atype is-an-idxptr))
      (setq ndimb (==> btype is-an-idxptr))
      (if (and (<> ndima 1) (<> ndima 2))
          (dhc-error "m*m: idx must be of dimension 1 or 2" a))
      (if (and (<> ndimb 1) (<> ndimb 2))
          (dhc-error "m*m: idx must be of dimension 1 or 2" b))
      (setq expr 
            (if (= ndima 1)
                (if (= ndimb 1)
                    (if (= 1 (car :btype:u-extra))
                        (if c 
                            (if (symbolp c)
                                `(let ((-dh-b (float-matrix-nc)))
                                   (idx-dotm0 ,a (-dh-b (,b 0)) ,c)
                                   ,c)
                              `(let ((-dh-b (float-matrix-nc))
                                     (-dh-c ,c))
                                 (idx-dotm0 ,a (-dh-b (,b 0)) -dh-c)
                                 -dh-c))
                          `(let* ((-dh-b (float-matrix-nc))
                                  (-dh-a ,a)
                                  (-dh-c (clone-matrix -dh-a)))
                             (idx-dotm0 -dh-a (-dh-b (,b 0)) -dh-c)
                             -dh-c))
                      (dhc-error "m*m: idx 2 must have 1 element"))
                  (if (= 1 (car :btype:u-extra))
                      (if c
                          (if (symbolp c)
                              `(progn (idx-extm1 ,a (select ,b 0 0) ,c) ,c)
                            `(let ((-dh-c ,c))
                               (idx-m1extm1 ,a (select ,b 0 0) -dh-c)
                               -dh-c))
                        `(let ((-dh-c (float-matrix-nc ,(car :atype:u-extra)
                                                 ,(cadr :btype:u-extra))))
                           (idx-m1extm1 ,a (select ,b 0 0) -dh-c)
                           -dh-c))
                    (dhc-error "m*m: idx 2 have bad dimensions")))
              (if (= 1 ndimb)
                  (if c
                      (if (symbolp c)
                          `(progn (idx-m2dotm1 ,a ,b ,c) ,c)
                        `(let ((-dh-c ,c)) (idx-m2dotm1 ,a ,b -dh-c) -dh-c))
                    `(let* ((-dh-a ,a)
                            (-dh-c (float-matrix-nc (idx-dim -dh-a 0))))
                       (idx-m2dotm1 -dh-a ,b -dh-c) -dh-c))
                (if c
                    (if (symbolp c)
                        `(progn (idx-eloop ((-dh-x ,b) (-dh-y ,c))
                                  (idx-m2dotm1 ,a -dh-x -dh-y))
                                ,c)
                      `(let ((-dh-c ,c))
                         (idx-eloop ((-dh-x ,b) (-dh-y -dh-c)) 
                           (idx-m2dotm1 ,a -dh-x -dh-y))
                         -dh-c))
                  `(let* ((-dh-a ,a)
                          (-dh-b ,b)
                          (-dh-c (float-matrix-nc (idx-dim -dh-a 0) (idx-dim -dh-b 1))))
                     (idx-eloop ((-dh-x -dh-b) (-dh-y -dh-c)) 
                       (idx-m2dotm1 -dh-a -dh-x -dh-y))
                     -dh-c)))))
      (dhc-parse-replacement-source-t source expr) ) ) )

(when (functionp m+m)
  (dhm-t m+m(source)
    (let (((func a b &optional c) source))
      (dhc-parse-replacement-source-t
       source
       (if c
           (if (symbolp c)
               `(progn (idx-add ,a ,b ,c) ,c)
             `(let ((-dh-c ,c))
                (progn (idx-add ,a ,b -dh-c) -dh-c)))
         (if (symbolp b)
             `(let ((-dh-c (clone-matrix ,b)))
                (idx-add ,a ,b -dh-c) -dh-c)
           (if (symbolp a)
               `(let ((-dh-c (clone-matrix ,a)))
                  (idx-add ,a ,b -dh-c) -dh-c)
             `(let* ((-dh-b ,b)
                     (-dh-c (clone-matrix -dh-b)))
                (idx-add ,a -dh-b -dh-c) -dh-c))))) ) ) )

(when (functionp mxm)
  (dhm-t mxm(source)
    (let (((func a b &optional c) source))
      (dhc-parse-replacement-source-t
       source
       (if c
           (if (symbolp c)
               `(progn (idx-mul ,a ,b ,c) ,c)
             `(let ((-dh-c ,c))
                (progn (idx-mul ,a ,b -dh-c) -dh-c)))
         (if (symbolp b)
             `(let ((-dh-c (clone-matrix ,b)))
                (idx-mul ,a ,b -dh-c) -dh-c)
           (if (symbolp a)
               `(let ((-dh-c (clone-matrix ,a)))
                  (idx-mul ,a ,b -dh-c) -dh-c)
             `(let* ((-dh-b ,b)
                     (-dh-c (clone-matrix -dh-b)))
                (idx-mul ,a -dh-b -dh-c) -dh-c))))) ) ) )
		       
(when (functionp m-m)
  (dhm-t m-m(source)
    (let (((func a b &optional c) source))
      (dhc-parse-replacement-source-t
       source
       (if c
           (if (symbolp c)
               `(progn (idx-sub ,a ,b ,c) ,c)
             `(let ((-dh-c ,c))
                (progn (idx-sub ,a ,b -dh-c) -dh-c)))
         (if (symbolp b)
             `(let ((-dh-c (clone-matrix ,b)))
                (idx-sub ,a ,b -dh-c) -dh-c)
           (if (symbolp a)
               `(let ((-dh-c (clone-matrix ,a)))
                  (idx-sub ,a ,b -dh-c) -dh-c)
             `(let* ((-dh-b ,b)
                     (-dh-c (clone-matrix -dh-b)))
                (idx-sub ,a -dh-b -dh-c) -dh-c))))) )) )

(when (functionp m*c)
  (dhm-t m*c(source)
    (let (((func a b &optional c) source))
      (dhc-parse-replacement-source-t
       source
       (if c
           (if (symbolp c)
               `(let ((-dh-d (float-matrix)))
                  (-dh-d ,b)
                  (idx-dotm0 ,a -dh-d ,c) ,c)
             `(let ((-dh-d (float-matrix)) (-dh-c ,c))
                (-dh-d ,b)
                (idx-dotm0 ,a -dh-d -dh-c) -dh-c))
         (if (symbolp a)
             `(let ((-dh-d (float-matrix)) (-dh-c (clone-matrix ,a)))
                (-dh-d ,b)
                (idx-dotm0 ,a -dh-d -dh-c) -dh-c)
           `(let* ((-dh-d (float-matrix)) (-dh-a ,a)
                   (-dh-c (clone-matrix -dh-a)))
              (-dh-d ,b)
              (idx-dotm0 -dh-a -dh-d -dh-c) -dh-c))) ) ) ) )

(when (functionp m+c)
  (dhm-t m+c(source)
    (let (((func a b &optional c) source))
      (dhc-parse-replacement-source-t
       source
       (if c
           (if (symbolp c)
               `(let ((-dh-d (float-matrix)))
                  (-dh-d ,b)
                  (idx-addm0 ,a -dh-d ,c) ,c)
             `(let ((-dh-d (float-matrix)) (-dh-c ,c))
                (-dh-d ,b)
                (idx-addm0 ,a -dh-d -dh-c) -dh-c))
         (if (symbolp a)
             `(let ((-dh-d (float-matrix)) (-dh-c (clone-matrix ,a)))
                (-dh-d ,b)
                (idx-addm0 ,a -dh-d -dh-c) -dh-c)
           `(let* ((-dh-d (float-matrix)) (-dh-a ,a)
                   (-dh-c (clone-matrix -dh-a)))
              (-dh-d ,b)
            (idx-addm0 -dh-a -dh-d -dh-c) -dh-c))))) ))

(when (functionp transpose)
  (dhm-t transpose(source)
    (when (<> (length source) 2)
      (dhc-error "one argument expected"))
    (let* ((a (cadr source))
           (ndimin (==> :(dhc-parse-expr-t a):type is-an-idxptr)))
      (dhc-parse-replacement-source-t
       source
       (selectq ndimin
         (1 `(let ((m (copy-matrix ,a)))
               (unfold m 0 (idx-dim m 0) 1)))
         (2 `(let ((m2 (copy-matrix ,a)))
               (idx-transclone m2 '(1 0))))
         (t (dhc-error "Two dimensioned matrix expected" a)) )) ) ) )





;;; ------------------------------------------------------------------------
;;; DHM FOR PARSING 'MA' OPERATIONS
;;; ------------------------------------------------------------------------

;; ------------------------------
;; MA with one argument!

(dhm-t idx-clear(source)
  (when (<> (length source) 2)
    (dhc-error "one argument expected"))
  (let* ((in (cadr source))
         (tn (dhc-parse-expr-t in))
         (ndimin (==> :tn:type is-an-idxptr)))
    (if ~ndimin (dhc-error "not a matrix" in))
    (==> (unode-val :(unode-val :tn:type:u-type):u-type)
         access 'write)
    (if (< ndimin 3)
        (new t-node (list tn) :tn:type ()())
      (dhc-parse-replacement-source-t
       source
       (let ((yo '(idx-clear in)))
         (while (> ndimin 3)
           (setq yo `(idx-bloop ((in in)) ,yo))
           (incr ndimin -1))
         (setq yo `(idx-bloop ((in ,in)) ,yo))
         yo)))))

(dhm-c idx-clear(source treetype retplace)
  (let* ((idx-type :(cadr :treetype:tn-list):type)
         (ndim (==> idx-type is-an-idxptr))
         (srg-type (new dhc-type (==> idx-type get-element-type)))
         (ret-string (dhc-parse-expr-c (cadr source)
                                       (cadr :treetype:tn-list)
                                       ())))
    (dhc-add-c-statements
     (sprintf "Midx_m%dclear(%s,%s);"
              ndim ret-string
              (dhc-type-to-c-decl srg-type)))
    ret-string))


;; ------------------------------
;; MA with two same size args


(putp idx-copy 'cname "copy")
(putp idx-minus 'cname "minus")
(putp idx-abs 'cname "abs")
(putp idx-sqrt 'cname "sqrt")
(putp idx-qtanh 'cname "qtanh")
(putp idx-qdtanh 'cname "qdtanh")
(putp idx-stdsigmoid 'cname "stdsigmoid")
(putp idx-dstdsigmoid 'cname "dstdsigmoid")
(putp idx-expmx 'cname "expmx")
(putp idx-dexpmx 'cname "dexpmx")
(putp idx-sin 'cname "sin")
(putp idx-cos 'cname "cos")
(putp idx-atan 'cname "atan")
(putp idx-log 'cname "log")
(putp idx-exp 'cname "exp")

(dhm-t idx-copy(source)
  (when (and (<> (length source) 3) (<> (length source) 2))
    (dhc-error "This function has one or two (in [out]) arguments"))
  (let* ((in (cadr source))
         (tn-in (dhc-parse-expr-t in))
         (ndimin (==> :tn-in:type is-an-idxptr)))
    (if ~ndimin (dhc-error "not a matrix" in))
    (if (= (length source) 3)
        (let* ((out (caddr source))
               (tn-out (dhc-parse-expr-t out))
               (ndimout (==> :tn-out:type is-an-idxptr)))
          (if ~ndimout (dhc-error "not a matrix" out))
          (when (<> ndimin ndimout)
            (dhc-error 
             "Matrices have different numbers of dimensions"))
          (==> (unode-val :(unode-val :tn-out:type:u-type):u-type)
               access 'write)
          ;; because automatic redimensioning
          (==> (unode-val :tn-out:type:u-type)
               access 'write)
          (if (< ndimin 3)
              (new t-node (list tn-in tn-out) :tn-out:type () ())
            (dhc-parse-replacement-source-t
             source
             (let ((yo `(,(car source) in out)))
               (while (> ndimin 3)
                 (setq yo `(idx-bloop ((in in)(out out)) ,yo))
                 (incr ndimin -1))
               (setq yo `(idx-bloop ((in ,in)(out ,out)) ,yo))
               yo))))
      (if (< ndimin 3)
          (dhc-parse-replacement-source-t 
           source
           `(let* ((in ,in))
              (,(car source) in (clone-matrix in))))
        (dhc-parse-replacement-source-t
         source
         (let ((yo `(,(car source) in out)))
           (while (> ndimin 3)
             (setq yo `(idx-bloop ((in in)(out out)) ,yo))
             (incr ndimin -1))
           (setq yo `(let* ((in ,in) (out (clone-matrix in)))
                       (idx-bloop ((in in)(out out)) ,yo)))
           yo))))))


(dhm-c idx-copy(source treetype retplace)
  (let* ((idx-type-in :(cadr :treetype:tn-list):type)
         (cname (or (getp (get-dhm-target source) 'cname)
                    (dhc-error "Cannot compile this function (no cname)") ) )
         (idx-type-out :(caddr :treetype:tn-list):type)
         (ndim (==> idx-type-in is-an-idxptr))
         (srg-type-in (new dhc-type (==> idx-type-in get-element-type)))
         (srg-type-out (new dhc-type (==> idx-type-out get-element-type)))
         (c1 (dhc-parse-expr-c (cadr source)(cadr :treetype:tn-list)()))
         (ret-string (dhc-parse-expr-c (last source)
                                       (last :treetype:tn-list)
                                       ())))
    (if ~dhc-unprotect
        (dhc-add-c-statements
         (sprintf "check_main_maout(%s,%s);" c1 ret-string)))
    (dhc-add-c-statements
     (sprintf "Midx_m%d%s(%s,%s,%s,%s);"
              ndim cname c1 ret-string
              (dhc-type-to-c-decl srg-type-in)
              (dhc-type-to-c-decl srg-type-out)))
    ret-string))

(dhm-t-declare idx-copy idx-minus idx-abs idx-sqrt idx-qtanh idx-qdtanh
	       idx-stdsigmoid idx-dstdsigmoid idx-expmx idx-dexpmx idx-sin
	       idx-cos idx-atan idx-log idx-exp)
(dhm-c-declare idx-copy idx-minus idx-abs idx-sqrt idx-qtanh idx-qdtanh
	       idx-stdsigmoid idx-dstdsigmoid idx-expmx idx-dexpmx idx-sin
	       idx-cos idx-atan idx-log idx-exp)

;; ------------------------------
;; MA with two arguments, 
;; last one of dim 0

(putp idx-sum    'dhmarg idx-sumacc) 
(putp idx-sup    'dhmarg idx-supacc)
(putp idx-inf    'dhmarg idx-infacc)
(putp idx-sumsqr 'dhmarg idx-sumsqracc)

(putp idx-sum 'cname "sum")
(putp idx-sup 'cname "sup")
(putp idx-inf 'cname "inf")
(putp idx-sum 'clear t)

(putp idx-sumacc 'cname "sumacc")
(putp idx-supacc 'cname "supacc")
(putp idx-infacc 'cname "infacc")
(putp idx-sumsqr 'cname "sumsqr")
(putp idx-sumsqracc 'cname "sumsqracc")

(dhm-t idx-sum(source)
  (when (and (<> (length source) 3) (<> (length source) 2))
    (dhc-error "This function has one or two (in [out]) arguments"))
  (let* ((in (cadr source))
         (name (get-dhm-target source))
         (inner-name (or (getp name 'dhmarg) name))
         (tn-in (dhc-parse-expr-t in))
         (ndimin (==> :tn-in:type is-an-idxptr))
         (mgen (cadr (assoc (==> :tn-in:type get-element-type)
                            dhc-type-to-matrix))))
    
	 
    (if ~ndimin (dhc-error "not a matrix" in))
    (if (= (length source) 3)
        (let* ((out (caddr source))
               (tn-out (dhc-parse-expr-t out))
               (ndimout (==> :tn-out:type is-an-idxptr)))
          (if ~ndimout (dhc-error "not a matrix" out))
          (when (<> 0 ndimout)
            (dhc-error 
             "Output matrix is not an idx0"))
          (==> (unode-val :(unode-val :tn-out:type:u-type):u-type)
               access 'write)
          ;; because automatic redimensioning
          (==> (unode-val :tn-out:type:u-type)
               access 'write)
          (if (< ndimin 3)
              ;; full args, idx1
              (new t-node (list tn-in tn-out) :tn-out:type () ())
            ;; full args, idx3
            (dhc-parse-replacement-source-t
             source
             (let ((yo `(,inner-name in tEmP_m3AT)))
               (while (> ndimin 3)
                 (setq yo `(idx-bloop ((in in)) ,yo))
                 (incr ndimin -1))
               (setq yo `((idx-bloop ((in ,in)) ,yo)))
               (when (<> inner-name name)
                 (print inner-name name)
                 (if (print (getp (get-dhm-target name) 'clear))
                     (setq yo  `((idx-clear tEmP_m3AT) ,@yo))
                   (let ((to (new dhc-type (==> :tn-out:type get-element-type)))
                         (ti (new dhc-type (==> :tn-in:type get-element-type))) )
                     (setq yo `((cinline 
                                 ,(concat "*IDX_PTR((%s)," (dhc-type-to-c-decl to) 
                                          ") = *IDX_PTR((%s)," (dhc-type-to-c-decl ti) ");" )
                                 tEmP_m3AT ,in ) ,@yo)) ) ) )
               (setq yo `(let ((tEmP_m3AT ,out)) ,@yo tEmP_m3AT))
               yo))))
      ;; small idx, missing arg
      (dhc-parse-replacement-source-t 
       source `(progn (,name ,in (,mgen))) ) ) ) )

(dhm-c idx-sum(source treetype retplace)
  (let* ((idx-type-in :(cadr :treetype:tn-list):type)
         (cname (or (getp (get-dhm-target source) 'cname)
                    (dhc-error "Cannot compile this function (no cname)") ) )
         (idx-type-out :(caddr :treetype:tn-list):type)
         (ndim (==> idx-type-in is-an-idxptr))
         (srg-type-in (new dhc-type (==> idx-type-in get-element-type)))
         (srg-type-out (new dhc-type (==> idx-type-out get-element-type)))
         (c1 (dhc-parse-expr-c (cadr source)(cadr :treetype:tn-list)()))
         (ret-string (dhc-parse-expr-c (last source)
                                       (last :treetype:tn-list)
                                       ())))
    (if ~dhc-unprotect
        (dhc-add-c-statements
         (sprintf "check_main_m0out(%s,%s);" c1 ret-string)))
    (dhc-add-c-statements
     (sprintf "Midx_m%d%s(%s,%s,%s,%s);"
              ndim cname c1 ret-string
              (dhc-type-to-c-decl srg-type-in)
              (dhc-type-to-c-decl srg-type-out)))
    ret-string))

(dhm-t-declare idx-sum idx-sup idx-inf idx-sumacc 
               idx-supacc idx-infacc idx-sumsqr idx-sumsqracc)
(dhm-c-declare idx-sum idx-sup idx-inf idx-sumacc 
               idx-supacc idx-infacc idx-sumsqr idx-sumsqracc)

;; ------------------------------
;; MA with three same size args

(putp idx-add 'cname "add")
(putp idx-sub 'cname "sub")
(putp idx-mul 'cname "mul")
(putp idx-div 'cname "div")

(dhm-t idx-add(source)
  (when (and (<> (length source) 4) (<> (length source) 3))
    (dhc-error "This function has 2 or 3 (in in [out]) arguments"))
  (let* ((in1 (cadr source))
         (in2 (caddr source))
         (name (car source))
         (tn-in1 (dhc-parse-expr-t in1))
         (tn-in2 (dhc-parse-expr-t in2))
         (ndimin1 (==> :tn-in1:type is-an-idxptr))
         (ndimin2 (==> :tn-in2:type is-an-idxptr)))
    (if ~ndimin1 (dhc-error "not a matrix" in1))
    (if ~ndimin2 (dhc-error "not a matrix" in2))
    (when (<> ndimin1 ndimin2)
      (dhc-error 
       "Input matrices have different numbers of dimensions"))
    (if (= (length source) 4)
        (let* ((out (caddr (cdr source)))
               (tn-out (dhc-parse-expr-t out))
		    (ndimout (==> :tn-out:type is-an-idxptr)))
          (if ~ndimout (dhc-error "not a matrix" out))
          (when (<> ndimin1 ndimout)
            (dhc-error 
             "Matrices have different numbers of dimensions"))
          (==> (unode-val :(unode-val :tn-out:type:u-type):u-type)
               access 'write)
          ;; because automatic redimensioning
          (==> (unode-val :tn-out:type:u-type)
               access 'write)
          (if (< ndimin1 3)
              (new t-node (list tn-in1 tn-in2 tn-out) :tn-out:type () ())
            (dhc-parse-replacement-source-t
             source
             (let ((yo `(,name in1 in2 out)))
               (while (> ndimin1 3)
                 (setq yo `(idx-bloop ((in1 in1)(in2 in2)(out out)) ,yo))
                 (incr ndimin1 -1))
               (setq yo `(idx-bloop ((in1 ,in1)(in2 ,in2)(out ,out))
                           ,yo))
               yo))))
      (if (< ndimin1 3)
          (dhc-parse-replacement-source-t 
           source
           `(let ((tEmP_m1AT ,in1))
              (,name tEmP_m1AT ,in2 (clone-matrix tEmP_m1AT))))
        (dhc-parse-replacement-source-t
         source
         (let ((yo `(,name tEmP_m1AT in2 tEmP_m3AT)))
           (while (> ndimin1 3)
             (setq yo `(idx-bloop ((tEmP_m1AT tEmP_m1AT)
                                   (in2 in2)(tEmP_m3AT tEmP_m3AT))
                         ,yo))
             (incr ndimin1 -1))
           ;; beware of in1 or out appearing in2 (why strange names)
           (setq yo `(let* ((tEmP_m1AT ,in1)
                            (tEmP_m3AT (clone-matrix tEmP_m1AT)))
                       (idx-bloop ((tEmP_m1AT tEmP_m1AT)
                                   (in2 ,in2)
                                   (tEmP_m3AT tEmP_m3AT)) ,yo)))
           yo))))))

(dhm-c idx-add(source treetype retplace)
  (let* ((idx-type-in1 :(cadr :treetype:tn-list):type)
         (idx-type-in2 :(caddr :treetype:tn-list):type)
         (cname (or (getp (get-dhm-target source) 'cname)
                    (dhc-error "Cannot compile this function (no cname)") ) )
         (idx-type-out :(caddr (cdr :treetype:tn-list)):type)
         (ndim (==> idx-type-in1 is-an-idxptr))
         (srg-type-in1 (new dhc-type (==> idx-type-in1 get-element-type)))
         (srg-type-in2 (new dhc-type (==> idx-type-in2 get-element-type)))
         (srg-type-out (new dhc-type (==> idx-type-out get-element-type)))
         (c1 (dhc-parse-expr-c (cadr source)(cadr :treetype:tn-list)()))
         (c2 (dhc-parse-expr-c (caddr source)(caddr :treetype:tn-list)()))
         (ret-string (dhc-parse-expr-c (last source)
                                       (last :treetype:tn-list)
                                       ())))
    (if ~dhc-unprotect
        (dhc-add-c-statements
         (sprintf "check_main_main_maout(%s,%s,%s);" c1 c2 ret-string)))
    (dhc-add-c-statements
     (sprintf "Midx_m%d%s(%s,%s,%s,%s,%s,%s);"
              ndim cname c1 c2 ret-string
              (dhc-type-to-c-decl srg-type-in1)
              (dhc-type-to-c-decl srg-type-in2)
              (dhc-type-to-c-decl srg-type-out)))
    ret-string))

(dhm-t-declare idx-add idx-sub idx-mul idx-div)
(dhm-c-declare idx-add idx-sub idx-mul idx-div)

;; ------------------------------
;; MA with 3 arguments,
;; last one of dim 0

(putp idx-dot     'dhmarg idx-dotacc)
(putp idx-sqrdist 'dhmarg idx-sqrdistacc)
(putp idx-sqrdist 'cname "sqrdist")
(putp idx-sqrdistacc 'cname "sqrdistacc")


(dhm-t idx-dot(source)
  (when (and (<> (length source) 3) (<> (length source) 4))
    (dhc-error "This function has two or three (in in [out]) arguments"))
  (let* ((in1 (cadr source))
         (in2 (caddr source))
         (name (get-dhm-target source))
         (inner-name (or (getp name 'dhmarg) name))
         (tn-in1 (dhc-parse-expr-t in1))
         (tn-in2 (dhc-parse-expr-t in2))
         (ndimin1 (==> :tn-in1:type is-an-idxptr))
         (ndimin2 (==> :tn-in2:type is-an-idxptr))
         (mgen (caddr (assoc (==> :tn-in1:type get-element-type)
                             dhc-type-to-matrix))))
    (if ~ndimin1 (dhc-error "not a matrix" in1))
    (if ~ndimin2 (dhc-error "not a matrix" in2))
    (when (<> ndimin1 ndimin2)
      (dhc-error "Input matrices have different numbers of dimensions"))
    (if (= (length source) 4)
        (let* ((out (last source))
               (tn-out (dhc-parse-expr-t out))
               (ndimout (==> :tn-out:type is-an-idxptr)))
          (if ~ndimout (dhc-error "not a matrix" out))
          (when (<> 0 ndimout)
            (dhc-error "Output matrix is not an idx0"))
          (==> (unode-val :(unode-val :tn-out:type:u-type):u-type)
               access 'write)
          (if (< ndimin1 3)
              ;; full args, idx1
              (new t-node (list tn-in1 tn-in2 tn-out) :tn-out:type () ())
            ;; full args, idx3
            (dhc-parse-replacement-source-t
             source
             (let ((yo `(,inner-name in1 in2 tEmP_m3AT)))
               (while (> ndimin1 3)
                 (setq yo `(idx-bloop ((in1 in1)(in2 in2)) ,yo))
                 (incr ndimin1 -1))
               (setq yo `(idx-bloop ((in1 ,in1)(in2 ,in2))
                           ,yo))
               (setq yo `(let ((tEmP_m3AT ,(if (= inner-name name)
                                               out `(idx-clear ,out))))
                           ,yo tEmP_m3AT))
               yo))))
      ;; small idx, missing arg
      (if (< ndimin1 3)
          (dhc-parse-replacement-source-t 
           source
           ;; progn necessary or it generates 2 dhm cells in treetype
           `(progn (,name ,in1 ,in2 (,mgen))))
        ;; idx3, missing arg
        (dhc-parse-replacement-source-t
         source
         (let ((yo `(,inner-name in1 in2 tEmP_m3AT)))
           (while (> ndimin1 3)
             (setq yo `(idx-bloop ((in1 in1)(in2 in2)) ,yo))
             (incr ndimin1 -1))
           (setq yo `(let* ((tEmP_m3AT (,mgen)))
                       (idx-bloop ((in1 ,in1)(in2 ,in2)) ,yo) tEmP_m3AT))
           yo))))))

(dhm-c idx-dot(source treetype retplace)
  (let* ((idx-type-in1 :(cadr :treetype:tn-list):type)
         (idx-type-in2 :(caddr :treetype:tn-list):type)
         (ndim (==> idx-type-in1 is-an-idxptr))
         (name (get-dhm-target source))
         (cname (cond
                 ((= name idx-dot) (sprintf "dotm%d" ndim))
                 ((= name idx-dotacc) (sprintf "dotm%dacc" ndim))
                 (t (or (getp (get-dhm-target source) 'cname)
                        (dhc-error "Cannot compile this function (no cname)") )) ) )
         (idx-type-out :(last :treetype:tn-list):type)
         (srg-type-in1 (new dhc-type (==> idx-type-in1 get-element-type)))
         (srg-type-in2 (new dhc-type (==> idx-type-in2 get-element-type)))
         (srg-type-out (new dhc-type (==> idx-type-out get-element-type)))
         (c1 (dhc-parse-expr-c (cadr source)(cadr :treetype:tn-list)()))
         (c2 (dhc-parse-expr-c (caddr source)(caddr :treetype:tn-list)()))
         (ret-string (dhc-parse-expr-c (last source) 
                                       (last :treetype:tn-list) ())))
    (if ~dhc-unprotect
        (dhc-add-c-statements
         (sprintf "check_main_main_m0out(%s,%s,%s);" c1 c2 ret-string)))
    (dhc-add-c-statements
     (sprintf "Midx_m%d%s(%s,%s,%s,%s,%s,%s);"
              ndim cname c1 c2 ret-string
              (dhc-type-to-c-decl srg-type-in1)
              (dhc-type-to-c-decl srg-type-in2)
              (dhc-type-to-c-decl srg-type-out)))
    ret-string))

(dhm-t-declare idx-dot idx-dotacc idx-sqrdist idx-sqrdistacc)
(dhm-c-declare idx-dot idx-dotacc idx-sqrdist idx-sqrdistacc)


;; ------------------------------
;; MA with three args,
;; second one of dim 0

(putp idx-dotm0 'cname "dotm0")
(putp idx-dotm0acc 'cname "dotm0acc")
(putp idx-addm0 'cname "addm0")
(putp idx-addm0acc 'cname "addm0acc")

(dhm-t idx-dotm0(source)
  (when (and (<> (length source) 4) (<> (length source) 3))
    (dhc-error "This function has 2 or 3 (in in [out]) arguments"))
  (let* ((in1 (cadr source))
         (in2 (caddr source))
         (name (car source))
         (tn-in1 (dhc-parse-expr-t in1))
         (tn-in2 (dhc-parse-expr-t in2))
         (ndimin1 (==> :tn-in1:type is-an-idxptr))
         (ndimin2 (==> :tn-in2:type is-an-idxptr)))
    (if ~ndimin1 (dhc-error "not a matrix" in1))
    (if ~ndimin2 (dhc-error "not a matrix" in2))
    (when (<> ndimin2 0)
      (dhc-error "Second input matrix must be an idx0"))
    (if (= (length source) 4)
        (let* ((out (caddr (cdr source)))
               (tn-out (dhc-parse-expr-t out))
               (ndimout (==> :tn-out:type is-an-idxptr)))
          (if ~ndimout (dhc-error "not a matrix" out))
          (when (<> ndimin1 ndimout)
            (dhc-error "Matrices have different numbers of dimensions"))
          (==> (unode-val :(unode-val :tn-out:type:u-type):u-type)
               access 'write)
          (==> (unode-val :tn-out:type:u-type)
               access 'write)
          (if (< ndimin1 3)
              (new t-node (list tn-in1 tn-in2 tn-out) :tn-out:type () ())
            (dhc-parse-replacement-source-t
             source
             (let ((yo `(,name in1 tEmP_m3AT out)))
               (while (> ndimin1 3)
                 (setq yo `(idx-bloop ((in1 in1)(out out)) ,yo))
                 (incr ndimin1 -1))
               (setq yo `(let ((tEmP_m3AT ,in2))
                           (idx-bloop ((in1 ,in1)(out ,out))
                             ,yo)))
               yo))))
      (if (< ndimin1 3)
          (dhc-parse-replacement-source-t 
           source
           `(let ((tEmP_m1AT ,in1))
              (,name tEmP_m1AT ,in2 (clone-matrix tEmP_m1AT))))
        (dhc-parse-replacement-source-t
         source
         (let ((yo `(,name tEmP_m1AT in2 out)))
           (while (> ndimin1 3)
             (setq yo `(idx-bloop ((tEmP_m1AT tEmP_m1AT)
                                   (out out))
                         ,yo))
             (incr ndimin1 -1))
           (setq yo `(let* ((tEmP_m1AT ,in1)
                            (in2 ,in2)
                            (out (clone-matrix tEmP_m1AT)))
                       (idx-bloop ((tEmP_m1AT tEmP_m1AT)
                                   (out out)) ,yo)))
           yo))))))

(dhm-c idx-dotm0(source treetype retplace)
  (let* ((idx-type-in1 :(cadr :treetype:tn-list):type)
         (idx-type-in2 :(caddr :treetype:tn-list):type)
         (cname (or (getp (get-dhm-target source) 'cname)
                    (dhc-error "Cannot compile this function (no cname)") ))
         (idx-type-out :(caddr (cdr :treetype:tn-list)):type)
         (ndim (==> idx-type-in1 is-an-idxptr))
         (srg-type-in1 (new dhc-type (==> idx-type-in1 get-element-type)))
         (srg-type-in2 (new dhc-type (==> idx-type-in2 get-element-type)))
         (srg-type-out (new dhc-type (==> idx-type-out get-element-type)))
         (c1 (dhc-parse-expr-c (cadr source)(cadr :treetype:tn-list)()))
         (c2 (dhc-parse-expr-c (caddr source)(caddr :treetype:tn-list)()))
         (ret-string (dhc-parse-expr-c (last source)
                                       (last :treetype:tn-list)
                                       ())))
    (if ~dhc-unprotect
        (dhc-add-c-statements
         (sprintf "check_main_m0in_maout(%s,%s,%s);" c1 c2 ret-string)))
    (dhc-add-c-statements
     (sprintf "Midx_m%d%s(%s,%s,%s,%s,%s,%s);"
              ndim cname c1 c2 ret-string
              (dhc-type-to-c-decl srg-type-in1)
              (dhc-type-to-c-decl srg-type-in2)
              (dhc-type-to-c-decl srg-type-out)))
	 ret-string))

(dhm-t-declare idx-dotm0 idx-dotm0acc idx-addm0 idx-addm0acc)
(dhm-c-declare idx-dotm0 idx-dotm0acc idx-addm0 idx-addm0acc)

;; ------------------------------
;; Matrix * Vector

(putp idx-m2dotm1 'cname "m2dotm1")
(putp idx-m2dotm1acc 'cname "m2dotm1acc")

(dhm-t idx-m2dotm1(source)
  (when (and (<> (length source) 3) (<> (length source) 4))
    (dhc-error "This function has 2 or 3 (in in [out]) arguments"))
  (let* ((in1 (cadr source))
         (in2 (caddr source))
         (name (car source))
         (tn-in1 (dhc-parse-expr-t in1))
         (tn-in2 (dhc-parse-expr-t in2))
         (ndimin1 (==> :tn-in1:type is-an-idxptr))
         (ndimin2 (==> :tn-in2:type is-an-idxptr)))
    (if ~ndimin1 (dhc-error "not a matrix" in1))
    (if ~ndimin2 (dhc-error "not a matrix" in2))
    (if (<> ndimin1 2) (dhc-error "Arg #1 is not a 2 dimensional matrix"))
    (if (<> ndimin2 1) (dhc-error "Arg #2 is not a 1 dimensional matrix"))
    (if (= (length source) 4)
        (let* ((out (last source))
               (tn-out (dhc-parse-expr-t out))
               (ndimout (==> :tn-out:type is-an-idxptr)))
          (if ~ndimout (dhc-error "not a matrix" out))
          (if (<> ndimout 1) (dhc-error 
                              "Arg #3 is not a 1 dimensional matrix"))
          (==> (unode-val :(unode-val :tn-out:type:u-type):u-type)
               access 'write)
          (==> (unode-val :tn-out:type:u-type)
               access 'write)
          (new t-node (list tn-in1 tn-in2 tn-out) :tn-out:type () ()))
      ;; Missing arg
      (dhc-parse-replacement-source-t 
       source
       `(let ((in1 ,in1)(in2 ,in2))
          (let ((out (clone-matrix in2)))
            (,name in1 in2 out) out))))))

(dhm-c idx-m2dotm1(source treetype retplace)
  (let* ((idx-type-in1 :(cadr :treetype:tn-list):type)
         (idx-type-in2 :(caddr :treetype:tn-list):type)
         (ndim (==> idx-type-in1 is-an-idxptr))
         (cname (or (getp (get-dhm-target source) 'cname)
                    (dhc-error "Cannot compile this function (no cname)") ) )
         (idx-type-out :(last :treetype:tn-list):type)
         (srg-type-in1 (new dhc-type (==> idx-type-in1 get-element-type)))
         (srg-type-in2 (new dhc-type (==> idx-type-in2 get-element-type)))
         (srg-type-out (new dhc-type (==> idx-type-out get-element-type)))
         (c1 (dhc-parse-expr-c (cadr source)(cadr :treetype:tn-list)()))
         (c2 (dhc-parse-expr-c (caddr source)(caddr :treetype:tn-list)()))
         (ret-string (dhc-parse-expr-c (last source) 
                                       (last :treetype:tn-list) ())))
    (if ~dhc-unprotect
        (dhc-add-c-statements
         (sprintf "check_main_main_maout_dot21(%s,%s,%s);" c1 c2 ret-string)))
    (dhc-add-c-statements
     (sprintf "Midx_%s(%s,%s,%s,%s,%s,%s);"
              cname c1 c2 ret-string
              (dhc-type-to-c-decl srg-type-in1)
              (dhc-type-to-c-decl srg-type-in2)
              (dhc-type-to-c-decl srg-type-out)))
    ret-string))

(dhm-t-declare idx-m2dotm1 idx-m2dotm1acc)
(dhm-c-declare idx-m2dotm1 idx-m2dotm1acc)



;; ------------------------------
;; Tensor4 * Tensor2

(putp idx-m4dotm2 'cname "m4dotm2")
(putp idx-m4dotm2acc 'cname "m4dotm2acc")

(dhm-t idx-m4dotm2(source)
  (when (and (<> (length source) 3) (<> (length source) 4))
    (dhc-error "This function has 2 or 3 (in in [out]) arguments"))
  (let* ((in1 (cadr source))
         (in2 (caddr source))
         (name (car source))
         (tn-in1 (dhc-parse-expr-t in1))
         (tn-in2 (dhc-parse-expr-t in2))
         (ndimin1 (==> :tn-in1:type is-an-idxptr))
         (ndimin2 (==> :tn-in2:type is-an-idxptr)))
    (if ~ndimin1 (dhc-error "not a matrix" in1))
    (if ~ndimin2 (dhc-error "not a matrix" in2))
    (if (<> ndimin1 4) (dhc-error "Arg #1 is not a 4 dimensional matrix"))
    (if (<> ndimin2 2) (dhc-error "Arg #2 is not a 2 dimensional matrix"))
    (if (= (length source) 4)
        (let* ((out (last source))
               (tn-out (dhc-parse-expr-t out))
               (ndimout (==> :tn-out:type is-an-idxptr)))
          (if ~ndimout (dhc-error "not a matrix" out))
          (if (<> ndimout 2) 
              (dhc-error "Arg #3 is not a 2 dimensional matrix"))
          (==> (unode-val :(unode-val :tn-out:type:u-type):u-type)
               access 'write)
          (==> (unode-val :tn-out:type:u-type)
               access 'write)
          (new t-node (list tn-in1 tn-in2 tn-out) :tn-out:type () ()))
      ;; Missing arg
      (dhc-parse-replacement-source-t 
       source
       `(let ((in1 ,in1)(in2 ,in2))
          (let ((out (clone-matrix in2)))
            (,name in1 in2 out) out))))))

(dhm-c idx-m4dotm2(source treetype retplace)
  (let* ((idx-type-in1 :(cadr :treetype:tn-list):type)
         (idx-type-in2 :(caddr :treetype:tn-list):type)
         (ndim (==> idx-type-in1 is-an-idxptr))
         (cname (or (getp (get-dhm-target source) 'cname)
                    (dhc-error "Cannot compile this function (no cname)") ) )
         (idx-type-out :(last :treetype:tn-list):type)
         (srg-type-in1 (new dhc-type (==> idx-type-in1 get-element-type)))
         (srg-type-in2 (new dhc-type (==> idx-type-in2 get-element-type)))
         (srg-type-out (new dhc-type (==> idx-type-out get-element-type)))
         (c1 (dhc-parse-expr-c (cadr source)(cadr :treetype:tn-list)()))
         (c2 (dhc-parse-expr-c (caddr source)(caddr :treetype:tn-list)()))
         (ret-string (dhc-parse-expr-c (last source) 
                                       (last :treetype:tn-list) ())))
    (if ~dhc-unprotect
        (dhc-add-c-statements
         (sprintf "check_main_main_maout_dot42(%s,%s,%s);" 
                  c1 c2 ret-string)))
    (dhc-add-c-statements
     (sprintf "Midx_%s(%s,%s,%s,%s,%s,%s);"
              cname c1 c2 ret-string
              (dhc-type-to-c-decl srg-type-in1)
              (dhc-type-to-c-decl srg-type-in2)
              (dhc-type-to-c-decl srg-type-out)))
    ret-string))

(dhm-t-declare idx-m4dotm2 idx-m4dotm2acc)
(dhm-c-declare idx-m4dotm2 idx-m4dotm2acc)



;; ------------------------------
;; External product

(putp idx-m1extm1 'dhmarg 1)
(putp idx-m2extm2 'dhmarg 2)
(putp idx-m1extm1acc 'dhmarg 1)
(putp idx-m2extm2acc 'dhmarg 2)
(putp idx-m1extm1 'cname "m1extm1")
(putp idx-m2extm2 'cname "m2extm2")
(putp idx-m1extm1acc 'cname "m1extm1acc")
(putp idx-m2extm2acc 'cname "m2extm2acc")

(dhm-t idx-m1extm1(source)
  (when (and (<> (length source) 3) (<> (length source) 4))
    (dhc-error "This function has 2 or 3 (in in [out]) arguments"))
  (let* ((in1 (cadr source))
         (in2 (caddr source))
         (name (get-dhm-target source))
         (e-dim (getp name 'dhmarg))
         (tn-in1 (dhc-parse-expr-t in1))
         (tn-in2 (dhc-parse-expr-t in2))
         (ndimin1 (==> :tn-in1:type is-an-idxptr))
         (ndimin2 (==> :tn-in2:type is-an-idxptr))
         (mgen (cadr (assoc (==> :tn-in1:type get-element-type)
                            dhc-type-to-matrix))))
    (if ~ndimin1 (dhc-error "not a matrix" in1))
    (if ~ndimin2 (dhc-error "not a matrix" in2))
    (if (<> ndimin1 e-dim) 
        (dhc-error (sprintf "Arg #1 is not a %dD matrix" e-dim)))
    (if (<> ndimin2 e-dim) 
        (dhc-error (sprintf "Arg #2 is not a %dD matrix" e-dim)))
    (if (= (length source) 4)
        (let* ((out (last source))
               (tn-out (dhc-parse-expr-t out))
               (ndimout (==> :tn-out:type is-an-idxptr)))
          (if ~ndimout (dhc-error "not a matrix" out))
          (if (<> ndimout (* 2 e-dim))
              (dhc-error 
               (sprintf "Arg #3 is not a %dD matrix" e-dim)))
          (==> (unode-val :(unode-val :tn-out:type:u-type):u-type)
               access 'write)
          (==> (unode-val :tn-out:type:u-type)
               access 'write)
          (new t-node (list tn-in1 tn-in2 tn-out) :tn-out:type () ()))
      ;; Missing arg
      (dhc-parse-replacement-source-t 
       source
       `(let ((in1 ,in1)(in2 ,in2))
          (let ((out ,(if (= e-dim 1)
                          `(,mgen (idx-dim in1 0) (idx-dim in2 0))
                        `(,mgen (idx-dim in1 0) (idx-dim in1 1)
                                (idx-dim in2 0) (idx-dim in2 1)))))
            (,name in1 in2 out) out))))))


(dhm-c idx-m1extm1(source treetype retplace)
  (let* ((idx-type-in1 :(cadr :treetype:tn-list):type)
         (idx-type-in2 :(caddr :treetype:tn-list):type)
         (ndim (==> idx-type-in1 is-an-idxptr))
         (cname (or (getp (get-dhm-target source) 'cname)
                    (dhc-error "Cannot compile this function (no cname)") ) )
         (idx-type-out :(last :treetype:tn-list):type)
         (srg-type-in1 (new dhc-type (==> idx-type-in1 get-element-type)))
         (srg-type-in2 (new dhc-type (==> idx-type-in2 get-element-type)))
         (srg-type-out (new dhc-type (==> idx-type-out get-element-type)))
         (c1 (dhc-parse-expr-c (cadr source)(cadr :treetype:tn-list)()))
         (c2 (dhc-parse-expr-c (caddr source)(caddr :treetype:tn-list)()))
         (ret-string (dhc-parse-expr-c (last source) 
                                       (last :treetype:tn-list) ())))
    (if ~dhc-unprotect
        (dhc-add-c-statements
         (sprintf (if (= ndim 1) "check_m1in_m1in_m2out(%s,%s,%s);" 
                    "check_m2in_m2in_m4out(%s,%s,%s);")
                  c1 c2 ret-string)))
    (dhc-add-c-statements
     (sprintf "Midx_%s(%s,%s,%s,%s,%s,%s);"
              cname c1 c2 ret-string
              (dhc-type-to-c-decl srg-type-in1)
              (dhc-type-to-c-decl srg-type-in2)
              (dhc-type-to-c-decl srg-type-out)))
    ret-string))

(dhm-t-declare idx-m1extm1 idx-m2extm2 idx-m1extm1acc idx-m2extm2acc)
(dhm-c-declare idx-m1extm1 idx-m2extm2 idx-m1extm1acc idx-m2extm2acc)



;;; ------------------------------------------------------------------------
;;; DHM FOR PARSING PRINTF
;;; ------------------------------------------------------------------------


(de dhc-match-string-types (source arg-tnodes)
  (let*  ((arg-types
           (all ((ty arg-tnodes))
             (if (==> :ty:type is-a-ptr)
                 (dhu-tclass (dhu-type :ty:type))
               (dhu-tclass :ty:type))) )
          (str-type ())
          (search (lambda (pos) 
                    (regex-seek
                     "((%)(-)?([0-9])*(\\.)?([0-9])*([a-z]|[A-Z]|\\ ))|(%%)"
                     source (+ (car pos) (cadr pos)))))
          (pos '(0 0)) (i 0) (num-args (length arg-types)))
    (while (and pos (< i num-args))
      (setq pos (search pos))
      (when (consp pos)
        (setq str-type (mid source (car pos) (cadr pos)))
        (if (not (selectq (right str-type 1)
                   ("d" 
                    (member (car arg-types) 
                            '(dht-number dht-int dht-byte dht-ubyte)))
                   (("f" "e" "g")
                    (member (car arg-types)
                            '(dht-number dht-flt dht-real)))
                   (("x" "X")
                    (member (car arg-types) 
                            '(dht-number dht-int dht-byte dht-ubyte)))
                   ("s"
                    (member (car arg-types) 
                            '(dht-str)))
                   ("%" t)
                   (t (dhc-error (concat "unknown type \" " str-type "\"")) ) ))
            (dhc-error (concat "type mismatch: \"" source "\" -> "  str-type)) )
        (when (<> "%" (right str-type 1))
          (setq arg-types (cdr arg-types))
          (setq i (+ 1 i)))))
    (if (or (<> i num-args)
            (and pos (setq pos (search pos))
                 (<> "%%" (mid source (car pos) (cadr pos)))))
        (dhc-error "number of arguments disagrees with number in format string") ) ) )

(dhm-t printf(source)
  (when (> 2 (length source))
    (dhc-error "at least one argument expected"))
  (let* ((tns (all ((tn (cdr source)))
                (if (not (stringp tn))
                    (dhc-parse-expr-t tn)
                  (new t-node () (new dhc-type 'dht-ptr 
				      (new dhc-type 'dht-str)) tn ())))))
    (when ~(==> :(car tns):type is-a-strptr)
          (dhc-error "first argument must be a string"))
    (if (stringp (cadr source))
        (dhc-match-string-types :(car tns):source (cdr tns)))
    (new t-node tns (new dhc-type 'dht-bool))))

(dhm-c printf(source treetype retplace)
  (let ((data ())
        (arg-source (cdr source))
        (arg-names 
         (all ((nm (cdr source)) 
               (nmt (cdr :treetype:tn-list)))
           (if (not (stringp nm))
               (dhc-parse-expr-c nm nmt ())
             nm)))
        (arg-types
         (all ((ty (cdr :treetype:tn-list)))
           (if (==> :ty:type is-a-ptr)
               (dhu-tclass (dhu-type :ty:type))
             (dhu-tclass :ty:type))) ) )
    (if (not (stringp (car arg-source)))
        (setq data (sprintf "printf((char *)((%s)->data)" (car arg-names)))
      (setq data (sprintf "printf(%l" (car arg-source))) )
    (each ((thearg (cdr arg-names))
           (theargsource (cdr arg-source))
           (thetype (cdr arg-types)))
      (if (= thetype 'dht-str)
          (if ~(stringp theargsource)
            (setq data (concat data ",(char *)((" thearg ")->data)"))
            (setq data (concat data "," "\"" (dhc-printf-to-c theargsource) "\"")))
        (setq data (concat data "," thearg))))
    (dhc-add-c-statements  (concat  data ");")))
  "0")





;;; ------------------------------------------------------------------------
;;; DHM FOR PARSING STRING OPERATIONS
;;; ------------------------------------------------------------------------



(dhm-t asc(source)
  (when (<> 2 (length source))
    (dhc-error "one argument expected"))
  (let* ((tn (dhc-parse-expr-t (cadr source))))
    (when ~(==> :tn:type is-a-strptr)
          (dhc-error "argument must be an string"))
    (new t-node (list tn) (new dhc-type 'dht-ubyte))))

(dhm-c asc(source treetype retplace)
  (let ((exp (dhc-parse-expr-c (cadr source)
                               (cadr :treetype:tn-list) ())))
    (if ~dhc-unprotect
        (dhc-add-c-statements 
         (sprintf "RTERR_EMPTYSTR(!(strlen((char*)(%s->data))));" exp)))
    (sprintf "(*((%s *)%s->data))" 
             (dhc-type-to-c-decl :treetype:type) exp)))

(dhm-t chr(source)
  (when (<> 2 (length source))
    (dhc-error "one argument expected"))
  (let* ((ta (dhc-parse-expr-t (cadr source)))
         (na (==> :ta:type is-a-number))
         (rettype (new dhc-type 'dht-ptr (new dhc-type 'dht-str)))
         (srg-type (dhu-type rettype))
         (symbol-srg (new dhc-symbol (named (sprintf "%d_srg" 
                                                     tmpnames-seed))
                          lex-level))
         (tret (new t-node (list ta) rettype ())))
    (if ~na
        (dhc-error "argument must be a number")
      (incr tmpnames-seed)
      (dhc-unify-types :symbol-srg:type srg-type)
      (setq bump-list (append bump-list (list symbol-srg)))
      (setq :tret:transfer (list symbol-srg))
      tret)))

(dhm-c chr(source treetype retplace)
  (let* ((srg-symb (car :treetype:transfer))
         (val (dhc-parse-expr-c (cadr source)
                                (cadr :treetype:tn-list) ())))
    (if ~dhc-unprotect
        (dhc-add-c-statements
         (sprintf "RTERR_RANGE(((int)%s<0)||((int)%s>255));" val val)))
    
    (dhc-add-c-statements (sprintf "Msrg_resize(%s, 2);" :srg-symb:c-name))
    (dhc-add-c-statements 
     (sprintf "((char *)(%s->data))[0] = (int)%s;"
              :srg-symb:c-name val))
    (dhc-add-c-statements 
     (sprintf "((char *)(%s->data))[1] = '\\0';"
              :srg-symb:c-name))
    (sprintf "%s" :srg-symb:c-name)))

(dhm-t concat(source)
  (when (> 2 (length source))
    (dhc-error "one or more arguments expected"))
  (let* ((tns (all ((tn (cdr source)))
                (dhc-parse-expr-t tn)))
         (rettype (new dhc-type 'dht-ptr (new dhc-type 'dht-str)))
         (srg-type (dhu-type rettype))
         (symbol-srg (new dhc-symbol (named (sprintf "%d_srg" 
                                                     tmpnames-seed))
                          lex-level))
         (tret (new t-node tns rettype ())))
    (each ((na tns))
      (if (null (==> :na:type is-a-strptr))
          (dhc-error "arguments must all be strings")))
    (incr tmpnames-seed)
    (dhc-unify-types :symbol-srg:type srg-type)
    (setq bump-list (append bump-list (list symbol-srg)))
    (setq :tret:transfer (list symbol-srg))
    tret))

(dhm-c concat(source treetype retplace)
  (let* ((srg-symb (car :treetype:transfer))
         (string-names 
          (all ((nm (cdr source)) (nmt (cdr :treetype:tn-list)))
            (dhc-parse-expr-c nm nmt ()))) )
    (dhc-add-c-statements (sprintf "Msrg_resize(%s, "
                                   :srg-symb:c-name))
    (each ((thestr string-names))
      (dhc-add-c-statements (sprintf "strlen((char*)(%s->data))+"
                                     thestr)))
    (dhc-add-c-statements (sprintf "1);" ))
    (dhc-add-c-statements (sprintf "strcpy((char*)(%s->data),(char*)(%s->data));"
                                   :srg-symb:c-name (car string-names)))
    (each ((thestr (cdr string-names)))
      (dhc-add-c-statements (sprintf "strcat((char*)(%s->data),(char*)(%s->data));"
                                     :srg-symb:c-name thestr)))
    (sprintf "%s" :srg-symb:c-name)))

(dhm-t downcase(source)
  (when (<> 2 (length source))
    (dhc-error "one argument expected"))
  (let* ((ta (dhc-parse-expr-t (cadr source)))
         (na (==> :ta:type is-a-strptr))
         (rettype (new dhc-type 'dht-ptr (new dhc-type 'dht-str)))
         (srg-type (dhu-type rettype))
         (symbol-srg (new dhc-symbol (named (sprintf "%d_srg" 
                                                     tmpnames-seed))
                          lex-level))
         (tret (new t-node (list ta) rettype ())))
    (if ~na
        (dhc-error "argument must be a string")
      (setq :srg-type:u-extra (new-unode rettype))
      (incr tmpnames-seed)
      (dhc-unify-types :symbol-srg:type srg-type)
      (setq bump-list (append bump-list (list  symbol-srg)))
      (setq :tret:transfer (list symbol-srg))
      tret)))

(dhm-c downcase(source treetype retplace)
  (let* ((srg-symb (car :treetype:transfer))
         (thestr (dhc-parse-expr-c (cadr source)
                                   (cadr :treetype:tn-list) ())))
    (dhc-add-c-statements (sprintf "Msrg_resize(%s, strlen((char*)(%s->data))+1);"
                                   :srg-symb:c-name thestr))
    (dhc-add-c-statements (sprintf "{\nint ctr;\nctr=0;" )) 
    (dhc-add-c-statements (sprintf "while (ctr<strlen((char*)(%s->data)))" thestr))
    (dhc-add-c-statements (sprintf "{" ))
    (dhc-add-c-statements
     (sprintf 
      "((char *)(%s->data))[ctr]=tolower(((char *)(%s->data))[ctr]);"
      :srg-symb:c-name   thestr ))
    (dhc-add-c-statements (sprintf "ctr++;"))
    (dhc-add-c-statements (sprintf "}\n}" ))
    (dhc-add-c-statements
     (sprintf "((char *)(%s->data))[strlen((char*)(%s->data))]='\\0';"
              :srg-symb:c-name thestr))
    (sprintf "%s" :srg-symb:c-name)))

(dhm-t index(source)
       (when (and (<> 3 (length source)) (<> 4 (length source)))
	     (dhc-error "two or three arguments expected"))
       (let* ((tns (all ((tn (cdr source)))
			(dhc-parse-expr-t tn))))
	 (if (null (==> :(car tns):type is-a-strptr))
	     (dhc-error "first argument must be a string"))
	 (if (null (==> :(cadr tns):type is-a-strptr))
	     (dhc-error "second argument must be a string"))
	 (if ~(null (caddr tns))
	   (if (null (==> :(caddr tns):type is-a-number))
	       (dhc-error "third optional argument must be a number")))
	 
	 (new t-node tns (new dhc-type 'dht-int))))

(dhm-c index(source treetype retplace)
       (let* ((var-names 
	       (all ((nm (cdr source)) (nmt (cdr :treetype:tn-list)))
		    (dhc-parse-expr-c nm nmt ())))
	      (r (car var-names))
	      (s (cadr var-names))
	      (n (caddr var-names)) )
	 (dhc-add-c-externs (sprintf "extern_c int str_index();"))
	 (if (null n)   ; n present?
	     (sprintf "(%s) str_index(%s->data,%s->data,1)"
		      (dhc-type-to-c-decl :treetype:type) r s)
	   (if ~dhc-unprotect 
	       (dhc-add-c-statements
		(sprintf "RTERR_RANGE((int)%s<1);" n)))
	   (sprintf "(%s) str_index(%s->data,%s->data,%s)"
		    (dhc-type-to-c-decl :treetype:type) r s n))))
	 
(dhm-t len(source)
  (when (<> 2 (length source))
    (dhc-error "one argument expected"))
  (let* ((tn (dhc-parse-expr-t (cadr source)))
         (n (==> :tn:type is-a-strptr)))
    (if ~n
        (dhc-error "argument must be an string")
      (new t-node (list tn) (new dhc-type 'dht-int)))))

(dhm-c len(source treetype retplace)
  (let ((exp (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list) ())))
    (sprintf "(strlen((char*)(%s->data)))" exp)))

(dhm-t left(source)
  (when (<> 3 (length source))
    (dhc-error "two arguments expected"))
  (let* ((tn (dhc-parse-expr-t (cadr source)))
         (tm (dhc-parse-expr-t (caddr source)))
         (n (==> :tn:type is-a-strptr))
         (m (==> :tm:type is-a-number))
         (rettype (new dhc-type 'dht-ptr (new dhc-type 'dht-str)))
         (srg-type (dhu-type rettype))
         (symbol-srg (new dhc-symbol (named (sprintf "%d_srg" 
                                                     tmpnames-seed))
                          lex-level))
         (tret (new t-node (list tn tm) rettype ())))
    (if ~m
        (dhc-error "second argument must be a number"))
    (if ~n
        (dhc-error "first argument must be an string"))
    (incr tmpnames-seed)
    (dhc-unify-types :symbol-srg:type srg-type)
    (setq bump-list (append bump-list (list symbol-srg)))
    (setq :tret:transfer (list symbol-srg))
    tret))

(dhm-c left(source treetype retplace)
  (let* ((srg-symb (car :treetype:transfer))
         (valstr (dhc-parse-expr-c (cadr source)
                                   (cadr :treetype:tn-list) ()))
         (val (dhc-parse-expr-c (caddr source)
                                (caddr :treetype:tn-list) ())))
    (if ~dhc-unprotect 
        (dhc-add-c-statements
         (sprintf "RTERR_RANGE((int)%s<0);" val)))
    (dhc-add-c-statements (sprintf "Msrg_resize(%s, strlen((char*)(%s->data))+1);"
                                   :srg-symb:c-name valstr))
    (dhc-add-c-externs "char *memccpy();")
    (dhc-add-c-statements 
     (sprintf "if (memccpy(%s->data,%s->data,'\\0',(int) %s)==NULL)"
              :srg-symb:c-name valstr val))
    (dhc-add-c-statements (sprintf "((char *)(%s->data))[(int) %s]='\\0';"
                                   :srg-symb:c-name val))
    (sprintf "%s" :srg-symb:c-name)))

(dhm-t mid(source)
  (when (and (<> 3 (length source)) (<> 4 (length source)))
    (dhc-error "two or three arguments expected"))
  (let* ((tns (all ((tn (cdr source)))
                (dhc-parse-expr-t tn)))
         (rettype  (new dhc-type 'dht-ptr (new dhc-type 'dht-str)))
         (srg-type (dhu-type rettype))
         (symbol-srg (new dhc-symbol (named (sprintf "%d_srg" 
                                                     tmpnames-seed))
                          lex-level))
         (tret (new t-node tns rettype ())))
    (if (null (==> :(car tns):type is-a-strptr))
        (dhc-error "first argument must be a string"))
    (if (null (==> :(cadr tns):type is-a-number))
        (dhc-error "second argument must be a number"))
    (if ~(null (caddr tns))
      (if (null (==> :(caddr tns):type is-a-number))
          (dhc-error "third optional argument must be a number")))
    (incr tmpnames-seed)
    (dhc-unify-types :symbol-srg:type srg-type)
    (setq bump-list (append bump-list (list symbol-srg)))
    (setq :tret:transfer (list symbol-srg))
    tret))

(dhm-c mid(source treetype retplace)
  (let* ((srg-symb (car :treetype:transfer))
         (var-names 
          (all ((nm (cdr source)) (nmt (cdr :treetype:tn-list)))
            (dhc-parse-expr-c nm nmt ())))
         (thestr (car var-names))
         (n (cadr var-names))
         (l (caddr var-names)) )
    (when ~dhc-unprotect
      (dhc-add-c-statements
       (sprintf "RTERR_RANGE((int)%s<1);" n))
      (if ~(null l)   ; l present?
        (dhc-add-c-statements
         (sprintf "RTERR_RANGE((int)%s<0);" l))))
    (dhc-add-c-statements (sprintf "Msrg_resize(%s,1);"
                                   :srg-symb:c-name))
    (dhc-add-c-statements (sprintf "((char *)(%s->data))[0]='\\0';"
                                   :srg-symb:c-name))
    (if (null l)
        (dhc-add-c-statements (sprintf "if (%s<=strlen((char*)(%s->data)))" n thestr))
      (dhc-add-c-statements (sprintf "if ((%s!=0)&&(%s<=strlen((char*)(%s->data))))"
                                     l n thestr)))
    (dhc-add-c-statements (sprintf "{"))
    (dhc-add-c-statements (sprintf "Msrg_resize(%s,strlen((char*)(%s->data))-%s+2);"
                                   :srg-symb:c-name thestr n))
    (if (null l)
        (dhc-add-c-statements 
         (sprintf "strcpy((char*)(%s->data),((char *)(%s->data)+%s-1));"
                  :srg-symb:c-name thestr n))
      (dhc-add-c-statements 
       (sprintf
        "if (memccpy(%s->data,((char *)(%s->data)+%s-1),'\\0',%s)==NULL)"
        :srg-symb:c-name thestr n l))
      (dhc-add-c-statements 
       (sprintf "((char *)(%s->data))[%s]='\\0';"
                :srg-symb:c-name l)))
    (dhc-add-c-statements (sprintf "}"))
    (sprintf "%s" :srg-symb:c-name)))


(dhm-t-declare left right)

(dhm-c right(source treetype retplace)
  (let* ((srg-symb (car :treetype:transfer))
         (valstr (dhc-parse-expr-c (cadr source)
                                   (cadr :treetype:tn-list) ()))
         (val (dhc-parse-expr-c (caddr source)
                                (caddr :treetype:tn-list) ())))
    (if ~dhc-unprotect
        (dhc-add-c-statements
         (sprintf "RTERR_RANGE((int)%s<0);" val)))
    (dhc-add-c-statements (sprintf "Msrg_resize(%s, strlen((char*)(%s->data))+1);"
                                   :srg-symb:c-name valstr))
    (dhc-add-c-statements 
     (sprintf "strcpy((char*)(%s->data),(char *)((char *)(%s->data)+"
              :srg-symb:c-name valstr))
    (dhc-add-c-statements 
     (sprintf "(int)((strlen((char*)(%s->data))>%s)?(strlen((char*)(%s->data))-%s):0)));"
              valstr val valstr val))
    (sprintf "%s" :srg-symb:c-name)))

(dhm-t sprintf(source)
  (when (> 2 (length source))
    (dhc-error "at least one argument expected"))
  (let* ((tns (all ((tn (cdr source)))
                (if (not (stringp tn))
		    (dhc-parse-expr-t tn)
                  (new t-node () (new dhc-type 'dht-ptr 
                                      (new dhc-type 'dht-str)) tn ()))))
         (rettype  (new dhc-type 'dht-ptr (new dhc-type 'dht-str)))
         (srg-type (dhu-type rettype))
         (symbol-srg (new dhc-symbol 
			  (named (sprintf "%d_srg" tmpnames-seed))
                          lex-level))
         (tret (new t-node tns rettype ())))
    (when ~(==> :(car tns):type is-a-strptr)
          (dhc-error "first argument must be a string"))
    (if (stringp (cadr source))
        (dhc-match-string-types :(car tns):source (cdr tns)))
    (incr tmpnames-seed)
    (dhc-unify-types :symbol-srg:type srg-type)
    (setq bump-list (append bump-list (list symbol-srg)))
    (setq :tret:transfer (list symbol-srg))
    tret))

(dhm-c sprintf(source treetype retplace)
  (let ((arg-source (cdr source))
        (arg-names 
         (all ((nm (cdr source)) 
	       (nmt (cdr :treetype:tn-list)))
           (if (not (stringp nm))
	       (dhc-parse-expr-c nm nmt ())
             nm)))
        (srg-symb (car :treetype:transfer))
        (data ())
        (arg-types
         (all ((ty (cdr :treetype:tn-list)))
           (if (==> :ty:type is-a-ptr)
               (dhu-tclass (dhu-type :ty:type))
             (dhu-tclass :ty:type))) ) )
    (dhc-add-c-statements "{\nchar tempstr[1100]; int templen;")
    (if ~(stringp (car arg-source))
      (setq data (sprintf "sprintf(tempstr,(char *)((%s)->data)"
                          (car arg-names)))
      (setq data (sprintf "sprintf(tempstr,\"%s\"" 
                          (dhc-printf-to-c (car arg-source)))))
    (each ((theargsource (cdr arg-source))
           (thearg (cdr arg-names))
           (thetype (cdr arg-types)))
      (if (= thetype 'dht-str)
          (if ~(stringp theargsource)
            (setq data (concat data ",(char *)((" thearg ")->data)"))
            (setq data (concat data "," "\""
                               (dhc-printf-to-c theargsource)
                               "\"")))
        (setq data (concat data "," thearg))))
    
    (dhc-add-c-statements  (concat  data ");"))
    (dhc-add-c-statements  "tempstr[sizeof(tempstr)-1] = 0;")
    (dhc-add-c-statements  "templen = strlen(tempstr);")
    (dhc-add-c-statements  "if (templen >= sizeof(tempstr)-1)")
    (dhc-add-c-statements  "run_time_error(\"sprintf buffer full\");")
    (dhc-add-c-statements (sprintf "Msrg_resize(%s, templen+1);" :srg-symb:c-name))
    (dhc-add-c-statements (sprintf "strcpy((char*)(%s->data),tempstr);\n}" :srg-symb:c-name))
    (sprintf "%s" :srg-symb:c-name)))

(dhm-t str(source)
  (when (<> 2 (length source))
    (dhc-error "one argument expected"))
  (let* ((ta (dhc-parse-expr-t (cadr source)))
         (na (==> :ta:type is-a-number))
         (rettype (new dhc-type 'dht-ptr (new dhc-type 'dht-str)))
         (srg-type (dhu-type rettype))
         (symbol-srg (new dhc-symbol (named (sprintf "%d_srg" 
                                                     tmpnames-seed))
                          lex-level))
         (tret (new t-node (list ta) rettype ())))
    (if ~na
        (dhc-error "argument must be a number")
      (incr tmpnames-seed)
      (dhc-unify-types :symbol-srg:type srg-type)
      (setq bump-list (append bump-list (list symbol-srg)))
      (setq :tret:transfer (list symbol-srg))
      tret)))

(dhm-c str(source treetype retplace)
  (let* ((srg-symb (car :treetype:transfer))
         (val (dhc-parse-expr-c (cadr source)
                                (cadr :treetype:tn-list) ())))
    (dhc-add-c-statements (sprintf "{\nchar tmpchar[STRING_BUFFER];"))
    (dhc-add-c-statements (sprintf "sprintf(tmpchar,\"%%g\",(double)(%s));" val))
    (dhc-add-c-statements (sprintf "Msrg_resize(%s, strlen(tmpchar));"
                                   :srg-symb:c-name))
    (dhc-add-c-statements (sprintf "strcpy((char*)(%s->data),tmpchar);"
                                   :srg-symb:c-name))
    (dhc-add-c-statements (sprintf "}"))
    (sprintf "%s" :srg-symb:c-name)))

(dhm-t strhex(source)
  (when (<> 2 (length source))
    (dhc-error "one argument expected"))
  (let* ((ta (dhc-parse-expr-t (cadr source)))
         (na (==> :ta:type is-a-number))
         (rettype (new dhc-type 'dht-ptr (new dhc-type 'dht-str)))
         (srg-type (dhu-type rettype))
         (symbol-srg (new dhc-symbol (named (sprintf "%d_srg" 
                                                     tmpnames-seed))
                          lex-level))
         (tret (new t-node (list ta) rettype ())))
    (if ~na
        (dhc-error "argument must be a number")
      (incr tmpnames-seed)
      (dhc-unify-types :symbol-srg:type srg-type)
      (setq bump-list (append bump-list (list symbol-srg)))
      (setq :tret:transfer (list symbol-srg))
      tret)))

(dhm-c strhex(source treetype retplace)
  (let* ((srg-symb (car :treetype:transfer))
         (val (dhc-parse-expr-c (cadr source)
                                (cadr :treetype:tn-list) ())))
    (dhc-add-c-statements (sprintf "{\nchar tmpchar[STRING_BUFFER];"))
    (dhc-add-c-statements (sprintf "sprintf(tmpchar,\"0x%%x\",(int)(%s));" val))
    (dhc-add-c-statements (sprintf "Msrg_resize(%s, strlen(tmpchar));"
                                   :srg-symb:c-name))
    (dhc-add-c-statements (sprintf "strcpy((char*)(%s->data),tmpchar);"
                                   :srg-symb:c-name))
    (dhc-add-c-statements (sprintf "}"))
    (sprintf "%s" :srg-symb:c-name)))

(dhm-t strdel(source)
  (when (<> 4 (length source))
    (dhc-error "three arguments expected"))
  (let* ((ta (dhc-parse-expr-t (cadr source)))
         (tb (dhc-parse-expr-t (caddr source)))
         (tc (dhc-parse-expr-t (caddr (cdr source))))
         
         (na (==> :ta:type is-a-strptr))
         (nb (==> :tb:type is-a-number))
         (nc (==> :tc:type is-a-number))
         (rettype (new dhc-type 'dht-ptr (new dhc-type 'dht-str)))
         (srg-type (dhu-type rettype))
         (symbol-srg (new dhc-symbol (named (sprintf "%d_srg" 
                                                     tmpnames-seed))
                          lex-level))
         (tret (new t-node (list ta tb tc) rettype ())))
    (if ~na
        (dhc-error "first argument must be a string"))
    (if ~nb
        (dhc-error "second argument must be a number"))
    (if ~nc
        (dhc-error "third argument must be a number")
      (incr tmpnames-seed)
      (dhc-unify-types :symbol-srg:type srg-type)
      (setq bump-list (append bump-list (list symbol-srg)))
      (setq :tret:transfer (list symbol-srg))
      tret)))

(dhm-c strdel(source treetype retplace)
  (let* ((srg-symb (car :treetype:transfer))
         (valstr (dhc-parse-expr-c (cadr source)
                                   (cadr :treetype:tn-list) ()))
         (n (dhc-parse-expr-c (caddr source)
                              (caddr :treetype:tn-list) ()))
         (l (dhc-parse-expr-c (caddr (cdr source))
                              (caddr (cdr :treetype:tn-list)) ())))
    (when ~dhc-unprotect
      (dhc-add-c-statements
       (sprintf "RTERR_RANGE((int)%s<1);" n))
      (dhc-add-c-statements
       (sprintf "RTERR_RANGE((int)%s<0);" l)))
    (dhc-add-c-statements (sprintf "Msrg_resize(%s, strlen(%s->data)+1);"
                                   :srg-symb:c-name valstr))
    (dhc-add-c-statements
     (sprintf "memccpy(%s->data,%s->data,'\\0',(int)(%s-1));"
              :srg-symb:c-name valstr n))
    (dhc-add-c-statements (sprintf "((char *)(%s->data))[(int)(%s-1)]='\\0';"
                                   :srg-symb:c-name n))
    (dhc-add-c-statements 
     (sprintf "if ((%s+%s-1)<strlen(%s->data))" n l valstr))
    (dhc-add-c-statements 
     (sprintf "strcat(%s->data,(char *)((char *)%s->data+%s+%s-1));"
              :srg-symb:c-name valstr n l))
    (sprintf "%s" :srg-symb:c-name)))

(dhm-t strins(source)
  (when (<> 4 (length source))
    (dhc-error "three arguments expected"))
  (let* ((ta (dhc-parse-expr-t (cadr source)))
         (tb (dhc-parse-expr-t (caddr source)))
         (tc (dhc-parse-expr-t (caddr (cdr source))))
         (na (==> :ta:type is-a-strptr))
         (nb (==> :tb:type is-a-number))
         (nc (==> :tc:type is-a-strptr))
         (rettype (new dhc-type 'dht-ptr (new dhc-type 'dht-str)))
         (srg-type (dhu-type rettype))
         (symbol-srg (new dhc-symbol (named (sprintf "%d_srg" 
                                                     tmpnames-seed))
                          lex-level))
         (tret (new t-node (list ta tb tc) rettype ())))
    (if ~na
        (dhc-error "first argument must be a string"))
    (if ~nb
        (dhc-error "second argument must be a number"))
    (if ~nc
        (dhc-error "third argument must be a string")
      (incr tmpnames-seed)
      (dhc-unify-types :symbol-srg:type srg-type)
      (setq bump-list (append bump-list (list symbol-srg)))
      (setq :tret:transfer (list symbol-srg))
      tret)))

(dhm-c strins(source treetype retplace)
  (let* ((srg-symb (car :treetype:transfer))
         (stra (dhc-parse-expr-c (cadr source)
                                 (cadr :treetype:tn-list) ()))
         (n (dhc-parse-expr-c (caddr source)
                              (caddr :treetype:tn-list) ()))
         (strb (dhc-parse-expr-c (caddr (cdr source))
                                 (caddr (cdr :treetype:tn-list)) ())))
    (if ~dhc-unprotect
        (dhc-add-c-statements
         (sprintf "RTERR_RANGE((int)%s<0);" n)))
    (dhc-add-c-statements 
     (sprintf "Msrg_resize(%s, strlen((char*)(%s->data))+strlen((char*)(%s->data))+1);"
              :srg-symb:c-name stra strb))
    (dhc-add-c-statements
     (sprintf "memccpy(%s->data,%s->data,'\\0',(int)(%s));"
              :srg-symb:c-name stra n))
    (dhc-add-c-statements (sprintf "((char *)(%s->data))[(int)(%s)]='\\0';"
                                   :srg-symb:c-name n))
    (dhc-add-c-statements
     (sprintf "strcat(%s->data,%s->data);"
              :srg-symb:c-name strb))
    (dhc-add-c-statements 
     (sprintf "if (((int)%s)<strlen((char*)(%s->data)))" n stra))
    (dhc-add-c-statements 
     (sprintf "  strcat(%s->data,(char *)((char *)%s->data+%s));"
              :srg-symb:c-name stra n))
    (sprintf "%s" :srg-symb:c-name)))

(dhm-t-declare downcase upcase)

(dhm-c upcase(source treetype retplace)
  (let* ((srg-symb (car :treetype:transfer))
         (thestr (dhc-parse-expr-c (cadr source)
                                   (cadr :treetype:tn-list) ())))
    (dhc-add-c-statements (sprintf "Msrg_resize(%s, strlen((char*)(%s->data))+1);"
                                   :srg-symb:c-name thestr))
    (dhc-add-c-statements (sprintf "{\nint ctr;\nctr=0;" )) 
    (dhc-add-c-statements (sprintf "while (ctr<strlen((char*)(%s->data)))" thestr))
    (dhc-add-c-statements (sprintf "{" ))
    (dhc-add-c-statements
     (sprintf "((char *)(%s->data))[ctr]=toupper(((char *)(%s->data))[ctr]);"
              :srg-symb:c-name   thestr ))
    (dhc-add-c-statements (sprintf "ctr++;"))
    (dhc-add-c-statements (sprintf "}\n}" ))
    (dhc-add-c-statements
     (sprintf "((char *)(%s->data))[strlen((char*)(%s->data))]='\\0';"
              :srg-symb:c-name thestr))
    (sprintf "%s" :srg-symb:c-name)))

(dhm-t val(source)
  (when (<> 2 (length source))
    (dhc-error "one argument expected"))
  (let* ((ta (dhc-parse-expr-t (cadr source)))
         (na (==> :ta:type is-a-strptr)))
    (if ~na
        (dhc-error "argument must be an string")
      (new t-node (list ta) (new dhc-type 'dht-number)))))

(dhm-c val(source treetype retplace)
  (let* ((valstr (dhc-parse-expr-c (cadr source)
                                   (cadr :treetype:tn-list) ())))
    (sprintf "atof((char *)(%s->data))" valstr)))


;;; ------------------------------------------------------------------------
;;; DHM FOR PARSING LIST OPERATIONS
;;; ------------------------------------------------------------------------


(de dhc-list-access (var-name pos-list)
  (when ~(consp pos-list)
        (setq pos-list (list pos-list)))
  (if  (= 1 (length pos-list))
      (concat "L_ACCESS(" var-name ", " (str (car pos-list)) ")")
    (concat "L_ACCESS(*"
            (dhc-list-access var-name (cdr pos-list)) ", "
            (str (car pos-list)) ")")))

(de dhc-list-or-nil (tnode)
  (if (= (dhu-type :tnode:type) 'dht-nil)
      'dht-nil
    (if (==> :tnode:type is-a-listptr)
        'dht-list
      ())))

(dhm-t car(source)
  (when ~(= 1 (length (cdr source)))
        (dhc-error "one argument expected"))
  (let* ((tn (dhc-parse-expr-t (cadr source))))
    (selectq (dhc-list-or-nil tn)
      (dht-nil  
       (new t-node (list tn) :tn:type))
      (dht-list 
       (new t-node (list tn) (car (dhu-extra (dhu-type :tn:type))) ()) )
      (t
       (dhc-error "argument must be a list")) ) ) )
	 
(dhm-c car(source treetype retplace)
  (let* ((exp (dhc-parse-expr-c (cadr source)
                                (cadr :treetype:tn-list) ()))
         (return-type :treetype:type)
         (full-list (dhc-parse-expr-c (cadr source)
                                      (cadr :treetype:tn-list) ())))
    (if (= 'dht-nil (unode-val :return-type:u-tclass))
        "0"
      (sprintf "*((%s *) %s)"
               (dhc-type-to-c-decl return-type)
               (dhc-list-access full-list 0) ) ) ) )

(dhm-t cdr(source)
  (when ~(= 1 (length (cdr source)))
        (dhc-error "one argument expected"))
  (let* ((tn (dhc-parse-expr-t (cadr source)))
         (return-tnode ()) (srg-type ()) (symb-srg ()))
    (selectq (dhc-list-or-nil tn)
      (dht-nil  
       (new t-node (list tn) (new dhc-type 'dht-nil) source))
      (dht-list
       (if (= 0 (1- (length (dhu-extra (dhu-type :tn:type)))))
           (new t-node (list tn) (new dhc-type 'dht-nil))
         (let* ((symb-srg (new dhc-symbol
                               (named (sprintf "%d_srg" tmpnames-seed))
                               lex-level))
                (list-type  (new dhc-type 'dht-ptr
                                 (new dhc-type 'dht-list
                                      (cdr (dhu-extra (dhu-type :tn:type))) ) ))
                (srg-type (dhu-type list-type))
                (return-tnode (new t-node (list tn) list-type ())) )
           (incr tmpnames-seed)
           (dhc-unify-types :symb-srg:type srg-type)
           (setq bump-list (append bump-list (list symb-srg)))
           (setq :return-tnode:transfer (list symb-srg))
           return-tnode)))
      (t
       (dhc-error "argument must be a list")))))


(dhm-c cdr(source treetype retplace)
  (let* ((srg-symb ()) (arg-name ()) (arg-type ())
         (return-type :treetype:type))
    (if (= 'dht-nil (unode-val :return-type:u-tclass))  ; null list?
        "0"
      (setq srg-symb (car :treetype:transfer))
      (setq arg-name
            (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list) ()))
      (setq arg-type :(cadr :treetype:tn-list):type)
      (dhc-add-c-statements
       (sprintf "Msrg_resize(%s,%d*sizeof(dharg));"
                :srg-symb:c-name
                (length (dhu-extra (dhu-type return-type))) ) )
      (each ((ty (cdr (dhu-extra (dhu-type return-type))))
             (ctr (range 1 (1- (length (dhu-extra (dhu-type return-type)))))) )
        (dhc-add-c-statements
         (sprintf "*((%s *) %s) = *((%s *)%s);"
                  (dhc-type-to-c-decl ty)
                  (dhc-list-access :srg-symb:c-name (1- ctr))
                  (dhc-type-to-c-decl ty)
                  (dhc-list-access arg-name ctr)) ) )
      (sprintf "%s" :srg-symb:c-name))))

(dhm-t cons(source)
  (let* ((tns (all ((tn (cdr source))) (dhc-parse-expr-t tn)))
         (types (all ((ty tns)) :ty:type))
         (return-tnode ()) (srg-type ()) (symb-srg ()))
    (when (<> 2 (length tns))
      (dhc-error "two arguments expected"))
    (when ~(dhc-list-or-nil (cadr tns))
          (dhc-error "second argument must be a list"))
    (setq symb-srg (new dhc-symbol
                        (named (sprintf "%d_srg" tmpnames-seed))
                        lex-level))
    (setq return-tnode (new t-node tns
                            (new dhc-type 'dht-ptr
                                 (new dhc-type 'dht-list
                                      (append 
                                       (list (car types))
                                       (dhu-extra (dhu-type (cadr  types))) ) ) )
                            () ) )
    (setq srg-type (dhu-type:return-tnode:type))
    (incr tmpnames-seed)
    (dhc-unify-types :symb-srg:type srg-type)
    (setq bump-list (append bump-list (list symb-srg)))
    (setq :return-tnode:transfer (list symb-srg))
    return-tnode)))

(dhm-c cons(source treetype retplace)
  (let* ((srg-symb (car :treetype:transfer))
         (return-type :treetype:type)
         (arg-names 
          (all ((nm (cdr source)) (nmt (cdr :treetype:tn-list)))
            (dhc-parse-expr-c nm nmt ())))
         (arg-types (all ((nm (cdr :treetype:tn-list)))
                      :nm:type)))
    (dhc-add-c-statements
     (sprintf "Msrg_resize(%s,%d*sizeof(dharg));"
              :srg-symb:c-name
              (1+ (length (dhu-extra (dhu-type (cadr arg-types))))) ) )
    (dhc-add-c-statements       ; first is always a simple type
     (sprintf "*((%s *) %s)=%s;"
              (dhc-type-to-c-decl (car arg-types))
              (dhc-list-access :srg-symb:c-name 0)
              (car arg-names)))
    (each ((ty (dhu-extra (dhu-type (cadr arg-types))))
           (ctr (range 1 (length (dhu-extra (dhu-type (cadr arg-types)))))) )
      (dhc-add-c-statements       ; simple type
       (sprintf "*((%s *) %s) = *((%s *)%s);"
                (dhc-type-to-c-decl ty)
                (dhc-list-access :srg-symb:c-name ctr)
                (dhc-type-to-c-decl ty)
                (dhc-list-access (cadr arg-names) (1- ctr)))))
    (sprintf "%s" :srg-symb:c-name)))

(dhm-t last(source)
  (when ~(= 1 (length (cdr source)))
        (dhc-error "one argument expected"))
  (let* ((tn (dhc-parse-expr-t (cadr source))))
    (selectq (dhc-list-or-nil tn)
      (dht-nil  
       (new t-node (list tn) :tn:type))
      (dht-list 
       (new t-node (list tn) (last (dhu-extra (dhu-type :tn:type))) ()))
      (t        
       (dhc-error "argument must be a list")))))

(dhm-c last(source treetype retplace)
  (let* ((exp (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list) ()))
         (arg-type  :(cadr :treetype:tn-list):type)
         (return-type :treetype:type)
         (full-list (dhc-parse-expr-c (cadr source)
                                      (cadr :treetype:tn-list) ())))
    (if (= 'dht-nil (unode-val :return-type:u-tclass))
        "0"
      (sprintf "*((%s *) %s)"          ; simple type     
               (dhc-type-to-c-decl return-type)
               (dhc-list-access full-list
                                (1- (length (dhu-extra (dhu-type arg-type))))) ) ) ) )

(dhm-t length(source)
  (when ~(= 1 (length (cdr source)))
        (dhc-error "one argument expected"))
  (let* ((tn (dhc-parse-expr-t (cadr source))))
    (when ~(dhc-list-or-nil tn)
          (dhc-error "argument must be a list"))
    (new t-node (list tn)
         (new dhc-type 'dht-int) ())))

(dhm-c length(source treetype retplace)
  (let* ((exp (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list) ()))
         (arg-type  :(cadr :treetype:tn-list):type)
         (return-type :treetype:type))
    (sprintf "%d" (length (dhu-extra (dhu-type arg-type)))) ) )

(dhm-t list(source)
  (let* ((tns (all ((tn (cdr source))) (dhc-parse-expr-t tn)))
         (types (all ((ty tns)) :ty:type))
         (return-tnode ()) 
         (srg-type ()) 
         (symb-srg ()))
    (if (not (consp tns))
        (new t-node () (new dhc-type 'dht-nil) source)
      (setq symb-srg (new dhc-symbol
                          (named (sprintf "%d_srg" tmpnames-seed))
                          lex-level))
      (setq return-tnode
            (new t-node tns (new dhc-type 'dht-ptr 
                                 (new dhc-type 'dht-list types) )
                 ()))
      (setq srg-type (dhu-type :return-tnode:type))
      (incr tmpnames-seed)
      (dhc-unify-types :symb-srg:type srg-type)
      (setq bump-list (append bump-list (list symb-srg)))
      (setq :return-tnode:transfer (list symb-srg))
      return-tnode)))

(dhm-c list(source treetype retplace)
  (let* ((srg-symb (car :treetype:transfer))
         (return-type :treetype:type)
         (arg-names 
          (all ((nm (cdr source)) (nmt (cdr :treetype:tn-list)))
            (dhc-parse-expr-c nm nmt ())))
         (arg-types (all ((nm (cdr :treetype:tn-list)))
                      :nm:type)))
    (if (= 'dht-nil (unode-val :return-type:u-tclass))  ; null list?
        "0"
      (dhc-add-c-statements 
       (sprintf "Msrg_resize(%s,%d*sizeof(dharg));"
                :srg-symb:c-name (length arg-names)))
      (each ((nm arg-names) (ty arg-types)
             (ctr (range 0 (1- (length arg-names)))))
        (dhc-add-c-statements
         (sprintf "*((%s *) %s)=%s;"
                  (dhc-type-to-c-decl ty)
                  (dhc-list-access :srg-symb:c-name ctr)
                  nm)))
      (sprintf "%s" :srg-symb:c-name))))

(dhm-t nth(source)
  (let* ((tns (all ((tn (cdr source))) (dhc-parse-expr-t tn)))
         (types (all ((ty tns)) :ty:type))
         (number ()) (nth-type ()))
    (when (<> 2 (length tns))
      (dhc-error "two arguments expected"))
    (when (<> 'dht-number (unode-val :(car types):u-tclass))
      (dhc-error "first argument must be a number"))
    (setq the-number :(car tns):source)
    (when (not (numberp the-number))
      (dhc-error "first argument must be an actual number"))      
    (when ~(dhc-list-or-nil (cadr tns))
          (dhc-error "second argument must be a list"))
    (setq nth-type (nth the-number (dhu-extra (dhu-type (cadr types)))))
    (if (null nth-type)
        (new t-node tns (new dhc-type 'dht-nil) ())
      (new t-node tns nth-type ()) ) ) )

(dhm-c nth(source treetype retplace)
  (let* ((arg-names 
          (all ((nm (cdr source)) (nmt (cdr :treetype:tn-list)))
            (dhc-parse-expr-c nm nmt ())))
         (arg-types 
          (all ((nm (cdr :treetype:tn-list)))
            :nm:type))
         (return-type :treetype:type))
    (if (= 'dht-nil (unode-val :return-type:u-tclass))
        "0"
      (sprintf "*((%s *)%s)"
               (dhc-type-to-c-decl return-type)
               (dhc-list-access (cadr arg-names)
                                (val (car arg-names))))))))


(dhm-t reverse(source)
  (when ~(= 1 (length (cdr source)))
        (dhc-error "one argument expected"))
  (let* ((tn (dhc-parse-expr-t (cadr source)))
         (return-tnode ()) (srg-type ()) (symb-srg ()))
    (selectq (dhc-list-or-nil tn)
      (dht-nil
       (new t-node (list tn) (new dhc-type 'dht-nil) source))
      (dht-list
       (let* ((srg-type ())
              (symb-srg 
               (new dhc-symbol
                    (named (sprintf "%d_srg" tmpnames-seed))
                    lex-level))
              (return-tnode 
               (new t-node (list tn)
                    (new dhc-type 'dht-ptr
                         (new dhc-type 'dht-list
                              (reverse (dhu-extra (dhu-type :tn:type))) ) )
                    () )) )
         (setq srg-type (dhu-type :return-tnode:type))
         (incr tmpnames-seed)
         (dhc-unify-types :symb-srg:type srg-type)
         (setq bump-list (append bump-list (list symb-srg)))
         (setq :return-tnode:transfer (list symb-srg))
         return-tnode))
      (t
       (dhc-error "argument must be a list")))))
	 
(dhm-c reverse(source treetype retplace)
  (let* ((srg-symb ()) (arg-name ()) (arg-type ()) (parm-list ())
         (return-type :treetype:type))
    (if (= 'dht-nil (unode-val :return-type:u-tclass))  ; null list?
        "0"
      (setq srg-symb (car :treetype:transfer))
      (setq arg-name
            (dhc-parse-expr-c (cadr source) (cadr :treetype:tn-list) ()))
      (setq arg-type :(cadr :treetype:tn-list):type)
      (dhc-add-c-statements
       (sprintf "Msrg_resize(%s,%d*sizeof(dharg));"
                :srg-symb:c-name
                (length (dhu-extra (dhu-type return-type))) ) )
      (let* ((ty (dhu-extra (dhu-type arg-type)))
             (ctr (range 0 (1- (length (dhu-extra (dhu-type return-type))))))
             (rctr (reverse ctr)))
        (each ((ty ty) (ctr ctr) (rctr rctr))
          (dhc-add-c-statements
           (sprintf "*((%s *) %s) = *((%s *)%s);"
                    (dhc-type-to-c-decl ty)
                    (dhc-list-access :srg-symb:c-name rctr)
                    (dhc-type-to-c-decl ty)
                    (dhc-list-access arg-name ctr)))) )
      (sprintf "%s" :srg-symb:c-name))))

(dhm-t append(source)
  (let* ((tns (all ((tn (cdr source))) (dhc-parse-expr-t tn)))
         (types (all ((ty tns)) :ty:type))
         (new-types ())
         (return-tnode ()) (srg-type ()) (symb-srg ()))
    (each ((tn tns))
      (when ~(dhc-list-or-nil tn)
            (dhc-error "arguments must be lists")))
    (each ((ty types))
      (setq new-types (append new-types (dhu-extra (dhu-type ty)))) )
    (if (null new-types)
        (new t-node tns (new dhc-type 'dht-nil))
      (setq symb-srg (new dhc-symbol
                          (named (sprintf "%d_srg" tmpnames-seed))
                          lex-level))
      (setq return-tnode (new t-node tns
                              (new dhc-type 'dht-ptr
                                   (new dhc-type 'dht-list
                                        new-types) )
                              ()))
      (setq srg-type (dhu-type :return-tnode:type))
      (incr tmpnames-seed)
      (dhc-unify-types :symb-srg:type srg-type)
      (setq bump-list (append bump-list (list symb-srg)))
      (setq :return-tnode:transfer (list symb-srg))
      return-tnode)))

(dhm-c append(source treetype retplace)
  (let* ((srg-symb (car :treetype:transfer))
         (return-type :treetype:type)
         (ctr 0)
         (arg-names 
          (all ((nm (cdr source)) (nmt (cdr :treetype:tn-list)))
            (dhc-parse-expr-c nm nmt ())))
         (arg-types (all ((nm (cdr :treetype:tn-list)))
                      :nm:type)))
    (if (= 'dht-nil (unode-val :return-type:u-tclass))  ; null list?
        "0"
      (dhc-add-c-statements
       (sprintf "Msrg_resize(%s,%d*sizeof(dharg));"
                :srg-symb:c-name 
                (length (dhu-extra (dhu-type return-type))) ))
      (each ((nm arg-names) (arg-type arg-types))
        (when (<> 'dht-nil (unode-val :arg-type:u-tclass))
          (each ((ty (dhu-extra (dhu-type arg-type)))
                 (arg-ctr (range 0 (1- (length (dhu-extra (dhu-type arg-type)))))) )
            (dhc-add-c-statements
             (sprintf "*((%s *) %s) = *((%s *) %s);"
                      (dhc-type-to-c-decl ty)
                      (dhc-list-access :srg-symb:c-name ctr)
                      (dhc-type-to-c-decl ty)
                      (dhc-list-access nm arg-ctr)))
            (setq ctr (1+ ctr)))))
      (sprintf "%s" :srg-symb:c-name))))



;;; ------------------------------------------------------------------------
;;; DHM FOR PARSING OBJECT OPERATIONS
;;; ------------------------------------------------------------------------



(dhm-t letslot(source)
  (when (> 1 (length source))
    (dhc-error "one or more arguments expected"))
  (let* ((obj-tnode (dhc-parse-expr-t (cadr source)))
         (prog-tnode ())
         (symbol-table symbol-table)
         (new-symbols ())
         (object-c-name ()))
    (when ~(==> :obj-tnode:type is-an-objptr)
          (dhc-error "first argument must be an object"))
    (setq object-c-name :obj-tnode:symbol:c-name)
    (each ((slot (unode-val :(unode-val :obj-tnode:type:u-type):u-temps)))
      (let ((sym (new dhc-symbol (car slot) 0)))
        (dhc-unify-types (cdr slot) :sym:type)
        (setq :sym:c-name (concat object-c-name "->"
                                  (dhc-lisp-to-c-slot-name
                                   (nameof (car slot)))))
        (setq new-symbols (nconc1 new-symbols (cons (car slot) sym))) ) )
    (setq symbol-table (append new-symbols symbol-table))
    (setq prog-tnode (dhc-parse-progn-t (cddr source)))
    (setq :prog-tnode:tn-list (cons obj-tnode :prog-tnode:tn-list))
    prog-tnode))

(dhm-c letslot(source treetype retplace)
  (let ((ret (dhc-parse-progn-c (cddr source) (cddr :treetype:tn-list) retplace)))
    (let* ((ctype (dhu-type (dhu-type :(cadr :treetype:tn-list):type)))
           (cname (dhu-name ctype))
           (kname (sprintf "Kc_%s_R%s" cname (dhu-hash ctype))) )
      (when (dhu-class ctype)
        (dhc-add-c-externs (dhc-class-to-struct-decl ctype))
        (dhc-add-c-metaexterns 
         (sprintf "extern_c dhclassdoc_t %s;" kname))
        (dhc-add-c-depends kname) ) )
    ret ) )

(dhm-t scope(source)
  (when (> 3 (length source))
    (dhc-error "two or more arguments expected"))
  (let* ((symb-tnode (dhc-parse-expr-t (cadr source)))
         (slot-list (cddr source))
         (tn-list (list symb-tnode))
         (class-type ())
         (object-slots ())
         (slot-info ())
         (ret-type ()))
    (when (null  (==> :symb-tnode:type is-an-objptr))
      (dhc-error "first argument must be an object"))
    (setq ret-type :symb-tnode:type)
    (do-while (consp slot-list)
      (if (null (==> ret-type is-an-objptr))
          (dhc-error "slot is not an object" (car slot-info)) )
      (setq object-slots (unode-val :(dhu-type ret-type):u-temps))
      (nconc1 tn-list (new t-node () ret-type (car slot-list)))
      (when (not (setq slot-info (assoc (car slot-list) object-slots)))
        (dhc-error "unrecognized slot name" (car slot-list)) )
      (setq ret-type (cdr slot-info))
      (setq slot-list (cdr slot-list)) )
    (if (==> ret-type is-a-simple)
        (new t-node tn-list ret-type ())
      (if (not (==> ret-type is-a-ptr))
          (dhc-internal-error "returning a strange type")
        (new t-node tn-list ret-type ()))) ) )

(dhm-c scope(source treetype retplace)
  (let* ((tn-list (cdr :treetype:tn-list))
         (cname-src (dhc-parse-expr-c (cadr source) 
                                      (car tn-list) ()))
         (return-type :treetype:type)
         (slot-list (cddr source))
         (result ()))
    (setq result (sprintf "%s" cname-src))
    (each  ((slot slot-list)
            (tn (cdr tn-list)) )
      (let* ((ctype (dhu-type (dhu-type :tn:type)))
             (cname (dhu-name ctype))
             (kclass (sprintf "Kc_%s_R%s" cname (dhu-hash ctype)) ) )
        (when (dhu-class ctype)
          (dhc-add-c-externs 
           (dhc-class-to-struct-decl ctype))
          (dhc-add-c-metaexterns 
           (sprintf "extern_c dhclassdoc_t %s;" kclass))
          (dhc-add-c-depends kclass) ) )
      (setq result 
            (concat result "->" 
                    (dhc-lisp-to-c-slot-name (nameof slot)) ) ) )
    result ) )
    
(dhm-t to-obj(source)
  (when (<> 3 (length source))
    (dhc-error "two arguments are expected in compiled mode" source) )
  (let* ((cname (cadr source))
         (xnode (dhc-parse-expr-t (caddr source)))
         (ctype (dhc-class-to-dhc-type cname)) 
         (otype (dhc-obj-type-from-class cname))
         (checked ())
         (tn ()) )
    ;; check argument
    (when (not (or (==> :xnode:type is-a-dc)
                   (==> :xnode:type is-a-gptr)
                   (==> :xnode:type is-an-objptr) ))
      (dhc-error "A gptr or an object is expected" source) )
    ;; check subclass relationship when possible
    (when (==> :xnode:type is-an-objptr)
      (let ((tname (dhu-name ctype))
            (type (dhu-type (dhu-type :xnode:type))))
        (while (and (not checked) (==> type is-a-class) )
          (when (= (dhu-name type) tname)
            (setq checked t) ) 
          (setq type (dhu-type type)) ) ) )
    ;; construct tnode
    (setq tn (new t-node (list (new t-node () ctype cname) xnode)
                  (new dhc-type 'dht-ptr otype) ) )
    (setq :tn:transfer checked)
    tn ) )

(dhm-c to-obj(source treetype retplace)
  (let* ((ctype :(cadr :treetype:tn-list):type)
         (cname (dhu-name ctype))
         (kname (sprintf "Kc_%s_R%s" cname (dhu-hash ctype)))
         (vtname (sprintf "Vt_%s" cname)) )
    (if (or dhc-unprotect :treetype:transfer)
        ;; no runtime check is needed (or asked for)
        (sprintf "(struct CClass_%s*)(%s)" cname
                 (dhc-parse-expr-c (caddr source) 
                                   (caddr :treetype:tn-list) ()) )
      ;; a runtime check is needed
      (when (not retplace)
        (setq retplace 
              (sprintf "L%d_%d_obj" lex-level tmpnames-seed))
        (dhc-add-c-declarations 
         (sprintf "struct CClass_%s *%s;" cname retplace))
        (incr tmpnames-seed) )
      (dhc-add-c-statements 
       (sprintf "%s = (struct CClass_%s*)(%s);" retplace cname
                (dhc-parse-expr-c (caddr source) 
                                  (caddr :treetype:tn-list) ()) ))
      (when (dhu-class ctype)
        (dhc-add-c-depends kname) 
	(dhc-add-c-metaexterns 
	 (sprintf "extern_c dhclassdoc_t %s;" kname))
        (dhc-add-c-externs
         (sprintf "extern_c struct VClass_%s %s;" cname vtname) ) )
      (dhc-add-c-statements
       (sprintf "check_obj_class((void*)%s, (void*)&%s);"
                retplace vtname) )
      retplace ) ) )

(dhm-t is-of-class(source)
  (when (<> 3 (length source))
    (dhc-error "two arguments are expected" source) )
  (let* ((cname (caddr source))
         (xnode (dhc-parse-expr-t (cadr source)))
         (ctype (dhc-class-to-dhc-type cname)) 
         (otype (dhc-obj-type-from-class cname))
         (checked ())
         (tn ()) )
    ;; check argument
    (when (not (or (==> :xnode:type is-a-dc)
                   (==> :xnode:type is-a-gptr)
                   (==> :xnode:type is-an-objptr) ))
      (dhc-error "A gptr or an object is expected" source) )
    ;; check subclass relationship when possible
    (when (==> :xnode:type is-an-objptr)
      (let ((tname (dhu-name ctype))
	    (type (dhu-type (dhu-type :xnode:type))) )
	;; object declaration is a superclass of wanted class: true
	(while (and (not checked) (==> type is-a-class) )
	  (when (= (dhu-name type) tname) (setq checked "1"))
          (setq type (dhu-type type)) )
	;; object declaration is not a superclass of wanted class: false
	(when (not checked)
	  (setq type ctype)
          (setq tname (dhu-name (dhu-type (dhu-type :xnode:type))))
          (setq checked "0")
	  (while (and checked (==> type is-a-class))
	    (when (= (dhu-name type) tname) (setq checked ()))
	    (setq type (dhu-type type)) ) ) ) )
    ;; construct tnode
    (setq tn (new t-node (list xnode (new t-node () ctype cname))
                  (new dhc-type 'dht-bool) ) )
    (setq :tn:transfer checked)
    tn ) )

(dhm-c is-of-class(source treetype retplace)
  (let* ((ctype :(caddr :treetype:tn-list):type)
         (cname (dhu-name ctype))
         (kname (sprintf "Kc_%s_R%s" cname (dhu-hash ctype)))
         (vtname (sprintf "Vt_%s" cname)) )
    (if (or :treetype:ignore :treetype:transfer)
        ;; no runtime check is needed (or asked for)
        (or :treetype:transfer "0")
      ;; a runtime check is needed
      (when (dhu-class ctype)
        (dhc-add-c-depends kname) 
	(dhc-add-c-metaexterns 
	 (sprintf "extern_c dhclassdoc_t %s;" kname))
        (dhc-add-c-externs 
	 (sprintf "extern_c struct VClass_%s %s;" cname vtname) ) )
      (when (not retplace)
	(setq retplace (dhc-declare-temp-var :treetype:type)) )
      (dhc-add-c-statements 
       (sprintf "%s = test_obj_class((void*)%s, (void*)&%s);"
		retplace
                (dhc-parse-expr-c (cadr source) 
                                  (cadr :treetype:tn-list) () )
		vtname ) )
      retplace ) ) )

(dhm-t new(source)
  (let* ((class-name (cadr source))
         (class-cname (dhc-lisp-to-c-name (nameof class-name)))
         (class-type (dhc-class-to-dhc-type class-name))
         (class-methods (dhu-extra class-type))
         (args (cddr source)))
    (if (assoc class-cname class-methods)  ;; constructor exists
        ;; constructor
        (dhc-parse-replacement-source-t
         source
         `(let ((_x_ (new-empty ,class-name)))
            (==> _x_ ,class-name ,@args)
            _x_ ) )
      ;; no constructor
      (when (<> 0 (length args))
        (dhc-error 
         "illegal number of arguments (no constructor for this class)"
         source))
      (dhc-parse-replacement-source-t 
       source 
       `(new-empty ,class-name) ) ) ) )

(dhm-t new-empty(source)
  (when (<> 1 (length (cdr source)))
    (dhc-error "expected only one argument" source))
  (let* ((class-name (cadr source))
         (class-type (dhc-class-to-dhc-type class-name))
         (obj-type (dhc-obj-type-from-class class-name))
         (symb-obj (new dhc-symbol
                        (named (sprintf "%d_obj" tmpnames-seed))
                        lex-level))
         (tnl ()) )
    (setq tnl (list (new t-node () class-type class-name)))
    (setq tnl (new t-node tnl (new dhc-type 'dht-ptr obj-type) ()))
    (incr tmpnames-seed)
    (dhc-unify-types :symb-obj:type obj-type)
    (setq bump-list (append bump-list (list symb-obj)))
    (setq :tnl:transfer (list symb-obj))
    tnl ) )

(dhm-c new-empty(source treetype retplace)
  (let ((obj-sym (car :treetype:transfer)))
    (let* ((ctype (dhu-type (dhu-type :treetype:type)))
           (cname (dhu-name ctype))
           (kname (sprintf "Kc_%s_R%s" cname (dhu-hash ctype))) )
      (when (dhu-class ctype)
        (dhc-add-c-externs 
         (dhc-class-to-struct-decl ctype))
        (dhc-add-c-externs 
         (dhc-class-to-vtable-decl ctype))
        (dhc-add-c-metaexterns 
         (sprintf "extern_c dhclassdoc_t %s;" kname) )
        (dhc-add-c-depends kname) ) )
    :obj-sym:c-name ) )

(dhm-t ==>(source)
  (when (> 3 (length source))
    (dhc-error "two or more arguments expected"))
  (let* ((obj-tnode (dhc-parse-expr-t (cadr source)))
         (method-name (caddr source))
         (args (if (consp (nthcdr 3 source))
                   (all ((arg (nthcdr 3 source)))
                     (dhc-parse-expr-t arg)) ) ) )
    (when (not (==> :obj-tnode:type is-an-objptr))
      (dhc-error "first argument must be an object") )
    (let* ((class-type (dhu-type (dhu-type :obj-tnode:type)))
           (class-name (dhu-name class-type))
           (method-cname ())
           (targetclass-type ())
           (method-type ())
           (method-class ()) )
      ;; dotted method syntax
      (when (consp method-name)
        (setq targetclass-type 
              (dhc-class-to-dhc-type (car method-name)))
        (setq method-name 
              (cdr method-name))
        ;; check that this is a superclass
        (let ((cl class-type))
          (while (and cl (==> cl is-a-class))
            (if (<> (dhu-name cl) (dhu-name targetclass-type))
                (setq cl (dhu-type cl))
              (setq cl ()) ) )
          (when cl
            (dhc-error "Not a superclass of object class" 
                       (car method-name)) ) ) )
      ;; search method
      (when (not (symbolp method-name))
        (dhc-error "Method name is not a symbol" method-name))
      (setq method-cname (dhc-lisp-to-c-name (nameof method-name)))
      (let ((sclass (or targetclass-type class-type)))
        (while (and (not method-type)
                    (==> sclass is-a-class) )
          (setq method-type (dhc-alist-get method-cname (dhu-extra sclass)) )
          (when method-type (setq method-class sclass))
          (setq sclass (dhu-type sclass)) ) )
      (when (not method-type)
        (dhc-error "Method not found" method-name) )
      (setq method-type (==> method-type copy))
      ;; the following is derived from dhc-parse-dh-c
      (let* ((func-arg (dhu-extra method-type))
             (func-temps (dhu-temps method-type))
             (return-type (dhu-type method-type))
             (tnl (cons obj-tnode args))
             (call-arg (all ((tynl tnl)) :tynl:type))
             (return-node ()) )
        ;; check argument types
        (when (<> (length func-arg) (length call-arg))
          (dhc-error "Incorrect number of arguments") )
        (each ((ty func-arg) (da call-arg))
          (dhc-unify-types ty da))
        (dhc-unify-all-dh call-arg func-temps return-type)
        ;; construct return treenode
        (setq return-node 
              (new t-node () method-type (caddr source)))
        (setq :return-node:transfer method-cname)
        (setq tnl (cons obj-tnode
                        (cons return-node
                              (cdr tnl) ) ) )
        (setq return-node 
              (new t-node tnl return-type))
        ;; remember temps
        (setq :return-node:transfer 
              (all ((ty func-temps))
                (let ((sym (new dhc-symbol 
                                (named (sprintf "%d_%s" 
                                                (dhc-postincr tmpnames-seed)
                                                method-cname))
                                lex-level)))
                  (while (==> ty is-a-ptr) (setq ty (dhu-type ty)))
                  (dhc-unify-types ty :sym:type)
                  sym)))
        (setq bump-list (append bump-list :return-node:transfer))
        ;; remember target class
        (setq :return-node:transfer
              (cons targetclass-type
                    :return-node:transfer) )
        return-node) ) ) )

(dhm-c ==>(source treetype retplace)
  (let* ((this (cadr :treetype:tn-list))
         (class-type (dhu-type (dhu-type :this:type)))
         (tnm (caddr :treetype:tn-list))
         (method-type :tnm:type)
         (method-cname :tnm:transfer)
         (targetclass-type (car :treetype:transfer))
         (ctype (or targetclass-type class-type)) 
         (cname (dhu-name ctype))
         (kname (sprintf "Kc_%s_R%s" cname (dhu-hash ctype)))
         (auxargs (all ((sym (cdr :treetype:transfer))) :sym:c-name))
         (args ()) )
    ;; add external declarations
    (when (dhu-class ctype)
      (let ((stype (dhu-type ctype)))
        (while (==> stype is-a-class)
          (when (dhu-class stype)
            (dhc-add-c-externs 
             (sprintf "struct CClass_%s;" (dhu-name stype))) )
          (setq stype (dhu-type stype)) ) )
      (dhc-add-c-externs 
       (dhc-class-to-struct-decl ctype))
      (dhc-add-c-externs 
       (dhc-class-to-vtable-decl ctype))
      (dhc-add-c-externs
       (sprintf "extern_c struct VClass_%s Vt_%s;" cname cname) )
      (dhc-add-c-metaexterns 
       (sprintf "extern_c dhclassdoc_t %s;" kname) )
      (dhc-add-c-depends kname) )
    ;; Prepare retplace
    (let ((retpart "")
          (objname ()) )
      (when (not :treetype:ignore) 
        (when (not retplace)
          (setq retplace (dhc-declare-temp-var :treetype:type)) )
        (setq retpart (concat retplace " = ")) ) 
      ;; Create args
      (setq args 
            (cons (setq objname
                        (dhc-parse-expr-c (cadr source) this ()) )
                  (all ((so (cdddr source))
                        (tt (cdddr :treetype:tn-list)) )
                    (dhc-parse-expr-c so tt () ) ) ) )
      ;; Cast object types
      (setq args
            (all ((arg args)
                  (argtype (dhu-extra method-type))
                  (argnode (cons (cadr :treetype:tn-list)
                                 (cdddr :treetype:tn-list)) ) )
              (if (or (==> argtype is-an-objptr) (==> argtype is-a-gptr))
                  (dhc-ptr-cast arg argtype :argnode:type)
                arg ) ) )
      ;; Generate call
      (dhc-add-c-statements
       (concat
        retpart
        (if targetclass-type
            ;; explicit target class
            (sprintf "Vt_%s.M_%s(" cname method-cname)
          ;; call via object vtable
          (sprintf "(%s)->Vtbl->M_%s(" objname method-cname) )
        (dhc-insert-op (append args auxargs) ", ")
        ");" ) ) )
    ;; The end
    retplace ) )





;;; ------------------------------------------------------------------------
;;; DHM FOR PARSING GRAPHICS OPERATIONS
;;; ------------------------------------------------------------------------


