;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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-util.lsh,v 1.52 2003/09/02 19:09:45 leonb Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;






;;; ------------------------------------------------------------------------
;;; ------------------------------------------------------------------------
;;;                  U   T   I   L   I   T   I   E   S
;;; ------------------------------------------------------------------------
;;; ------------------------------------------------------------------------

;; Table of content
;;    general functions (insert-op dhc-remove-nth merge-sort ...)
;;    general compiler functions (dhc-assign dhc-add-c-statements ...)
;;    set manipulation
;;    error handling
;;    types (dhc-type and methods)
;;    type unification
;;    typing for objects and classes
;;    extract prototype from a DH
;;    symbol table
;;    PARSER
;;    t-node
;;    parsing an expression
;;    parsing idx syntax
;;    parsing a matrix constant
;;    parsing numbers and matrix
;;    parsing string 
;;    parsing symbol 
;;    parsing a call to a DH
;;    generating call to DH and macro

;;; ------------------------------------------------------------------------
;;; GENERAL FUNCTIONS
;;; ------------------------------------------------------------------------


#? (dhc-insert-op <l> <op>)
;; Concatenate all strings in <l> separated with <op>.
;;.VP
;;? (insert-op '("3" "4" "5") "*")
;;= "3*4*5"
(de dhc-insert-op (l op)
  (let ((n (when l (list (car l)))))
    (each ((s (cdr l)))
      (setq n (cons s (cons op n))) )
    (apply concat (reverse n)) ) )

#? (dhc-nolast <l>)
;; Remove last element of list.
(de dhc-nolast (l)
  (reverse (cdr (reverse l))))

(de dhc-alist-add(key alist value)
  (alist-add key value alist) )

(de dhc-alist-get(key alist)
  (alist-get key alist) )

#? (dhc-remove-dup <l>)
;; Remove duplicates in a list.
(de dhc-remove-dup (l)
  (let ((ans ()))
    (each ((i l))
      (when (null (member i ans))
        (setq ans (nconc1 ans i)) ) )
    ans ) )

#? (dhc-remove-eqdup <l>)
;; Remove pointer duplicates from a list.
(de dhc-remove-eqdup (l)
  (when l
    (let ((ans (cons (car l) ())))
      (each ((i (cdr l)))
        (let ((c ans))
          (while (and (not (== (car c) i)) (cdr c))
            (setq c (cdr c)) )
          (when (not (== (car c) i))
            (rplacd c (cons i ())) ) ) )
      ans ) ) )

#? (dhc-remove-nth <n> <l>)
;;; Remove <n>th element from list <l>
(de dhc-remove-nth (n l) 
  (let ((r ()) (s 0))
    (each ((x l)) 
      (when (<> s n) 
        (setq r (cons x r))) 
      (incr s) )
    (reverse r) ) )

#? (dhc-split-list <l> <test>)
;; Returns two list containing the element of list <l>.  
;; The first list contains the element of <l> that pass 
;; the test <test>, the second list the remaining elements.
;;.CODE
;;  ? (dhc-split-list '(1 4 2 6 4 3 2 3 2 1 3) (lambda (x) (= 3 x)))
;;  = ((3 3 3) (1 4 2 6 4 2 2 1))
(de dhc-split-list (l test)
  (let ((yes ())
        (no ()))
    (each ((l l))
      (if (test l) (setq yes (cons l yes))
        (setq no (cons l no))))
    (list (reverse yes) (reverse no)) ) )

#? (dhc-postincr <symb>)
;; Increments variable <symb> by one 
;; and returns the value of the variable
;; *before* incrementing.
(dmd dhc-postincr(a) 
  `(let ((b ,a)) (incr ,a) b)))

#? dhc-debug-flag
;;.TYPE VAR
;; Turns on execution of code marked with |#@|
(setq dhc-debug-flag t)

#? |#@|
;;.TYPE DMC
;; Expressions prefixed by #@ are not evaluated
;; unless <dhc-debug-flag> is set to <t>.
(if dhc-debug-flag
    (dmc |#@| (list (read)) )
  (dmc |#@| ()) )


;;------------------------------------------------------------------------------
;; Utilities which are specific to the compiler
;;------------------------------------------------------------------------------


(de dhu-tclass (u) (unode-val :u:u-tclass))
(de dhu-temps (u) (unode-val :u:u-temps))
(de dhu-extra (u) (unode-val :u:u-extra))
(de dhu-type (u) (unode-val :u:u-type))
(de dhu-ndim (u) (unode-val :u:u-ndim))
(de dhu-bump (u) (unode-val :u:u-bump))
(de dhu-access (u) (unode-val :u:u-access))
(de dhu-name (u) (unode-val :u:u-name))
(de dhu-class (u) (unode-val :u:u-class))
(de dhu-hash (u) (==> u hashcode))

;; put or remove the "dht-" part of the name of a symbol
(de dht-short (symb)
  (named (mid (nameof symb) 5)))
(de dht-long (symb)
  (named (concat "dht-" (nameof symb))))

(de dhc-assign-unify(type1 type2)
  ;; unify setq only if complex or symbol is not typed yet
  ;; (setq a 3.4) is not unified if a is an integer!
  (when (==> type2 is-an-unk)
    (dhc-error "type unknown in assignement"))
  (==> type1 access 'write)
  (let ((type2-copy (==> type2 copy)))
    ;; prevent the bumping information to go the wrong way
    (setq :type2-copy:u-bump :type1:u-bump)
    (cond 
     ;; force type1 to be a number if type2 is
     ((==> type2 is-a-number)
      (dhc-unify-types type1 (new dhc-type 'dht-number)))
     ;; if simple, must be of same type but not unified!
     ((==> type2 is-a-simple)
      (dhc-unify-types type1 type2-copy))
     ;; if list are assigned, the list they point on is unified.
     ((==> type2 is-a-list)
      (dhc-unify-types type1 type2-copy)
      (dhc-unify-types (unode-val :type1:u-type)
                       (unode-val :type2:u-type))
      (each ((u1 (unode-val :type1:u-extra))
             (u2 (unode-val :type2:u-extra)))
        (dhc-unify-types u1 u2)))
     ;; if objects are assigned, their contents are unified
     ((==> type2 is-an-obj)
      (dhc-unify-types type1 type2-copy)
      ;; (dhc-unify-types (unode-val :type1:u-type)
      ;;			 (unode-val :type2:u-type))
      (each ((u1 (unode-val :type1:u-temps))      ; unify the slots
             (u2 (unode-val :type2:u-temps)))
        (dhc-unify-types u1 u2)))
     ;; if ptr are assigned, what they point on is unified.
     ((==> type2 is-a-ptr)
      (dhc-unify-types type1 type2-copy)
      (dhc-unify-types (unode-val :type1:u-type)
                       (unode-val :type2:u-type)))
     ;; if idx are assigned, unify the srg.
     ((==> type2 is-an-idx)
      (dhc-unify-types type1 type2-copy)
      (dhc-unify-types (unode-val :type1:u-type)
                       (unode-val :type2:u-type)))
     (t (dhc-error "don't know how to carry assignment")))))


(de dhc-add-strings (caller li)
  (flatten (all ((l li))
             (cond ((stringp l) l)
                   ((listp l)
                    (each ((l l))
                      (if ~(stringp l)
                        (error caller "string expected")))
                    l)
                   (t (error caller "string expected"))))))

#? (dhc-add-c-declarations <str>)
;; To be used in a <dhm-c> macro.
;; Adds string <str> into the declaration part 
;; of the current block of C code.
(de dhc-add-c-declarations l
  (setq c-declarations (append c-declarations 
                               (dhc-add-strings 'dhc-add-c-declarations l))))

#? (dhc-add-c-statements <str>)
;; To be used in a <dhm-c> macro.
;; Adds string <str> to the statement part 
;; of the current block of C code.
(de dhc-add-c-statements l
  (setq c-statements (append c-statements 
                             (dhc-add-strings 'dhc-add-c-statements l))))

#? (dhc-add-c-epilog <str>)
;; To be used in a <dhm-c> macro.
;; Adds string <str> to the epilog part 
;; of the current block of C code.
(de dhc-add-c-epilog l
  (setq c-epilog (append c-epilog 
                         (dhc-add-strings 'dhc-add-c-epilog l))))

;; Adds string <str> in the program section of 
;; the generated C file.
(de dhc-add-program l
  (setq program (append program
                          (dhc-add-strings 'dhc-add-program l))))

;; Adds string <str> in the metainformation 
;; section of the generated C file.
(de dhc-add-metaprogram l
  (setq metaprogram (append metaprogram
                            (dhc-add-strings 'dhc-add-metaprogram l))))

;; Adds string <str> in the initialization function
;; of the generated C file.
(de dhc-add-initialization l
  (setq initialization-calls (append initialization-calls
                                     (dhc-add-strings 'dhc-add-initialization l))))


#? (dhc-add-c-externs <str>)
;; To be used in a <dhm-c> macro.
;; Adds string <str> to the C code segment
;; declaring external symbols.
(de dhc-add-c-externs (str)
  (setq external-symbols (append external-symbols (list str))))

#? (dhc-add-c-metaexterns <str>)
;; To be used in a <dhm-c> macro.
;; Adds string <str> to the C code segment
;; declaring external symbols used in meta information.
(de dhc-add-c-metaexterns (str)
  (setq external-metasymbols (append external-metasymbols (list str))))


#? (dhc-add-c-header <str>)
;; To be used in a <dhm-c> macro.
;; Adds string <str> to the C code segment
;; declaring files included after
;; the standard LUSH include files.
(de dhc-add-c-header l
  (setq c-header (append c-header 
                         (dhc-add-strings 'dhc-add-c-header l))))

#? (dhc-add-c-pheader <str>)
;; To be used in a <dhm-c> macro.
;; Adds string <str> to the C code segment
;; declaring files included *before*
;; the standard LUSH include files.
(de dhc-add-c-pheader l
  (setq c-pheader 
        (append c-pheader 
                (dhc-add-strings 'dhc-add-c-pheader l))))

;; add dependencies to the current function
(de dhc-add-c-depends (name)
  (setq c-depends (cons name c-depends)) )

#? (dhc-class-to-struct-decl <type>)
;; Returns a string containing the C structure declaration
;; for objects of class <type>.
(de dhc-class-to-struct-decl (type)
  (when ~(= 'dht-class (unode-val :type:u-tclass))
        (dhc-error "type is not a class in dhc-class-to-struct-decl"))
  (let ((the-struct (sprintf (concat "struct CClass_%s {\n"
                                     "  struct VClass_%s *Vtbl;" )
                             (unode-val :type:u-name)
                             (unode-val :type:u-name) ))
        (class-ladder ())
        (type type))
    (while (<> 'dht-nil (unode-val :type:u-tclass))
      (setq class-ladder (cons type class-ladder))
      (setq type (unode-val :type:u-type)))
    
    (each ((type (cdr class-ladder)))
      (each ((slot (unode-val :type:u-temps)))
        (setq the-struct (concat the-struct "\n"
                                 (dhc-type-to-c-decl (cdr slot))
                                 " " 
                                 (dhc-lisp-to-c-name 
                                  (if (consp (car slot))  ;; why?
                                      (nameof (caar slot))
                                    (nameof (car slot)))) ";"))))
    (concat the-struct "\n};")))

#? (dhc-class-to-vtable-decl <type>)
;; Returns a string containing the C structure declaration
;; for the virtual table of class <type>.
(de dhc-class-to-vtable-decl (type)
  (when ~(= 'dht-class (unode-val :type:u-tclass))
        (dhc-error "type is not a class in dhc-class-to-struct-decl"))
  (let ((the-struct (sprintf (concat "struct VClass_%s {\n"
                                     "  dhclassdoc_t *Cdoc;\n"
                                     "  void (*Cdestroy)(gptr);")
                             (unode-val :type:u-name) ))
        (the-methods ())
        (sclass type)
        (slist ())
        (alist ()) )
    ;; gather methods in all classes and superclasses
    (while sclass
      (setq slist (cons sclass slist))
      (setq sclass (dhu-type sclass)) )
    (each ((sclass slist))
      (each (((name . type) (dhu-extra sclass)))
        (setq alist (dhc-alist-add name alist type)) ) )
    ;; generate vtable entries
    (setq the-methods
          (all (((name . type) (reverse alist)))
            (setq name (sprintf "(*M_%s)" name))
            (concat "\n " (dhc-compose-prototype type name) ";") ) )
    ;; output definition
    (concat the-struct
            (apply concat the-methods)
            "\n};") ) )

  
#? (dhc-type-to-c-decl <type>)
;; Returns a short string with the C equivalent of type <type>.
(de dhc-type-to-c-decl (type)
    (cond ((==> type is-an-idx)  "struct idx")
	  ((==> type is-a-srg)   "struct srg")
	  ((==> type is-a-flt)   "flt")
	  ((==> type is-a-real)  "real")
	  ((==> type is-an-int)  "int")
	  ((==> type is-a-short) "short")
	  ((==> type is-a-byte)  "char")
	  ((==> type is-a-ubyte) "unsigned char")
	  ((==> type is-a-bool)  "char")
	  ((==> type is-a-gptr)  
           (or (dhu-name type) "gptr"))
	  ((==> type is-an-obj)  
           (sprintf "struct CClass_%s" (dhu-name (dhu-type type))))
	  ((==> type is-a-ptr)  
           (concat (dhc-type-to-c-decl (dhu-type type)) "*"))
	  (t 
           (dhc-error "Unknown Type") ) ) )

(de dhc-arg-format (type)
  (cond  
   ((==> type is-a-ptr)
    (cond 
     ((==> (unode-val :type:u-type) is-an-idx) "dh_idx_ptr")
     ((==> (unode-val :type:u-type) is-a-srg)  "dh_srg_ptr")
     ((==> (unode-val :type:u-type) is-an-obj) "dh_obj_ptr")
     (t (dhc-error "Argument pointer type is unknown")) ) )
   ((==> type is-a-flt)    "dh_flt")
   ((==> type is-a-short)  "dh_short")
   ((==> type is-a-byte)   "dh_char")
   ((==> type is-a-ubyte)  "dh_uchar")
   ((==> type is-an-int)   "dh_int")
   ((==> type is-a-real)   "dh_real")
   ((==> type is-a-gptr)   "dh_gptr")
   ((==> type is-a-bool)   "dh_char")
   (t (dhc-error "Argument type is unknown"))))

(de dhc-type-to-srg-type (ty)
  (selectq (unode-val :ty:u-tclass)
    (dht-flt   "ST_F")
    (dht-real  "ST_D")
    (dht-int   "ST_I32")
    (dht-short "ST_I16")
    (dht-ptr   "ST_AT")
    (dht-ubyte "ST_U8")
    (dht-byte  "ST_I8")
    (dht-gptr  "ST_GPTR")
    (t (dhc-error "not a know type of matrix"))))

(de dhc-ptr-cast(expr type &optional type2)
  (let ((cast expr))
    ;; GPTRs
    (when (and (==> type is-a-gptr)
               (or (not type2) (==> type2 is-a-gptr)) )
      (when (<> (dhu-name type) (when type2 (dhu-name type2)))
        (setq cast (concat "(" (dhc-type-to-c-decl type) ")"))
        (when expr (setq cast (concat cast "(" expr ")"))) ) )
    ;; OBJPTRs
    (when (and (==> type is-a-ptr)
               (or (not type2) (==> type2 is-a-ptr)) )
      (setq type (dhu-type type))
      (setq type2 (when type2 (dhu-type type2)))
      (when (and (==> type is-an-obj)
                 (not (and type2 (==> type2 is-an-obj)
                           (= (dhu-name (dhu-type type))
                              (dhu-name (dhu-type type2)) ) ) ) )
        (setq cast (concat "(" (dhc-type-to-c-decl type) "*)"))
        (when expr (setq cast (concat cast "(" expr ")"))) ) )
    cast ) )


#? (dhc-declare-var <name> <type>)
;; generate C code to declare variable of 
;; name <name> of type <type> in the current block,
;; initialize it, and free it on exit.

(de dhc-declare-var(name type)
  (dhc-declare-var-in-stack name type) )

;; here is the version for allocating in the stack...
(de dhc-declare-var-in-stack (name type)
  (cond 
   ((or (==> type is-a-simple) 
        (==> type is-a-ptr) )
    (dhc-add-c-declarations 
     (sprintf "%s %s;" (dhc-type-to-c-decl type) name) ) )
   
   ((==> type is-an-idx) 
    (let ((ndim (unode-val :type:u-ndim)))
      (cond ((<> ndim 0)
             (dhc-add-c-declarations 
              (sprintf "Midx_declare(%s, %d);" name ndim) )
             (dhc-add-c-statements 
              (sprintf "Midx_init(%s, %d);" name ndim) ) )
            (t
             (dhc-add-c-declarations 
              (sprintf "Midx_declare0(%s);" name) )
             (dhc-add-c-statements 
              (sprintf "(%s)->ndim = 0;" name) ) ))))
   
   ((==> type is-an-obj)
    (let* ((ctype (dhu-type type))
           (cname (dhu-name ctype))
           (tname (dhc-type-to-c-decl type))
           (kname (sprintf "Kc_%s_R%s" cname (dhu-hash ctype))) )
      (when (dhu-class ctype)
        (dhc-add-c-externs 
         (sprintf "extern_c struct VClass_%s Vt_%s;" cname cname) )
        (dhc-add-c-externs
         (dhc-class-to-struct-decl (dhu-type type)) ) )
      (dhc-add-c-declarations 
       (concat tname (sprintf " %s_Struct;" name)))
      (dhc-add-c-declarations 
       (sprintf "%s *%s= &%s_Struct;" tname name name))
      (dhc-add-c-statements 
       (sprintf "memset(%s, 0, sizeof(%s));" name tname)
       (sprintf "%s->Vtbl = &Vt_%s;" name cname) )
      (dhc-add-c-epilog
       (sprintf "(%s->Vtbl->Cdestroy)((gptr)(%s));" name name) ) ) )
   
   ((==> type is-a-srg) 
    (dhc-add-c-declarations 
     (sprintf "Msrg_declare(%s);" name))
    (dhc-add-c-statements 
     (sprintf "Msrg_init(%s, %s);"
              name (dhc-type-to-srg-type (unode-val :type:u-type))))
    (dhc-add-c-epilog 
     (sprintf "Msrg_free(%s);" name)))
   (t (dhc-error "Unknown type"))))


;; here is the version for allocating in a pool...
(de dhc-declare-var-in-pool(obst name type)
  (cond 
   ((or (==> type is-a-simple) 
        (==> type is-a-ptr) )
    (dhc-add-c-declarations 
     (concat (dhc-type-to-c-decl type)
             (sprintf " %s;" name) ) ) )
   
   ((==> type is-an-idx) 
    (let ((ndim (unode-val :type:u-ndim)))
      (dhc-add-c-declarations 
       (sprintf "struct idx *%s;" name) )
      (dhc-add-c-externs 
       "extern_c gptr C_allocidx_C_pool(struct CClass_pool*, int);")
      (dhc-add-c-statements 
       (sprintf "%s = C_allocidx_C_pool(%s,%d);" name obst ndim) ) ) )
   
   ((==> type is-an-obj)
    (let* ((ctype (dhu-type type))
           (cname (dhu-name ctype))
           (kname (sprintf "Kc_%s_R%s" cname (dhu-hash ctype))) )
      (when (dhu-class ctype)
        (dhc-add-c-metaexterns 
         (sprintf "extern_c dhclassdoc_t %s;" kname))
        (dhc-add-c-depends kname)
        (dhc-add-c-externs
         (dhc-class-to-struct-decl (dhu-type type)) )
        (dhc-add-c-externs 
         (sprintf "extern_c struct VClass_%s Vt_%s;" cname cname) ) )
      (dhc-add-c-declarations 
       (sprintf "%s *%s;" (dhc-type-to-c-decl type) name))
      (dhc-add-c-externs 
       "extern_c gptr C_allocobj_C_pool(struct CClass_pool*, int, gptr);") 
      (dhc-add-c-statements 
       (sprintf "%s = C_allocobj_C_pool(%s,sizeof(%s),&Vt_%s);"
                name obst (dhc-type-to-c-decl type) cname ) ) ) )
   
   ((==> type is-a-srg) 
    (dhc-add-c-declarations 
     (sprintf "struct srg *%s;" name) )
    (dhc-add-c-externs
     "extern_c gptr C_allocsrg_C_pool(struct CClass_pool*);")
    (dhc-add-c-statements 
     (sprintf "%s = C_allocsrg_C_pool(%s);" name obst) )
    (dhc-add-c-statements 
     (sprintf "Msrg_init(%s,%s);" 
              name (dhc-type-to-srg-type (unode-val :type:u-type)) ) ) )
   
   (t (dhc-error "Unknown type")) ) )


#? (dhc-declare-temp-var <type> [<clue>])
;; Uses <tmpnames-seed> to generate a unique temp variable
;; of type <type>.  Returns the C string representation.
(de dhc-declare-temp-var (type &optional (clue ""))
  (let ((tmpvar (sprintf "L_Tmp%d%s" (dhc-postincr tmpnames-seed) clue) ))
    (dhc-declare-var tmpvar type)
    tmpvar))

;;#? (dhc-push-scope-t <l_1>....<l_n>)
;; Push a scope for parsing types.  <l_n> MUST return THE t-node
;; corresponding to the expression evaluated in the scope (because 
;; in that t-node all the symbol that are bumped will be stored.
;; The variable <bump-list> is created to contain the list of all
;; symbol in this scope.  These symbols will be declared,
;; initialized, bumped and freed automatically.  For any variable
;; in the scope, just add the dhc-symbol entry in to the list:
;; (setq bump-list (nconc1 bump-list symbol))
(dm dhc-push-scope-t (f . instr-list)
  `(let ((|_Split| ())
         (|_Treetype| ()))
     (let ((new-symbol-table symbol-table)
           (symbol-table symbol-table)
           (lex-level (1+ lex-level))
           (bump-list ()))
       (setq |_Treetype| ,(cons progn instr-list))
       ;; If the value is copied in a temp, de-unify (so do not bump)
       (let ((type :|_Treetype|:type))
         (cond
          ((==> type is-a-simple)
           (setq :|_Treetype|:type (==> type copy)))
          ((==> type is-a-ptr)
           (setq :|_Treetype|:type (new dhc-type (dhu-tclass type) (dhu-type type)))
           t ) ) )
       ;; bump return value
       (==> :|_Treetype|:type bump-level (1- lex-level))
       (setq |_Split| 
             (dhc-split-list bump-list 
                             (lambda (x) (< (==> :x:type bump-level)
                                            lex-level))))
       (setq :|_Treetype|:symbol (cadr |_Split|))
       (setq |_Split| (car |_Split|)))
     (setq bump-list (append bump-list |_Split|))
     |_Treetype|))

(dm dhc-bumped-block (f treetype retplace . instr-list)
  `(let ((block ())
         (retexpr ()))
     (let ((c-statements ())
           (c-declarations ())
           (c-epilog ())
           (bump-list :treetype:symbol))
       (each ((temp bump-list))
         (if (and (consp :temp:no-declare) 
                  (= (car :temp:no-declare) 'no-declare)
                  :(cdr :temp:no-declare):ignore)
             ()
           (if (and :temp:no-declare
                    (= (==> :temp:type access) 'read))
               ;; Renaming
               (setq :temp:c-name :temp:no-declare:c-name)
             ;; Normal declaretion
             (setq :temp:c-name
                   (sprintf "L%d_%d_%s" :temp:lex-level
                            (dhc-postincr tmpnames-seed)
                            (dhc-lisp-to-c-name (nameof :temp:lisp-name))))
             (dhc-declare-var :temp:c-name :temp:type))))
       (setq retexpr ,(cons progn instr-list))
       (setq block (append c-declarations c-statements c-epilog)))
     (setq c-statements (nconc c-statements block))
     retexpr))

(dm dhc-push-scope-c(f treetype retplace . instr-list)
  `(let ((tmpvar ())
         (retexpr ()))
     ;; If a return value is expected, 
     ;; allocate a temporary variable
     (when (and (or (==> :treetype:type is-a-simple)
                    (==> :treetype:type is-a-ptr))
                (not :treetype:ignore)
                (not retplace) )
       (setq retplace (dhc-declare-temp-var :treetype:type)))
     (dhc-add-c-statements "{")
     (setq retexpr ,(append (list 'dhc-bumped-block 'treetype 'retplace)
                            instr-list))
     (if (and retplace (<> retexpr retplace))
         (dhc-add-c-statements (sprintf "%s = %s;" retplace retexpr)))
     (dhc-add-c-statements "}")
     ;; not necessary when instr-list contains dhc-parse-expr-c (but see bloop)
     (if (and retplace (<> retexpr retplace))
         retplace
       (if (==> :treetype:type is-a-simple)
           retplace
         retexpr))))




;;; ------------------------------------------------------------------------
;;; ERROR HANDLING
;;; ------------------------------------------------------------------------


#? dhc-debug-stack
;;.TYPE VAR
;; Variable containing the source causing the error
(defvar dhc-debug-stack ())


#? (dhc-error <string> [<arg>])
;; Called when we get a syntax error in the source
(de dhc-error(string &optional argument)
  (printf "\n*** compiler : %s%s" (upcase (left string 1)) (mid string 2))
  (when argument (printf " : %l" argument))
  (printf "\n")
  (printf "*** in:   %s\n" (left (pname (car dhc-debug-stack)) 72))
  (each ((src (cdr dhc-debug-stack)))
    (printf "*** from: %s\n" (left (pname src) 70)))
  (let ((debug-hook (if dhc-debug-flag debug-hook :simple-debug-hook)))
    (error 'dhc-error "Translation aborted" ()) ) )


#? (dhc-check-symbol <source>)
;; Take an argument source and check if it is a symbol.  If it is
;; return the corresponding object of class dhc-symbol.  
(de dhc-check-symbol(source)
  (when ~(symbolp source)
        (dhc-error "Not a symbol" source) )
  (let ((sym ()))
    (when (not (setq sym (dhc-search-symtable source symbol-table)))
      (when (not (setq sym (dhc-search-symtable source global-table)))
        (dhc-error "Unknown symbol" source) ) )
    ;; Return the symbol object
    sym ) )

#? (dhc-internal-error <str>)
;; Called when we detect inconsistent internal state
(de dhc-internal-error(string)
  (printf "*** DH: internal-error: %s\n" string)
  (error 'dhc-internal-error "Translation aborted" ()) )







;;; ------------------------------------------------------------------------
;;; ------------------------------------------------------------------------
;;;      T Y P E    I N F E R E N C E
;;; ------------------------------------------------------------------------
;;; ------------------------------------------------------------------------

;;; ------------------------------------------------------------------------
;;; TYPES
;;; ------------------------------------------------------------------------

#? dhc-type
;; A dhc-type is a structure which contains almost all the information
;; which is available at compile time of an expression.  Information
;; which is not meant to be used in the construction of the DHDOC should
;; be kept away of dhc-type (that info can be used in the t-node
;; structure instead).  For instance <u-bump> and <u-access> have an impact
;; on the DHDOC (whether a variable is writable, whether an argument is a
;; temporary) but the flag <ignore-return-value> in a progn is not type
;; information and has nothing to do in the dhc-type construct.

;; Note that all fields must be unodes: the reason is that if A is unified
;; to B, and B to C, then A must be unified to C.  An efficient way to have
;; this transitive closure is to use unodes for everything.

(defclass dhc-type object	
  ;; the class
  u-tclass   ; see list of types and unification rules.
  ;; Type specific fields
  u-type     ; for idx, str, list: a srg type
             ; for srg: the type of the elements
             ; for functions: the type returned by the function
             ; for ptr, the type of the pointer target
             ; for class, the type of the superclass
  u-temps    ; for functions: a list of type for temporaries
             ; for classes and objects: a list of pairs (slotnamestr . slottype)
  u-ndim     ; for idx: the number of dimensions
             ; for classes and objects: number of slots
  u-extra    ; for classes: a list of pairs (methodnamestr . methodtype)
             ; for lists: a list of types
	     ; for functions: a list of dhc-type for the arguments
  u-class    ; for classes: the lisp class (optional)
  ;; Memory access fields
  u-bump    ; lexical level (start with ())
  u-access  ; 'read if the object is read only, 'write otherwise
  u-name    ; for class: name of class
            ; for gptr: optional name of pointer C type
  ;; Cached hash code
  u-hash
)			

;; order is important in following lists 
;; because it determine numeric promotions
(defvar dhc-simple-types 
  '(dht-dc dht-unk dht-int dht-flt dht-bool dht-nil
    dht-short dht-byte dht-ubyte dht-real 
    dht-gptr dht-number dht-dhm))
(defvar dhc-complex-types 
  '(dht-idx dht-srg dht-obj dht-class
    dht-func dht-ptr dht-str dht-list))
(defvar dhc-int-types 
  (reverse '(dht-int dht-short dht-byte dht-ubyte)))
(defvar dhc-number-types 
  (append dhc-int-types '(dht-number dht-flt dht-real)) )
(defvar dhc-all-types 
  (append dhc-simple-types dhc-complex-types))

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

#? (==> <dhc-type> print)
;; A type printer, for debugging purposes
(defmethod dhc-type print()
  (let ((desc (==> this type-to-desc)))
    (when (or (= (car desc) 'obj)
              (= (car desc) 'class) )
      (setq desc (list (car desc) (cadr desc))) )
    (printf "<TYPE::%l>" desc) ) )

#? (==> <dhc-type> hashcode)
;; returns a hashcode for a type.
;; only to be called after the type is fully unified.
(defmethod dhc-type hashcode()
  (let ((tclass (unode-val u-tclass))
        (hash (unode-val u-hash)) )
    (when (not (stringp (unode-val u-hash)))
      (cond
       ((not (functionp hashcode))
        (setq hash "0") )
       ((member tclass '(dht-ptr dht-idx dht-srg))
        (setq hash 
              (hashcode (list tclass 
                              (==> (unode-val u-type) hashcode) )) ) )
       ((= tclass 'dht-obj)
        (setq hash
              (hashcode (list tclass 
                              (dhu-name (unode-val u-type))) ) ) )
       ((= tclass 'dht-list)
        (setq hash
              (hashcode
               (list 'dht-list
                     (all ((u (unode-val u-extra))) (==> u hashcode)) ) ) ) )
       ((= tclass 'dht-func)
        (setq hash 
              (hashcode
               (list 'dht-func
                     (all ((u (unode-val u-extra))) (==> u hashcode))
                     (all ((u (unode-val u-temps))) (==> u hashcode))
                     (==> (unode-val u-type) hashcode) ) )) )
       ((= tclass 'dht-class)
        (let ((n (list 'dht-class
                       (unode-val u-name)
                       (==> (unode-val u-type) hashcode) 
                       (all (((nam . typ) (unode-val u-temps))) 
                         (list nam (==> typ hashcode)) )
                       (all (((nam . typ) (unode-val u-extra))) 
                         (list nam (==> typ hashcode)) ) )))
          (setq hash (hashcode n)) ) )
       ((= tclass 'dht-number)
        (setq hash (hashcode 'dht-real)) )
       ((= tclass 'dht-nil)
        (setq hash (hashcode 'dht-bool)) )
       (t
        (setq hash (hashcode tclass))) )
      ;; setup hash
      (unode-unify u-hash (new-unode hash) (lambda(a b) b)) )
    hash ) )



;; convert type to description.  
;; This function depend on the <unode-to-int>
;; converter <u-conv>.
(defmethod dhc-type type-to-desc ()
  (let ((tclass (unode-val u-tclass))
	(desc ())
	(add (lambda (u) (setq desc (nconc1 desc u)))))
    (add (dht-short tclass))
    (selectq tclass
      ;; pointers
      (dht-ptr 
       (add (==> (unode-val u-type) type-to-desc)))
      ;; arrays
      (dht-idx 
       (add (named (left (nameof (unode-val u-access)) 1)))
       (add (unode-val u-ndim))
       (add (==> (unode-val u-type) type-to-desc)) )
      ;; storage
      (dht-srg 
       (add (named (left (nameof (unode-val u-access)) 1)))
       (add (==> (unode-val u-type) type-to-desc)) )
      ;; functions
      (dht-func 
       (add (all ((u (unode-val u-extra))) (==> u type-to-desc)))
       (add (all ((u (unode-val u-temps))) (==> u type-to-desc)))
       (add (==> (unode-val u-type) type-to-desc)) )
      ;; gptr
      (dht-gptr
       (when (unode-val u-name) (add (unode-val u-name))) )
      ;; lists
      (dht-list 
       (setq desc (nconc desc (all ((u (unode-val u-extra)))
                                (==> u type-to-desc)))) )
      ;; classes
      (dht-class
       (let ((cl (unode-val u-class)))
         (add (if cl (classname cl) (unode-val u-name))) 
         (add this) ) )
      ;; objects
      (dht-obj
       (let* ((cltype (unode-val u-type))
              (cl (unode-val :cltype:u-class)) )
         (add (if cl (classname cl) (unode-val :cltype:u-name)))
         (add cltype) ) )
      ;; quasi-simple
      ((dht-str dht-dhm)
       ())
      ;; simple
      (t
       (when (not (member tclass dhc-simple-types))
         (dhc-error "not a know type") ) ) )
    ;; return
    desc ) )




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

;; Type testing syntax: (==> <obj> is-a-***)

(defmethod dhc-type is-an-idx()         ; return the number of dims
  (if (= (unode-val u-tclass) 'dht-idx)
      (unode-val u-ndim)))

(defmethod dhc-type is-a-list()         ; return the number of elements
  (if (= (unode-val u-tclass) 'dht-list)
      (unode-val u-ndim)))

(defmethod dhc-type is-a-str()          ; return t
  (if (= (unode-val u-tclass) 'dht-str)
      t ) )

(defmethod dhc-type is-a-srg()		; return the dhc-type of the elements
  (if (member (unode-val u-tclass) '(dht-srg dht-str dht-list))
      (unode-val u-type)))

(defmethod dhc-type is-a-true-srg()     ; return the dhc-type of the elements
  (if (= (unode-val u-tclass) 'dht-srg)
      (unode-val u-type)))

(defmethod dhc-type is-a-ptr()          ; return pointed to type
  (if (= (unode-val u-tclass) 'dht-ptr)
      (unode-val u-type) ) )

(defmethod dhc-type is-a-class()        ; return the name
  (if (= (unode-val u-tclass) 'dht-class)
      (unode-val u-name)))

(defmethod dhc-type is-a-func()         ; return the name
  (if (= (unode-val u-tclass) 'dht-func)
      (unode-val u-name)))

(defmethod dhc-type is-an-obj()         ; return number of slots
  (if (= (unode-val u-tclass) 'dht-obj)
      (unode-val u-ndim)))

(defmethod dhc-type is-an-idxptr()      ; return number of dims
  (if (= (unode-val u-tclass) 'dht-ptr)
      (==> (unode-val u-type) is-an-idx)))

(defmethod dhc-type is-an-objptr()      ; return the number of slots
  (if (= (unode-val u-tclass) 'dht-ptr)
      (==> (unode-val u-type) is-an-obj)))

(defmethod dhc-type is-a-srgptr()       ; return the type of srg
  (if (= (unode-val u-tclass) 'dht-ptr)
      (==> (unode-val u-type) is-a-true-srg)))

(defmethod dhc-type is-a-strptr()       ; return t
  (if (= (unode-val u-tclass) 'dht-ptr)
      (==> (unode-val u-type) is-a-str))) 

(defmethod dhc-type is-a-listptr()      ; return the number of elements
  (if (= (unode-val u-tclass) 'dht-ptr)
      (==> (unode-val u-type) is-a-list)))

(defmethod dhc-type get-element-type ()
  (cond 
   ((==> this is-a-ptr)
    (==> (unode-val u-type) get-element-type))
   ((==> this is-an-idx)
    (==> (unode-val u-type) get-element-type))
   ((==> this is-a-srg)
    (unode-val :(unode-val u-type):u-tclass))))

(defmethod dhc-type get-element-decl ()
  (cond 
   ((==> this is-a-ptr)
    (==> (unode-val u-type) get-element-decl))
   ((==> this is-an-idx)
    (==> (unode-val u-type) get-element-decl))
   ((==> this is-a-srg)
    (dhc-type-to-c-decl (unode-val u-type)))))
  
;; simple types

(defmethod dhc-type is-of-type (l)  
  (let ((tclass (unode-val u-tclass)))
    (if (consp l) (member tclass l) (= tclass l)) ) )
(defmethod dhc-type is-a-flt()
  (= (unode-val u-tclass) 'dht-flt))
(defmethod dhc-type is-a-real()
  (member (unode-val u-tclass) '(dht-real dht-number)))
(defmethod dhc-type is-a-bool()
  (member (unode-val u-tclass) '(dht-bool dht-nil)))
(defmethod dhc-type is-a-nil()
  (= (unode-val u-tclass) 'dht-nil))
(defmethod dhc-type is-a-func()
  (= (unode-val u-tclass) 'dht-func))
(defmethod dhc-type is-an-int()
  (= (unode-val u-tclass) 'dht-int))
(defmethod dhc-type is-a-short()
  (= (unode-val u-tclass) 'dht-short)))
(defmethod dhc-type is-a-byte()
  (= (unode-val u-tclass) 'dht-byte)))
(defmethod dhc-type is-a-ubyte()
  (= (unode-val u-tclass) 'dht-ubyte))
(defmethod dhc-type is-an-integer()
  (member (unode-val u-tclass) dhc-int-types))
(defmethod dhc-type is-a-dhm()
  (= (unode-val u-tclass) 'dht-dhm))
(defmethod dhc-type is-a-simple()
  (member (unode-val u-tclass) dhc-simple-types))
(defmethod dhc-type is-an-unk()
  (= (unode-val u-tclass) 'dht-unk))
(defmethod dhc-type is-a-dc()
  (= (unode-val u-tclass) 'dht-dc))
(defmethod dhc-type is-a-gptr()
  (= (unode-val u-tclass) 'dht-gptr))
(defmethod dhc-type is-a-number()
  (member (unode-val u-tclass) dhc-number-types))

(defmethod dhc-type knownp() 
  (<> (unode-val u-tclass) 'dht-unk) )


;;; ------------------------------------------------------------------------
;;
;; *** Set or access specific fields of complex data structures ***
;; 

;; a (ugly) convenience function to avoid writing nested (new dhc-type) calls
;; 
(defmethod dhc-type copy (&optional (delta-dim 0))
  (let ((ty (cond
             ;; gptr
             ((==> this is-a-gptr)
              (new dhc-type (unode-val u-tclass) 
                   (when u-name (unode-val u-name))) )
             ;; simple types
             ((==> this is-a-simple)
              (new dhc-type (unode-val u-tclass)))
             ;; idx types
             ((==> this is-an-idx)
              (new dhc-type (unode-val u-tclass) 
                   (+ (unode-val u-ndim) delta-dim)
                   (==> (unode-val u-type) copy delta-dim)))
             ;; class type
             ((==> this is-a-class)
              (new dhc-type (unode-val u-tclass) 
                   (unode-val u-name)
                   (unode-val u-type)              ; superclass
                   (all ((u (unode-val u-temps)))  ; slots
                     (cons (car u)
                           (cdr u) ))
                   (all ((u (unode-val u-extra)))  ; methods
                     (cons (car u)
                           (cdr u) ) )
                   (unode-val u-class) ) )         ; lisp class
             ;; object type
             ((==> this is-an-obj)
              (new dhc-type (unode-val u-tclass) 
                   (unode-val u-type)              ; class 
                   (all ((u (unode-val u-temps)))  ; slots
                     (cons (car u) (==> (cdr u) copy)) ) ) )
             ;; list type
             ((==> this is-a-list)
              (new dhc-type (unode-val u-tclass) 
                   (all ((u (unode-val u-extra)))
                     (==> u copy))))
             ;; string type
             ((==> this is-a-str)
              (new dhc-type (unode-val u-tclass)))
             ;; ptr type
             ((==> this is-a-ptr)
              (new dhc-type (unode-val u-tclass)
                   (==> (unode-val u-type) copy delta-dim)))
             ;; srg type
             ((==> this is-a-true-srg)
              (new dhc-type (unode-val u-tclass)
                   (==> (unode-val u-type) copy delta-dim)))
             ;; func type
             ((==> this is-a-func)
              (new dhc-type (unode-val u-tclass)
                   (all ((u (unode-val u-extra)))
                     (==> u copy))
                   (all ((u (unode-val u-temps)))
                     (==> u copy))
                   (==> (unode-val u-type) copy)))
             (t
              (error () "type copy not implemented yet" ())))))
    ;; initialize bump afresh
    (setq :ty:u-bump (new-unode lex-level))
    ;; copy access
    (setq :ty:u-access (new-unode (unode-val u-access)))
    ;; unify hash
    (unode-unify u-hash :ty:u-hash (lambda(a b) ()))
    ty))


#? (==> <dhc-type> access [<v>])
;; set or return the access type of a type.  
;; Possible values: 'read  or 'write
(defmethod dhc-type access (&optional v)
  (if v (if (and (<> v 'read) (<> v 'write))
	    (dhc-internal-error "not a known value for u-access")))
  (if v (unode-unify u-access (new-unode v) dhc-combine-u-access)
    (unode-val u-access)))



;; Recurse on subtypes.  On each subtypes apply the function <func>.
;; Only recurse on subtypes which appear as a substructure of type
;; (i.e. in an idx, recurse on the srg, but not on the type of the 
;; srg because that type is not a substructure).
(defmethod dhc-type recurse (func)
  (selectq (unode-val u-tclass)
    (dht-obj 
     (func this)
     (each ((u (unode-val u-temps)))
       (==> (cdr u) recurse func)))
    (dht-list
     (func this)
     (each ((u (unode-val u-extra)))
       (==>  u recurse func)) )
    (dht-idx 
     (func this)
     (==> (unode-val u-type) recurse func))
    (dht-ptr 
     (==> (unode-val u-type) recurse func))
    (dht-str
     (func this) )
    (dht-srg 
     (func this) )
    (dht-class 
     ())
    (dht-func 
     ())
    (t 
     (when (not (==> this is-a-simple))
       (error "recurse: unknown type") ) ) ) )

;; If a type is returned update its lexical level.
;; It will propagate to all the subfields, 
;; that they should also be updated.
(defmethod dhc-type bump-level (&optional lex)
  (if (null lex)
      (unode-val u-bump)
    (==> this recurse 
	 (lambda (x) (unode-unify :x:u-bump 
                                  (new-unode lex)
				  dhc-combine-u-bump)))))

;; Keep a track of all the different types found in 
;; a function prototype and unifies all identical types.
(de dhc-unify-all-dh (args temps return)
  (let ((entrypoint ())
        (returnpoint ()) 
        (alist ()) )
    (each ((ty args))
      (setq entrypoint (nconc entrypoint (dhc-gather-types ty t)))
      (setq returnpoint (nconc returnpoint (dhc-gather-types ty ()))) )
    (each ((ty temps))
      (setq entrypoint (nconc entrypoint (dhc-gather-types ty t))) )
    (let ((ty return))
      (setq returnpoint (nconc returnpoint (dhc-gather-types ty t))) )
    (setq entrypoint (dhc-remove-eqdup entrypoint))
    (setq returnpoint (dhc-remove-eqdup returnpoint))
    ;; build alist
    (each ((point returnpoint))
      (let* ((key (dhc-type-key point))
             (typ (dhc-alist-get key alist)) )
        (if (not typ)
            (setq alist (dhc-alist-add key alist point))
          (unode-unify :point:u-bump :typ:u-bump
                       dhc-combine-u-bump ) ) ) )
    ;; match return points
    (each ((point entrypoint))
      (let ((key ())
            (typ ()) )
        (cond
         ((==> point is-an-obj)
          ;; it's an object: look superclass return points
          (let ((classtyp (dhu-type point)))
            (while (setq key (==> classtyp is-a-class))
              (setq classtyp (dhu-type classtyp))
              (when (setq typ (dhc-alist-get key alist))
                (dhc-unify-types typ point) ) ) ) )
         (t
          ;; not an object: match exact type
          (setq key (dhc-type-key point))
          (when (setq typ (dhc-alist-get key alist))
            (dhc-unify-types typ point) ) ) ) ) )
    t ) )

(de dhc-type-key(ty)
  (cond
   ((==> ty is-a-str)
    (list 'str) )
   ((==> ty is-a-list)
    (cons 'lst (mapcar dhc-type-key (dhu-extra ty))))
   ((==> ty is-a-srg) 
    (list 'srg (dhc-type-key (dhu-type ty))) )
   ((==> ty is-an-idx)
    (list 'idx (dhu-ndim ty) (dhc-type-key (dhu-type (dhu-type ty)))) )
   ((==> ty is-an-obj)
    (dhu-name (dhu-type ty)) )
   ((==> ty is-a-ptr)
    (dhc-type-key (dhu-type ty)) )
   ((==> ty is-a-simple)
    (dhu-tclass ty) )
   (t
    (error "type is not handled") ) ) )

(de dhc-gather-types( ty allp )
  (let ((ans ()))
    (cond
     ((==> ty is-a-simple) 
      ans )
     ((==> ty is-a-ptr)
      (setq ans (nconc ans (dhc-gather-types (dhu-type ty) allp)))
      ans )
     ((==> ty is-an-idx)
      (when allp 
        (setq ans (nconc1 ans ty))
        (setq ans (nconc1 ans (dhu-type ty))) )
      ans )
     ((==> ty is-a-str)
      (when allp (setq ans (nconc1 ans ty)))
      ans )
     ((==> ty is-a-list)
      (when allp (setq ans (nconc1 ans ty)))
      (each ((aty (dhu-extra ty)))
        (setq ans (nconc ans (dhc-gather-types aty allp))) ) )
     ((==> ty is-a-srg)
      (when allp (setq ans (nconc1 ans ty))) )
     ((==> ty is-an-obj)
      (when allp (setq ans (nconc1 ans ty)))
      (let ((nallp (or allp (= (dhu-access ty) 'write))))
        (each ((aslot (dhu-temps ty)))
          (setq ans (nconc ans (dhc-gather-types (cdr aslot) nallp))) ) 
        ans ) )
     (t
      (error "unknown type") ) ) ) )

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


#? (new dhc-type <class> [<a1>] [<a2>])
;;.IP 
;; Declaration of simple types: (new dhc-type <type>).  Where <type> is
;; a symbol from like, 'dht-flt 'dht-bool, 'dht-nil, etc...
;;.IP 
;; Declaration of arrays: (new dhc-type 'dht-out <ndim> [<type>])
;; Where <type> can be any type (default is (new dhc-type 'dht-flt)).
;; <ndim> is an integer.
;;.IP
;; Declaration of object: (new dhc-type 'dht-obj <type-list>)
;; where <type-list> is a list of cons of the form (name . type)
;;.IP
;; Declaration of functions: (new dhc-type 'dht-func <type-list>)
;; where <type-list> is a list of valid types corresponding to the 
;; arguments
;;
(defmethod dhc-type dhc-type(tc &optional a1 a2 a3 a4 a5)
  (each ((s (slots dhc-type)))
	(set s (new-unode)))
  (selectq tc
    ;; idx type
    (dht-idx
     (if (null a1)
         (dhc-error "number if idx dimensions missing"))
     (setq u-ndim (new-unode a1))
     (setq u-type (new-unode (if a2 a2 (new dhc-type 'dht-srg)))))
    ;; pointer type
    (dht-ptr
     (when (null a1)
       (dhc-error "ptr must point on something"))
     (setq u-type (new-unode a1)))
    ;; storage type
    (dht-srg
     (setq u-type (new-unode (if a1 a1 (new dhc-type 'dht-flt)))) )
    ;; list type
    (dht-list
     (when (not a1)
       (error 'dhc-type "missing list arguments" ()) )
     (setq u-type (new-unode (new dhc-type 'dht-ubyte)))
     (setq u-extra (new-unode a1))
     (setq u-ndim (new-unode (length a1))) )
    ;; string type
    (dht-str
     (setq u-type (new-unode (new dhc-type 'dht-ubyte))) )
    ;; class type
    (dht-class
     (when (not a1)
       (error 'dhc-type "dht-class must have a name" ()) )
     (when (not a2)
       (error 'dhc-type "dht-class must have a superclass" ()) )
     (setq u-name (new-unode a1))            ; name
     (setq u-type (new-unode a2))            ; superclass type
     (setq u-temps (new-unode (if a3 a3)))   ; slots
     (setq u-extra (new-unode (if a4 a4)))   ; methods
     (setq u-ndim (new-unode (length a3)))   ; number of slots
     (setq u-class (new-unode (if (classp a5) a5))) ) ; lisp class
    ;; object type
    (dht-obj
     (when (not a1)
       (error 'dhc-type "dht-obj must have a class type" ()) )
     (setq u-type (new-unode a1))            ; class
     (setq u-temps (new-unode (if a2 a2)))   ; slot
     (setq u-extra (new-unode (if a3 a3)))   ; methods
     (setq u-ndim (new-unode (length a2))))  ; number of slots
    ;; function type
    (dht-func
     (setq u-extra (new-unode a1))
     (setq u-temps (new-unode a2))
     (setq u-type (new-unode a3)))
    ;; unknown type
    (dht-unk 
     (when (or a1 a2 a3) 
       (dhc-internal-error "no args expected")))
    ;; gptr type
    (dht-gptr 
     (when a1 (setq u-name (new-unode a1)))
     (when (or a2 a3)
       (dhc-internal-error "at most one arg expected")) )
    ;; simple types
    (t 
     (when (not (member tc dhc-simple-types))
       (dhc-internal-error "new dhc-type: Unknown type class"))))
  (setq u-tclass (new-unode tc))
  (setq u-access (new-unode 'read))
  (setq u-bump (new-unode lex-level)) )



;;; ------------------------------------------------------------------------
;;; THE TYPE UNIFICATION FUNCTION
;;; ------------------------------------------------------------------------

;; Function for combining the type class
;; possibly associated to a TCLASS u-node

;; COMBINATION RULES
;;
;; ---- don't care ---
;; dht-unk + dht-***    --> dht-*** (dht-*** is anything)
;;
;; ---- identity ----
;; dht-xxx + dht-xxx    --> dht-xxx
;;
;; ---- numerical promotion ----
;; dht_number + dht_flt --> dht_flt
;; dht_number + dht_int --> dht_int
;; dht_number + dht_real --> dht_real
;; dht_int + dht_flt    --> dht_flt
;; dht_bool + dht_nil	--> dht_bool

;;
;; Other = ERROR

(de dhc-unif-error (s &optional l)
  (printf (if ~l e-message (concat e-message s (sprintf "%l" l))))
  (printf "\n       %l\n       %l\n" ot1 ot2)
  (dhc-error ""))

(de dhc-absorb-tclass (a b c1 c2)
  (when (or (and (= a c1) (= b c2))
            (and (= a c2) (= b c1)))
    t))

(de dhc-combine-tclass(a b)
  (cond
   ((= a 'dht-unk) b)                                     ; don't know
   ((= b 'dht-unk) a) 
   ((= a b) a)                                            ; identity
   ((dhc-absorb-tclass a b 'dht_bool 'dht_nil) 'dht-bool)
   ((and (= a 'dht-number) (member b dhc-number-types)) b)
   ((and (= b 'dht-number) (member a dhc-number-types)) a)
   (t (dhc-unif-error "type mismatch: " (list a b)))))    ; error

(de dhc-combine-u-access (a b)
  (if (and (= a 'read) (= b 'read))
      'read 'write))

(de dhc-combine-u-bump (a b)
  (if ~a b (if ~b a (min a b))))

(de dhc-combine-number(a b)
  (cond
   ((= a 'dht-number) b)                                  ; don't know
   ((= b 'dht-number) a) 
   ((= a b) a)                                            ; identity
   (t (dhc-unif-error "type mismatch: " (list a b)))))    ; error

;; Extra call for initializing stack of error message.  
;; Recursively check subfields of objects, functions, and arrays.
(de dhc-unify-types(ot1 ot2)
  ;; initialize stack of of error messages
  (let ((e-message "*** Unification error: ")) 
    (dhc-unify-t ot1 ot2)))

(de dhc-unify-t(t1 t2)
  (let* ((class1 (unode-val :t1:u-tclass))
         (class2 (unode-val :t2:u-tclass))
         (tclass ()))
    ;; check for dont-care type used only by run time error routines
     (when (and (<> class1 'dht-dc)
	        (<> class2 'dht-dc))
       (unode-unify :t1:u-bump :t2:u-bump dhc-combine-u-bump)
       ;; The following ensures that a type coming from a scope above but only 
       ;; typed at a scope below still has the correct bumping information 
       ;; (ex: an argument which only sees (-idx- arg) inside a let).
       (if (= class1 'dht-unk)
           (==> t2 recurse (lambda (x) 
                             (unode-unify :x:u-bump
                                          (new-unode (unode-val :t2:u-bump))
                                          dhc-combine-u-bump))))
       (if (= class2 'dht-unk)
           (==> t1 recurse (lambda (x) 
                             (unode-unify :x:u-bump 
                                          (new-unode (unode-val :t1:u-bump))
                                          dhc-combine-u-bump))))
       ;; if one of the type is dht-unk (all unode empty),
       ;; unify all unodes (all slots).
       (when (or (= class1 'dht-unk)
                 (= class2 'dht-unk))
         (unode-unify :t1:u-tclass :t2:u-tclass dhc-combine-tclass)
         (each ((s (slots dhc-type)))
           (unode-unify (apply scope (list t1 s)) 
                        (apply scope (list t2 s)) or))) 
       (unode-unify :t1:u-tclass :t2:u-tclass dhc-combine-tclass)
       (setq tclass (unode-val :t1:u-tclass))
       
       (let ((e-message (concat e-message (sprintf "%l " tclass))))
         (cond 
          ;; simple types
          ((member tclass dhc-simple-types) ())
          ;; complex types
          ((member tclass dhc-complex-types)
           (dhc-unify-complex-type t1 t2))
          (t 
           (dhc-unif-error "don't know how to unify")))))) )

(de dhc-add-message (mess . l)
  (let ((e-message (concat e-message mess)))
    (apply progn l)))

(de dhc-unify-complex-type (t1 t2)
  ;; take care of u-access, u-bump 
  (unode-unify :t1:u-access :t2:u-access dhc-combine-u-access)
  (cond 
   ;; idx type
   ((= tclass 'dht-idx)
    (if (<> (unode-val :t1:u-ndim) (unode-val :t2:u-ndim))
        (dhc-unif-error 
         (sprintf ": number of dimension mismatch: %d %d"
                  (unode-val :t1:u-ndim) (unode-val :t2:u-ndim))))
    (dhc-unify-t (unode-val :t1:u-type)
                 (unode-val :t2:u-type)))
   ;; ptr type
   ((= tclass 'dht-ptr) 
    (dhc-unify-t (unode-val :t1:u-type)
                 (unode-val :t2:u-type)))
   ;; str type
   ((= tclass 'dht-str)
    (dhc-unify-t (unode-val :t1:u-type)
                 (unode-val :t2:u-type)) )
   ;; list type
   ((= tclass 'dht-list)
    (each ((u1 (unode-val :t1:u-extra))
           (u2 (unode-val :t2:u-extra)))
      (dhc-unify-t u1 u2))
    (dhc-unify-t (unode-val :t1:u-type)
                 (unode-val :t2:u-type)))
   ;; srg type
   ((= tclass 'dht-srg)
    (dhc-unify-t (unode-val :t1:u-type)
                 (unode-val :t2:u-type)) )
   ;; obj type
   ((= tclass 'dht-obj)
    (dhc-obj-subclass-check t1 t2)
    (let ((u1 (reverse (unode-val :t1:u-temps)))
          (u2 (reverse (unode-val :t2:u-temps))))
      (while u1
        (dhc-unify-t (cdr (car u1)) (cdr (car u2)))
        (setq u1 (cdr u1))
        (setq u2 (cdr u2)) )
      ;; Remaining slots live as long as the object itself
      (while u2
        (==> (cdar u2) recurse 
             (lambda(x) (unode-unify :x:u-bump :t1:u-bump
                                     dhc-combine-u-bump )) )
        (setq u2 (cdr u2)) ) )
    () )
   ;; take care of u-extra 
   ((<> (unode-uid :t1:u-extra) 
        (unode-uid :t2:u-extra)) ; optimization
    (let* ((extra1 (unode-val :t1:u-extra))
           (extra2 (unode-val :t2:u-extra))
           (temp1 (unode-val :t1:u-temps))
           (temp2 (unode-val :t2:u-temps)) )
      (if (<> (length extra1) (length extra2))
          (dhc-error " number of arguments mismatch"
                     (list (length extra1) (length extra2)) ) )
      (if (<> (length temp1) (length temp2))
          (dhc-error " number of temporaries mismatch"
                     (list (length temp1) (length temp2)) ) )
      (selectq tclass
        (dht-func 
         (dhc-add-message " arguments mismatch:"
                          (mapc dhc-unify-t extra1 extra2))
         (dhc-add-message " temporaries mismatch:"
                          (mapc dhc-unify-t temp1 temp2) )
         (dhc-add-message " return type mismatch:"
                          (dhc-unify-t (unode-val :t1:u-type)
                                       (unode-val :t2:u-type))))))
    (unode-unify :t1:u-extra :t2:u-extra or)
    () ) ) )


#? (dhc-desc-to-type <desc>)
;; Convert a type description to a type.  
;; Argument <desc> is a type description
;; similar to those returned by <dhinfo-t> and <classinfo-t>.
(de dhc-desc-to-type (desc)
  (let* ((tclass (car desc))
         (e-message (concat (or e-message "") (sprintf "%l: " tclass))) )
    (cond 
     ;; complex types
     ((member tclass '(idx obj func srg ptr str class))
      (let (((tclass &optional arg1 arg2 arg3 arg4) desc)
            (new-type ()))
        (setq new-type 
              (selectq tclass
                (srg 
                 (new dhc-type 'dht-srg 
                      (dhc-desc-to-type arg2)))
                (str 
                 (new dhc-type 'dht-str))
                (idx 
                 (new dhc-type 'dht-idx 
                      arg2
                      (dhc-desc-to-type arg3)))
                (ptr 
                 (new dhc-type 'dht-ptr
                      (dhc-desc-to-type arg1)))
                (obj 
                 (if (is-of-class arg2 dhc-type)
                     (==> arg2 copy)
                   (dhc-obj-type-from-class 
                    (if (classp arg2) arg2 arg1) ) ) )
                (class
                 (if (is-of-class arg2 dhc-type)
                     (==> arg2 copy)
                   (dhc-class-to-dhc-type 
                    (if (classp arg2) arg2 arg1) ) ) )
                (func 
                 (new dhc-type 'dht-func
                      (mapcar dhc-desc-to-type arg1)
                      (mapcar dhc-desc-to-type arg2)
                      (dhc-desc-to-type arg3))) ) )
        (if (or (= tclass 'idx) (= tclass 'srg))
            (==> new-type access (if (= arg1 'r) 'read 'write)))
        (if (= tclass 'obj)
            (==> new-type access 'write))
        new-type ) )
     ;; list type
     ((= tclass 'list)
      (new dhc-type 'dht-list (mapcar dhc-desc-to-type (cdr desc))) )
     ;; gptr
     ((= tclass 'gptr)
      (new dhc-type 'dht-gptr (cadr desc)) )
     ;; simple types
     ((member (dht-long tclass) dhc-simple-types)
      (new dhc-type (dht-long tclass)))
     (t 
      (dhc-error (sprintf "don't know how to typify %l" desc))))))


;; Returns a dhc-type for class <classname>
;; without any methods but with slots.
;; Argument <classname> can be a symbolic name
;; or a lisp class
(de dhc-class-type-stub (cl) 
  (let ((clname ())
        (c-info-t ())
        (dhc-stub ()))
    (cond
     ((classp cl) 
      (setq clname (classname cl)))
     ((symbolp cl) 
      (setq clname cl) 
      (setq cl (eval `:,clname)))
     (t 
      (error 'dhc-class-type-stub "expecting symbol or class" cl)) )
    
    (cond
     ;; first search global symbol table
     ((setq c-info-t (dhc-search-symtable clname global-table))
      :c-info-t:type )
     ;; search an already compiled class
     ((not (classp cl))
      (dhc-error "cannot locate class with this name" clname) )
     ((not (setq c-info-t (classinfo-t cl)))
      (dhc-error "this class is not a compiled class" cl) )
     (t
      (new dhc-type 'dht-class
           (dhc-lisp-to-c-name (nameof clname))
           (if (super cl)
               (dhc-class-to-dhc-type (super cl))
             (new dhc-type 'dht-nil) )
           (all ((slot (nth 2 c-info-t)))
             (cons (car slot)
                   (dhc-desc-to-type (cadr slot)) ) )
           () cl ) ) ) ) )

(de dhc-class-to-dhc-type (cl)
  ;; Checks for duplicate slot names.
  ;; Works with pre-compiled classes and classes being currently compiled.
  (let ((clname ()))
    (cond
     ((classp cl) 
      (setq clname (classname cl)))
     ((symbolp cl) 
      (setq clname cl) 
      (setq cl (eval `:,clname)) )
     (t 
      (error 'dhc-class-type-stub "expecting symbol or class" cl)) )
    
    (let* ((class-symbol (dhc-search-symtable clname global-table))
	   (class-type (when class-symbol :class-symbol:type)) 
           (c-info-t ()) )
      (if class-type
          ;; found in global symbol table
          class-type
        ;; search an already compiled class
        (when (not (classp cl))
          (dhc-error "Not a valid class name" clname) )
        (setq c-info-t (classinfo-t cl))
        (when (not c-info-t)
          (dhc-error "Not a compiled class" clname) )
        (setq class-type (dhc-class-type-stub clname))
        ;; store it into the global table
        (setq class-symbol (new dhc-symbol clname 0))
        (setq :class-symbol:type class-type)
        (dhc-add-global-table class-symbol)
        ;; add the methods 
        (unode-unify 
         :class-type:u-extra
         (new-unode (append (unode-val :class-type:u-extra)
                            (all ((method (nth 3 c-info-t)))
                              (cons (car method)
                                    (dhc-desc-to-type (cadr method)) ) ) ) )
         (lambda (a b) b) )
        class-type ) ) ) )

(de dhc-obj-type-from-class(cl)
  (let* ((slots ())
         (the-object ())
         (the-class (dhc-class-to-dhc-type cl)))
    ;; search class and all super classes for slots
    (let ((the-class the-class))
      (do-while (<> 'dht-nil (unode-val :the-class:u-tclass))
        (setq slots (append slots
                            (all ((u (unode-val :the-class:u-temps))) 
                              (cons (car u) (==> (cdr u) copy)))))
        (setq the-class (unode-val :the-class:u-type))))
    ;; check for duplicate slot names (forbidden in compiled code)
    (let ((ans ()))
      (each ((i (mapcar car slots)))
        (if (null (member i ans))
            (setq ans (nconc1 ans i))
          (dhc-error "duplicate slot name found" i))))
    (setq the-object 
          (new dhc-type 'dht-obj (==> the-class copy) slots))
    (==> the-object access 'write)
    the-object ) )

(de dhc-obj-subclass-check (obj-a obj-b)
  ;; test if type obj-a represents the type of obj-b
  ;; or the type of one of its superclasses
  (let* ((a (unode-val :obj-a:u-type))
         (b (unode-val :obj-b:u-type))
         (class-a (unode-val :a:u-name))
         (class-b (unode-val :b:u-name)))
    (while (and (<> class-a class-b)
                (<> 'dht-nil (unode-val :b:u-tclass)))
      (setq b (unode-val :b:u-type))
      (setq class-b (unode-val :b:u-name)))
    (when (= 'dht-nil (unode-val :b:u-tclass))
      (dhc-unif-error "object is not compatible with declared class"
                      class-a ) ) ) )

(de dhc-add-method-to-class-type (class-type method mtype)
  ;; Verify prototype
  (let ((alist ())
        (sclass class-type))
    ;; FIXME: This looks fishy
    (while sclass
      (each (((name . type) (dhu-extra sclass)))
        (let ((otype (dhc-alist-get name alist)))
          (when otype
            (let ((e-message "*** Method prototype mismatch: "))
              (dhc-unify-t otype type) ) )
          (dhc-alist-add name alist type) ) )
      (setq sclass (dhu-type sclass)) ) )
  ;; Add new method into class description
  (unode-unify :class-type:u-extra
               (new-unode (append (unode-val :class-type:u-extra)
                                  (list (cons method mtype)) ))
               (lambda (a b) b) ) )

(de dhc-methods-of-class(cl)   
  (let ((sclass (dhc-class-to-dhc-type cl))
        (slist ())
        (alist ()) )
    (while sclass
      (setq slist (cons sclass slist))
      (setq sclass (dhu-type sclass)) )
    (each ((sclass slist))
      (each (((name . type) (dhu-extra sclass)))
        (setq alist (dhc-alist-add name alist type)) ) )
    ;; reversing restores proper method order.
    (reverse alist) ) )

 ;; Produce a list of string suitable to be in a DHDOC
(de dhc-d-to-doc (desc)
  (let ((tclass (car desc)))
    (cond 
     ;; special
     ((= tclass 'str)
      (list "DH_STR,"))
     ((= tclass 'number)
      (list "DH_REAL,"))
     ((= tclass 'gptr)
      (if (cdr desc)
          (list (sprintf "DH_GPTR(%l)," (cadr desc)))
        (list "DH_GPTR(0),") ) )
     ((= tclass 'list)
      (append (list (sprintf "DH_LIST(%d)," (length (cdr desc))))
              (apply append (mapcar dhc-d-to-doc (cdr desc)))
              (list "DH_END_LIST,")))
     ;; complex types
     ((member tclass '(idx obj func srg ptr list))
      (apply dhc-d-to-doc-complex desc))
     ;; simple types
     ((member (dht-long tclass) dhc-simple-types)
      (list (sprintf "DH_%s," (upcase (nameof tclass)))) )
     (t 
      (dhc-unif-error "unrecognized type descriptor" desc)))))

(de dhc-d-to-doc-access(v)
    (if (= v 'r) "DHT_READ" "DHT_WRITE"))

(de dhc-d-to-class-type (tclass arg1 &optional arg2)
  (cond
   ((is-of-class arg2 dhc-type)
    arg2 )
   ((classp arg2)
    (dhc-class-to-dhc-type arg2) )
   ((symbolp arg1)
    (dhc-class-to-dhc-type arg1) )
   (t
    (error 'dhc-d-to-class-type "internal" ()) ) ) )

(de dhc-d-to-doc-complex (tclass arg1 &optional arg2 arg3 arg4)
  (selectq tclass 
    ;; pointer
    (ptr 
     (dhc-d-to-doc arg1))
    ;; idx
    (idx 
     (append (list (concat "DH_IDX("
                           (dhc-d-to-doc-access arg1)
                           (sprintf ",%d)," arg2) ))
             (dhc-d-to-doc arg3)))
    ;; srg
    (srg 
     (append (list (concat "DH_SRG(" 
                           (dhc-d-to-doc-access arg1) 
                           ")," ))
             (dhc-d-to-doc arg2)))
    ;; object
    (obj
     ;; parse all possibilities for desc
     (let* ((cltype (dhc-d-to-class-type tclass arg1 arg2))
            (classdoc (sprintf "Kc_%s_R%s" 
                               (dhu-name cltype) 
                               (dhu-hash cltype))) )
       (when (dhu-class cltype)
         (dhc-add-c-metaexterns 
          (sprintf "extern_c dhclassdoc_t %s;" classdoc))
         (dhc-add-c-externs 
          (dhc-class-to-struct-decl cltype)) )
       ;; What if this wasn't a class?
       (list (sprintf "DH_OBJ(%s)," classdoc)) ) )
    ;; function
    (func 
     (each ((temps arg2))
       (when (= (car temps) 'obj)
         (let* ((cltype (apply dhc-d-to-class-type temps))
                (classdoc (sprintf "Kc_%s_R%s" 
                                   (dhu-name cltype) 
                                   (dhu-hash cltype))) )
           (dhc-add-c-metaexterns
            (sprintf "extern_c dhclassdoc_t %s;" classdoc) ) ) ) )
     (append 
      (list (sprintf "DH_FUNC(%d)," (length arg1)))
      (apply append (mapcar dhc-d-to-doc arg1))
      (when arg2 
        (apply append 
               (list (list (sprintf "DH_TEMPS(%d)," (length arg2)))
                     (flatten (mapcar dhc-d-to-doc-temp arg2))
                     (list "DH_END_TEMPS,") ) ) )
      (cons "DH_RETURN," (dhc-d-to-doc arg3))
      (list "DH_END_FUNC,") ) ) ) )

(de dhc-d-to-doc-temp (desc)
  (let* ((tclass (car desc)))
    (selectq tclass
      (idx 
       (list (concat 
              (sprintf "DH_IDX(DHT_WRITE,%d)," (caddr desc))
              (apply concat (dhc-d-to-doc (caddr (last desc)))) )) )
      (obj 
       (let* ((cltype (apply dhc-d-to-class-type desc))
              (classdoc (sprintf "Kc_%s_R%s" 
                                 (dhu-name cltype)
                                 (dhu-hash cltype) )) )
         (list (sprintf "DH_OBJ(%s)," classdoc)) ) )
      (func 
       (list (sprintf "DH_FUNC(DHT_WRITE,%d)," (caddr desc))) )
      (list 
       (append (list (sprintf "DH_LIST(%d)," (length (cdr desc))))
               (all ((de (cdr desc)))
                 (car (dhc-d-to-doc de)))
               (list "DH_END_LIST,")))
      (str 
       (list (concat "DH_STR,")))
      (srg 
       (list (concat "DH_SRG(DHT_WRITE), "
                     (apply concat (dhc-d-to-doc (caddr desc))))))
      (t 
       (error 'dhc-d-to-doc-temp
                "don't know how to DHDOC a temporary of this type" desc)) ) ) )











;;; ------------------------------------------------------------------------
;;; ------------------------------------------------------------------------
;;;             S  Y  M  B  O  L      T  A  B  L  E
;;; ------------------------------------------------------------------------
;;; ------------------------------------------------------------------------




;;; ------------------------------------------------------------------------
;;; SYMBOLS
;;; ------------------------------------------------------------------------

#? (new dhc-symbol <name> <lex> [<fmt>])
;; return an symbol object which knows the lisp name <name>, the C name, the 
;; scope level (passed in <lex>.  <lex> is zero if the symbol is an 
;; argument).  <fmt> is by default "L%d_%s" where %d refers to the
;; scope level (<lex>) and %s to the C name of the symbol (computed from
;; the lisp name with dhc-lisp-to-c-name.

(defclass dhc-symbol object
  lisp-name		; The lisp symbol
  lex-level		; Depth. Depth 0 marks the arguments
  c-name		; The name in the C code
  type                  ; type of symbol
  no-declare )          ; symbol should not be declared as a variable)


(defmethod dhc-symbol dhc-symbol(name lex &optional (fmt "L%d_%s"))
  (setq lisp-name name)
  (setq lex-level lex)
  (setq c-name (sprintf fmt lex (dhc-lisp-to-c-name (nameof name))))
  (setq type (new dhc-type 'dht-unk))
  (setq :type:u-bump (new-unode lex)))


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

#@ (defmethod dhc-symbol print()
     (printf "<SYMBOL,%l@%d,%s,%l>" lisp-name lex-level c-name type) )



;;; ------------------------------------------------------------------------
;;; SYMBOL CREATION
;;; ------------------------------------------------------------------------

;; Make a C name with a Lisp name

(setq dhc-valid-c-identifier
      "[A-Za-z0-9_]+" )			; We always prepend something, so
					; it does not need to start with a letter

(setq dhc-lisp-to-c-translations	; Add your own...
      '(
	("@" 	"At")			; A capital letter ensures that
	("%" 	"Percent")		; no homonym exist
	("/" 	"Over")
	("&" 	"Et")
	("-" 	"_")			; '-' and '_' are identical
	("<>" 	"Ne")
	(">=" 	"Le")
	("<=" 	"Ge")
	("=" 	"Eq")
	(">" 	"Lt")
	("<" 	"Gt")
	("^\\|" 	"")             ; Quote
	("\\|$" 	"")             ; Quote
	("\\*\\*" 	"Power")
	("\\*" 		"Times")
	("\\+" 		"Plus")
	("\\$"	 	"Dollar")
	("\\^" 		"Caret")
	("\\."    	"X")
	("\\?"		"Qmark") ) )


(de dhc-lisp-to-c-name(name)
  (let ((newname (downcase name))
        (translations dhc-lisp-to-c-translations))
    ;; While not a valid identifier
    (while (not (regex-match dhc-valid-c-identifier newname))
      ;; Complain if no more translations
      (when (not (consp translations))
        (dhc-error "Cannot translate this symbol into a C identifier" name) )
      ;; Try the current translation
      (setq newname (regex-subst (caar translations) (cadar translations) newname ))
      ;; Advance to the next translation
      (setq translations (cdr translations)) ) 
    newname ) )

(de dhc-printf-to-c(stri)
  ;; Vastly simplified
  (regex-subst "^\"|\"$" "" (pname stri)) )




;;; ------------------------------------------------------------------------
;;;  SYMBOL TABLE
;;; ------------------------------------------------------------------------


;;; Symbol tables are currently implemented as assocs.
;;; The compiler efficiency could be vastly improved
;;; by implementing more clever symbol tables.


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

;; Create a symbol table with a list of argument
(de dhc-arguments-to-symtable(args lex)
  (all ((i args))
    (cons i (new dhc-symbol i lex)) ) ) 

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

#? (dhc-search-symtable <symbolname> <table>)
;; Search a symbol table
(de dhc-search-symtable(symbol table)
  (cond
   ((listp table)
    (dhc-alist-get symbol table) )
   ((is-of-class table |HTABLE|)
    (table symbol) )
   (t
    (error 'dhc-search-symtable 
           "Symbol table must be an alist or a htable" 
           table) ) ) )

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

#? (dhc-add-to-symtable <table> <symbolobject>)
;; Return a new symbol table with one more element
(de dhc-add-to-symtable(table symbol)
  (cons (cons :symbol:lisp-name symbol) table) )


#? (dhc-add-symbol-table <symb> <lex>)
;; Add a symbol named <symb> at lexical level <lex> 
;; into the current symbol table.
(de dhc-add-symbol-table (symb lex)
  (let ((newsymb (new dhc-symbol symb lex)))
    (setq symbol-table (dhc-add-to-symtable symbol-table newsymb))
    newsymb ) )

#? (dhc-add-global-table <symb>)
;; Add a symbol to the global table
(de dhc-add-global-table(symb)
  (let ((clname :symb:lisp-name))
    (cond
     ((listp global-table)
      (setq global-table (cons (cons clname symb) global-table)) )
     ((is-of-class global-table |HTABLE|)
      (global-table clname symb) ) ) ) )


;;; ------------------------------------------------------------------------
;;; ------------------------------------------------------------------------
;;;                       P   A   R   S   E   R
;;; ------------------------------------------------------------------------
;;; ------------------------------------------------------------------------

;;------------------------------------------------------------------------------
;;  t-node (a type structure for expressions)
;;------------------------------------------------------------------------------
#? (new t-node <t-node-list> <type> [<source>] [<symbol>])
;; Returns a t-node (type node).  
;; T-nodes contains all the type information of a LISP expression.  
;; If <source> is a symbol, then the slot <symbol> should contain 
;; an object of class <dhc-symbol>.
;;.PP
;; A t-node contains 5 slots: 
;;.VP
;;         <tn-list> <type> <source> <symbol> <ignore> 
;;.PP
;; The slot <type> holds the return type of the expression which is parsed.
;; is a t-node.  If the expression is terminal, the slot tn-list should be the
;; empty list and the slot source should contain the corresponding source.
;;
;; Examples:
;;.VP
;; Parsing the expression  (+ a b) 
;; returns the t-node      <<+:(dhm)>,<a:(flt)>,<b:(flt)>:(flt)>
;;
;; In this t-node the slots are:
;;   tn-list : a list of 3 t-nodes    = (<+:(dhm)> <a:(flt)> <b:(flt)>)
;;   type    : a return dhc-type node = (flt)
;;   source  : the original source    = (+ a b)
;;
;; For the first element of the above t-node 
;; i.e. (car :t_node_above:tn-list)
;;   tn-list : a list of t-nodes    = ()
;;   type    : a return dhc-type node = (dhm)
;;   source  : the original source    = +
;;.PP
;; 

(defclass t-node object
  tn-list
  type
  source
  ignore
  symbol      ; if t-node of a symbol, holds the dhc-symbol 
              ; if t-node of a scope, hold a list of dhc-symbol
  transfer )  ; available to transfer information from dhm-t to dhm-c

(defmethod t-node t-node (tn ty &optional so symb)
  (if tn
      (if (consp tn)
	  (each ((tno tn))
            (if (<> (classof tno) t-node)
                (dhc-internal-error "not a valid t-node in list" tno)))
	(if (<> (classof tn) t-node)
	    (dhc-internal-error "not a valid t-node: bad t-node" tn))))
  (if (<> (classof ty) dhc-type)
      (dhc-internal-error "not a valid t-node: bad type" ty))
  (setq tn-list tn)
  (setq type ty)
  (setq source so)
  (setq symbol symb)
  (setq ignore :ignore) )  ; global ignore set in dhc-parse-expr-t

(defmethod t-node print ()
  (if ~tn-list
      (printf "%s<%l:%l>" (if ignore "#" "") source type)
    (printf "%s<" (if ignore "#" ""))
    (each ((tn (dhc-nolast tn-list)))
      (printf "%l," tn))
    (printf "%l:%l>" (last tn-list) type)))

(defmethod t-node pprint ()
  (let ((tabb (if tabb tabb 0))
	(tabu (lambda (n) (for (i 1 n 1) (printf " ")))))
    (tabu tabb)
    (printf "<")
    (if source 
	(printf "%l %l%7d>\n" source type (unode-uid :type:u-tclass))
      (printf "tn-list:\n")
      (let ((tabb (+ 3 tabb)))
	(each ((tn tn-list))
          (==> tn pprint)))
      (tabu (1+ tabb))
      (printf "type:\n")
      (tabu (+ 3 tabb))
      (printf "%l%7d\n" type (unode-uid :type:u-tclass))
      (tabu (1+ tabb))
      (printf "symbol:\n")
      (tabu (+ 3 tabb))
      (if ~symbol 
	  (printf "%l\n" symbol)
	(if ~(listp symbol)
	  (printf "%l%7d\n" symbol (unode-uid :symbol:type:u-tclass))
	  (printf "%l%7d\n" (car symbol) (unode-uid :(car symbol):type:u-tclass))
	  (each ((symbol (cdr symbol)))
            (tabu (+ 3 tabb))
            (printf "%l%7d\n" symbol (unode-uid :symbol:type:u-tclass)))))
      (tabu tabb)
      (printf ">\n"))))

;;-----------------------------------------------------------------------------
#? (dhc-make-t-node <expr>)
;; Return a treetype (a t-node) for <expr> but 
;; leave all the types unknown.
(de dhc-make-t-node (expr)
  (if ~(listp expr)
    (new t-node () (new dhc-type 'dht-unk) expr)
    (new t-node 
         (mapcar dhc-make-t-node expr) (new dhc-type 'dht-unk))))


;;; ------------------------------------------------------------------------
;;; DHM: MACRO-DEFINITION OF SPECIFIC STRUCTURES
;;; ------------------------------------------------------------------------


;;; ------------------------------------------------------------------------
;; DHM DEFINITION



#? (dhc-copy-source-tree <source>)
;; Utility for dhc-get-treetype.
;; Copies a source tree list (except leaves).
;; Returns the copy.
(de dhc-copy-source-tree (source)
  (if (consp source) 
      (append source () (cdr (lastcdr source)))
    source ) )


#? (dhc-get-treetype <source>)
;; This function returns the treetype of a expression.
;;.VP
;; ? (dhc-get-treetype '(+ 3 4))                              
;; = <<+:(dhm)>,<3:(number)>,<4:(number)>:(number)>
;; ? (dhc-get-treetype '(lambda (a) (-flt- a) a))
;; = <<lambda:(dhm)>
;;    ,<<a:(flt)>:(unk)>
;;    ,<<-flt-:(dhm)>,<a:(flt)>:(flt)>
;;    ,<a:(flt)>
;;    :(func ((flt)) () (flt))>
(de dhc-get-treetype (source)
  (let ((lex-level 0)
        (tmpnames-seed 0)
        (symbol-table ())
        (dhc-debug-stack ()))
    (dhc-parse-expr-t source)))



#? (dhc-get-type <source>)
;; This function returns the dhc-type of expression <source>
(de dhc-get-type (source)
  :(dhc-get-treetype source):type)



#? (dhm-t <func> (source) . <body>)
;; Installs a new DHM-T for the function named <func>.
;;
;; The DHM-T function will be called when parsing a list expression
;; starting with function <func>.  This list expression is passed
;; as argument to the DHM-T function.  It should construct
;; and return a t-node for the provided source code.

(dm dhm-t (fn name args . body)
  (when (or (not (consp args)) (<> (length args) 1))
    (error 'dhm-t "Incorrect arguments for dhm-t" name) )
  `(let ((func :,name))
     (if (and dhc-debug-flag (getp func 'dhm-t))
         (printf "*** Redefining dhm-t for %l\n" ',name))
     (if (or (is-of-class func |DE|)
             (is-of-class func |DF|)
             (is-of-class func |DM|)
             (is-of-class func |DX|)
             (is-of-class func |DY|)
             (is-of-class func |DZ|) )
         (putp func 'dhm-t (lambda ,args ,@body))
       (error 'dhm-t "Not a valid target for a dhm-t" ',name) )
     ',name ) )

#? (dhm-t-declare <model> <f1> ... <fn> )
;; Associates the dhm-t for function <model>
;; with all functions <f1> to <fn>.
(dm dhm-t-declare(fn model . copies)
  `(let ((dhm (getp :,model 'dhm-t)))
     (when (not (functionp dhm))
       (error 'dhm-t-declare "No dhm-t defined for" ',model) )
     (each ((func (list ,@(all ((copy copies)) (list 'scope copy))))
            (name ',copies) )
       (if (and dhc-debug-flag (getp func 'dhm-t))
           (printf "*** Redefining dhm-t for %l\n" name))
       (if (or (is-of-class func |DE|)
               (is-of-class func |DF|)
               (is-of-class func |DM|)
               (is-of-class func |DX|)
               (is-of-class func |DY|) 
               (is-of-class func |DZ|) )
           (putp func 'dhm-t dhm)
         (error 'dhm-t "Not a valid target for a dhm-t" name) ) )
     ',copies) )


#? (dhm-c <symb> (source treetype retplace) . <body>)
;; Installs a new DHM-T for the function named <func>.
;;
;; The DHM-C function will be called when generating C code for 
;; a list expression starting with function <func>.  
;; This list expression is passed as argument <source> of 
;; the DHM-C function.  Argument <treetype> is the t-node prepared 
;; by the DHM-T function.  The function should call the <dhc-add-c-xxx>
;; functions to compose the C code and return a string representing
;; a C expression for the return value.  When argument <retplace>
;; is non nil, it contains the name of a variable where the return
;; value must be stored.  The dhm-c function should then return 
;; this name.

(dm dhm-c (fn name args . body)
  (when (or (not (consp args)) (<> (length args) 3))
    (error 'dhm-t "Incorrect arguments for dhm-c" name) )
  `(let ((func :,name))
     (if (and dhc-debug-flag (getp func 'dhm-c))
         (printf "*** Redefining dhm-c for %l\n" ',name))
     (if (or (is-of-class func |DE|)
             (is-of-class func |DF|)
             (is-of-class func |DM|)
             (is-of-class func |DX|)
             (is-of-class func |DY|) 
             (is-of-class func |DZ|) )
         (putp func 'dhm-c (lambda ,args ,@body))
       (error 'dhm-c "Not a valid target for a dhm-c" ',name) )
     ',name ) )

#? (dhm-c-declare <model> <f1> ... <fn> )
;; Associates the dhm-c for function <model>
;; with all functions <f1> to <fn>.
(dm dhm-c-declare(fn model . copies)
  `(let ((dhm (getp :,model 'dhm-c)))
     (when (not (functionp dhm))
       (error 'dhm-c-declare "No dhm-c defined for" ',model) )
     (each ((func (list ,@(all ((copy copies)) (list 'scope copy))))
            (name ',copies) )
       (if (and dhc-debug-flag (getp func 'dhm-c))
           (printf "*** Redefining dhm-c for %l\n" name))
       (if (or (is-of-class func |DE|)
               (is-of-class func |DF|)
               (is-of-class func |DM|)
               (is-of-class func |DX|)
               (is-of-class func |DY|) 
               (is-of-class func |DZ|) )
           (putp func 'dhm-c dhm) 
         (error 'dhm-c "Not a valid target for a dhm-c" name) ) )
     ',copies) )


#? (get-dhm-t <symb>)
;; Return the dhm-t for function <symb>
(de get-dhm-t (symb)
  (when (symbolp symb)
    (setq symb (eval `:,symb)) )
  (getp symb 'dhm-t) )

#? (get-dhm-c <symb>)
;; Return the dhm-c for function <symb>
(de get-dhm-c (symb)
  (when (symbolp symb)
    (setq symb (eval `:,symb)) )
  (getp symb 'dhm-c) )


#? (get-dhm-target <source>)
;; This function can be called within a dhm
;; to return the function object for which the dhm applies
(de get-dhm-target(source)
  (when (consp source)
    (setq source (car source)) )
  (when (symbolp source)
    (setq source (eval `:,source)) )
  source )
   


;;; ------------------------------------------------------------------------
;;; PREPROCESSING AND MACRO-EXPANSIONS
;;; ------------------------------------------------------------------------
;;; Surely needs a lot more dhm-p.
;;; It would have been better to do this in dhc-parse-expr-t



#? (dhm-p <func> (source) . <body>)
;; Installs a new DHM-P for the function named <func>
;; 
;; The DHM-P function will be called when preprocessing
;; a list expression starting with function <func>.
;; The list expression is passed as <source>. 
;; It should construct a copy of <source>, using
;; function <dhc-pp> on all parts of <source>
;; that can be subject to macro-expansion
;;
;; There are relatively few DHM-P functions
;; because the SN3 compiler lacked this facilities.
;; In the absence of a DHM-P function, all arguments
;; of a function call are considered for macro-expansion.
;; This is obviously wrong for functions like <let>
;; or <quote>.  

(dm dhm-p (fn name args . body)
  (when (or (not (consp args)) (<> (length args) 1))
    (error 'dhm-t "Incorrect arguments for dhm-p" name) )
  `(let ((func :,name))
     (if (and dhc-debug-flag (getp func 'dhm-p))
         (printf "*** Redefining dhm-p for %l\n" ,name))
     (if (or (is-of-class func |DF|)
             (is-of-class func |DM|)
             (is-of-class func |DY|)
             (is-of-class func |DX|) )
         (putp func 'dhm-p (lambda ,args ,@body))
       (if (or (is-of-class func |DE|)
               (is-of-class func |DZ|) )
           (error 'dhm-p "DE and DZ functions do not need dhm-p" ',name) 
         (error 'dhm-p "Not a valid target for a dhm-t" ',name) ) ) 
     ',name ) )

#? (get-dhm-p <symb>)
;; Return the dhm-p for function <symb>
(de get-dhm-p (symb)
  (when (symbolp symb)
    (setq symb (eval `:,symb)) )
  (getp symb 'dhm-p) )


#? (dhc-pp <body>)
;; Macro preprocessor for the dhc compiler.
;; return a version of lisp expression <body> with
;; all macros (both dm and dmd) expanded. 
(de dhc-pp(body)
  (if (atomp body)
      body
    (let* ((source body)
           (fname (car body))
           (func  (if (symbolp fname) (eval `:,fname) fname))
           (dhm   ()) )
      ;; inlined mlambda
      (when (and (consp fname) (= (car fname) 'mlambda))
        (setq func (eval fname)) )
      (cond
       ;; dhm-p is provided
       ((setq dhm (get-dhm-p func))
        (setq body (dhm body))
        (let ((x (dhc-pp (car body))))
          (if (is-of-class x |DM|)
              (dhc-pp body)
            body) ) )
       ;; macro function except those with a dhm-t
       ((and (is-of-class func |DM|) (not (get-dhm-t func)))
        (dhc-pp (eval `(macro-expand ,body))) )
       ;; sn3 defaults to expanding everything
       ((functionp func)
        (cons (car body) (dhc-pp-all (cdr body))) )
       ;; limited lambda syntax (compatibility purposes)
       ((and (consp fname) (= (car fname) 'lambda))
        (let ((bindings ())
              (argnam (cadr fname))
              (argval (cdr source)) )
          (while (or argnam argval)
            (when (not (and (consp argnam) (consp argval) (symbolp (car argnam))))
              (dhc-error "Cannot expand this lambda function call" body) )
            (setq bindings (cons (list (car argnam) (car argval)) bindings))
            (setq argnam (cdr argnam))
            (setq argval (cdr argval)) )
          `(let ,(reverse bindings) ,@(cddr fname)) ) )
       ;; sn3 defaults to expanding everything
       ;; with a convoluted algorithm whose effects 
       ;; are hopefully reproduced below.
       (t
        (let ((x (dhc-pp (car body))))
          (if (is-of-class x |DM|)
              (eval `(macro-expand ,body))
            (cons x (dhc-pp-all (cdr body))) ) ) ) ) ) ) )

(de dhc-pp-all(src)
  (let ((x ()))
    (while (consp src)
      (setq x (cons (dhc-pp (car src)) x))
      (setq src (cdr src)) )
    (nconc (reverse x) src) ) )



;;; ------------------------------------------------------------------------
;;; PARSING AN EXPRESSION
;;; ------------------------------------------------------------------------


;; This variable is set to true when in declaration mode (i.e. (-idx1- a))
;; If a symbol is of unknown type, and we are not in declaration mode,
;; an appropriate error message is issued.  This hack relieves us from
;; having to check that all the variable of a dhm are of known type before
;; we extract information about them.  (ex: (idx-copy a b c))
(setq dhc-declaration-mode ())

(de dhc-parse-expr-t(source &optional ig)
  ;; okay.
  (let* ((dhc-debug-stack (cons source dhc-debug-stack))
         (ignore ig) ;; ignore is a global for the dhm-t
         (tnout
          ;; Dispatch to specific parsing routines
          (cond
           ;; Case of an empty list
           ((not source)
            (new t-node () (new dhc-type 'dht-nil) source))
           ;; Case of a number
           ((numberp source)
            (dhc-parse-number-t source))
           ;; Case of a constant matrix
           ((matrixp source)
            (dhc-parse-matrix-t source))
           ;; Case of a string constant
           ((stringp source)
            (dhc-parse-string-t source))
           ;; Case of a symbol
           ;;  (special cases for compiled functions and t)
           ((symbolp source)
            (cond ((or (dhc-search-symtable source symbol-table)
                       (dhc-search-symtable source global-table) )
                   (let ((symb (dhc-parse-variable-t source)))
                     (if (and ~dhc-declaration-mode
                              (==> :symb:type is-an-unk))
                         (dhc-error "Unknown type" source)
                       symb)))
                  ((get-dhm-t source)
                   (new t-node () (new dhc-type 'dht-dhm) source))
                  ((= source t)
                   (new t-node () (new dhc-type 'dht-bool) source))
                  ((is-of-class (eval `:,source) |DH|)
                   (new t-node () 
                        (dhc-desc-to-type (dhinfo-t (eval `:,source)))
                        source ) )
                  (t 
                   (dhc-error "Unknown symbol" source))))
           ;; Case of a function 
           ((functionp source)
            (cond ((get-dhm-t source)
                   (new t-node () (new dhc-type 'dht-dhm) 
                        source ) )
                  ((is-of-class source |DH|)
                   (new t-node () 
                        (dhc-desc-to-type (dhinfo-t (eval `:,source)))
                        source ) )
                  ((and source (= source declare.autoreplace))
                   (dhc-error "Syntax error in type declaration" source) )
                  (t
                   (dhc-error "Cannot compile this function call" source)) ) )
           ;; List expression
           ((consp source)
            (let* ((car-source (car source))
                   (tn (dhc-parse-expr-t car-source))
                   (car-type :tn:type) )
              ;; Parse the list expression
              (cond 
               ((and (not (dhc-search-symtable car-source symbol-table))
                     (==> car-type is-a-dhm))
                (let* ((dhm-running car-source)
                       (dhm-t-node ((get-dhm-t car-source) source)))
                  ;; unless there was source replacement...
                  (when (= (car source) car-source)
                    (setq :dhm-t-node:tn-list 
                          (cons (new t-node () car-type car-source)
                                :dhm-t-node:tn-list)))
                  dhm-t-node))
               ((==> car-type is-an-idxptr)
                (dhc-parse-idx-t tn source))
               ((==> car-type is-a-func)
                (dhc-parse-dh-t source))
               ;; Error
               (t
                (dhc-error "Not a compilable function" (car source)) ) )))
           (t 
            (dhc-error "cannot compile this expression" source))) ) )
    (setq :tnout:ignore ig)
    tnout ) )


#? (dhc-parse-replacement-source-t <source> <newsource>)
;; A dangerous hack to allow source replacement from within a dhm-t.  Modifies
;; the source tree being parsed and calls the dhm-t for the "newsource" The
;; "source" argument should be the input argument of the calling dhm-t.  See
;; the dhm-t for incr for usage.  No corresponding dhm-c is needed.
(de dhc-parse-replacement-source-t (source newsource)
  (setq newsource (dhc-pp (dhc-copy-source-tree newsource)))
  (rplaca source (car newsource))
  (rplacd source (cdr newsource))
  (dhc-parse-expr-t source ignore))

(de dhc-parse-expr-c(source treetype retplace)
  (let ((dhc-debug-stack (cons source dhc-debug-stack)))
    ;; sanity checks
    (if (not (is-of-class treetype t-node))
        (dhc-internal-error 
         (sprintf "treetype must be a t-node: %l" treetype)))
    (when (if (atomp source)
              (or :treetype:tn-list
                  (and (not :treetype:source)
                       (not (==> :treetype:type is-a-bool))
                       (not (==> :treetype:type is-a-nil))) )
            (or (not (listp :treetype:tn-list))
                (<> (length :treetype:tn-list) (length source)) ) )
      (dhc-internal-error 
       (sprintf "treetype structure does not match source: %l" treetype)) )
    ;; generate code
    (let ((returned-expr 
           ;; Dispatch to specific parsing routines
           (cond
            ;; Case of an empty list
            ((not source) "0")
            ;; Case of a number
            ((numberp source)
             (dhc-parse-number-c source treetype retplace))
            ;; Case of a constant matrix
            ((matrixp source)
             (dhc-parse-matrix-c source treetype retplace))
            ;; Case of a string constant
            ((stringp source)
             (dhc-parse-string-c source treetype retplace))
            ;; Case of a variable
            ((symbolp source)
             (if (<> source t)
                 (dhc-parse-variable-c source treetype retplace)
               "1"))
            ;; Other
            ((consp source)
             (let ((funct (car source))
                   (funct-t (car :treetype:tn-list)))
               (cond
                ;; Is that a DHM ?
                ((and (not (dhc-search-symtable (car source) symbol-table))
                      (==> :funct-t:type is-a-dhm))
                 (let ((dhm-running (car source))
                       (dhm (get-dhm-c (car source))) )
                   (when (not dhm)
                     (error 'dhc-parse-expr-c "No dhm-c for function" (car source)) )
                   (dhm source treetype retplace)))
                ;; Is it an idx?
                ((==> :funct-t:type is-an-idxptr)
                 (dhc-parse-idx-c source treetype retplace))
                ;; is it a function or macro
                ;; i.e.: "(idx-m2dotm2 a b c)"
                ((==> :funct-t:type is-a-func)
                 (dhc-parse-dh-c source treetype retplace))
                ;; Error
                (t
                 (dhc-error "Not a compilable function" (car source)) ) ))))))
      ;; If retplace is there, it is always used!      
      (if (not (and retplace (<> returned-expr retplace)))
          returned-expr
        (dhc-add-c-statements (sprintf "%s = %s;" retplace returned-expr))
        retplace ) ) ) )


;; Utility used for parsing args that will be used multiple times
;; Returns a cname to be applied in the function layout.
;; Creates a retplace so that inlines won't be executed multiple times,
;; but tries to detect cases where this will wasted (symbols, constants).
;;  EX:  If used to parse the args of (foo a 1 (+ 1 3)),
;;       this func will only create a temp for the last arg.

(de dhc-parse-expr-for-multi-use-c (source treetype retplace)
  ;; create a temp retplace if it is not a leaf
  (when (and ~retplace (consp source))
    (setq retplace (dhc-declare-temp-var :treetype:type)))
  (dhc-parse-expr-c source treetype retplace))



;;; ------------------------------------------------------------------------
;;; PARSING A PROGN
;;; ------------------------------------------------------------------------

;; parse a list of expression and return the last one
(de dhc-parse-progn-t(source)
  (if (consp source)
      (let ((treetype-list (append (all ((so (dhc-nolast source)))
                                     (dhc-parse-expr-t so t))
                                   (list (dhc-parse-expr-t (last source)
                                                           ignore)))))
        (new t-node treetype-list :(last treetype-list):type () ()))
    ;; empty progn
    (new t-node () (new dhc-type 'dht-nil) ())))

(de dhc-parse-progn-c(source treetype-list retplace)
  (if ~(consp source)
    "0"
    (each ((so (dhc-nolast source)) (ty (dhc-nolast treetype-list)))
      (dhc-parse-expr-c so ty ()))
    (dhc-parse-expr-c (last source) (last treetype-list) retplace)))

;;; ------------------------------------------------------------------------
;;; PARSING THE IDX ACCESS SYNTAX
;;; ------------------------------------------------------------------------

(de dhc-parse-idx-t(idx-tn source)
  (let* ((ndim (==> :idx-tn:type is-an-idxptr))
	 (args (cdr source))
	 (tnl (all ((so args)) (dhc-parse-expr-t so)))
	 (el-type (new dhc-type (==> :idx-tn:type get-element-type)))
	 (dims-tnlist ()) )
    
    (when (> (length args) (1+ ndim))
      (dhc-error "Too many dimensions"))
    (when (< (length args) ndim)
      (dhc-error "Not enough dimensions"))
    (if (= (length args) ndim)
        (setq dims-tnlist tnl)
      (setq dims-tnlist (dhc-nolast tnl))
      (==> (dhu-type (dhu-type :idx-tn:type)) access 'write)
      (dhc-assign-unify el-type :(last tnl):type))
    (each ((val dims-tnlist))
      (dhc-unify-types :val:type (new dhc-type 'dht-number)))
    (setq tnl (cons idx-tn tnl))
    (if (= (length args) ndim)
        (new t-node tnl el-type source)
      (new t-node tnl :idx-tn:type source))))

(de dhc-parse-idx-c(source treetype retplace)
  (let* ((mattn (car :treetype:tn-list))
         (ndim (==> :mattn:type is-an-idxptr))
         (nargs (length (cdr source)))
         (is-set (<> ndim nargs))
         (mat (dhc-parse-expr-for-multi-use-c 
               (car source) mattn (if is-set retplace)))
         (el-decl (==> :mattn:type get-element-decl))
         (inds-so (if is-set 
                      (dhc-nolast (cdr source)) 
                    (cdr source)))
         (inds-tn (if is-set 
                      (dhc-nolast (cdr :treetype:tn-list))
                    (cdr :treetype:tn-list)))
         (inds (all ((so inds-so) (tn inds-tn))
                 (dhc-parse-expr-for-multi-use-c so tn ())))
         (num -1)
         (mlist (dhc-insert-op 
                 (all ((x inds)) 
                   (sprintf "(%s)->mod[%d]*((int)%s)" mat (incr num) x))
                 "+")) )
    (setq num -1)
    (when (> ndim 0)
      (each ((x inds) (so inds-so))
        (if ~(numberp so)
          (if ~dhc-unprotect
              (dhc-add-c-statements
               (sprintf "RTERR_BOUND(%s<0 || %s>=(%s)->dim[%d]);"
                        x x  mat (incr num))))
          ;; else
          (when (< so 0) (dhc-error "index out of bounds"))
          (if ~dhc-unprotect
              (dhc-add-c-statements
               (sprintf "RTERR_BOUND(%s>=(%s)->dim[%d]);"
                        x  mat (incr num)))))))
    (if (= ndim nargs)
        ;; SOURCE FOR GET
        (if (= 0 ndim)
            (sprintf " *IDX_PTR(%s,%s)"  mat el-decl)
          ;; else
          (sprintf "IDX_PTR(%s,%s)[%s]"  mat el-decl mlist))
      ;; SOURCE FOR SET
      (if (= 0 ndim)
          (dhc-add-c-statements
           (sprintf "*IDX_PTR(%s,%s) = %s;"
                    mat el-decl
                    (dhc-parse-expr-c (last source)
                                      (last :treetype:tn-list) ())))
        ;; else
        (dhc-add-c-statements
         (sprintf "IDX_PTR(%s,%s)[%s] = %s;"
                  mat el-decl mlist
                  (dhc-parse-expr-c (last source)
                                    (last :treetype:tn-list) ()))))
      
      mat ) ) )



;;; ------------------------------------------------------------------------
;;; PARSING A MATRIX CONSTANT
;;; ------------------------------------------------------------------------


(de dhc-base-type-of-srg(srg)
  (let* ((cls (classof srg)))
    (new dhc-type
         (cond
          ((= cls |DSTORAGE|)    'dht-real)
          ((= cls |FSTORAGE|)    'dht-flt)
          ((= cls |I32STORAGE|)  'dht-int)
          ((= cls |I16STORAGE|)  'dht-short)
          ((= cls |I8STORAGE|)   'dht-char)
          ((= cls |U8STORAGE|)   'dht-uchar)
          ((= cls |GPTRSTORAGE|) 'dht-gptr)
          (t (dhc-error "Illegal literal storage type")) ) ) ) )


(de dhc-parse-matrix-t (source)
  (let* ((ndim (idx-ndim source))
         (base-type (dhc-base-type-of-srg (idx-storage source))) 
         (srg-type (new dhc-type 'dht-srg base-type))
         (idx-type (new dhc-type 'dht-idx ndim 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 () rettype source)))
    (incr tmpnames-seed)
    (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))

(de dhc-parse-matrix-c (source treetype retplace)
  (let ((constant-name (sprintf "constant_%d_%d" lex-level tmpnames-seed))
        ((idx-symb srg-symb) :treetype:transfer)
        (ndim (idx-ndim source))
        (ctype (==> :treetype:type get-element-decl))
        (s "")
        (size ())
        (temp-mat ()))
    
    (incr tmpnames-seed)
    (setq size (apply * (bound source)))
    (setq temp-mat (copy-any-matrix source))
    (dhc-add-c-declarations (sprintf "static %s %s[] = {" 
                                     ctype constant-name))
    (for (i 0 (- size 2))
         (when (= 9 (mod i 10))
           (dhc-add-c-declarations s)
           (setq s ""))
         (setq s (concat s (sprintf "%l, " (temp-mat i)))))
    (dhc-add-c-declarations (concat s (sprintf "%l}; " (temp-mat (1- size)))))
    (dhc-add-c-statements (sprintf "(%s)->srg = %s;" :idx-symb:c-name :srg-symb:c-name))
    (dhc-add-c-statements (sprintf "(%s)->flags &= ~IDF_UNSIZED;" :idx-symb:c-name))
    (dhc-add-c-statements (sprintf "(%s)->offset = 0;" :idx-symb:c-name))
    (let ((siz 1))
      (for (i (1- ndim) 0 -1)
           (let ((nd (idx-dim source i)))
             (dhc-add-c-statements (sprintf "(%s)->dim[%d] = %d;" :idx-symb:c-name i nd))
             (dhc-add-c-statements (sprintf "(%s)->mod[%d] = %d;" :idx-symb:c-name i siz))
             (setq siz (* siz nd)) ) )
      (dhc-add-c-statements (sprintf "(%s)->size = %d;" :srg-symb:c-name siz)) )
    (dhc-add-c-statements (sprintf "(%s)->flags &= ~STS_MALLOC;" :srg-symb:c-name))
    (dhc-add-c-statements (sprintf "(%s)->flags |= STS_STATIC;" :srg-symb:c-name))
    (dhc-add-c-statements (sprintf "(%s)->data = %s;" :srg-symb:c-name constant-name))
    :idx-symb:c-name))



;;; ------------------------------------------------------------------------
;;; PARSING A NUMBER
;;; ------------------------------------------------------------------------

;; This is more complex than you think:
;; A number may be an INT, a FLT or a REAL.

(de dhc-parse-number-t(source)
  (new t-node () (new dhc-type 'dht-number) source))

(de dhc-parse-number-c(source treetype retplace)
  (let ((tclass (unode-val (scope :treetype:type u-tclass))))
    (selectq tclass
      (dht-flt (sprintf "%l" source))
      (dht-number (sprintf "%l" source))
      ((dht-int dht-byte dht-ubyte) (sprintf "%l" source))
      (dht-real (sprintf "%l" source))
      (t (dhc-error "don't know this kind of number")))))

;;; ------------------------------------------------------------------------
;;; PARSING A STRING
;;; ------------------------------------------------------------------------

(de dhc-parse-string-t (source)
  (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))
         (tn (new t-node () rettype source)))
    (incr tmpnames-seed)
    (dhc-unify-types :str-symb:type str-type)
    (setq bump-list (append bump-list (list str-symb)))
    (setq :tn:transfer str-symb)
    tn))

(de dhc-parse-string-c (source treetype retplace)
  (let ((str-symb :treetype:transfer))
    (dhc-add-c-statements (sprintf "Msrg_resize(%s, %d+1);"
                                   :str-symb:c-name (len source)))
    (dhc-add-c-statements (sprintf "strcpy((char*)((%s)->data),%l);"
                                   :str-symb:c-name source))
    :str-symb:c-name))


;;; ------------------------------------------------------------------------
;;; PARSING A SYMBOL
;;; ------------------------------------------------------------------------

(de dhc-parse-variable-t(source)
  (let ((sym (dhc-check-symbol source)))
    (new t-node () :sym:type source sym)))

(de dhc-parse-variable-c(source treetype retplace)
  (scope :treetype:symbol c-name))




;;; ------------------------------------------------------------------------
;;; PARSING A CALL TO A DH
;;; ------------------------------------------------------------------------


(de dhc-parse-dh-t(source)
  (when (not (symbolp (car source)))
    (dhc-error "Unsupported call to unnamed function" (car source)) )
  (let* ((dhfunc (eval `:,(car source)))
         (symbol (dhc-search-symtable (car source) global-table))
         (func-type (if symbol 
                        (==> :symbol:type copy)
                      (dhc-desc-to-type (dhinfo-t dhfunc))))
         (func-temps (unode-val :func-type:u-temps))
         (return-type (unode-val :func-type:u-type))
         (func-arg (unode-val :func-type:u-extra))
         (tnl (all ((so (cdr source))) 
                (dhc-parse-expr-t so)))
         (calling-types (all ((tynl tnl)) 
                          :tynl:type))
         (return-node ()))
    (if (<> (length tnl) (length func-arg))
        (dhc-error (sprintf "bad number of arguments: %l" source)))
    (each ((ty func-arg)
           (da calling-types))    
      (dhc-unify-types ty da))
    (dhc-unify-all-dh calling-types func-temps return-type)
    (setq tnl (cons (new t-node () func-type (car source)) tnl))
    (setq return-node (new t-node tnl return-type))
    (setq :return-node:transfer 
          (all ((ty func-temps))
            (let ((sym (new dhc-symbol 
                            (named (sprintf "%d_%s" 
                                            (dhc-postincr tmpnames-seed)
                                            (nameof (car source))))
                            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))
    return-node) )

(de dhc-compose-prototype(functype cname)
  (let ((output ())
        (args (dhu-extra functype))
        (tmps (dhu-temps functype)) )
    ;; check externs
    (each ((arg (append args tmps)))
      (when (==> arg is-an-objptr)
        (setq arg (dhu-type arg)) )
      (when (==> arg is-an-obj)
        (setq arg (dhu-type arg))
        (when (dhu-class arg)
          (dhc-add-c-externs (sprintf "struct CClass_%s;" (dhu-name arg))) ) ) )
    ;; build arg type list
    (setq output
          (append
           (all ((arg args)) ;; arguments
             (dhc-type-to-c-decl arg) )
           (all ((arg tmps)) ;; temporaries
             (when (not (==> arg is-a-ptr))
               (setq arg (new dhc-type 'dht-ptr arg)) )
             (dhc-type-to-c-decl arg) ) ) )
    ;; build declaration
    (apply concat
           (append (list (dhc-type-to-c-decl (dhu-type functype)))
                   (list " " cname " ( " )
                   (list (dhc-insert-op output ", "))
                   (list " )") ) ) ) )

(de dhc-parse-dh-c(source treetype retplace)
  (when (not (symbolp (car source)))
    (dhc-error "Unsupported call to unnamed function" (car source)) )
  (let ((symbol (dhc-search-symtable (car source) global-table)))
    (let (((cfunc mfunc ctest mtest kfunc) 
           (if ~symbol 
               (dhinfo-c (eval `:,(car source)))
             (list (sprintf "C_%s" :symbol:c-name) "" "" ""
                   (sprintf "K_%s_R%s" :symbol:c-name 
                            (dhu-hash :symbol:type) ) ) ) )
          (args (all ((so (cdr source)) 
                      (tt (cdr :treetype:tn-list)))
                  (dhc-parse-expr-c so tt ()))) )
      ;; Cast object types
      (let ((functype :(car :treetype:tn-list):type))
        (setq args
              (all ((arg args)
                    (argtype (dhu-extra functype))
                    (argnode (cdr :treetype:tn-list)) )
                (if (or (==> argtype is-an-objptr) (==> argtype is-a-gptr))
                    (dhc-ptr-cast arg argtype :argnode:type) 
                  arg  ) ) ) )
      ;; Update extern declaration and dependencies
      (let ((ftype :(car :treetype:tn-list):type))
        (when (and ~symbol (= mfunc ""))
          (dhc-add-c-externs
           (concat "extern_c " (dhc-compose-prototype ftype cfunc) ";") )
          (dhc-add-c-depends kfunc)
          (dhc-add-c-metaexterns (sprintf "extern_c dhdoc_t %s;" kfunc)) )
        (when (and ~symbol (<> ctest "") (= mtest ""))
          (dhc-add-c-externs
           (concat "extern_c " (dhc-compose-prototype ftype ctest) ";") ) ) )
      ;; Prepare args
      (setq args (dhc-insert-op 
                  (append args (all ((sym :treetype:transfer)) 
                                 :sym:c-name))
                  ", "))
      (when (<> ctest "")
        (dhc-add-c-statements 
         (concat (if (<> mtest "") mtest ctest) 
                 "(" args ");")) )
      ;; avoid returning inline because of side effects
      (if (<> mfunc "")
          (error 'dhc-parse-dh-c
                 "Macro based DH functions are no longer supported"
                 symbol )
        ;; unless ignored, a c function needs a retplace
        (when ~:treetype:ignore
          (when ~retplace
            (setq retplace (dhc-declare-temp-var :treetype:type)))
          (setq cfunc (sprintf "%s = (%s) %s"
                               retplace
                               (dhc-type-to-c-decl :treetype:type)
                               cfunc)))
        ;; add-c the c function and return retplace
        (dhc-add-c-statements (concat cfunc "(" args ");"))
        retplace ) ) ) ) 


