path: root/gcc/melt/warmelt-first.melt

;; -*- Lisp -*-
;; file warmelt-first.melt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(comment "***
    Copyright 2008, 2009 Free Software Foundation, Inc.
    Contributed by Basile Starynkevitch <basile@starynkevitch.net>

    This file is part of GCC.

    GCC 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 3, or (at your option)
    any later version.

    GCC 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 GCC; see the file COPYING3.  If not see
    <http://www.gnu.org/licenses/>.
***")

;; the copyright notice above apply both to warmelt-first.melt and 
;; to the generated file  warmelt-first*.c

;;    This file is the first part of a bootstrapping compiler for the
;;    MELT lisp dialect, compiler which should be able to
;;    compile itself (into generated C file[s])
;;    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;****************************************************************
;;       C L A S S E S 
;;****************************************************************

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ================ general classes

;; root class
(defclass class_root 
  :predef CLASS_ROOT
  :doc #{The $CLASS_ROOT is the topmost root of all classes. Every class
should be some indirect subclass of $CLASS_ROOT. And $CLASS_ROOT
should be the only class without superclass.}# )

;; class of everything with a property table
(defclass class_proped 
  :super class_root 
  :fields (prop_table)
  :predef CLASS_PROPED
  :doc #{The $CLASS_PROPED is the common super-class for objects with a
property table $PROP_TABLE (an object map associating property naming
symbols to arbitrary value.}# )


;; arbitrary container as class
(defclass class_container
  :super class_root
  :predef CLASS_CONTAINER
  :fields (container_value)
  :doc #{The $CLASS_CONTAINER is a class for mutable containers (that is
references). The contained value is $CONTAINER_VALUE.}#)

;; class of named objects
(defclass class_named 
  :super class_proped 
  :fields (named_name) 
  :predef CLASS_NAMED
  :doc #{The $CLASS_NAMED is the super-class of every named object. The
$NAMED_NAME field is conventionally a string.}# )

;; class of discriminants
(defclass class_discriminant 
  :super class_named 
  :fields (disc_methodict 
	   disc_sender
	   disc_super)
  :predef CLASS_DISCRIMINANT
  :doc #{The $CLASS_DISCRIMINANT is the class of every discriminant. It has the
method dictionnary $DISC_METHODICT and the super-discriminant
$DISC_SUPER. The $DISC_SENDER can hold a closure doing the send if the
selector is not found. Otherwise, the default is to send thru the
super-discriminant.}# )

;; class of classes
(defclass class_class
  :super class_discriminant
  :fields (class_ancestors class_fields class_data)
  :doc #{The $CLASS_CLASS is the class of all classes - which are
therefore discriminants.  The $CLASS_ANCESTORS field holds the
sequence of ancestors. The $CLASS_FIELDS gives the sequence of
inherited and own fields. The $CLASS_DATA is for class
variables. Instances of $CLASS_CLASS are automagically created by the
$DEFCLASS macro.}#
  :predef CLASS_CLASS
)

;; class of fields
(defclass class_field
  ;; the fields' objnum is its offset
  :super class_named
  :fields (fld_ownclass fld_data)
  :doc #{The $CLASS_FIELD is the class of every field. Its objnum is its
offset. Its $FLD_OWNCLASS is the class owning that field. The
$FLD_DATA is for additional data. Instances of $CLASS_FIELD are
automagically created by the $DEFCLASS macro.}#
  :predef CLASS_FIELD)

;; class of primitive
(defclass class_primitive
  :super class_named
  :fields (prim_formals prim_type prim_expansion)
  :doc #{The $CLASS_PRIMITIVE is the class of descriptors of
primitives. The $PRIM_FORMALS field is the sequence of formal
arguments, the $PRIM_TYPE field is the type of the primitive, and its
expansion is described by $PRIM_EXPANSION. Instances of
$CLASS_PRIMITIVE are automagically created by the $DEFPRIMITIVE
macro.}#
  :predef CLASS_PRIMITIVE)

;; class of C iterators
(defclass class_citerator
  :super class_named
  :fields (citer_start_formals		;the formal start arguments
	   citer_state			;the symbol representing the iterator state
	   citer_body_formals 		;the formal body arguments
	   citer_expbefore		;expansion before body
	   citer_expafter		;expansion after body
	   )
  :doc #{The $CLASS_CITERATOR is the class describing c-iterators. The
formal start arguments are in the $CITER_START_FORMALS field, the
$CITER_STATE field gives the state symbol, the $CITER_BODY_FORMALS
gives the formal body arguments, and the before and after expansions
are $CITER_EXPBEFORE and $CITER_EXPAFTER. Instances of
$CLASS_CITERATOR are automagically created by the $DEFCITERATOR
macro.}#
  :predef CLASS_CITERATOR)

(defclass class_any_matcher
  :super class_named
  :fields (amatch_in		;the formal input arguments
	   amatch_matchbind		;the matched formal binding
	   amatch_out			;the formal output arguments
	   )
  :doc #{The $CLASS_ANY_MATCHER is the common super-class for matcher
descriptors. The $AMATCH_IN gives the formal input arguments, the
$AMATCH_MATCHBIND is the formal binding of the matched stuff, and
$AMATCH_OUT is the formal output arguments. Instances of sub-classes
of $CLASS_ANY_MATCHER are automagically created by macros like
$DEFCMATCHER and $DEFUNMATCHER.}# )

					; class of C matchers (in patterns)
(defclass class_cmatcher
  :super class_any_matcher
  :fields (
	   cmatch_state			;the symbol representing the match state
	   cmatch_exptest		;expansion for test expr [in patterns]
	   cmatch_expfill		;expansion for filling instr
					;[in patterns]
	   cmatch_expoper		;expansion for operator use
					;[in expressions] using outs
	   )
  :doc #{The $CLASS_CMATCHER is the class for c-matcher
descriptors. $CMATCH_STATE is the state symbol, $CMATCH_EXPTEST gives
the expansion for testing in patterns, $CMATCH_EXPFILL is the
expansion for filling a matched pattern. $CMATCH_EXPOPER is the
expansion for operator uses. Instances of $CLASS_CMATCHER are
automagically created by the $DEFCMATCHER macro.}#
  :predef CLASS_CMATCHER)

					; class of function matcher (in patterns)
(defclass class_funmatcher
  :super class_any_matcher
  :fields (
	   fmatch_matchf		;matching function
	   ;; first argument to matching function is the funmatcher.
	   ;; second argument is the stuff to match next arguments are input
	   ;; primary result is non-nil iff the match succeeded. secondary results
	   ;; are the deconstructed stuff
	   fmatch_applyf		;applying function
	   ;; first argument to applying function is the funmatcher.
	   ;; next arguments are from the expression
	   fmatch_data			;client data
	   )
  :doc #{The $CLASS_FUNMATCHER describes fun-matchers. $FMATCH_MATCHF is
the matching function -for patterns. $FMATCH_APPLYF is the applying
function -for expressions. $FMATCH_DATA is some additional client
data. Instances of $CLASS_FUNMATCHER are automagically created by the
$DEFUNMATCHER macro.}#
  :predef CLASS_FUNMATCHER
  )

;; class of located stuff
(defclass class_located
  :super class_proped
  :fields (loca_location)
  :doc #{The $CLASS_LOCATED is the super-class for located stuff,
  having a source file location given by the $LOCA_LOCATION field,
  conventionally a mixed location box with $DISCR_MIXED_LOCATION.}#
  :predef CLASS_LOCATED)

;; class of source expressions
(defclass class_sexpr
  :predef CLASS_SEXPR
  :super class_located
  :fields (sexp_contents		;list of contents
	   )
  :doc #{The $CLASS_SEXPR is the class of source expressions, as
parsed by the reader before their macro expansion into abstract syntax
tree [see $CLASS_SOURCE]. The $SEXP_CONTENTS field is a list of
contents.}# )

;; class of message selectors
(defclass class_selector
  :super class_named
  :fields (sel_signature sel_data)
  :doc #{The $CLASS_SELECTOR is the class of message selectors, created by
the $DEFSELECTOR macro. The $SEL_SIGNATURE could give a signature (as
a formal argument list) and the $SEL_DATA is for additional data.}#
  :predef CLASS_SELECTOR)


;; class of symbols
(defclass class_symbol
  :predef CLASS_SYMBOL
  :super class_named
  :doc #{The $CLASS_SYMBOL is the class of symbols. The $SYMB_DATA is
  a field for some additional data. The reader may create instances of
  $CLASS_SYMBOL when encoutering new symbols. Symbols are interned
  inside the $INITIAL_SYSTEM_DATA.}#
  :fields (symb_data))

;; class of generated (ie cloned) symbols - like lisp gensym-ed
(defclass class_cloned_symbol
  :super class_symbol
  :fields (csym_urank			;unique rank as a boxed integer
	   )
  :doc #{The $CLASS_CLONED_SYMBOL is the sub-class of cloned symbols,
e.g. like GENSYM-ed symbols is many Lisps.  Cloned symbols are
internally generated inside the MELT translator by the $CLONE_SYMBOL
function. Their $CSYM_URANK field gives their unique rank as a boxed
integer. Cloned symbols are not interned.}#)

;; class of keyword symbols
(defclass class_keyword
  :predef CLASS_KEYWORD
  :super class_symbol
  :doc #{The $CLASS_KEYWORD is the sub-class of keywords, that is
symbols starting with a colon, which are handled specially and
implicitly quoted. Most ctypes are denoted by such keywords
like @code{:long :value} etc. The reader parses as keyword any symbol
starting with a colon. Keywords are interned inside the
$INITIAL_SYSTEM_DATA.}#
  :fields ())

;; class of C types keywords - it is predefined to ensure
;; install_ctype_descr always refer to the same class
(defclass class_ctype
  :predef CLASS_CTYPE
  :super class_named
  :fields (
	   ctype_keyword ;the keyword associated to the ctype (e.g. :long)
	   ctype_cname	 ;the name for C of the type (eg long)
	   ctype_parchar ;the name of the melt parameter char (eg BPAR_LONG)
	   ctype_parstring ;the name of the melt parameter string (eg BPARSTR_LONG)
	   ctype_argfield ;the name of the melt argument union field (eg bp_long)
	   ctype_resfield ;the name of the melt result union field (eg bp_longptr)
	   ctype_marker	  ;the name of the marker routine
	   ctype_descr	  ;descriptive string
	   ctype_altkeyword ;the alternate keyword associated to the ctype (e.g. :longinteger)
	   )
  :doc #{The $CLASS_CTYPE is for predefined descriptors of C
types (like long or tree). $CTYPE_KEYWORD gives the associated
keywords (for formal argument lists, etc...), $CTYPE_CNAME gives the C
identifier of the type. Parameter passing is described by
$CTYPE_PARCHAR (for the character) and $CTYPE_PARSTRING (for the
corresponding C string). Argument member in union is given by
$CTYPE_ARGFIELD, and by $CTYPE_RESFIELD for results.  The marking
routine is $CTYPE_MARKER and $CTYPE_DESCR is some descriptive string
or data. A possible alternate keyword is given by $CTYPE_ALTKEYWORD.
 Adding new c-types requires an update of MELT runtime!}# )


;; class of system data -- be careful to keep the FSYSDAT_*
;; identifiers from melt-runtime.h in sync!
(defclass class_system_data
  :predef CLASS_SYSTEM_DATA
  :super class_named
  :doc #{The $CLASS_SYSTEM_DATA has a singleton instance, the
$INITIAL_SYSTEM_DATA. It contains lots of fields, starting by
SYSDATA_, for various system facilities.  It is very magical, and
should be kept in sync with the MELT runtime.  Only for gurus! So
don't instanciate this class!}#
  :fields (sysdata_mode_dict			;stringmap for commands
	   sysdata_cont_fresh_env			;closure to make a fresh environment
	   sysdata_value_exporter		;closure to export a value
	   sysdata_macro_exporter		;closure to export a macro
	   sysdata_symboldict 		; stringmap for symbols
	   sysdata_keywdict 			;stringmap for keywords
	   sysdata_addsymbol 		;closure to add a symbol of given name
	   sysdata_addkeyw		;closure to add a keyword of given name
	   sysdata_internsymbol		;closure to intern a symbol
	   sysdata_internkeyw		;closure to intern a keyword
	   sysdata_value_importer	;closure to import a value
	   sysdata_pass_dict		;stringmap for passes
	   sysdata_exit_finalizer       ;;closure to be called after the passes, at finalization
	   sysdata_meltattr_definer	;;closure to be called for melt attributes
	   sysdata_patmacro_exporter	;closure to export a patmacro
	   sysdata_debugmsg		;closure for debugmsg
	   sysdata_stdout		;raw file for stdout
	   sysdata_stderr		;raw file for stderr
	   sysdata_dumpfile		;raw file for dump_file
	   sysdata_unit_starter		;closure to be called at
					;compilation unit start
	   sysdata_unit_finisher	;closure to be called at
					;compilation unit end
	   ;;;keep these spare slots to ease the addition of other slots
	   sysdata___spare1
	   sysdata___spare2
	   sysdata___spare3
	   sysdata___spare4
	   ))


;; class for debug information (used for debug_msg & dbgout* stuff)
(defclass class_debug_information 
  :super class_root
  :fields (dbgi_out 			;the produced outbuf
	   dbgi_occmap ;the occurrence map (to avoid outputing twice the same object)
	   dbgi_maxdepth ;the boxed integer maximal depth
	   )
  :doc #{The $CLASS_DEBUG_INFORMATION is for debug information output,
e.g. $DEBUG_MSG macro.  The produced output or buffer is $DBGI_OUT,
the occurrence map is $DBGI_OCCMAP, used to avoid outputting twice the
same object. The boxed maximal depth is $DBGI_MAXDEPTH.}# )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ================ classes for environments & bindings

;;;; the class for environments - predefined to ensure all
;;;; environments have the same (super*)class
(defclass class_environment
  :predef CLASS_ENVIRONMENT
  :super class_root
  :doc #{The $CLASS_ENVIRONMENT reifies environments. The binding map
is $ENV_BIND, the previous environment is $ENV_PREV, and the procedure
if any of this environment is $ENV_PROC. It is heavily used within the
MELT translator. Module initialization produces fresh instances of
it. See the $CURRENT_MODULE_ENVIRONMENT_CONTAINER and
$PARENT_MODULE_ENVIRONMENT macros.}#
  :fields (env_bind			;the map of bindings
	   env_prev			;the previous environment
	   env_proc			;the procedure of this environment
	   ))

(defclass class_described_environment
  :super class_environment
  :fields (denv_descr
	   )
  :doc #{The $CLASS_DESCRIBED_ENVIRONMENT provides an extra descriptor
$DENV_DESCR which can for example be a descriptive string.}#)

;; the (super-)class of any binding
(defclass class_any_binding
  :super class_root
  :fields (binder)
  :doc #{The $CLASS_ANY_BINDING is the super-class of every
  binding. The $BINDER field is the bound name. Bindings are added by
  module initializers. Don't create bindings by instanciating this
  class in user code, they are created within the Melt translator.}# )

;;; superclass of exported bindings
(defclass class_exported_binding
  :super class_any_binding
  :fields ( )
  :doc #{The $CLASS_EXPORTED_BINDING is the super-class of exported bindings.}#
  )

;; macro binding
(defclass class_macro_binding
  :super class_exported_binding
  :fields (mbind_expanser)
  :doc #{The $CLASS_MACRO_BINDING is the class of exported macro
bindings. See the $EXPORT_MACRO macro.}# )

;; pattern macro binding
(defclass class_patmacro_binding
  :super class_macro_binding
  :fields (patbind_expanser)
  :doc #{The $CLASS_PATMACRO_BINDING is the class of exported
pattern-macro bindings. See the $EXPORT_PATMACRO macro.}# ) 

;; value binding - as exported 
(defclass class_value_binding
  :super class_exported_binding
  :fields (vbind_value)
  :doc #{The $CLASS_PATMACRO_BINDING is the class of exported value bindings.
See The $EXPORT_VALUES macro.}#
)

					; formal binding (used in generated defprimitive)
(defclass class_formal_binding
  :super class_any_binding
  :fields (fbind_type)
  ;;the obj_num is the argument rank
  :predef CLASS_FORMAL_BINDING
  :doc #{The $CLASS_FORMAL_BINDING is the class of formal argument
bindings [like in @code{defun lambda defprimitive defciterator}
etc..]. The $FBIND_TYPE gives the formal's c-type.}# )


;;; fixed bindings are defined in a compilation unit and can be
;;; implemented as constants in routine
(defclass class_fixed_binding
  :super class_any_binding
  :fields (fixbind_data			;the common slot describing data
	   )
  :doc #{The internal $CLASS_FIXED_BINDING is a super-class of bindings
  inside a compilation unit. The data description is inside
  $FIXBIND_DATA. Fixed bindings are internal to the translator.}#)


;; selector binding
(defclass class_selector_binding
  :super class_fixed_binding
  :fields (sbind_selectordef 		;the "source" defselector
	   ;; maybe we need an selectorval for the actual value
	   )
  :doc #{The internal $CLASS_SELECTOR_BINDING is a fixed binding for
  selectors. See $DEFSELECTOR macro. The $SBIND_SELECTORDEF gives the
  definition.}# )

;; primitive binding
(defclass class_primitive_binding
  :super class_fixed_binding
  :fields (pbind_primdef		;the source defprimitive
	   pbind_primitive		;the primitive proper
	   )
  :doc #{The internal $CLASS_PRIMITIVE_BINDING is for primitive
bindings. See $DEFPRIMITIVE macro. The $PBIND_PRIMDEF gives the
definition, and the $PBIND_PRIMITIVE gives the primitive itself.}# )

;; citerator binding
(defclass class_citerator_binding
  :super class_fixed_binding
  :fields (cbind_citerdef		;the source defciterator
	   cbind_citerator		;the citerator proper
	   )
  :doc #{The internal $CLASS_CITERATOR_BINDING is for c-iterator
  bindings. See the $DEFCITERATOR macro. The $CBIND_CITERDEF gives the
  definition, and the $CBIND_CITERATOR provides the c-iterator itself.}#
)


;; function binding
(defclass class_function_binding
  :super class_fixed_binding
  :fields (fubind_defun ;the source definition
	   )
  :doc #{The internal $CLASS_FUNCTION_BINDING is for function
bindings. See the $DEFUN macro. The $FUBIND_DEFUN provides the
definition.}# 
)

;; class binding
(defclass class_class_binding
  :super class_fixed_binding
  :fields (cbind_defclass ;the source definition
	   cbind_class			;the built class
	   )
  :doc #{The internal $CLASS_CLASS_BINDING is for class bindings. See
the $DEFCLASS macro. The definition is provided by $CBIND_DEFCLASS,
and the class itself is given by $CBIND_CLASS. A class definition also
define fields.}#  )

;; field binding
(defclass class_field_binding
  :super class_fixed_binding
  :fields (flbind_clabind		;the class binding
	   flbind_field			;the field proper
	   )
  :doc #{The internal $CLASS_FIELD_BINDING is for field bindings. See
the $DEFCLASS macro. The class binding is $FLBIND_CLABIND, and the
defined field is $FLBIND_FIELD.}# )

;; instance binding
(defclass class_instance_binding
  :super class_fixed_binding
  :fields ( ibind_iclass		;the instance's class
	    )
  :doc #{The internal $CLASS_INSTANCE_BINDING is for instance
bindings. See the $DEFINSTANCE macro. The instance's class is in
$IBIND_ICLASS.}#  )

;; cmatcher binding
(defclass class_cmatcher_binding
  :super class_fixed_binding
  :fields (cmbind_matcher		;the cmatcher
	   )
  :doc #{The internal $CLASS_CMATCHER_BINDING is for c-matcher
bindings. See the $DEFCMATCHER macro. The c-matcher is in
$CMBIND_MATCHER.}# )


;; funmatcher binding
(defclass class_funmatcher_binding
  :super class_fixed_binding
  :fields (fmbind_funmatcher		;the funmatcher (of class_funmatcher)
	   fmbind_defunmatcher		;the source definition
	   )
  :doc #{The internal $CLASS_FUNMATCHER_BINDING is for funmatcher
bindings. See the $DEFUNMATCHER macro. The funmatcher is in
$FMBIND_FUNMATCHER and its definition in $FMBIND_DEFUNMATCHER.}#)

;; let binding
(defclass class_let_binding
  :super class_any_binding
  :fields (letbind_type			;the ctype 
	   letbind_expr			;the expression
	   letbind_loc			;the optional src location
	   )
  :doc #{The internal $CLASS_LET_BINDING is for internal let
  bindings. See The $LET macro and also the
  $CLASS_NORMAL_LET_BINDING. The c-type of the bound valus is
  $LETBIND_TYPE, the expression is $LETNIND_EXPR, the source location
  if any is $LEBIND_LOC.}# )

;; normalized let binding
(defclass class_normal_let_binding
  :super class_let_binding
  :fields  ()
  :doc #{The internal $CLASS_NORMAL_LET_BINDING is for internal
normalized bindings. The bound expression is in normal form. Very
often the $BINDER is a cloned symbol.}# 
) ;no additional field, but letbind_expr is "normal"

;; label binding
(defclass class_label_binding
  :super class_any_binding
  :fields (labind_loc			;location of the label
;;; following fields are filled later in the compilation phase
	   labind_clonsy		;unique cloned symbol
	   labind_res			;result localvar
	   )
  :doc #{The internal $CLASS_LABEL_BINDING is for labels. See The
$FOREVER and $EXIT macros. The label source location is $LABIND_LOC,
the cloned symbol unique to the label is $LABIND_CLONSY. The local
variables for the result is $LABIND_RES.}# )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ================ GCC compiler passes
(defclass class_gcc_pass
  :predef CLASS_GCC_PASS
  :super class_named
  ;; keep the fields list in sync with melt-runtime.h FGCCPASS_*
  :fields (gccpass_gate			;closure for gate
	   gccpass_exec			;closure for execution
	   gccpass_data			;extra data
	   ;;;; the following fields are mimicking their equivalent in
	   ;;;; struct opt_pass of gcc/tree-pass.h
	   ;;;;;; if it is a boxed integer, get the integer
	   ;;;;;; if it is a string or a named, translate it
	   ;;;;;; if it is a list or a tuple, make an OR mask of them
	   gccpass_properties_required 
	   gccpass_properties_provided
	   gccpass_properties_destroyed
	   gccpass_todo_flags_start
	   gccpass_todo_flags_finish
	   )
  :doc #{ The $CLASS_GCC_PASS is the super-class of GCC compiler
passes descriptors, as provided in MELT. Once correctly instanciated,
such a pass descriptor should be registered thru the
$INSTALL_MELT_GCC_PASS primitive. Pass descriptors are named (be
careful to give a unique unused name!). The $GCCPASS_GATE is the pass
gate function. The $GCCPASS_EXEC is the pass execution function. The
field $GCCPASS_DATA can be used for client data. The fields
$GCCPASS_PROPERTIES_REQUIRED $GCCPASS_PROPERTIES_PROVIDED
$GCCPASS_PROPERTIES_DESTROYED $GCCPASS_TODO_FLAGS_START
$GCCPASS_TODO_FLAGS_FINISH are like their counterparts in C, and can
be a boxed integer, a string or named [i.e. symbol], or a tuple or
list of them.}# )

(defclass class_gcc_gimple_pass
  :predef CLASS_GCC_GIMPLE_PASS
  :super class_gcc_pass
  :fields ( )
  :doc #{ The $CLASS_GCC_GIMPLE_PASS is for GCC gimple pass descriptors. }# 
)

(defclass class_gcc_rtl_pass
  :predef CLASS_GCC_RTL_PASS
  :super class_gcc_pass
  :fields ( )
  :doc #{ The $CLASS_GCC_RTL_PASS is for GCC RTL pass descriptors. }# 
  
)

(defclass class_gcc_simple_ipa_pass
  :predef CLASS_GCC_SIMPLE_IPA_PASS
  :super class_gcc_pass
  :fields ( )
  :doc #{ The $CLASS_GCC_SIMPLE_IPA_PASS is for GCC simple IPA pass
descriptors. }# )


;;;; mode 
(defclass class_melt_mode
  :super class_named
  :predef CLASS_MELT_MODE
  :fields (meltmode_help
	   meltmode_fun
	   meltmode_data
	   )
  :doc #{ The $CLASS_MELT_MODE describe mode handlers, as given by the
@code{-fmelt=} or @code{-fplugin-arg-melt-mode=} GCC program flag. The
$MELTMODE_HELP is a help string. The $MELTMODE_FUN is the function to
run the command, and the $MELTMODE_DATA gives additional client
data. See the $INSTALL_MELT_MODE function. }# )
	   
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ================  source program elements

;; common superclass of source abstract syntax tree elements
(defclass class_source 
  :super class_located
  :fields ( 
	  )
  :doc #{The $CLASS_SOURCE is the common super-class of source elements,
i.e. of abstract syntax tree elements after macro-expansion. Its
subclasses are produced by macro expanders.}# )




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; module compilation context
(defclass class_module_context
  :super class_root
  :fields (mocx_modulename		;the module name
	   mocx_expfieldict		;dict of exported fields
	   mocx_expclassdict		;dict of exported classes
	   mocx_initialenv		;the initial environment
	   )
  :doc #{The internal $CLASS_MODULE_CONTEXT describes the whole module
context of a translation. $MOCX_MODULENAME gives the module name,
$MOCX_EXPFIELDICT gives the dictionnary of exported fields,
$MOCX_EXPCLASSDICT gives the dictionnary of exported classes, and
$MOCX_INITIALENV the initial environment. For gurus!}# )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; normalization context
(defclass class_normalization_context
  :super class_root
  :fields (nctx_initproc		;initial procedure
	   nctx_proclist		;list of procedures
	   nctx_datalist		;list of data
	   nctx_valuelist		;list of imported values
	   nctx_symbmap			;stringmap of name to interned symbols
	   nctx_keywmap			;stringmap of name to interned keywords
	   nctx_symbcachemap		;objmap of cached symbol -> occurrence
	   nctx_predefmap		;objmap of predef -> boxedrank or symbols
	   nctx_valmap			;objmap of values -> data 
	   nctx_valbindmap 		;objmap of value binding -> data
	   nctx_curproc			;current procedure
	   nctx_modulcontext		;the module compilation context
	   nctx_qdatcurmodenvbox ;quasi data for current_module_environment_container
	   nctx_qdatparmodenv		;quasi data for parent_module_environment
	   nctx_procurmodenvlist	;list of procedures using the current_module_environment_container construct
	   )
  :doc #{The internal $CLASS_NORMALIZATION_CONTEXT (for gurus only) is used for
expression normalization by the translator. $NCTX_INITPROC gives the
initial procedure. $NCTX_PROCLIST is the list of
procedures. $NCTX_DATALIST is the list of data. $NCTX_VALUELIST gives
the list of imported values. $NCTX_SYMBMAP and $NCTX_KEYWMAP are
dictionnaries mapping symbol or keyword names to interned symbols or
keywords. $NCTX_SYMBCACHEMAP is an object map to cache the occurrence
of symbols. $NCTX_PREDEFMAP is a map from predefined to
ranks. $NCTX_VALMAP is an object map from value to data, and
$NCTX_VALBINDMAP is an object map from value binding to data. The
Current procedure is $NCTX_CURPROC. The module compilation context is
$NCTX_MODULCONTEXT. The quasidata for the current module environment
container is $NCTX_QDATCURMODENVBOX. The quasi data for the parent
module's environment is $NCTX_QDATPARMODENV. The list of procedures
using the current module environment is in $NCTX_PROCURMODENVLIST.}# )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ================ classes for code generation


;;; code generation context
(defclass class_c_generation_context
  :super class_root
  :fields ( gncx_objrout 		;the containing object routine
	    gncx_locmap			;objmap from normal bindings to locals
	    gncx_freeptrlist		;list of freed local pointers
	    gncx_freelonglist		;list of freed local longs
	    gncx_freeothermaps		;map keyed by ctypes of list of freed local others
	    gncx_retloc			;return location
	    gncx_compicache		;cache map of procedure to compiled routines
	    gncx_modulcontext		;the module compilation context
	    gncx_matchmap		;map keyed by normal matchers
					;giving a unique label prefix
	    )
  :doc #{The internal $CLASS_C_GENERATION_CONTEXT (for gurus) is the class of
contexts for C code generation, while generating a single C
routine. The containing object routine is $GNCX_OBJROUT. The object
map from normal bindings to local is given in $GNCX_LOCMAP. The list
of freed local value pointers is in $GNCX_FREEPTRLIST. The list of
free longs is in $GNCX_FREELONGLIST. For other c-types, each c-type
has its list, associated to it in $GNCX_FREEOTHERMAPS. The return
location is in $GNCX_RETLOC. The cached map of procedures to compiled
routines is in $GNCX_COMPICACHE. The module compilation context is in
$GNCX_MODULCONTEXT. A map keyed by normal matchers to give a unique
label prefix is in $GNCX_MATCHMAP.}# )


;; code generation context for initial routine
(defclass class_initial_generation_context
  :super class_c_generation_context
  :fields (igncx_prevenvloc	    ;local for previous environment [parent_module_environment]
	   igncx_contenvloc	    ;local for the container of environment
	   igncx_procurmodenvlist   ;list of routines using the current_module_environment_container
	   igncx_importmap	    ;mapping of imported symbols to locvars
	   )
  :doc #{The internal $CLASS_INITIAL_GENERATION_CONTEXT (for gurus) is used when
generating the initial routine of a module, which builds the current
environment and evaluates the module toplevel expressions. The
$IGNCX_PREVENVLOC is the local for the parent environment. The
$IGNCX_CONTENVLOC is the local for the container of the current
module's environment. The list of routines using it is in
$IGNCX_PROCURMODENVLIST. The mapping of imported symbolts to locals is
$IGNCX_IMPORTMAP.}# )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; common superclass for objcode
(defclass class_generated_c_code
  :super class_root
  :fields (
	   )
  :doc #{The super-class $CLASS_GENERATED_C_CODE is a common
super-class for representing generated C abstract syntax trees inside
the MELT translator. Within MELT, it has nothing in common with GCC
compiled C abstract syntax trees (that is @code{:tree} and
@code{:gimple}).}#)


;; 

;;****************************************************************
;;       P R I M I T I V E S 
;;****************************************************************

;; primitive to ignore a value
(defprimitive ignore (v) :void
  :doc #{Ignore the value passed as argument. Useful to avoid translation warnings, or to force the type of a conditional. See $CTYPE_VOID.}#
  #{/*ignore*/(void)($v)}#)  

;; primitive to return a void
(defprimitive void () :void 
  :doc #{Return a void value. See $IGNORE and $CTYPE_VOID.}#
#{/*void*/0}#)

;; primitive for converting a string constant into a string value
(defprimitive stringconst2val (discr :cstring strc) :value
  :doc #{Convert a C-string constant $STRC into a string value of discriminant $DISCR. See also $QUOTE macro applied to a string.}#
  #{meltgc_new_string((meltobject_ptr_t)($discr), ($strc))}#)


;; primitive for testing if an object is a (sub) instance of a class
(defprimitive is_a (obj cla) :long
  :doc #{Test if $OBJ is an instance of the $CLA class [or a
 subclass]. Return 0 otherwise, e.g. when $OBJ is not an object. See
 also $IS_NOT_A.}#
 #{melt_is_instance_of((melt_ptr_t)($obj), (melt_ptr_t)($cla))}#)

;; primitive for testing if an object is NOT a (sub) instance of a class
(defprimitive is_not_a (obj cla) :long
  :doc #{Test if $OBJ is @emph{not} an instance of the $CLA class [or a
 subclass]. Negation of $IS_A.}#
 #{!melt_is_instance_of((melt_ptr_t)($obj), (melt_ptr_t)($cla))}#)

;; primitive for testing objectness
(defprimitive is_object (obj) :long
  :doc #{Test if $OBJ is indeed an object. See also $IS_NOT_OBJECT.}#
  #{(melt_magic_discr((melt_ptr_t)($obj)) == OBMAG_OBJECT)}#)

(defprimitive is_not_object (obj) :long
  :doc #{Test if $OBJ is not an object. Negation of $IS_OBJECT.}#
  #{(melt_magic_discr((melt_ptr_t)($obj)) != OBMAG_OBJECT)}#)


;; primitive to safely return a global predef by its index
(defprimitive get_globpredef (:long ix) :value
  :doc #{Safely gives the predefined of index $IX or null.}#
  #{(melt_globpredef($ix))}#)

;; primitive to get the discriminant of a value
(defprimitive discrim (v) :value
  :doc #{Safely gives the discriminant of a value (even if it is null).}#
  #{(melt_discr((melt_ptr_t)($v)))}#)

;; primitive to get the integer inside a boxed or mixed integer or objnum
(defprimitive get_int (v) :long
  :doc #{Safely gets the integer number inside $V, a boxed or mixed
  integer, or an object.}#
  #{(melt_get_int((melt_ptr_t)($v)))}#)
;; primitive to put the integer inside a boxed or mixed integer or objnum
(defprimitive put_int (v :long i) :void
  :doc #{Safely puts the integer number $I inside $V, a boxed or mixed
  integer, or an object.}#
  #{melt_put_int((melt_ptr_t)($v), ($i))}#)

;; primitive to get the hashcode of an object (or 0)
(defprimitive obj_hash (v) :long
  :doc #{Safely gives the hashcode of object $V or else 0.}#
  #{(melt_obj_hash((melt_ptr_t)($v)))}#)
;; primitive to get the length of an object (or 0)
(defprimitive obj_len (v) :long
  :doc #{Safely gives the length of object $V or else 0.}#
  #{(melt_obj_len((melt_ptr_t)($v)))}#)
;; primitive to get the number of an object (or 0)
(defprimitive obj_num (v) :long
  :doc #{Safely gives the number of object $V or else 0.}#
  #{(melt_obj_num((melt_ptr_t)($v)))}#)
;; primitive to get the serial of an object (or 0 when ENABLE_CHECKING is not set)
(defprimitive obj_serial (v):long
  :doc #{Safely gives the serial when ENABLE_CHECKING of object $V or else 0.}#
  #{(melt_obj_serial((melt_ptr_t)($v)))}#)

;; primitive to compute a nonzero hash
(defprimitive nonzero_hash () :long
  :doc #{Gives a pseudo-random non-zero number suitable as an hash code.}# 
  "(melt_nonzerohash())")

;; primitive for identity and non-identity test
(defprimitive == (a b) :long 
  :doc #{Test identity of values $A and $B.}#
  #{(($a) == ($b))}#)
(defprimitive != (a b) :long 
  :doc #{Test that values $A and $B are not identical.}#
  #{(($a) != ($b))}#)


;;; the call counter - do not redefine the name, it is used by expansion of debug_msg macro!
(defprimitive the_callcount () :long "callcount")
;;; the current frame depth
(defprimitive the_framedepth () :long "(melt_curframdepth())")

;;; the timestamp of compilation & md5 checksum of the generated C file
(defprimitive out_cplugin_compiled_timestamp_err () :void "melt_puts(stderr,melt_compiled_timestamp)")
(defprimitive out_cplugin_md5_checksum_err () :void "melt_puts(stderr,melt_md5)")

;; primitive to force garbage collection
(defprimitive minor_garbcoll (:long siz) :void 
  :doc #{Force a minor MELT garbage collection. The $SIZ is the amount
  of memory to reserve.}#
  #{melt_garbcoll(($siz), MELT_MINOR_OR_FULL)}#)

(defprimitive full_garbcoll (:long siz) :void
  :doc #{Force a full MELT garbage collection. The $SIZ is the amount
  of memory to reserve.}#
  #{melt_garbcoll(($siz), MELT_NEED_FULL)}#)

;; primitive to get or create a symbol from a string value
(defprimitive get_symbolstr (strv) :value
  :doc #{Get an existing symbol of given string value $STRV or null if not found.}#
  #{meltgc_named_symbol( melt_string_str((melt_ptr_t)($strv)), MELT_GET)}#)
(defprimitive create_symbolstr (strv) :value
  :doc #{Retrieve an existing symbol of given string value $STRV or
create it if not found.}# 
  #{meltgc_named_symbol(melt_string_str((melt_ptr_t)($strv)), MELT_CREATE)}#)

;; primitive to get or create a keyword from a string value
(defprimitive get_keywordstr (strv) :value
  :doc #{Get an existing keyword of given string value $STRV or null if not found.}#
  #{meltgc_named_keyword( melt_string_str((melt_ptr_t)($strv)), MELT_GET)}#)
(defprimitive create_keywordstr (strv) :value
  :doc #{Retrieve an existing keyword of given string value $STRV or
create it if not found.}# 
  #{meltgc_named_keyword( melt_string_str((melt_ptr_t)($strv)), MELT_CREATE)}#)


;; runtime assertion with message called by expansion of assert_msg
;;; @@ UGLY HACK TO ALWAYS HAVE A filename
(defprimitive assert_failed (:cstring msg :cstring filename :long lineno) :void
  :doc #{Internally used by $ASSERT_MSG macro. Runtime assert failed with message $MSG in file $FILENAME at line $LINENO.}#
  #{melt_assert_failed(($msg),($filename)?($filename):__FILE__,
  ($lineno)?($lineno):__LINE__, __FUNCTION__);
}#)

;; check explicitly the call stack  
(defprimitive checkcallstack_msg (:cstring msg) :void
  :doc #{Low level costly primitive to check the entire call stack to
help hunt memory or GC bugs. Displays the given $MSG if the check went
wrong. Use it when desperate.}#
  #{melt_check_call_frames(MELT_ANYWHERE, $msg);}#)

;; for breakpoint
(defprimitive cbreak_msg (:cstring msg) :void
  :doc #{Low level primitive for GDB breakpoints. Use it temporarily,
given a string $MSG, with gdb when desperate.}#
  #{melt_cbreak($msg)}#)

;;; less, lessorequal, greater, greaterorequal, equal, different number 
(defprimitive <i (:long a b) :long :doc #{Integer test that $A less than $B.}#
  #{(($a) < ($b))}#)
(defprimitive <=i (:long a b) :long :doc #{Integer test that $A less or equal to $B.}#
  #{(($a) <= ($b))}#)
(defprimitive ==i (:long a b) :long  :doc #{Integer test that $A is equal to $B.}#
  #{(($a) == ($b))}#)
(defprimitive >i (:long a b) :long  :doc #{Integer test that $A greater than $B.}# 
  #{(($a) > ($b))}#)
(defprimitive >=i (:long a b) :long :doc #{Integer test that $A greater or equal to $B.}#
  #{(($a) >= ($b))}#)
(defprimitive !=i (:long a b) :long  :doc #{Integer test that $A is unequal to $B.}#
  #{(($a) != ($b))}#)
;;; integer arithmetic
(defprimitive +i (:long a b) :long  :doc #{Integer binary addition of $a and $b.}#
  #{(($a) + ($b))}#)
(defprimitive -i (:long a b) :long  :doc #{Integer binary substraction of $a and $b.}#
  #{(($a) - ($b))}#)
(defprimitive *i (:long a b) :long  :doc #{Integer binary product of $a and $b.}#
  #{(($a) * ($b))}#)
(defprimitive andi (:long a b) :long   :doc #{Integer binary bitwise and of $a and $b.}#
  #{(($a) & ($b))}#)
(defprimitive ori (:long a b) :long  :doc #{Integer binary bitwise or of $a and $b.}#
  #{(($a) | ($b))}#)
(defprimitive xori (:long a b) :long :doc #{Integer binary bitwise exclusive-or of $a and $b.}#  
  #{(($a) ^ ($b))}#)
(defprimitive negi (:long i) :long  :doc #{Integer unary negation of $i.}#
  #{(-($i))}#)
(defprimitive noti (:long i) :long :doc #{Integer unary bitwise complement of $i.}# 
  #{(~($i))}#)

(defprimitive /i (:long a b) :long  :doc #{Integer binary division of $a and $b, robust to zero-divide.}#
  #{(melt_idiv(($a), ($b)))}#)
(defprimitive %i (:long a b) :long   :doc #{Integer binary modulus of $a and $b, robust to zero-divide.}#
  #{(melt_imod(($a), ($b)))}#)
(defprimitive /iraw (:long a b)  :long  :doc #{Integer raw division of $a and $b, crash on zero-divide.}# #{(($a) / ($b))}#)
(defprimitive %iraw (:long a b)  :long  :doc #{Integer raw modulus of $a and $b, crash on zero-divide.}##{(($a) % ($b))}#)
;; boolean not
(defprimitive not (:long i) :long  :doc #{Integer unary logical negation of $i.}#  #{(!($i))}#)

;;; citerator on integers
(defciterator foreach_long_upto
  (:long imin imax)			;start formals
  eachlong				;state
  (:long ix)				;local formals
  :doc #{The $FOREACH_LONG_UPTO c-iterator provides the usual
ascending integer iterator. Start formals are $IMIN, the minimum start
integer, and $IMAX, le maximal ending integer. Local formal is $IX,
the current index. The body is executed for each integer value $IX
from $IMIN to $IMAX included.}#
  					;before expansion
#{/*start $eachlong */
    long $eachlong#_min =  $imin;
    long $eachlong#_max = $imax;
    long $eachlong#_cur = 0;
    for ($eachlong#_cur = $eachlong#_min;
         $eachlong#_cur <= $eachlong#_max;
	 $eachlong#_cur ++) {
	    $ix = $eachlong#_cur	    
}#
 					;after expansion
   #{ } /*end eachlong */}#
)
   
;;; nullity test (for values)
(defprimitive null (v) :long :doc #{Test that $V is the null value.}#
  #{(($v) == NULL)}#)
(defprimitive notnull (v) :long :doc #{Test that $V is not the null value.}#
  #{(($v) != NULL)}#)
;;; zero test (for numbers)
(defprimitive zerop (:long i)  :long :doc #{Test that $I is zero.}# #{(($i) == OL)}#)
;; primitive for testing if debug
(defprimitive need_dbg (:long depth) :long :doc #{Test if debug messages are needed for the given $DEPTH.}#
  #{(flag_melt_debug && melt_dbgcounter>=melt_debugskipcount && ($depth)>=0 && ($depth) <= MELTDBG_MAXDEPTH)}#)

(defprimitive need_dbglim (:long depth limit) :long :doc #{Test if debug messages are needed for the given $DEPTH and $LIMIT.}#
  #{(flag_melt_debug && melt_dbgcounter>=melt_debugskipcount
		     && ($depth)>=0 && ($depth) < ($limit))}#)
;;; debug on dumpfile
(defprimitive outcstring_dbg (:cstring s) :void :doc #{output a debug string $S.}#
  #{melt_puts(dump_file,($s))}#)
(defprimitive outnum_dbg (:cstring pref :long l :cstring suf) :void
  :doc #{debug output an integer $L with prefix $PREF and suffix $SUF.}#
  #{melt_putnum(dump_file,($pref), ($l), ($suf))}#)
(defprimitive outstr_dbg (str) :void :doc #{output a debug string value $STR.}#
  #{melt_putstr(dump_file,(melt_ptr_t)($str))}#)
(defprimitive outstrbuf_dbg (sbuf) :void :doc #{output a debug stringbuffer value $SBUF.}#
  #{melt_putstrbuf(dump_file,(melt_ptr_t)($sbuf))}#)
(defprimitive outnewline_dbg () :void :doc #{output a debug newline.}#
  #{melt_newlineflush(dump_file)}#)
;;; output on stderr
(defprimitive outnum_err (:cstring pref :long l :cstring suf) :void
  :doc #{output on stderr the number $L with prefix $PREF and suffix $SUF.}#
  #{melt_putnum(stderr,($pref), ($l), ($suf))}#)
(defprimitive outcstring_err (:cstring s) :void
  :doc #{Output on stderr the string $s.}#
  #{melt_puts(stderr,($s))}#)
(defprimitive outstrbuf_err (sbuf) :void
  :doc #{Output on stderr the stringbuffer value $sbuf.}#
  #{melt_putstrbuf(stderr,(melt_ptr_t)($sbuf))}#)
(defprimitive outnewline_err () :void
  :doc #{Output on stderr a newline and flush.}#
  "melt_newlineflush(stderr)")
(defprimitive outstr_err (str) :void
  :doc #{Output on stderr a MELT string.}#
  #{melt_putstr(stderr, (melt_ptr_t)($str))}#)

(defprimitive message_dbg (:cstring msg) :void :doc #{Debug message $msg}#
  #{debugeputs(($msg))}#)
(defprimitive messagenum_dbg (:cstring msg :long i) :void 
  :doc #{Debug output with message $msg number $i}#
  #{debugnum(($msg), ($i))}#)
(defprimitive messageval_dbg (:cstring msg :value val) :void
  :doc #{Debug output with message $msg value $val}#
  #{debugvalue(($msg), ((void*)($val)))}#)
(defprimitive longbacktrace_dbg (:cstring msg :long maxdepth) :void
  :doc #{Detailed debug backtrace with message $MSG up to $MAXDEPTH.}#
  #{debugbacktrace(($msg), (int)(maxdepth))}#)
(defprimitive shortbacktrace_dbg (:cstring msg :long maxdepth) :void
  :doc #{Short debug backtrace with message $MSG up to $MAXDEPTH.}#
  #{ 
#if ENABLE_CHECKING
  if (flag_melt_debug)
    melt_dbgshortbacktrace(($msg), ($maxdepth));
#endif
}#)
(defprimitive checkval_dbg (val :cstring msg) :value
  :doc #{Low-level costly check of value $VAL with message $MSG. Mostly useful for gurus.}#
  #{melt_checked_assignmsg (($val),($msg))}#)
(defprimitive debugcstring (:cstring msg str) :void
  :doc #{Debug cstring $MSG $STR.}#
  #{debugeprintf("debugcstring %s '%s'", $msg, $str)}#)

(defprimitive the_null_cstring () :cstring
  :doc #{The null const cstring.}#
  #{(char*)0}#
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; STRBUF primitives
;; primitive to make a strbuf
(defprimitive make_strbuf (discr) :value
  :doc #{Make a new stringbuffer value of given $DISCR - or null if bad $DISCR.}#
  #{meltgc_new_strbuf((meltobject_ptr_t)($discr), (char*)0)}#)
(defprimitive strbuf_usedlength (sbuf) :long
  :doc #{Give the used length of given $SBUF string buffer or else 0.}#
  #{melt_strbuf_usedlength((melt_ptr_t)($sbuf))}#)

(defprimitive is_strbuf (v) :long
  :doc #{Test if value $V is a stringbuffer.}# 
  #{(melt_magic_discr((melt_ptr_t)($v)) == OBMAG_STRBUF)}#)


;; actually all the sbuf routines now take an outbuf argument, which can be either a string buffer of a file
(defprimitive is_out (v) :long
  :doc #{Test if value $V is a output value (a stringbuffer or a file).}# 
  #{ (melt_is_out ((melt_ptr_t) $v)) }#)

;; primitive to add a string const into a strbuf
(defprimitive add2sbuf_strconst (sbuf :cstring str) :void 
  :doc #{Add into stringbuffer $SBUF the constant string $STR.}#
  #{meltgc_add_strbuf((melt_ptr_t)($sbuf), ($str))}#)
;; primitive to add a string value into a strbuf
(defprimitive add2sbuf_string (sbuf str) :void 
  :doc #{Add into stringbuffer $SBUF the string value $STR.}#
  #{meltgc_add_strbuf((melt_ptr_t)($sbuf), melt_string_str((melt_ptr_t)($str)))}#)
;; primitive to add the location info of a mixedloc into a strbuf
(defprimitive add2sbuf_mixloc (sbuf mixl) :void
  :doc #{Add into stringbuffer $SBUF the mixed loc $MIXL.}#
  #{/*add2sbufmixloc*/ if (melt_magic_discr((melt_ptr_t)($mixl)) == OBMAG_MIXLOC)
  meltgc_strbuf_printf((melt_ptr_t)($sbuf), "{%s:%d}",
		       LOCATION_FILE(melt_location_mixloc((melt_ptr_t)$mixl)),
		       LOCATION_LINE(melt_location_mixloc((melt_ptr_t)$mixl))); }#)

;; primitive to add the short location info of a mixedloc into a strbuf
(defprimitive add2sbuf_short_mixloc (sbuf mixl) :void
  :doc #{Add into stringbuffer $SBUF the mixed loc $MIXL in short form.}#
  #{/*add2sbufshortmixloc*/ { if (melt_magic_discr((melt_ptr_t)($mixl)) == OBMAG_MIXLOC)
  meltgc_strbuf_printf((melt_ptr_t)($sbuf), "{%s:%d}", 
		       lbasename(LOCATION_FILE(melt_location_mixloc((melt_ptr_t)$mixl))), 
		       LOCATION_LINE(melt_location_mixloc((melt_ptr_t)" mixl "))); }#)

;; primitive to add the texi location info of a mixedloc into a strbuf
(defprimitive add2sbuf_texi_mixloc (sbuf mixl) :void
  :doc #{Add into stringbuffer $SBUF the mixed loc $MIXL in texinfo form.}#
  #{/*add2sbufteximixloc*/ if (melt_magic_discr((melt_ptr_t)($mixl)) == OBMAG_MIXLOC) 
  meltgc_strbuf_printf((melt_ptr_t)($sbuf), "file @file{%s}, line %d", 
		       lbasename(LOCATION_FILE(melt_location_mixloc((melt_ptr_t)$mixl))), 
		       LOCATION_LINE(melt_location_mixloc((melt_ptr_t)$mixl))); }#)

;; primitive to add an indentation or space into a strbuf
(defprimitive add2sbuf_indent (sbuf :long depth) :void
  :doc #{Add into stringbuffer $SBUF an indentation of given $DEPTH or a space.}#
  #{meltgc_strbuf_add_indent((melt_ptr_t)($sbuf), ($depth), 64)}#)


;; primitive to add an indented newline into a strbuf
(defprimitive add2sbuf_indentnl (sbuf :long depth) :void
  :doc #{Add into stringbuffer $SBUF an indented newline of given $DEPTH.}#
  #{meltgc_strbuf_add_indent((melt_ptr_t)($sbuf), ($depth), 0)}#)


;; primitive to add a strbuf into a strbuf
(defprimitive add2sbuf_sbuf (sbuf asbuf) :void 
  :doc #{Add into stringbuffer $SBUF the content of stringbuffer $ASBUF.}#
  #{meltgc_add_strbuf((melt_ptr_t)($sbuf), melt_strbuf_str($asbuf))}#)

;; primitive to add a string value, C encoded, into a strbuf
(defprimitive add2sbuf_cencstring (sbuf str) :void 
  :doc #{Add into stringbuffer $SBUF the content of string $STR with C encoding.}#
  #{meltgc_add_strbuf_cstr((melt_ptr_t)($sbuf), melt_string_str((melt_ptr_t)($str)))}#)

;; primitive to add a strbuf, C encoded, into a strbuf
(defprimitive add2sbuf_cencstrbuf (sbuf asbuf) :void 
  :doc #{Add into stringbuffer $SBUF the content of stringbuffer $ASBUF with C encoding.}#
  #{meltgc_add_strbuf_cstr((melt_ptr_t)($sbuf), melt_strbuf_str((melt_ptr_t)($asbuf)))}#)

;; primitive to add a string value, Ccomment encoded, into a strbuf
(defprimitive add2sbuf_ccomstring (sbuf str) :void 
  :doc #{Add into stringbuffer $SBUF the content of string $STR with C-comment encoding, i.e. avoiding */.}#
  #{meltgc_add_strbuf_ccomment((melt_ptr_t)($sbuf), melt_string_str((melt_ptr_t)($str)))}#)

;; primitive to add a strbuf, C encoded, into a strbuf
(defprimitive add2sbuf_ccomstrbuf (sbuf asbuf) :void 
  :doc #{Add into stringbuffer $SBUF the content of stringbuffer $ASBUF with C-comment encoding, i.e. avoiding */.}#
  #{meltgc_add_strbuf_ccomment((melt_ptr_t)($sbuf), 
			       melt_strbuf_str((melt_ptr_t)($asbuf)))}#)

;; primitive to add a cstring const, Ccomment encoded, into a strbuf
(defprimitive add2sbuf_ccomconst (sbuf :cstring cstr) :void 
  :doc #{Add into stringbuffer $SBUF the constant string $CSTR with
 C-comment encoding so no */.}# 
 #{meltgc_add_strbuf_ccomment(($sbuf), $cstr)}#)

;; primitive to add into a strbuf a string as C ident (nonalphanum
;; replaced by _)
(defprimitive add2sbuf_cident (sbuf str) :void
  :doc #{Add into stringbuffer $SBUF the string $STR as a C identifier
  so nonalphanum replaced by _.}#
  #{meltgc_add_strbuf_cident((melt_ptr_t)($sbuf),
  melt_string_str((melt_ptr_t)($str)))}#)

;; primitive to add into a strbuf the prefix of a string as C ident (nonalphanum
;; replaced by _) limited by a small length 
(defprimitive add2sbuf_cidentprefix  (sbuf str :long preflen) :void
  :doc #{Add into stringbuffer $SBUF the prefix string $STR as a C identifier
  so nonalphanum replaced by _ limited by $PREFLEN.}#
  #{meltgc_add_strbuf_cidentprefix((melt_ptr_t)($sbuf), melt_string_str((melt_ptr_t)($str)), ($preflen))}#)

;; primitive to add a long in decimal into a strbuf
(defprimitive add2sbuf_longdec (sbuf :long num) :void
  :doc #{Add into stringbuffer $SBUF the number $NUM in decimal.}#
  #{meltgc_add_strbuf_dec((melt_ptr_t)($sbuf), ($num))}#)

;; primitive to add a long in hex into a strbuf
(defprimitive add2sbuf_longhex (sbuf :long num) :void
  :doc #{Add into stringbuffer $SBUF the number $NUM in hexa.}#
  #{meltgc_add_strbuf_hex((melt_ptr_t)($sbuf), ($num))}#)

;; primitive to add a routine descr into a strbuf
(defprimitive add2sbuf_routinedescr (sbuf rout) :void
  :doc #{Add into stringbuffer $SBUF the routine descriptor $ROUT.}#
  #{meltgc_add_strbuf((melt_ptr_t)($sbuf), melt_routine_descrstr((melt_ptr_t)($rout)))}#)

;;; primitive to output a strbuf into a file named by a cstring
(defprimitive output_sbuf_strconst (sbuf :cstring nam) :void
  :doc #{Output into file named $NAM the content of strinbuffer $SBUF.}#
#{ melt_output_strbuf_to_file(($sbuf), ($nam)) }#)
;;; primitive to output a strbuf into a file named by a stringval
(defprimitive output_sbuf_strval (sbuf vnam) :void
  :doc #{Output into file named by string value $VNAM the content of strinbuffer $SBUF.}#
#{ melt_output_strbuf_to_file(($sbuf), melt_string_str($vnam)) }#)

;;;;;;;;;;;;;;;; variant for outbuf

;; primitive to add a string const into a outbuf
(defprimitive add2out_strconst (out :cstring str) :void 
  :doc #{Add to output $OUT the cstring $STR.}#
  #{meltgc_add_out((melt_ptr_t)($out), ($str))}#)
;; primitive to add a string value into a outbuf
(defprimitive add2out_string (out str) :void 
  :doc #{Add to output $OUT the string value $STR.}#
  #{meltgc_add_out((melt_ptr_t)($out), melt_string_str((melt_ptr_t)($str)))}#)
;; primitive to add the location info of a mixedloc into a outbuf
(defprimitive add2out_mixloc (out mixl) :void
  :doc #{Add to output $OUT the mixed location $MIXL.}#
  #{/*add2outmixloc*/ { if (melt_magic_discr((melt_ptr_t)($mixl)) == OBMAG_MIXLOC) 
  meltgc_out_printf((melt_ptr_t)(" out "), "{%s:%d}", 
  LOCATION_FILE(melt_location_mixloc((melt_ptr_t)$mixl)), 
  LOCATION_LINE(melt_location_mixloc((melt_ptr_t)$mixl))); }#)

;; primitive to add an indentation or space into a outbuf
(defprimitive add2out_indent (out :long depth) :void
  :doc #{Add to output $OUT the indentation $DEPTH or a space.}#
  #{meltgc_out_add_indent((melt_ptr_t)($out), ($depth), 64)}#)


;; primitive to add an indented newline into a outbuf
(defprimitive add2out_indentnl (out :long depth) :void
  :doc #{Add to output $OUT the indented newline of given $DEPTH.}#
  #{meltgc_out_add_indent((melt_ptr_t)($out), ($depth), 0)}#)


;; primitive to add a strbuf into a outbuf
(defprimitive add2out_sbuf (out asbuf) :void 
  :doc #{Add to output $OUT the stringbuffer $ASBUF.}#
  #{meltgc_add_out((melt_ptr_t)($out), melt_out_str($asbuf))}#)

;; primitive to add a string value, C encoded, into a outbuf
(defprimitive add2out_cencstring (out str) :void 
  :doc #{Add to output $OUT the C-encoded string value $STR.}#
  #{meltgc_add_out_cstr((melt_ptr_t)($out), melt_string_str((melt_ptr_t)($str)))}#)

;; primitive to add a strbuf, C encoded, into a outbuf
(defprimitive add2out_cencstrbuf (out asbuf) :void 
  :doc #{Add to output $OUT the C-encoded stringbuffer $ASBUF.}#
  #{meltgc_add_out_cstr((melt_ptr_t)($out), melt_out_str((melt_ptr_t)($asbuf)))}#)

;; primitive to add a string value, Ccomment encoded, into a outbuf
(defprimitive add2out_ccomstring (out str) :void 
  :doc #{Add to output $OUT the C-comment encoded string value $STR.}#
  #{meltgc_add_out_ccomment((melt_ptr_t)($out), melt_string_str((melt_ptr_t)($str)))}#)

;; primitive to add a strbuf, C encoded, into a outbuf
(defprimitive add2out_ccomstrbuf (out asbuf) :void 
  :doc #{Add to $OUT the C-comment encoded stringbuffer $ASBUF.}#
  #{meltgc_add_out_ccomment((melt_ptr_t)($out), melt_out_str((melt_ptr_t)($asbuf)))}#)

;; primitive to add a cstring const, Ccomment encoded, into a outbuf
(defprimitive add2out_ccomconst (out :cstring cstr) :void 
  :doc #{Add to $OUT the constant C-comment encoded raw $CSTR.}#
  #{meltgc_add_out_ccomment(($out), $cstr)}#)

;; primitive to add into a outbuf a string as C ident (nonalphanum
;; replaced by _)
(defprimitive add2out_cident (out str) :void
  :doc #{Add to $OUT the MELT string $STR encocded as a C identifier, so
with every non-alnum character replaced with an underscore.}#
  #{meltgc_add_out_cident((melt_ptr_t)($out), 
			  melt_string_str((melt_ptr_t)($str)))}#)

;; primitive to add into a outbuf the prefix of a string as C ident (nonalphanum
;; replaced by _) limited by a small length 
(defprimitive add2out_cidentprefix  (out str :long preflen) :void
  :doc #{Add to $OUT the prefix of a string encoded as a C identifier,
limited by a small length $PREFLEN.}#
  #{meltgc_add_out_cidentprefix((melt_ptr_t)($out), 
				melt_string_str((melt_ptr_t)($str)), 
				($preflen))}#)

;; primitive to add a long in decimal into a outbuf
(defprimitive add2out_longdec (out :long num) :void
  :doc #{Add to $OUT the number $NUM in decimal.}#
  #{meltgc_add_out_dec((melt_ptr_t)($out), ($num))}#)

;; primitive to add a long in hex into a outbuf
(defprimitive add2out_longhex (out :long num) :void
  :doc #{Add to $OUT the number $NUM in hex.}#
  #{meltgc_add_out_hex((melt_ptr_t)($out), ($num))}#)

;; primitive to add a routine descr into a outbuf
(defprimitive add2out_routinedescr (out rout) :void
  :doc #{Add to $OUT the routine desscriptor $ROUT.}#
  #{meltgc_add_out((melt_ptr_t)($out), 
		   melt_routine_descrstr((melt_ptr_t)($rout)))}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; STRING primitives
;; primitive for testing if a value is a string
(defprimitive is_string (str) :long
  :doc #{Test that $STR is a string values.}#
  #{(melt_magic_discr((melt_ptr_t)($str)) == OBMAG_STRING)}#)
;; string equal
(defprimitive ==s (s1 s2) :long
  :doc #{Test that $S1 and $S2 are both string values and are equal.}#
  #{melt_string_same((melt_ptr_t)($s1), (melt_ptr_t)($s2))}#)
;;; make a string
(defprimitive make_string (dis str) :value
  :doc #{Make a new string of discriminant $DIS from string value $STR.}#
  #{(meltgc_new_stringdup((meltobject_ptr_t)($dis), 
			  melt_string_str((melt_ptr_t)($str))))}#)
(defprimitive make_stringconst (dis :cstring cstr) :value
  :doc #{Make a new string of distriminant $DIS from raw string constant $CSTR.}#
  #{(meltgc_new_stringdup((meltobject_ptr_t)($dis), ($cstr)))}#)
(defprimitive is_stringconst (str :cstring cs) :long
  :doc #{Test that value string $STR is the raw string constant $CS.}#
  #{(melt_is_string_const((melt_ptr_t)($str), ($cs)))}#)
(defprimitive string_length (str) :long
  :doc #{Give the length of string value $STR.}#
  #{melt_string_length((melt_ptr_t)($str))}#)
(defprimitive string= (s1 s2) :long 
  :doc #{Test that value strings $S1 and $S2 are equal as strings.}#
  #{melt_string_same(($s1), ($s2))}#)
(defprimitive string< (s1 s2) :long 
  :doc #{Test that value string $S1 is less than $S2, compared alphanumerically as strings.}#
  #{melt_string_less((melt_ptr_t)($s1), (melt_ptr_t)($s2))}#)
(defprimitive string> (s1 s2) :long 
  :doc #{Test that value string $S1 is greater than $S2.}#
  #{melt_string_less((melt_ptr_t)($s2), (melt_ptr_t)($s1))}#)

(defprimitive split_string_space (dis :cstring cs) :value
  :doc #{Split a cstring $CS into a list of space separated strings of
discriminant $DIS.}#
#{meltgc_new_split_string($cs, ' ', (melt_ptr_t) $dis)}#)

(defprimitive split_string_comma (dis :cstring cs) :value
  :doc #{Split a cstring $CS into a list of comma separated strings of
discriminant $DIS.}#
#{meltgc_new_split_string($cs, ',', (melt_ptr_t) $dis)}#)

(defprimitive split_string_colon (dis :cstring cs) :value
  :doc #{Split a cstring $CS into a list of colon separated strings of
discriminant $DIS.}#
#{meltgc_new_split_string($cs, ':', (melt_ptr_t)$dis)}#)

;;; convert a strbuf into a string
(defprimitive strbuf2string (dis sbuf) :value
  :doc #{make a string value of discriminant $DIS from the stringbuffer $SBUF.}#
  #{(meltgc_new_stringdup((meltobject_ptr_t)($dis), melt_strbuf_str((melt_ptr_t)($sbuf))))}#)


;;; compute the naked basename
(defprimitive make_string_nakedbasename (dis str) :value
  :doc #{make a string value of discriminant $DIS from the naked basename from file path $STR.}#
  #{(meltgc_new_string_nakedbasename((meltobject_ptr_t)($dis), melt_string_str((melt_ptr_t)($str))))}#)
;;; compute the naked temporary path for a basename with a suffix
(defprimitive make_string_tempname_suffixed (dis str :cstring suff) :value
  #{(meltgc_new_string_tempname_suffixed((meltobject_ptr_t)($dis), 
					 melt_string_str((melt_ptr_t)($str)), 
					 ($suff)))}#)
;;;; compile a C code file as module and load it. First argument is an
;;;; environment, second argument is the string containing the C file
;;;; path. Return value is the new environment provided by the loaded
;;;; module.
(defprimitive load_melt_module (env str) :value
  :doc #{load a MELT module by C compilation of file $STR with
  environment $ENV. Gives the new environment after loading the module.}#
  #{(meltgc_load_melt_module((melt_ptr_t)($env),
  melt_string_str((melt_ptr_t)($str))))}#)

;; generate a loadable module from a MELT generated C source file; the
;;  out is the dynloaded module without any *.so suffix 
(defprimitive generate_melt_module (src outnam) :void
  :doc #{Generate and load a module whose source is named after $SRC 
and whose binary is named after $OUTNAM without any '.so' suffix.}#
  #{meltgc_generate_melt_module($src,$outnam);}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; OBJECT primitives
;; primitive to get an object length
(defprimitive object_length (ob) :long 
  :doc #{Gives the length of object $OB.}#
  #{((long)melt_object_length((melt_ptr_t)($ob)))}#)
;; primitive to get the nth field of an object
(defprimitive object_nth_field (ob :long n) :value
  :doc #{Safely retrieve from object $OB its $N-th field or else null.}#
  #{(melt_field_object((melt_ptr_t)($ob), ($n)))}#)

(defprimitive subclass_of (cl1 cl2) :long
  :doc #{Safely test if class $CL1 is a sub-class of class $CL2.}#
  #{melt_is_subclass_of((meltobject_ptr_t)($cl1), (meltobject_ptr_t)($cl2))}#)
(defprimitive subclass_or_eq (cl1 cl2) :long
  :doc #{Safely test if class $CL1 is the same or a sub-class of class $CL2.}#
  #{(($cl1 == $cl2) || melt_is_subclass_of((meltobject_ptr_t)($cl1), (meltobject_ptr_t)($cl2)))}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; MULTIPLEs primitives
;;;; test
(defprimitive is_multiple (mul) :long
  :doc #{Safely test if $MUL is a tuple.}#
  #{(melt_magic_discr((melt_ptr_t)($mul)) == OBMAG_MULTIPLE)}#)
(defprimitive is_multiple_or_null (mul) :long
  :doc #{Safely test if $MUL is a tuple or null.}#
  #{(($mul) == NULL || (melt_unsafe_magic_discr((melt_ptr_t)($mul)) == OBMAG_MULTIPLE))}#)
;;; make
(defprimitive make_multiple (discr :long ln) :value
  :doc #{Make a tuple of given discriminant $DISCR and length $LN - gives null otherwise.}#
  #{(meltgc_new_multiple((meltobject_ptr_t)($discr), ($ln)))}#)
(defprimitive make_tuple1 (discr v1) :value
  :doc #{Make a 1-tuple of discriminant $DISCR and content $V1.}#
  #{(meltgc_new_mult1((meltobject_ptr_t)($discr), (melt_ptr_t)($v1)))}#)
(defprimitive make_tuple2 (discr v1 v2) :value
  :doc #{Make a 2-tuple of discriminant $DISCR and content $V1 $V2.}#
  #{(meltgc_new_mult2((meltobject_ptr_t)($discr), (melt_ptr_t)($v1),  (melt_ptr_t)($v2)))}#)
(defprimitive make_tuple3 (discr v1 v2 v3) :value
  :doc #{Make a 3-tuple of discriminant $DISCR and content $V1 $V2 $V3.}#
  #{(meltgc_new_mult3((meltobject_ptr_t)($discr), (melt_ptr_t)($v1),  (melt_ptr_t)($v2),  (melt_ptr_t)($v3)))}#)
(defprimitive make_tuple4 (discr v1 v2 v3 v4) :value
  :doc #{Make a 4-tuple of discriminant $DISCR and content $V1 $V2 $V3 $V4.}#
  #{(meltgc_new_mult4((meltobject_ptr_t)($discr), (melt_ptr_t)($v1),  
		      (melt_ptr_t)($v2),  (melt_ptr_t)($v3),  (melt_ptr_t)($v4)))}#)
(defprimitive make_tuple5 (discr v1 v2 v3 v4 v5) :value
  :doc #{Make a 5-tuple of discriminant $DISCR and content $V1 $V2 $V3 $V4 $V5.}#
  #{(meltgc_new_mult5((meltobject_ptr_t)($discr), (melt_ptr_t)($v1),  
		      (melt_ptr_t)($v2),  (melt_ptr_t)($v3),  (melt_ptr_t)($v4),
		      (melt_ptr_t)($v5)))}#)
(defprimitive make_tuple6 (discr v1 v2 v3 v4 v5 v6) :value
  :doc #{Make a 6-tuple of discriminant $DISCR and content $V1 $V2 $V3 $V4 $V5 $V6.}#
  #{(meltgc_new_mult6((meltobject_ptr_t)($discr), (melt_ptr_t)($v1),  
		      (melt_ptr_t)($v2),  (melt_ptr_t)($v3),  (melt_ptr_t)($v4),
		      (melt_ptr_t)($v5),  (melt_ptr_t)($v6)))}#)
(defprimitive make_tuple7 (discr v1 v2 v3 v4 v5 v6 v7) :value
  :doc #{Make a 7-tuple of discriminant $DISCR and content $V1 $V2 $V3 $V4 $V5 $V6 $V7.}#
  #{(meltgc_new_mult7((meltobject_ptr_t)($discr), (melt_ptr_t)($v1),  
		      (melt_ptr_t)($v2),  (melt_ptr_t)($v3),  (melt_ptr_t)($v4),
		      (melt_ptr_t)($v5),  (melt_ptr_t)($v6),  (melt_ptr_t)($v7)))}#)

;; primitive to build the subsequence of a multiple
(defprimitive subseq_multiple (mul :long startix endix) :value
  :doc #{Make a tuple from as subsequence of $MUL from indexes $STARTIX to $ENDIX.}#
 #{ meltgc_new_subseq_multiple((melt_ptr_t)($mul),
				  (int)($startix), (int)($endix)) }#)

;; primitive to get the nth  in a multiple
(defprimitive multiple_nth (mul :long n) :value
  :doc #{Safely retrieve from tuple $MUL its $N-th component or else null.}#
  #{(melt_multiple_nth((melt_ptr_t)($mul), ($n)))}#)
;; primitive to get the length of a multiple
(defprimitive multiple_length (mul) :long
  :doc #{Gives the length of tuple $MUL.}#
  #{(melt_multiple_length((melt_ptr_t)($mul)))}#)
;; put into a multiple.
(defprimitive multiple_put_nth (mul :long n :value v) :void
  :doc #{Put into tuple $MUL at rank $N the component $V. Avoid circularities!}#
  #{meltgc_multiple_put_nth((melt_ptr_t)($mul), ($n), (melt_ptr_t)($V))}#)
;; sort a multiple, the compare function should return a boxed integer
(defprimitive multiple_sort (mul cmp discrm) :value
  :doc #{Gives the sorted tuple from tuple $MUL using compare function
  $CMP (returning a boxed integer) and discriminant $DISCRM.}#
  #{meltgc_sort_multiple((melt_ptr_t)($mul), (melt_ptr_t)($cmp), (melt_ptr_t)($discrm))}#)

;; public comparator for named instances
(defun compare_named_alpha (n1 n2)
  :doc #{Alphanumerical compare of named instances $N1 and $N2. 
Returns a boxed integer.}#
  (cond 
   ( (== n1 n2) '0)
   ( (is_not_a n1 class_named) 
     '1)
   ( (is_not_a n2 class_named)
     '-1)
   (:else
    (let ( (sn1 (unsafe_get_field :named_name n1))
	   (sn2 (unsafe_get_field :named_name n2)) )
      (cond
       ( (string< sn1 sn2) 
	 '-1)
       ( (string> sn1 sn2)
	 '1)
       (:else
	'0))))))

;; cmatcher for the tuple nth argument
(defcmatcher tuple_nth 
  (matchedtup :long matchedrk)				;match & ins
  (outcomp)				;out
  tupnth				;statesymb
  :doc #{The $TUPLE_NTH matcher with input number $MATCHEDRK matches a
tuple of length greater than $MATCHEDRK and retrieve the component
of that index, and matches it against the sub-pattern.}#
  ;;test expansion
   #{/*$TUPNTH ?*/ (melt_is_multiple_at_least(((melt_ptr_t)$matchedtup), 1+ (int)($matchedrk)))}#
   ;;fill expansion
  #{/*$TUPNTH !*/ $outcomp = melt_multiple_nth((melt_ptr_t)($matchedtup),(int)($matchedrk));
   }#
  ;; no operator expansion 
)


;;; cmatcher for a cstring of a given content
(defcmatcher cstring_same 
  (:cstring str cstr)
  ()
  strsam
  :doc #{The $CSTRING_SAME c-matcher match a string $STR and test if
  it equals to the constant string $CSTR. The match fails if $STR is a
  null string or different from $CSTR.}# 

#{/*$strsam test*/ ($str && $cstr && !strcmp($str, $cstr)) }#
  ;; no fill or operator
)

;; primitive to compute the length of a cstring
(defprimitive cstring_length
  (:cstring cstr) :long
  :doc #{Compute safely the length a C-string $cstr. Gives 0 if null argument. }#
  #{(($cstr)?strlen($cstr):0)}#)

;; cmatcher for a tuple of a given exact size
(defcmatcher tuple_sized
  (tup :long ln)			;match & ins
  () 					;outs
  tupsiz				;statesymb
  :doc #{Match a tuple of given exact size.}#
  ;;test expansion
   #{(melt_is_multiple_of_length((melt_ptr_t)($tup), (int) ($ln)))}#
  ;; no fill expansion
  ;; no operator expansion
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; MAPOBJECTs primitives
;;;; test
(defprimitive is_mapobject (map) :long
  :doc #{Test if given $MAP is an object map.}#
  #{(melt_magic_discr((melt_ptr_t)($map)) == OBMAG_MAPOBJECTS)}#)
;; primitive to get the allocated size of a mapobject
(defprimitive mapobject_size (map) :long
  :doc #{Safely retrieve the allocated size of given object-map $MAP or else 0.}#
  #{(melt_size_mapobjects((meltmapobjects_ptr_t)($map)))}#)
;; primitive to get the attribute count of a mapobject
(defprimitive mapobject_count (map) :long
  :doc #{Safely retrieve the count of given object-map $MAP or else 0.}#
  #{(melt_count_mapobjects((meltmapobjects_ptr_t)($map)))}#)
;; primitive to get the nth attribute of a mapobject
(defprimitive mapobject_nth_attr (map :long n) :value
  :doc #{Safely retrieve from given object-map $MAP its $N-th attribute or else null.}#
  #{(melt_nthattr_mapobjects((meltmapobjects_ptr_t)($map), (int)($n)))}#)
;; primitive to get the nth value of a mapobject
(defprimitive mapobject_nth_val (map :long n) :value
  :doc #{Safely retrieve from given object-map $MAP its $N-th value or else null.}#
  #{(melt_nthval_mapobjects((meltmapobjects_ptr_t)($map), (int)($n)))}#)
;; primitive to get the value of an attribute in a mapobject
(defprimitive mapobject_get (map attr) :value
  :doc #{Safely get from given object-map $MAP the value associated to $ATTR or else null.}#
  #{melt_get_mapobjects((meltmapobjects_ptr_t)($map), (meltobject_ptr_t)($attr))}#)
;; primitive for making a new map of objects
(defprimitive make_mapobject (discr :long len) :value
  :doc #{Make an object-map of discriminant $DISCR and initial size $LEN or null.}#
  #{(meltgc_new_mapobjects( (meltobject_ptr_t) ($discr), ($len)))}#)
;; primitive for putting into a map of objects
(defprimitive mapobject_put (map key val) :void
  :doc #{Safely put into object-map $MAP the given $KEY with $VAL.}#
  #{meltgc_put_mapobjects( (meltmapobjects_ptr_t) ($map), 
			   (meltobject_ptr_t) ($key), 
			   (melt_ptr_t)($val))}#)
;; primitive for removing from a map of objects
(defprimitive mapobject_remove (map key) :void
  :doc #{Safely remove from object-map $MAP the given $KEY.}#
  #{meltgc_remove_mapobjects( (meltmapobjects_ptr_t) ($map), 
			      (meltobject_ptr_t)($key))}#)
;;; iterator inside a map of object
(defciterator foreach_in_mapobject
  (:value objmap)
  eachobmap
  (:value curat curva)
  :doc #{The $FOREACH_IN_MAPOBJECT c-iterator iterates inside the
  given $OBJMAP and retrieves a $CURAT attribute and its $CURVA
  value.}#
  ;; before expansion
  #{ /*$eachobmap :*/ int $eachobmap#_ix=0, $eachobmap#_siz=0;
  for ($eachobmap#_ix=0; 
     /* we retrieve in $eachobmap#_siz the size at each iteration since it could change. */
       $eachobmap#_ix>=0 && ($eachobmap#_siz= melt_size_mapobjects($objmap))>0
       && $eachobmap#_ix < $eachobmap#_siz;
       $eachobmap#_ix++) {
    $curat = NULL;
    $curva = NULL;
    $curat = ((meltmapobjects_ptr_t)$objmap)->entab[$eachobmap#_ix].e_at;
    if ($curat == HTAB_DELETED_ENTRY) { $curat = NULL; continue; };
    if (!$curat) continue;
    $curva = ((meltmapobjects_ptr_t)$objmap)->entab[$eachobmap#_ix].e_va;
    if (!$curva) continue; 
}#
;;; after expansion
  #{ /* end $eachobmap */
    $curat = NULL;  
    $curva = NULL;  }
}#
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; MAPSTRINGs primitive
;; test
(defprimitive is_mapstring (map) :long
  :doc #{Safely test if $MAP is a string-map.}#
  #{(melt_magic_discr((melt_ptr_t)($map)) == OBMAG_MAPSTRINGS)}#)
;; primitive to get the allocated size of a mapstring
(defprimitive mapstring_size (map) :long 
  :doc #{Safely return the current allocated size of a string-map $MAP or else 0.}#
  #{(melt_size_mapstrings((struct meltmapstrings_st*)($map)))}#)
;; primitive to get the attribute count of a mapstring
(defprimitive mapstring_count (map) :long
  :doc #{Safely return the current count of a string-map $MAP or else 0.}#
  #{(melt_count_mapstrings((struct meltmapstrings_st*)($map)))}#)
;; get an entry in a mapstring from a C string
(defprimitive mapstring_rawget (map :cstring cstr) :value
  :doc #{Safely get in a string-map $MAP the value associated with raw c-string $CSTR or else null.}#
  #{(melt_get_mapstrings((struct meltmapstrings_st*)($map), ($cstr)))}#)
;; primitive for making a new map of strings
(defprimitive make_mapstring (discr :long len) :value
  :doc #{Make a new string-map of discriminant $DISCR and initial length $LEN - or null if failed.}#
  #{(meltgc_new_mapstrings( (meltobject_ptr_t) ($discr), ($len)))}#)
;; primitive for putting into a map of strings
(defprimitive mapstring_rawput (map :cstring key :value val) :void
  :doc #{Safely put into a string-map $MAP the raw c-string $KEY associated to value $VAL.}#
  #{meltgc_put_mapstrings( (struct meltmapstrings_st *) ($map), ($key), (melt_ptr_t) ($val))}#)
(defprimitive mapstring_putstr (map keystr val) :void
  :doc #{Safely put into a string-map $MAP the string value $KEYSTR associated to value $VAL.}#
  #{meltgc_put_mapstrings((struct meltmapstrings_st *) ($map), melt_string_str((melt_ptr_t)($keystr)), (melt_ptr_t)($val))}#)
(defprimitive mapstring_getstr (map keystr) :value
  :doc #{Safely get in a string-map $MAP the value associated with a value string $KEYSTR or else null.}#
  #{(melt_get_mapstrings((struct meltmapstrings_st*)($map), melt_string_str((melt_ptr_t)($keystr))))}#)
;; primitives for removing from a map of strings
(defprimitive mapstring_rawremove (map :cstring key) :void
  :doc #{Safely remove from a string-map $MAP the value associated with raw c-string $KEY.}#
  #{meltgc_remove_mapstrings((struct meltmapstrings_st*) ($map), ($key))}#)
(defprimitive mapstring_removestr (map keystr) :void
  :doc #{Safely remove from a string-map $MAP the value associated with string value $KEYSTR.}#
  #{meltgc_remove_mapstrings((struct meltmapstrings_st*) ($map), melt_string_str((melt_ptr_t)$keystr))}#)

;; primitive to make the nth stringattr of a mapobject
(defprimitive mapstring_nth_attrstr (map sdicr :long n) :value
  :doc #{Safely get from string-map $MAP the $N-th string and make a string value of 
discriminant $SDICR from it.}#
  #{(meltgc_new_stringdup((meltobject_ptr_t)($sdicr),  
			  melt_nthattrraw_mapstrings((struct meltmapstrings_st*)($map), (int)($n))))}#)
;; primitive to get the nth value of a mapobject
(defprimitive mapstring_nth_val (map :long n) :value
  :doc #{Safely retrieve from string-map $MAP its $N-th value or null.}#
  #{(melt_nthval_mapstrings((struct meltmapstrings_st*)($map), (int)($n)))}#)
;;; iterator inside a map of strings
(defciterator foreach_in_mapstring
  (:value strmap)
  eachstrmap
  (:value curat curva)
  :doc #{The $FOREACH_IN_MAPSTRING c-iterator iterates inside the
given $STRMAP and retrieves a $CURAT string attribute value and its
$CURVA value. If $CURVA happens to be an instance of $CLASS_NAMED
with a name equal to the string key, we use it as $CURAT otherwise we
make a $CURAT string.}#
  ;; before expansion
  #{ /*$eachstrmap :*/ int $eachstrmap#_ix=0, $eachstrmap#_siz=0;
  for ($eachstrmap#_ix=0; 
     /* we retrieve in $eachstrmap#_siz the size at each iteration since it could change. */
       $eachstrmap#_ix>=0 && ($eachstrmap#_siz= melt_size_mapstrings($strmap))>0
       && $eachstrmap#_ix < $eachstrmap#_siz;
       $eachstrmap#_ix++) {
    const char* $eachstrmap#_str = NULL;
    const char* $eachstrmap#_nam = NULL;
    $curat = NULL;
    $curva = NULL;
    $eachstrmap#_str = ((struct meltmapstrings_st*)$strmap)->entab[$eachstrmap#_ix].e_at;
    if ($eachstrmap#_str == HTAB_DELETED_ENTRY) { $curat = NULL; continue; };
    if (!$eachstrmap#_str) continue;
    $curva = ((struct meltmapstrings_st*)$strmap)->entab[$eachstrmap#_ix].e_va;
    if (!$curva) continue; 
    if (melt_is_instance_of($curva, MELT_PREDEF (CLASS_NAMED)) 
	&& ($curat = melt_object_nth_field ((melt_ptr_t) $curva, FNAMED_NAME)) != NULL		   
	&& ($eachstrmap#_nam = melt_string_str ((melt_ptr_t) $curat)) != (char*)0
	&& !strcmp ($eachstrmap#_nam, $eachstrmap#_str))
      $curat = $curat;
    else {
      $curat = NULL;
      $curat =  meltgc_new_stringdup((meltobject_ptr_t) MELT_PREDEF (DISCR_STRING), $eachstrmap#_str);
    }
    $eachstrmap#_str = (const char*)0;
    $eachstrmap#_nam = (const char*)0;
}#
;;; after expansion
  #{ /* end $eachstrmap */
    $curat = NULL;  
    $curva = NULL;  }
}#
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; ROUTINEs primitives
;; test
(defprimitive is_routine (rou) :long
  :doc #{Test if value $ROU is a routine.}#
  #{(melt_magic_discr((melt_ptr_t)($rou)) == OBMAG_ROUTINE)}#)
;;; descriptive string of a routine
(defprimitive routine_descr (rou) :value
  :doc #{Retrieve the descriptive value string of a routine $ROU or else null.}#
  #{(meltgc_new_stringdup(melt_routine_descrstr((melt_ptr_t)($rou))))}#)
;;; size of a routine
(defprimitive routine_size  (rou) :long
  :doc #{Gives the size of a routine value $ROU, i.e. its number of constants.}#
  #{(melt_routine_size((melt_ptr_t)($rou)))}#)
;;; nth comp in routine
(defprimitive routine_nth (rou :long ix) :value
  :doc #{Retrieve in routine value $ROU its component of index $IX.}#
  #{(melt_routine_nth((melt_ptr_t)($rou), (int) ($ix)))}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; CLOSUREs primitives
;; test
(defprimitive is_closure (clo) :long
  :doc #{Test if value $CLO is a closure, i.e. a functional value.}#
  #{(melt_magic_discr((melt_ptr_t)($clo)) == OBMAG_CLOSURE)}#)
(defprimitive closure_size (clo) :long
  :doc #{Give the size of a closure value $CLO, i.e. the number of closed values.}#
  #{(melt_closure_size((melt_ptr_t)($clo)))}#)
(defprimitive closure_routine (clo) :value
  :doc #{Give the routine value inside a closure value $CLO or else null.}#
  #{(melt_closure_routine((melt_ptr_t)($clo)))}#)
(defprimitive closure_nth (clo :long ix) :value
  :doc #{Retrieve in closure value $CLO its component of index $IX.}#
  #{(melt_closure_nth((melt_ptr_t)($clo), (int)($ix)))}#)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; boxed INTEGERs primitives
;; test
(defprimitive is_integerbox (ib) :long
  :doc #{Test if a value $IB is a boxed integer.}#
  #{(melt_magic_discr((melt_ptr_t)($ib)) == OBMAG_INT)}#)
;; to get the boxed integer use get_int
;; make
(defprimitive make_integerbox (discr :long n) :value
  :doc #{Make a boxed integer of given discrimant $DISCR and integer $N.}#
  #{(meltgc_new_int((meltobject_ptr_t)($discr), ($n)))}#)

;;; pattern
(defcmatcher integerbox_of 
  (:value bx)
  (:long ict)
  iboxof
  :doc #{The $INTEGERBOX_OF matches a boxed integer $BX. If indeed it
  is a boxed integer, its integer content should match $ICT. The match
  fails if $BX is not a boxed integer (e.g. is the null value or non
  boxed-integer). See also $MAKE_INTEGERBOX $IS_INTEGERBOX.}#
  ;; test
  #{ /* $iboxof ?*/ $bx && melt_magic_discr($bx) == OBMAG_INT }#
  ;; fill
  #{ /* $iboxof !*/ $ict = ((struct meltint_st*)$bx)->val; }#
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; BOX primitives (boxed values, i.e. reference)
;; test
(defprimitive is_box (box) :long
  :doc #{Test if value $BOX is a box, ie a reference.}#
  #{(melt_magic_discr((melt_ptr_t)($box)) == OBMAG_BOX)}#)
;; safe fetch content
(defprimitive box_content (box) :value
  :doc #{Safely retrieve the content of a box value $BOX or else null.}#
  #{melt_box_content((meltbox_ptr_t)($box))}#)
;; put into a box
(defprimitive box_put (box val) :void
  :doc #{Safely put into box value $BOX the value $VAL.}#
  #{meltgc_box_put((melt_ptr_t)($box), (melt_ptr_t)($val))}#)
;; make a box
(defprimitive make_box (discr valb) :value
  :doc #{Make a box value of discriminant $DISCR and content $VALB.}#
  #{meltgc_new_box((meltobject_ptr_t)($discr), (melt_ptr_t)($valb))}#)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; LIST primitives
;; test
(defprimitive is_list (li) :long
  :doc #{Test if value $LI is a list.}#
  #{(melt_magic_discr((melt_ptr_t)($li)) == OBMAG_LIST)}#)
(defprimitive is_list_or_null (li) :long
  :doc #{Test iv value $LI is null or a list.}#
  #{(($li) == NULL 
     || (melt_unsafe_magic_discr((melt_ptr_t)($li)) == OBMAG_LIST))}#)
;; first pair of list
(defprimitive list_first (li) :value
  :doc #{Safely retrieve the first pair of list value $LI, or null.}#
  #{(melt_list_first((melt_ptr_t)($li)))}#)
;; last pair of list
(defprimitive list_last (li) :value
  :doc #{Safely retrieve the last pair of list value $LI, or null.}#
  #{(melt_list_last((melt_ptr_t)($li)))}#)
;; length of list
(defprimitive list_length (li) :long
  :doc #{Safely compute the length of list value $LI, or else 0.}#
  #{(melt_list_length((melt_ptr_t)($li)))}#)
;; append into list
(defprimitive list_append (li el) :void
  :doc #{Safely append to list value $LI an element $EL thru a new pair.}#
  #{meltgc_append_list((melt_ptr_t)($li), (melt_ptr_t)($el))}#)
;; prepend into list
(defprimitive list_prepend (li el) :void
  :doc #{Safely prepend to list value $LI an element $EL thru a new pair.}#
  #{meltgc_prepend_list((melt_ptr_t)($li), (melt_ptr_t)($el))}#)
;; pop first from list
(defprimitive list_popfirst (li) :value
  :doc #{Pop the first element from a list $LI and give it, or else null.}#
  #{(meltgc_popfirst_list((melt_ptr_t)($li)))}#)
;; make list
(defprimitive make_list (discr) :value
  :doc #{Make a new list value of given discriminant $DISCR.}#
  #{(meltgc_new_list((meltobject_ptr_t)($discr)))}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; PAIR primitives
;; test
(defprimitive is_pair (pa) :long
  :doc #{Test if a value $PA is a pair.}#
  #{(melt_magic_discr((melt_ptr_t)($pa)) == OBMAG_PAIR)}#)
;; head
(defprimitive pair_head (pa) :value
  :doc #{Safely retrieve the head of pair value $PA or else null.}#
  #{(melt_pair_head((melt_ptr_t)($pa)))}#)
;; tail
(defprimitive pair_tail (pa) :value
  :doc #{Safely retrieve the tail pair of pair value $PA or else null.}#
  #{(melt_pair_tail((melt_ptr_t)($pa)))}#)
;; change the head of a pair
(defprimitive pair_set_head (pa hd) :void
  :doc #{Safely set in pair $PA its head to $HD. 
Please avoid using that to introduce circularities in lists.}#
 #{meltgc_pair_set_head((melt_ptr_t)($pa), ($hd))}#)
;; length of a pair list
(defprimitive pair_listlength (pa) :long
  :doc #{Compute the linked length of given pair value $PA or else 0.}#
  #{(melt_pair_listlength((melt_ptr_t)($pa)))}#)
;; make
(defprimitive make_pair (discr hd tl) :value
  :doc #{Create a new pair of given discrimiant $DISCR head $HD and
tail $TL or else null.}#
  #{(meltgc_new_pair((meltobject_ptr_t)($discr), (melt_ptr_t)($hd), (melt_ptr_t)($tl)))}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; MIXINT primitives (use get_int to get the integer)
;; test
(defprimitive is_mixint (mi) :long
  :doc #{Test if value $MI is a mixedint value.}#
  #{(melt_magic_discr((melt_ptr_t)($mi)) == OBMAG_MIXINT)}#)
;; get the value
(defprimitive mixint_val (mi) :value
  :doc #{Get the value inside a mixedint value $MI. The integer can be retrieved using $GET_INT.}#
  #{(melt_val_mixint((melt_ptr_t)($mi)))}#)
;; make a mixint
(defprimitive make_mixint (dis val :long num) :value
  :doc #{Make a mixint value of given discriminant $DIS value $VAL and number $NUM or else null.}#
  #{(meltgc_new_mixint((meltobject_ptr_t)($dis), (melt_ptr_t)($val), ($num)))}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; MIXLOC primitives (use get_int to get the integer)
;; test
(defprimitive is_mixloc (mi) :long
  :doc #{Test if value $MI is a mixed location value.}#
  #{(melt_magic_discr((melt_ptr_t)($mi)) == OBMAG_MIXLOC)}#)
;; get the value
(defprimitive mixloc_val (mi) :value
  :doc #{Safely retrieve the value inside a mixed location value $MI.}#
  #{(melt_val_mixloc((melt_ptr_t)($mi)))}#)
(defprimitive mixloc_location (mi) :long
  :doc #{Safely retrieve as an opaque long the location of a mixed location value $MI.}#
  #{((long) melt_location_mixloc((melt_ptr_t)($mi)))}#)
(defprimitive mixloc_locline (mi) :long
  :doc #{Retrieve the line of the location of a mixed location value $MI.}#
  #{(LOCATION_LINE(melt_location_mixloc((melt_ptr_t)$mi)))}#)
(defprimitive mixloc_locfile (mi) :cstring
  :doc #{Retrieve the filename as a raw cstring of a mixed location value $MI.}#
  #{(LOCATION_FILE(melt_location_mixloc((melt_ptr_t)$mi)))}#)

;; make a mixloc
(defprimitive make_mixloc (dis val :long num loc) :value
  :doc #{Make a mixed location value of given discriminant $DIS value $VAL
number $NUM opaque location number $LOC.}#
  #{(meltgc_new_mixloc((meltobject_ptr_t)($dis), (melt_ptr_t)($val), 
		       ($num), (location_t)($loc)))}#)



;; test for mixbigint
(defprimitive is_mixbigint (mb) :long
  :doc #{Test if value $MB is a mixed bigint.}#
  "(melt_magic_discr((melt_ptr_t)(" mb ")) == OBMAG_MIXBIGINT)")
(defprimitive mixbigint_val (mb) :value
  :doc #{Retrieve the value inside a mixed bigint $MB.}#
  #{melt_val_mixbigint($mb)}#)

(defprimitive ppstrbuf_mixbigint (:value sbuf :long indent :value mb) :void
 :doc #{Pretty prints into string buffer $SBUF at indentation $INDENT the mixed bigint $MB.}#
 #{meltgc_ppstrbuf_mixbigint($sbuf,$indent,$mb);}#
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; READ FILE primitive
(defprimitive read_file (filnam) :value
  :doc #{Read from file named by the $FILNAM string balue a list of MELT s-expressions.}#
  #{(meltgc_read_file (melt_string_str((melt_ptr_t)($filnam)), (char*)0))}#)


;; to signal an error in a  source with some additional string value
(defprimitive error_strv (loc :cstring cmsg :value strv) :void
  :doc #{Show an error at boxed location $LOC with raw message string $CMSG and string value $STRV.}#
  #{melt_error_str((melt_ptr_t)($loc), ($cmsg), (melt_ptr_t)($strv))}#)

;; signal a plain error in a  source
(defprimitive error_plain (loc :cstring cmsg) :void
  :doc #{Show a plain error at boxed location $LOC with raw message string $CMSG.}#
  #{melt_error_str((melt_ptr_t)($loc), ($cmsg), (melt_ptr_t)0)}#)


;; to signal an warning in a  source with some additional string value
(defprimitive warning_strv (loc :cstring cmsg :value strv) :void
  :doc #{Show a warning at boxed location $LOC with raw message string $CMSG and string value $STRV.}#
  #{melt_warning_str(0, (melt_ptr_t)($loc), ($cmsg), (melt_ptr_t)($strv))}#)

;; signal a plain warning in a  source
(defprimitive warning_plain (loc :cstring cmsg) :void
  :doc #{Show a plain warning at boxed location $LOC with raw message string $CMSG.}#
  #{melt_warning_str(0, (melt_ptr_t)($loc), ($cmsg), (melt_ptr_t)0)}#)


;; signal a plain warning 
(defprimitive warningmsg_plain (:cstring cmsg) :void
  :doc #{Show a plain warning with raw message string $CMSG.}#
  #{warning(0, "MELT WARNING MSG [#%ld]::: %s", melt_dbgcounter, ($cmsg))}#  )


;; signal a plain warning 
(defprimitive warningmsg_strv (:cstring cmsg :value strv) :void
  :doc #{Show a plain warning with raw message string $CMSG and string value $STRV.}#
  #{warning (0, "MELT WARNING MSG [#%ld]::: %s - %s", melt_dbgcounter, ($cmsg), 
	       melt_string_str((melt_ptr_t)($strv)))}#
  )

;; signal a plain error 
(defprimitive errormsg_plain (:cstring cmsg) :void
  :doc #{Show a plain error with raw message string $CMSG.}#
  #{error ("MELT ERROR MSG [#%ld]::: %s", melt_dbgcounter, ($cmsg))}#
  )


;; signal a plain error
(defprimitive errormsg_strv (:cstring cmsg :value strv) :void
  :doc #{Show a plain error with raw message string $CMSG and string value $STRV.}#
  #{error("MELT ERROR MSG [#%ld]::: %s - %s", melt_dbgcounter, ($cmsg),
	  melt_string_str((melt_ptr_t)($strv)))}#
  )


;; to signal an inform in a  source with some additional string value
(defprimitive inform_strv (loc :cstring cmsg :value strv) :void
  :doc #{Show a notice at boxed location $LOC with raw message string $CMSG and string value $STRV.}#
  #{melt_inform_str((melt_ptr_t)($loc), ($cmsg), (melt_ptr_t)($strv))}#)
;; signal a plain inform in a  source
(defprimitive inform_plain (loc :cstring cmsg) :void
  :doc #{Show a plain warning at boxed location $LOC with raw message string $CMSG.}#
  #{melt_inform_str((melt_ptr_t)($loc), ($cmsg), (melt_ptr_t)0)}#)

(defprimitive informsg_strv (:cstring cmsg :value strv) :void
  :doc #{Show a plain notice with raw message string $CMSG and string value $STRV.}#
  #{inform(UNKNOWN_LOCATION, ("MELT INFORM [#%ld]: %s - %s"), melt_dbgcounter, ($cmsg), 
			     melt_string_str((melt_ptr_t)($strv)))}#
  )

(defprimitive informsg_plain (:cstring cmsg) :void
  :doc #{Show a plain notice with raw message string $CMSG.}#
  #{inform(UNKNOWN_LOCATION, "MELT INFORM [#%ld]: %s",  melt_dbgcounter, ($cmsg))}#
  )

(defprimitive informsg_long (:cstring msg :long n) :void
  :doc #{Show a plain notice with raw message string $CMSG and number $N.}#
  #{inform(UNKNOWN_LOCATION, "MELT INFORM [#%ld]: %s * %ld",  melt_dbgcounter, ($msg), ($n))}#
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; the discriminant for name strings
(definstance discr_name_string class_discriminant
  :predef DISCR_NAME_STRING
  :obj_num OBMAG_STRING
  :doc #{The $DISCR_NAME_STRING is the discriminant of name strings, such as the $NAMED_NAME of symbols.}#
;;; :named_name '"DISCR_NAME_STRING"
;;; :disc_super discr_string   ;; forward reference not allowed
  )

;;; the discriminant for strings
(definstance discr_string class_discriminant
  :predef DISCR_STRING
  :obj_num OBMAG_STRING
  :doc #{The $DISCR_STRING is the discriminant of strings. See also
$DISCR_NAME_STRING and $DISCR_VERBATIM_STRING.}#
  :named_name '"DISCR_STRING")

(unsafe_put_fields discr_name_string :disc_super discr_string)
(unsafe_put_fields discr_name_string :named_name
		   '"DISCR_NAME_STRING")
;;; the discriminant for verbatim strings (used for defprimitive)
(definstance discr_verbatim_string class_discriminant
  :obj_num OBMAG_STRING
  :predef DISCR_VERBATIM_STRING
  :doc #{The $DISCR_VERBATIM_STRING is the discriminant of verbatim strings. See also $DISCR_STRING.}#
  :named_name '"DISCR_VERBATIM_STRING"
  :disc_super discr_string
  )

;;; the discriminant for any receiver (used for sending to everything)
(definstance discr_any_receiver class_discriminant
  :doc #{The $DISCR_ANY_RECEIVER is the topmost discriminant of any value. See also $CTYPE_VALUE.}#
  :named_name '"DISCR_ANY_RECEIVER"
  )

(unsafe_put_fields discr_string :disc_super discr_any_receiver)

;;; the discriminant for null reciever (used for sending to nil)
(definstance discr_null_receiver class_discriminant
  :doc #{The $DISCR_NULL_RECEIVER is the discriminant of the nil value, handling messages sent to nil.}#
  :predef DISCR_NULL_RECEIVER
  :disc_super discr_any_receiver
  :named_name '"DISCR_NULL_RECEIVER")

;;; the discriminant for strbuf
(definstance discr_strbuf class_discriminant
  :doc #{The $DISCR_STRBUF is the discriminant of string buffer values.}#
  :predef DISCR_STRBUF
  :obj_num OBMAG_STRBUF  
  :disc_super discr_any_receiver
  :named_name '"DISCR_STRBUF")

;;; the discriminant for integers
(definstance discr_integer class_discriminant
  :doc #{The $DISCR_INTEGER is the discriminant of boxed integers. See also $CTYPE_LONG.}#
  :predef DISCR_INTEGER
  :obj_num OBMAG_INT 
  :disc_super discr_any_receiver
  :named_name '"DISCR_INTEGER")

;;; the discriminant for constant integers, like '123
(definstance discr_constant_integer class_discriminant
  :predef DISCR_CONSTANT_INTEGER
  :obj_num OBMAG_INT
  :disc_super discr_integer
  :named_name '"DISCR_CONSTANT_INTEGER"
  :doc #{The $DISCR_CONSTANT_INTEGER is the discriminant for constant
integer values, in particular those obtained by quoting an
integer. The number inside is constant and remains unchanged by
$PUT_INT. See also $DISCR_INTEGER.}# )

;;; the discriminant for lists
(definstance discr_list class_discriminant
  :doc #{The $DISCR_LIST is the discriminant of list values, made of pairs. See also $DISCR_PAIR.}#
  :predef DISCR_LIST
  :obj_num OBMAG_LIST 
  :disc_super discr_any_receiver
  :named_name '"DISCR_LIST")

;;; the discriminant for pairs
(definstance discr_pair class_discriminant
  :doc #{The $DISCR_PAIR is the discriminant of pairs, notably inside lists. See also $DISCR_LIST.}#
  :predef DISCR_PAIR
  :obj_num OBMAG_PAIR 
  :disc_super discr_any_receiver
  :named_name '"DISCR_PAIR")

;;; the discriminant for multiples
(definstance discr_multiple class_discriminant
  :doc #{The $DISCR_MULTIPLE is the discriminant of multiple values, i.e. tuples. 
See also $DISCR_FIELD_SEQUENCE and $DISCR_CLASS_SEQUENCE.}#
  :predef DISCR_MULTIPLE
  :obj_num OBMAG_MULTIPLE
  :disc_super discr_any_receiver
  :named_name '"DISCR_MULTIPLE")

;;; the discriminant for sequence of fields
(definstance discr_field_sequence class_discriminant
  :doc #{The $DISCR_FIELD_SEQUENCE is the discriminant of field
sequence tuple values, e.g. within classes. See also $DISCR_MULTIPLE
and $CLASS_CLASS.}#
  :predef DISCR_FIELD_SEQUENCE
  :obj_num OBMAG_MULTIPLE
  :named_name '"DISCR_FIELD_SEQUENCE"
  :disc_super discr_multiple
  )

;;; the discriminant for boxes
(definstance discr_box class_discriminant
  :doc #{The $DISCR_BOX is the discriminant of box values, containing
a single mutable value. See also $CLASS_CONTAINER.}#
  :predef DISCR_BOX
  :obj_num OBMAG_BOX
  :disc_super discr_any_receiver
  :named_name '"DISCR_BOX")

;;; the discriminant for trees
(definstance discr_tree class_discriminant
  :doc #{The $DISCR_TREE is the discriminant of boxed GCC tree values. See also $CTYPE_TREE.}#
  :predef DISCR_TREE
  :obj_num OBMAG_TREE
  :disc_super discr_any_receiver
  :named_name '"DISCR_TREE")

;;; the discriminant for gimples
(definstance discr_gimple class_discriminant
  :doc #{The $DISCR_GIMPLE is the discriminant of boxed GCC gimple values. See also $CTYPE_GIMPLE.}#
  :predef DISCR_GIMPLE
  :obj_num OBMAG_GIMPLE
  :disc_super discr_any_receiver
  :named_name '"DISCR_GIMPLE")

;;; the discriminant for gimple_seqs
(definstance discr_gimple_seq class_discriminant
  :doc #{The $DISCR_GIMPLE_SEQ is the discriminant of boxed GCC gimple_seq values. See also $CTYPE_GIMPLE_SEQ.}#
  :predef DISCR_GIMPLE_SEQ
  :obj_num OBMAG_GIMPLESEQ
  :disc_super discr_any_receiver
  :named_name '"DISCR_GIMPLE_SEQ")

;;; the discriminant for edges
(definstance discr_edge class_discriminant
  :doc #{The $DISCR_EDGE is the discriminant of boxed GCC edge values. See also $CTYPE_EDGE.}#
  :predef DISCR_EDGE
  :obj_num OBMAG_EDGE
  :disc_super discr_any_receiver
  :named_name '"DISCR_EDGE")

(definstance discr_basic_block class_discriminant
  :doc #{The $DISCR_BASIC_BLOCK is the discriminant of boxed GCC basic_block values. See
also $CTYPE_BASIC_BLOCK.}#
  :predef DISCR_BASIC_BLOCK
  :obj_num OBMAG_BASICBLOCK
  :disc_super discr_any_receiver
  :named_name '"DISCR_BASIC_BLOCK")

;;; the discriminant for maps of objects
(definstance discr_map_objects class_discriminant
  :doc #{The $DISCR_MAP_OBJECTS is the discriminant of hash-map values associating MELT objects to
non-nil value.}#
  :predef DISCR_MAP_OBJECTS
  :obj_num OBMAG_MAPOBJECTS
  :disc_super discr_any_receiver
  :named_name '"DISCR_MAP_OBJECTS")

;;; the discriminant for maps of strings
(definstance discr_map_strings class_discriminant
  :doc #{The $DISCR_MAP_STRINGS is the discriminant of hash-map values associating raw strings to 
non-nil value. See also $CTYPE_CSTRING.}#
  :predef DISCR_MAP_STRINGS
  :obj_num OBMAG_MAPSTRINGS
  :disc_super discr_any_receiver
  :named_name '"DISCR_MAP_STRINGS")

;;; the discriminant for maps of trees
(definstance discr_map_trees class_discriminant
  :doc #{The $DISCR_MAP_TREES is the discriminant of hash-map values associating raw GCC tree-s
to non-nil value. See also $CTYPE_TREE.}#
  :predef DISCR_MAP_TREES
  :obj_num OBMAG_MAPTREES
  :disc_super discr_any_receiver
  :named_name '"DISCR_MAP_TREES")

;;; the discriminant for maps of gimples
(definstance discr_map_gimples class_discriminant
  :doc #{The $DISCR_MAP_GIMPLES is the discriminant of hash-map values associating raw GCC gimple-s 
to non-nil value. See also $CTYPE_GIMPLE.}#
  :predef DISCR_MAP_GIMPLES
  :obj_num OBMAG_MAPGIMPLES
  :disc_super discr_any_receiver
  :named_name '"DISCR_MAP_GIMPLES")

;;; the discriminant for maps of gimple_seqs
(definstance discr_map_gimple_seqs class_discriminant
  :doc #{The $DISCR_MAP_GIMPLE_SEQS is the discriminant of hash-map values associating raw GCC gimple_seq-s 
to non-nil value. See also $CTYPE_GIMPLE_SEQ.}#
  :predef DISCR_MAP_GIMPLE_SEQS
  :obj_num OBMAG_MAPGIMPLESEQS
  :disc_super discr_any_receiver
  :named_name '"DISCR_MAP_GIMPLE_SEQS")

;;; the discriminant for maps of edges
(definstance discr_map_edges class_discriminant
  :doc #{The $DISCR_MAP_EDGES is the discriminant of hash-map values associating raw GCC edge-s 
to non-nil value. See also $CTYPE_EDGE.}#
  :predef DISCR_MAP_EDGES
  :obj_num OBMAG_MAPEDGES
  :disc_super discr_any_receiver
  :named_name '"DISCR_MAP_EDGES")

;;; the discriminant for maps of basic_blocks
(definstance discr_map_basic_blocks class_discriminant
  :doc #{The $DISCR_MAP_BASIC_BLOCKS is the discriminant of hash-map values associating raw GCC basic_block-s 
to non-nil value. See also $CTYPE_BASIC_BLOCK.}#
  :predef DISCR_MAP_BASIC_BLOCKS
  :obj_num OBMAG_MAPBASICBLOCKS
  :disc_super discr_any_receiver
  :named_name '"DISCR_MAP_BASIC_BLOCKS")


;;; the discriminant for PPL constraint system (not predefined)
(definstance discr_ppl_constraint_system class_discriminant
  :obj_num OBMAG_SPECPPL_CONSTRAINT_SYSTEM
  :doc #{The $DISCR_PPL_CONSTRAINT_SYSTEM is the discriminant of boxed PPL constraint systems.}#
  :disc_super discr_any_receiver
  :named_name '"DISCR_PPL_CONSTRAINT_SYSTEM"
  )

;;; the discriminant for PPL polyhedron
(definstance discr_ppl_polyhedron class_discriminant
  :obj_num OBMAG_SPECPPL_POLYHEDRON
  :doc #{The $DISCR_PPL_POLYHEDRON is the discriminant of boxed PPL polyhedra.}#
  :disc_super discr_any_receiver
  :named_name '"DISCR_PPL_POLYHEDRON"
  )

;;; the discriminant for files [closed by the garbage collector] (not
;;; predefined)
(definstance discr_file class_discriminant
  :obj_num OBMAG_SPEC_FILE
  :doc #{The $DISCR_FILE is the discriminant of boxed FILE*, which are fclose-d when the 
boxed value is inaccessible. See also $DISCR_RAWFILE.}#
  :disc_super discr_any_receiver
  :named_name '"DISCR_FILE"
  )

;; the discrimiant for raw files [not closed implicitly] (not
;;; predefined)
(definstance discr_rawfile class_discriminant
  :doc #{The $DISCR_RAWFILE is the discriminant of boxed FILE*, The MELT garbage collector dont
fclose them. See also $DISCR_FILE.}#
  :obj_num OBMAG_SPEC_RAWFILE
  :disc_super discr_file
  :named_name '"DISCR_RAWFILE"
  )


;;; the discriminant for sequence of classes 
(definstance discr_class_sequence class_discriminant
  :doc #{The $DISCR_CLASS_SEQUENCE is the discriminant of class sequence tuple values, e.g. inside classes. 
See also $CLASS_CLASS and $DISCR_MULTIPLE.}#
  :predef DISCR_CLASS_SEQUENCE
  :obj_num OBMAG_MULTIPLE
  :named_name '"DISCR_CLASS_SEQUENCE"
  :disc_super discr_multiple
  )


;;; the discriminant for method dictionnary maps
(definstance discr_method_map class_discriminant
  :doc #{The $DISCR_METHOD_MAP is the discriminant of method
dictionnary maps, associating selector values to closure value. See
also $CLASS_CLASS, $CLASS_SELECTOR, $DISCR_CLOSURE and
$DISCR_MAP_OBJECTS.}#
  :predef DISCR_METHOD_MAP
  :obj_num OBMAG_MAPOBJECTS
  :disc_super discr_map_objects
  :named_name '"DISCR_METHOD_MAP")

;;; the discriminant for charcode integers
(definstance discr_character_integer class_discriminant
  :doc #{The $DISCR_CHARACTER_INTEGER is the discriminant of 'character' boxed integer values. 
See also $DISCR_INTEGER.}#
  :predef DISCR_CHARACTER_INTEGER
  :obj_num OBMAG_INT
  :named_name '"DISCR_CHARACTER_INTEGER"
  :disc_super discr_integer
  )


;;; the discriminant for mixedintegers
(definstance discr_mixed_integer class_discriminant
  :doc #{The $DISCR_MIXED_INTEGER is the discriminant of mixed integer values, 
containing both a number and a value component.}#
  :predef DISCR_MIXED_INTEGER
  :obj_num OBMAG_MIXINT
  :disc_super discr_any_receiver
  :named_name '"DISCR_MIXED_INTEGER")


;;; the discriminant for mixedintegers
(definstance discr_mixed_bigint class_discriminant
  :doc #{The $DISCR_MIXED_BIGINT is the discriminant of mixed bigint values, 
containing both a GMP number and a value component.}#
  :predef DISCR_MIXED_BIGINT
  :obj_num OBMAG_MIXBIGINT
  :disc_super discr_any_receiver
  :named_name '"DISCR_MIXED_BIGINT")



;;; the discriminant for mixed locations
(definstance discr_mixed_location class_discriminant
  :doc #{The $DISCR_MIXED_LOCATION is the discriminant of mixed location values, 
containing both a GCC location and a value component.}#
  :predef DISCR_MIXED_LOCATION
  :obj_num OBMAG_MIXLOC
  :disc_super discr_any_receiver
  :named_name '"DISCR_MIXED_LOCATION")


;;; the discriminant for closures
(definstance discr_closure class_discriminant
  :doc #{The $DISCR_CLOSURE is the discriminant of MELT function closures, i.e. functional values. 
See also $DISCR_ROUTINE.}#
  :predef DISCR_CLOSURE
  :obj_num OBMAG_CLOSURE
  :disc_super discr_any_receiver
  :named_name '"DISCR_CLOSURE")

;;; the discriminant for routines
(definstance discr_routine class_discriminant
  :doc #{The $DISCR_ROUTINE is the discriminant of MELT routine values, which boxes 
the routine pointer and the constants inside MELT function closure values. See also $DISCR_CLOSURE.}#
  :predef DISCR_ROUTINE
  :obj_num OBMAG_ROUTINE
  :disc_super discr_any_receiver
  :named_name '"DISCR_ROUTINE")


;;; by having the install_ctype_descr called inside each ctype
;;; initialization, we are sure it is called once for each, because
;;; ctype-s are predefined
(defun install_ctype_descr (ctyp :cstring descr)
  :doc #{Install a new ctype $CTYP with descriptive string $DESCR. 
Also add the ctype as symbol data in the keyword and the alternate keyword if provided.}#
					;(debug_msg ctyp "install_ctype_descr")
  (assert_msg "check ctyp" (is_a ctyp class_ctype)) 
  (if (unsafe_get_field :ctype_descr ctyp)
      (return))
  (let ( (ckw (unsafe_get_field :ctype_keyword ctyp)) 
	 (altkw (unsafe_get_field :ctype_altkeyword ctyp)) 
	 (ds (make_stringconst discr_string descr))
	 )
    (assert_msg "check ctype ckw" (is_a ckw class_keyword))
    (unsafe_put_fields ckw :symb_data ctyp)
    (if (is_a altkw class_keyword)
	(put_fields altkw :symb_data ctyp))
    ds
    ))


;;; every ctype should be predefined. normexp_defprimitive requires this
;;; while predef are somehow costly, we don't have that much many ctype-s
;;; and each of them nearly requires some code in melt-runtime.h
;;; which should be enhanced for any new ctype
;; the C type for values
(definstance ctype_value class_ctype
  :doc #{The $CTYPE_VALUE is the c-type of any MELT value. See also $DISCR_ANY_RECEIVER, $CLASS_ROOT etc. Keyword is :value.}#
  :predef CTYPE_VALUE
  :named_name  '"CTYPE_VALUE"
  :ctype_keyword ':value
  :ctype_cname  '"melt_ptr_t"
  :ctype_parchar '"BPAR_PTR"
  :ctype_parstring '"BPARSTR_PTR"
  ;; value have to be passed specially, we need to pass the address of the pointer
  :ctype_argfield '"bp_aptr"
  :ctype_resfield '"bp_aptr"
  :ctype_marker '"gt_ggc_mx_melt_un"
  )
(install_ctype_descr ctype_value "any melt value pointer")

;; the C type for long
(definstance ctype_long class_ctype
  :doc #{The $CTYPE_LONG is the c-type of raw long number stuff. See also $DISCR_INTEGER. Keyword is :long.}#
  :predef CTYPE_LONG
  :named_name  '"CTYPE_LONG"
  :ctype_keyword ':long
  :ctype_cname  '"long"
  :ctype_parchar '"BPAR_LONG"
  :ctype_parstring '"BPARSTR_LONG"
  :ctype_argfield '"bp_long"
  :ctype_resfield '"bp_longptr"
  )
(install_ctype_descr ctype_long "C long unboxed integer")

;; the C type for gcc trees
(definstance ctype_tree class_ctype
  :doc #{The $CTYPE_TREE is the c-type of raw GCC tree stuff. See also $DISCR_TREE. Keyword is :tree.}#
  :predef CTYPE_TREE
  :named_name  '"CTYPE_TREE"
  :ctype_keyword ':tree
  :ctype_cname  '"tree"
  :ctype_parchar '"BPAR_TREE"
  :ctype_parstring '"BPARSTR_TREE"
  :ctype_argfield '"bp_tree"
  :ctype_resfield '"bp_treeptr"
  :ctype_marker '"gt_ggc_mx_tree_node"
  )
(install_ctype_descr ctype_tree "GCC tree pointer")

;; the C type for gcc gimples
(definstance ctype_gimple class_ctype
  :doc #{The $CTYPE_GIMPLE is the c-type of raw GCC gimple stuff. See also $DISCR_GIMPLE. Keyword is :gimple.}#
  :predef CTYPE_GIMPLE
  :named_name  '"CTYPE_GIMPLE"
  :ctype_keyword ':gimple
  :ctype_cname '"gimple"
  :ctype_parchar '"BPAR_GIMPLE"
  :ctype_parstring '"BPARSTR_GIMPLE"
  :ctype_argfield '"bp_gimple"
  :ctype_resfield '"bp_gimpleptr"
  :ctype_marker '"gt_ggc_mx_gimple_statement_d"
  )
(install_ctype_descr ctype_gimple "GCC gimple pointer")

;; the C type for gcc gimple_seqs
(definstance ctype_gimple_seq class_ctype
  :doc #{The $CTYPE_GIMPLE_SEQ is the c-type of raw GCC gimple_seq stuff. See also $DISCR_GIMPLE_SEQ. 
Keyword is :gimple_seq.}#
  :predef CTYPE_GIMPLE_SEQ
  :named_name  '"CTYPE_GIMPLE_SEQ"
  :ctype_keyword ':gimple_seq
  ; :ctype_altkeyword ':gimpleseq
  :ctype_cname  '"gimple_seq"
  :ctype_parchar '"BPAR_GIMPLESEQ"
  :ctype_parstring '"BPARSTR_GIMPLESEQ"
  :ctype_argfield '"bp_gimpleseq"
  :ctype_resfield '"bp_gimpleseqptr"
  :ctype_marker '"gt_ggc_mx_gimple_seq_d"
  )
(install_ctype_descr ctype_gimple_seq "GCC gimpleseq pointer")

;; the C type for gcc basic_blocks
(definstance ctype_basic_block class_ctype
  :doc #{The $CTYPE_BASIC_BLOCK is the c-type of raw GCC basic_block stuff. See also $DISCR_BASIC_BLOCK.
Keyword is :basic_block.}#
  :predef CTYPE_BASIC_BLOCK
  :named_name  '"CTYPE_BASIC_BLOCK"
  :ctype_keyword ':basic_block
  ; :ctype_altkeyword ':basicblock
  :ctype_cname  '"basic_block"
  :ctype_parchar '"BPAR_BB"
  :ctype_parstring '"BPARSTR_BB"
  :ctype_argfield '"bp_bb"
  :ctype_resfield '"bp_bbptr"
  :ctype_marker '"gt_ggc_mx_basic_block_def"
  )
(install_ctype_descr ctype_basic_block "GCC basic_block")

;; the C type for gcc edges
(definstance ctype_edge class_ctype
  :doc #{The $CTYPE_EDGE is the c-type of raw GCC edge stuff. See also $DISCR_EDGE.
Keyword is :edge.}#
  :predef CTYPE_EDGE
  :named_name  '"CTYPE_EDGE"
  :ctype_keyword ':edge
  :ctype_cname '"edge"
  :ctype_parchar '"BPAR_EDGE"
  :ctype_parstring '"BPARSTR_EDGE"
  :ctype_argfield '"bp_edge"
  :ctype_resfield '"bp_edgeptr"
  :ctype_marker '"gt_ggc_mx_edge_def"
  )
(install_ctype_descr ctype_edge "GCC edge")

;;; the ctype for PPL coefficients
(definstance ctype_ppl_coefficient class_ctype
  :predef CTYPE_PPL_COEFFICIENT
  :doc #{The $CTYPE_PPL_COEFFICIENT is the c-type of raw PPL coefficient stuff. See also $DISCR_PPL_POLYHEDRON.
Keyword is :ppl_coefficient.}#
  :named_name '"CTYPE_PPL_COEFFICIENT"
  :ctype_keyword ':ppl_coefficient
  :ctype_cname  '"ppl_Coefficient_t"
  :ctype_parchar '"BPAR_PPL_COEFFICIENT"
  :ctype_parstring '"BPARSTR_PPL_COEFFICIENT"
  :ctype_argfield '"bp_ppl_coefficient"
  :ctype_resfield '"bp_ppl_coefficientptr"
)
(install_ctype_descr ctype_ppl_coefficient "PPL coefficient")

;;;; PPL linear expressions
(definstance ctype_ppl_linear_expression class_ctype
  :predef CTYPE_PPL_LINEAR_EXPRESSION
  :doc #{The $CTYPE_PPL_LINEAR_EXPRESSION is the c-type of raw PPL linear expression stuff.
Keyword is :ppl_linear_expression.}#
  :named_name '"CTYPE_PPL_LINEAR_EXPRESSION"
  :ctype_keyword ':ppl_linear_expression
  :ctype_cname  '"ppl_Linear_Expression_t"
  :ctype_parchar '"BPAR_PPL_LINEAR_EXPRESSION"
  :ctype_parstring '"BPARSTR_PPL_LINEAR_EXPRESSION"
  :ctype_argfield '"bp_ppl_linear_expression"
  :ctype_resfield '"bp_ppl_linear_expressionptr"
)
(install_ctype_descr ctype_ppl_linear_expression "PPL linear expression")

;;; the ctype for PPL constraints
(definstance ctype_ppl_constraint class_ctype
  :predef CTYPE_PPL_CONSTRAINT
  :doc #{The $CTYPE_PPL_CONSTRAINT is the c-type of raw PPL constraint stuff.
Keyword is :ppl_constraint.}#
  :named_name '"CTYPE_PPL_CONSTRAINT"
  :ctype_keyword ':ppl_constraint
  :ctype_cname  '"ppl_Constraint_t"
  :ctype_parchar '"BPAR_PPL_CONSTRAINT"
  :ctype_parstring '"BPARSTR_PPL_CONSTRAINT"
  :ctype_argfield '"bp_ppl_constraint"
  :ctype_resfield '"bp_ppl_constraintptr"
)
(install_ctype_descr ctype_ppl_constraint "PPL constraint")

;;; the ctype for PPL constraint_systems
(definstance ctype_ppl_constraint_system class_ctype
  :predef CTYPE_PPL_CONSTRAINT_SYSTEM
  :doc #{The $CTYPE_PPL_CONSTRAINT_SYSTEM is the c-type of raw PPL constraint system stuff.
Keyword is :ppl_constraint_system.}#
  :named_name '"CTYPE_PPL_CONSTRAINT_SYSTEM"
  :ctype_keyword ':ppl_constraint_system
  :ctype_cname  '"ppl_Constraint_System_t"
  :ctype_parchar '"BPAR_PPL_CONSTRAINT_SYSTEM"
  :ctype_parstring '"BPARSTR_PPL_CONSTRAINT_SYSTEM"
  :ctype_argfield '"bp_ppl_constraint_system"
  :ctype_resfield '"bp_ppl_constraint_systemptr"
)
(install_ctype_descr ctype_ppl_constraint_system "PPL constraint_system")

;;; the ctype for PPL polyhedra (=polyhedrons)
(definstance ctype_ppl_polyhedron class_ctype
  :predef CTYPE_PPL_POLYHEDRON
  :named_name '"CTYPE_PPL_POLYHEDRON"
  :doc #{The $CTYPE_PPL_POLYHEDRON is the c-type of raw PPL polyhedron stuff.
Keyword is :ppl_polyhedron.}#
  :ctype_keyword ':ppl_polyhedron
  :ctype_cname  '"ppl_Polyhedron_t"
  :ctype_parchar '"BPAR_PPL_POLYHEDRON"
  :ctype_parstring '"BPARSTR_PPL_POLYHEDRON"
  :ctype_argfield '"bp_ppl_polyhedron"
  :ctype_resfield '"bp_ppl_polyhedronptr"
)
(install_ctype_descr ctype_ppl_polyhedron "PPL polyhedron")

;;;;;;;;;;;;;;;;
;; the C type for void
(definstance ctype_void class_ctype
  :predef CTYPE_VOID
  :doc #{The $CTYPE_VOID is the c-type of void stuff, used for expressions, e.g. primitive invocations, 
with only a side effect and no results. Keyword is :void but cannot be used to type an argument or a result.}#
  :named_name  '"CTYPE_VOID"
  :ctype_keyword ':void
  :ctype_cname  '"void"
  ;; void is never passed as argument or as extra result
  )
(install_ctype_descr ctype_void "void type for side-effecting primitives without results")

;; the C type for constant C strings
(definstance ctype_cstring class_ctype
  :doc #{The $CTYPE_CSTRING is the c-type of raw C string [const char*] stuff. See also DISCR_STRING.
Keyword is :cstring.}#
  :predef CTYPE_CSTRING
  :named_name  '"CTYPE_CSTRING"
  :ctype_keyword ':cstring
  :ctype_cname  (stringconst2val discr_name_string "const char*")
  :ctype_parchar '"BPAR_CSTRING"
  :ctype_parstring '"BPARSTR_CSTRING"
  :ctype_argfield '"bp_cstring"
  )
(install_ctype_descr ctype_cstring "C constant strings (statically allocated outside of any heap)")



;; function to add a new symbol [called by meltgc_named_symbol in the runtime]
(defun add_new_symbol_token (syda str)
  (assert_msg "check syda" (is_a syda class_system_data))
  (let ( (sy (instance class_symbol :named_name str)) 
	 (sydict (unsafe_get_field :sysdata_symboldict syda))
	 )
    (mapstring_putstr sydict str sy)
    sy))

;; function to add a new keyword [called by meltgc_named_keyword in the runtime]
(defun add_new_keyword_token (syda str)
  (assert_msg "check syda" (is_a syda class_system_data))
  (let ( (kw (instance class_keyword :named_name str)) 
	 (kwdict (unsafe_get_field :sysdata_keywdict syda))
	 )
    (mapstring_putstr kwdict str kw)
    kw))

;; function to intern a symbol (or return the previous one)
(defun intern_symbol (inidat symb)
  (assert_msg "check inidat" (is_a inidat class_system_data))
  (assert_msg "check sym" (is_a symb class_symbol))
  (let ( (syname (unsafe_get_field :named_name symb)) 
	 (sydict (unsafe_get_field :sysdata_symboldict inidat))
	 (oldsy (mapstring_getstr sydict syname)) )
    (if oldsy 
	oldsy 
      (progn 
	(mapstring_putstr sydict syname symb) 
					;		(messageval_dbg "warm interning symbol" symb)
	symb))
    ))


;; function to intern a keyword (or return the previous one)
(defun intern_keyword (inidat keyw)
  (assert_msg "check inidat" (is_a inidat class_system_data))
  (assert_msg "check keyw" (is_a keyw class_keyword))
  (let ( (kwname (unsafe_get_field :named_name keyw)) 
	 (kwdict (unsafe_get_field :sysdata_keywdict inidat))
	 (oldkw (mapstring_getstr kwdict kwname)) )
    (if oldkw 
	oldkw
      (progn (mapstring_putstr kwdict kwname keyw) keyw))
    ))

;;; container of a mapstring for cloning symbol, maping symbol names to boxed integer
(definstance container_clonemapstring class_container
  :container_value (make_mapstring discr_map_strings 200)
  )

(defun clone_symbol (symb)
  :doc #{Function to clone a given symbol or string $SYMB, producing a new instance of class_cloned_symbol}#
  (let ( (mapstr (unsafe_get_field :container_value container_clonemapstring)) 
	 (synam
	  (cond
	   ( (is_string symb) 
	     symb)
	   ( (is_a symb class_named) 
	     (unsafe_get_field :named_name symb))
	   (:else 
	    (let ( (discrinam (get_field :named_name (discrim symb)))
		   )
	      (warningmsg_strv "clone_symbol got invalid argument of discriminant" 
			       discrinam)
	      (shortbacktrace_dbg "clone_symbol error.." 15)
	      (debug_msg symb "clone_symbol bad symb")
	      (messageval_dbg "clone_symbol symn not named or string" symb)
	      (let ( (:cstring namcstr (the_null_cstring)
			       ) )
		(code_chunk clonamstr
		      #{
		      static char clonambuf[100];
		      const char *s = melt_string_str ($discrinam);
		      if (s) s = strchr(s, '_');
		      if (!s) s = "_What";
		      memset (clonambuf, 0, sizeof(clonambuf));
		      snprintf (clonambuf, 
				sizeof(clonambuf)-1,
				"Cloned_Melt%s", s);
		      $namcstr = clonambuf;	    
		      }#
		      )
		(make_stringconst discr_string namcstr)
		)))
	   ))
	 (boxi (mapstring_getstr mapstr synam)) )
    (assert_msg "check synam" (is_string synam))
    (if (not (is_integerbox boxi))
	(progn 
	  (setq boxi (make_integerbox discr_integer 0))
	  (mapstring_putstr mapstr synam boxi)))
    (let ( (:long i (get_int boxi)) )
      (setq i (+i i 1))
      (put_int boxi i)
      (instance class_cloned_symbol
		:named_name synam
		:csym_urank (make_integerbox discr_integer i)))))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; initial fresh environment container maker - inside INITIAL_SYSTEM_DATA
(defun initfresh_contenvmaker (prevenv :cstring modnam)
  (if (need_dbg 0) 
      (shortbacktrace_dbg "initfresh_contenvmaker" 15))
  (let (
	(descr (if modnam (make_stringconst discr_string modnam)))
	(newenv (fresh_env prevenv descr)) 
	(newcont (instance class_container 
			   :container_value newenv))
	)
					;(debug_msg newcont "initfresh_contenvmaker result newcont")
    (return newcont)
    ))

;; initial value exporter - inside INITIAL_SYSTEM_DATA
(defun initvalue_exporter (sym val contenv)
  ;;(debug_msg sym "initvalue_exporter sym")
  ;;(debug_msg val "initvalue_exporter val")
  ;;(debug_msg contenv "initvalue_exporter contenv")
  ;;(if (need_dbg 0) 
  ;;    (shortbacktrace_dbg "initvalue_exporter" 15))
  (let ( (parenv (parent_module_environment)) )
    (if (null contenv)
	(progn
	  (if parenv
	      (warningmsg_strv "exporting value too early with null environment container"  (unsafe_get_field :named_name sym)))
	  (return)
	  ))
    (assert_msg "check sym" (is_a sym class_symbol))
    (assert_msg "check contenv" (is_a contenv class_container))
    (let ( (env (unsafe_get_field :container_value contenv)) )
      (if  (and (null env) parenv)
	  (progn
	    (informsg_strv "exporting value too early with null environment" (unsafe_get_field :named_name sym))
	    (return)
	    ))
      (assert_msg "check good env" (is_a env class_environment))
      (let (
	    (prevbind (if parenv (find_env parenv sym)))
	    (valbind (instance
		      class_value_binding
		      :binder sym
		      :vbind_value val
		      )) 
	    (symnam (unsafe_get_field :named_name sym))
	    )
	(cond 
	 ( (null prevbind) () )
	 ( (and 
	    (is_a prevbind class_selector_binding)
	    (is_a val class_selector))
	   (warningmsg_strv "not exporting previous bound selector" symnam)
	   (return))
	 ( (and
	    (is_a prevbind class_instance_binding)
	    (is_object val))
	   (warningmsg_strv "not exporting previous bound instance" symnam)
	   (return))
	 ( (and
	    (is_a prevbind class_primitive_binding)
	    (is_a val class_primitive))
	   (warningmsg_strv "not exporting previous bound primitive" symnam)
	   (return))
	 ( (and
	    (is_a prevbind class_function_binding)
	    (is_closure val))
	   (warningmsg_strv "not exporting previous bound function" symnam)
	   (return))
	 ( (and
	    (is_a prevbind class_class_binding)
	    (is_a val class_class))
	   (warningmsg_strv "not exporting previous bound class" symnam)
	   (return))
	 ( (and
	    (is_a prevbind class_field_binding)
	    (is_a val class_class))
	   (warningmsg_strv "not exporting previous bound field" symnam)
	   (return)
	   )
	 ( (and
	    (is_a prevbind class_instance_binding)
	    (is_object val))
	   (warningmsg_strv "not exporting previous bound instance" symnam)
	   (return)
	   )
	 (  (is_a prevbind class_value_binding)
	    (let ( (preval (unsafe_get_field :vbind_value prevbind))
		   (prevdiscr (discrim preval))
		   (curdiscr (discrim val))
		   )
	      (if (== prevdiscr curdiscr)
		  (progn
		    (warningmsg_strv "not exporting previous bound homogenous value" symnam)
		    (warningmsg_strv "common value discrim" 
				     (unsafe_get_field :named_name prevdiscr))
		    (return)))
	      ))
	 )
	(assert_msg "check valbind" (is_a valbind class_any_binding))
	(put_env env valbind)
	(return)
	))))


;; initial value importer - inside INITIAL_SYSTEM_DATA
(defun initvalue_importer (sym parenv :cstring strnam modnam)
  (code_chunk ensuremodnam #{ /* $ensuremodnam */ if (!$modnam) $modnam = "???"; 
	      }#)
  (if (is_not_a sym class_symbol)
      (progn
	(debug_msg sym "initvalue_importer bad symb")
	(code_chunk errfailimport 
		    #{ /* $errfailimport */ 
		    if ($strnam)
		      error ("MELT [%s]: imported symbol %s not found",
				 $modnam, $strnam);
		    else
		      error ("MELT [%s]: importing non symbol", $modnam);
		    }#)
	(return)
	))
  (assert_msg "check sym" (is_a sym class_symbol))
  (assert_msg "check parenv" (is_a parenv class_environment))
  (let ( (valbind (find_env parenv sym))
	 )
    (if (is_not_a valbind class_value_binding)
	(let ( (symnam (get_field :named_name sym)) 
	       (bindiscr (discrim valbind))
	       (bindiscrnam (get_field :named_name bindiscr))
	       )
	  (assert_msg "check symnam" (is_string symnam))
	  (code_chunk errbadimport 
		      #{ /* $errbadimport */
		      const char* $errbadimport#_str = melt_string_str ((melt_ptr_t)$symnam);
		      error ("MELT [%s]: imported symbol %s has unexpected binding of %s",
			     $modnam,
			     $errbadimport#_str?$errbadimport#_str:$strnam,
			     melt_string_str ((melt_ptr_t)$bindiscrnam));
		    }#)
	  (return)
	  ))
    (assert_msg "check valbind" (is_a valbind class_value_binding))
    (return (unsafe_get_field :vbind_value valbind))
    ))

;; initial macro exporter - inside INITIAL_SYSTEM_DATA
(defun initmacro_exporter (sym val contenv)
  (assert_msg "check sym" (is_a sym class_symbol))
  (if (null contenv)
      (progn
	(if (parent_module_environment)
	    (warningmsg_strv "exporting macro too early with null environment container" 
			     (unsafe_get_field :named_name sym)))
	(return)
	))
  (assert_msg "check contenv" (is_a contenv class_container))
  (let ( (env (unsafe_get_field :container_value contenv)) )
					;(if (need_dbg 0) (shortbacktrace_dbg "initmacro_exporter" 15))
    (if (null env)
	(progn
	  (informsg_strv "exporting macro too early with null environment"
			 (unsafe_get_field :named_name sym))
	  (return)
	  ))
    (assert_msg "check env" (is_a env class_environment))
    (assert_msg "check val is closure" (is_closure val))
    (let ( (macbind (instance
		     class_macro_binding
		     :binder sym
		     :mbind_expanser val))
	   )
      (put_env env macbind)
      (debug_msg macbind "initmacro_exporter macbind")
      (return)
      )))

;; initial patmacro exporter - inside INITIAL_SYSTEM_DATA
(defun initpatmacro_exporter (sym macval patval contenv)
  (debug_msg sym "initpatmacro_exporter sym")
  (assert_msg "check sym" (is_a sym class_symbol))
  (if (null contenv)
      (progn
	;;(if (parent_module_environment)
	;;    (warningmsg_strv "exporting patmacro too early with null environment container" 
	;;		     (unsafe_get_field :named_name sym)))
	(return)
	))
  (assert_msg "check contenv" (is_a contenv class_container))
  (let ( (env (unsafe_get_field :container_value contenv)) )
    (if (null env)
	(progn
	  (informsg_strv "exporting patmacro too early with null environment"
			 (unsafe_get_field :named_name sym))
	  (return)
	  ))
    (assert_msg "check env" (is_a env class_environment))
    (assert_msg "check macval is closure" (is_closure macval))
    (assert_msg "check patval is closure" (is_closure patval))
    (let ( (macbind (instance
		     class_patmacro_binding
		     :binder sym
		     :mbind_expanser macval
		     :patbind_expanser patval))
	   )
      (put_env env macbind)
      (debug_msg macbind "initpatmacro_exporter macbind")
      (return)
      )))


;; internal non-exported class for delayed queues.
(defclass class_delayed_queue
  :super class_named
  :fields (delqu_first
	   delqu_last
	   delqu_data
	   ))

;; private final queue
(definstance final_delayed_queue class_delayed_queue
  :named_name '"final_delayed_queue"
  :delqu_first (make_list discr_list)
  :delqu_last (make_list discr_list)
  )


;;;;;; the queue for full exit
(defun init_exitfinalizer ()
  (debug_msg final_delayed_queue "init_exitfinalizer final_delayed_queue at start")
  (let ( (firstlist (unsafe_get_field :delqu_first final_delayed_queue))
	 (lastlist (unsafe_get_field :delqu_last final_delayed_queue))
	 (revlastlist (make_list discr_list))
	 (rescont (instance class_container))
	 )
;;; call the first routines in natural order
    (list_every 
     firstlist
     (lambda (firstproc)
       (let ( (prevres (unsafe_get_field :container_value rescont)) 
	      (nextres (firstproc prevres final_delayed_queue))
	      )
	 (unsafe_put_fields rescont :container_value nextres)
	 )))
;;; reverse the last list
    (list_every 
     lastlist 
     (lambda (lastproc)
       (if (is_closure lastproc) (list_prepend revlastlist lastproc))))
;;; call the last routines in reverse order
    (list_every
     revlastlist
     (lambda (lastproc)
       (let ( (prevres (unsafe_get_field :container_value rescont)) 
	      (nextres (lastproc prevres final_delayed_queue))
	      )
	 (unsafe_put_fields rescont :container_value nextres)
	 )))
    (debug_msg rescont "init_exitfinalizer ending rescont")
    ))


(defun at_exit_first (fun)
  :doc #{Use $AT_EXIT_FIRST to register a function to be run at MELT
exit, in first place.}#
  (let ( (firstlist (unsafe_get_field :delqu_first final_delayed_queue))
	 )
    (if (is_closure fun) (list_append firstlist fun)))
  )  

(defun at_exit_last (fun)
  :doc #{Use $AT_EXIT_LAST to register a function to be run at MELT
exit, in last place.}#
  (let ( (lastlist (unsafe_get_field :delqu_last final_delayed_queue))
	 )
    (if (is_closure fun) (list_append lastlist fun)))
  )

;;;;;; private queue for start of compilation unit
(definstance start_unit_delayed_queue class_delayed_queue
  :named_name '"start_unit_delayed_queue"
  :delqu_first (make_list discr_list)
  :delqu_last (make_list discr_list)
  )


(defun init_unitstarter ()
  (debug_msg start_unit_delayed_queue "init_unitstarter start_unit_delayed_queue at start")
  (let ( (firstlist (unsafe_get_field :delqu_first start_unit_delayed_queue))
	 (lastlist (unsafe_get_field :delqu_last start_unit_delayed_queue))
	 (revlastlist (make_list discr_list))
	 (rescont (instance class_container))
	 )
;;; call the first routines in natural order
    (list_every 
     firstlist
     (lambda (firstproc)
       (let ( (prevres (unsafe_get_field :container_value rescont)) 
	      (nextres (firstproc prevres start_unit_delayed_queue))
	      )
	 (unsafe_put_fields rescont :container_value nextres)
	 )))
;;; reverse the last list
    (list_every 
     lastlist 
     (lambda (lastproc)
       (if (is_closure lastproc) (list_prepend revlastlist lastproc))))
;;; call the last routines in reverse order
    (list_every
     revlastlist
     (lambda (lastproc)
       (let ( (prevres (unsafe_get_field :container_value rescont)) 
	      (nextres (lastproc prevres start_unit_delayed_queue))
	      )
	 (unsafe_put_fields rescont :container_value nextres)
	 )))
    (debug_msg rescont "init_unitstarter ending rescont")
    ))


(defun at_start_unit_first (fun)
  :doc #{Use $AT_START_UNIT_FIRST to register a function to be run at start of translation unit, in first place.}#
  (let ( (firstlist (unsafe_get_field :delqu_first start_unit_delayed_queue))
	 )
    (if (is_closure fun) (list_append firstlist fun)))
  )  

(defun at_start_unit_last (fun)
  :doc #{Use $AT_START_UNIT_LAST to register a function to be run at start of translation unit, in first place.}#
  (let ( (lastlist (unsafe_get_field :delqu_last start_unit_delayed_queue))
	 )
    (if (is_closure fun) (list_append lastlist fun)))
  )


;;;; the private queue for compilation unit finish
(definstance finish_unit_delayed_queue class_delayed_queue
  :named_name '"finish_unit_delayed_queue"
  :delqu_first (make_list discr_list)
  :delqu_last (make_list discr_list)
  )

(defun init_unitfinisher ()
  (debug_msg finish_unit_delayed_queue "init_unitfinisher finish_unit_delayed_queue at start")
  (let ( (firstlist (unsafe_get_field :delqu_first finish_unit_delayed_queue))
	 (lastlist (unsafe_get_field :delqu_last finish_unit_delayed_queue))
	 (revlastlist (make_list discr_list))
	 (rescont (instance class_container))
	 )
;;; call the first routines in natural order
    (list_every 
     firstlist
     (lambda (firstproc)
       (let ( (prevres (unsafe_get_field :container_value rescont)) 
	      (nextres (firstproc prevres finish_unit_delayed_queue))
	      )
	 (unsafe_put_fields rescont :container_value nextres)
	 )))
;;; reverse the last list
    (list_every 
     lastlist 
     (lambda (lastproc)
       (if (is_closure lastproc) (list_prepend revlastlist lastproc))))
;;; call the last routines in reverse order
    (list_every
     revlastlist
     (lambda (lastproc)
       (let ( (prevres (unsafe_get_field :container_value rescont)) 
	      (nextres (lastproc prevres finish_unit_delayed_queue))
	      )
	 (unsafe_put_fields rescont :container_value nextres)
	 )))
    (debug_msg rescont "init_unitfinisher ending rescont")
    ))


(defun at_finish_unit_first (fun)
  :doc #{Use $AT_FINISH_UNIT_FIRST to register a function to be run at
end of compilation unit in first place}#
  (let ( (firstlist (unsafe_get_field :delqu_first finish_unit_delayed_queue))
	 )
    (if (is_closure fun) (list_append firstlist fun)))
  )  

(defun at_finish_unit_last (fun)
  :doc #{Use $AT_FINISH_UNIT_LAST to register a function to be run at
end of compilation unit in last place}#
  (let ( (lastlist (unsafe_get_field :delqu_last finish_unit_delayed_queue))
	 )
    (if (is_closure fun) (list_append lastlist fun)))
  )

;;;;;;;;;;;;;;;;;;;;;;;; debug message function

;; this is a rarely used function
(defun display_debug_message (val :cstring msgstr :long count)
  :doc #{Display in a debug-style the value $VAL with message raw string $MSGSTR and counter $COUNT. Rarely useful.}#
  (let ( (:long dbgcounter 0)
	 (sbuf (make_strbuf discr_strbuf)) 
	 (occmap (make_mapobject discr_map_objects 50))
	 (boxedmaxdepth (make_integerbox discr_integer 14))
	 (dbgi (instance class_debug_information
			 :dbgi_out sbuf
			 :dbgi_occmap occmap
			 :dbgi_maxdepth boxedmaxdepth))
	 )
    (code_chunk setdbgcounter #{$dbgcounter= ++melt_dbgcounter}#)
    (outnum_err "!*!#" dbgcounter "/")
    (outnum_err "" (-i (the_framedepth) 1) ":")
    (outcstring_err msgstr)
    (if (>i count 0) (outnum_err " !" count ": "))
    (dbg_output val dbgi 0)
    (outstrbuf_err sbuf)
    (outnewline_err)
    ))


;;;;
;; this function is inside INITIAL_SYSTEM_DATA and is internally used by the debug_msg macro
(defun debugmsg (val :cstring msgstr :long count)
  (if (need_dbg 0) 
      (let ( (:long dbgcounter 0)
	     (sbuf (make_strbuf discr_strbuf)) 
	     (occmap (make_mapobject discr_map_objects 53))
	     (boxedmaxdepth (make_integerbox discr_integer 10)) ;;;; @@@ DEBUGDEPTH
	     (dbgi (instance class_debug_information
			     :dbgi_out sbuf
			     :dbgi_occmap occmap
			     :dbgi_maxdepth boxedmaxdepth))
	     )
	(code_chunk setdbgcounter #{$dbgcounter= ++melt_dbgcounter}#)
	(outnum_dbg "!!!***###" dbgcounter "/")
	(outnum_dbg "" (-i (the_framedepth) 1) ":")
	(outcstring_dbg msgstr)
	(if (>i count 0) (outnum_dbg " !" count ": "))
	(dbg_out val dbgi 0)
	(outstrbuf_dbg sbuf)
	(outnewline_dbg)
	)))

;;;;;;;;;;;;;;;;;;;; initial system data 
(definstance initial_system_data class_system_data
  :doc #{The $INITIAL_SYSTEM_DATA is the unique instance of
$CLASS_SYSTEM_DATA. Only for gurus. It normally should not be
accessed or updated but is intenally useful to many MELT mechanisms.}#
  :predef INITIAL_SYSTEM_DATA
  :named_name '"INITIAL_SYSTEM_DATA"
  :sysdata_mode_dict  (make_mapstring discr_map_strings 40) ;stringmap for modes
  :sysdata_cont_fresh_env initfresh_contenvmaker	;fresh environment maker in module
  :sysdata_value_exporter initvalue_exporter ;value exporter in module
  :sysdata_macro_exporter initmacro_exporter ;macro exporter in module
  :sysdata_symboldict  (make_mapstring discr_map_strings 600) ;stringmap for symbols
  :sysdata_keywdict  (make_mapstring discr_map_strings 100) ;stringmap for keywords
  :sysdata_addsymbol  add_new_symbol_token ;closure to add a symbol of given name
  :sysdata_addkeyw add_new_keyword_token ;closure to add a keyword of given name
  :sysdata_internsymbol	intern_symbol	 ;closure to intern a symbol
  :sysdata_internkeyw intern_keyword	 ;closure to intern a keyword
  :sysdata_value_importer initvalue_importer
  :sysdata_pass_dict (make_mapstring discr_map_strings 100) ;stringmap for gcc passes
  :sysdata_exit_finalizer init_exitfinalizer
  :sysdata_patmacro_exporter initpatmacro_exporter ; patmacro exporter in module
  :sysdata_debugmsg debugmsg
  :sysdata_stdout ()			;initialized later
  :sysdata_stderr ()			;initialized later
  :sysdata_dumpfile ()			;initialized late
  :sysdata_unit_starter init_unitstarter
  :sysdata_unit_finisher init_unitfinisher
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; general purpose utility functions



;;; iterate fully in map of objects 
(defun mapobject_every (map f)
  :doc #{For a given hash-map of objects $MAP and a function $F,
apply $F to every attribute object and value in the map. Returns
nil.}#
  (if (is_mapobject map)
      (if (is_closure f)
	  (foreach_in_mapobject 
	   (map)
	   (curat  curval)
	   (f curat curval))
	)))

;;; iterate & test over a map of objects - if the called f returns nil
;;; (with perhaps a secondary value result) the iteration is stopped
;;; and returns the "failing" attr, value, & f's secundary result
(defun mapobject_iterate_test (map f)
  :doc #{With a given object hash-map $MAP and function $F which
  returns a boolean [=nil or not] test value and perhaps a secundary other value,
  iterate on the map and apply $F to every attribute and value in the
  $MAP. If $F returns a nil primary result, stop the iteration, and
  return the failed attribute, associated value, and an eventual other
  secundary results value returned by $F.}#
  (if (is_mapobject map)
      (if (is_closure f)
	  (foreach_in_mapobject 
	   (map)
	   (curat curval)
	   (multicall 
	    (test other)
	    (f curat curval)
	    (if (null test)
		(return curat curval other)))))))


;;; iterate fully in a map of strings
(defun mapstring_every (map f)
  :doc #{For a given hash-map of strings $MAP and a function $F,
apply $F to every attribute object and [perhaps allocated] string value. Returns
nil.}#
  (if (is_mapstring map)
      (if (is_closure f)
	  (foreach_in_mapstring
	   (map)
	   (curat curval)
	   (f curat curval)))))

;;; iterate & test over a map of strings - if the called f returns nil the
;;; iteration is stopped
(defun mapstring_iterate_test (map f)
  :doc #{For a given hash-map of strings $MAP and a function $F, apply
$F to every attribute object and string value. If it returns a null
value, with an other secundary value, gives the failing attribute, its
value, and the other.}#
  (if (is_mapstring map)
      (if (is_closure f)
	  (foreach_in_mapstring
	   (map)
	   (curat curval)
	   (multicall 
	    (test other)
	    (f curat curval)
	    (if (null test)
		(return curat curval other)
	   ))))))

;;;;;;;;;;;;;;;;


;;; citerator on lists
(defciterator foreach_in_list 
  (lis)					;start formals 
  eachlist				;state
  (curpair curcomp)			;local formals
  :doc #{The $FOREACH_IN_LIST iterator goes within a list, given by
the start formal $LIS. Local formals are $CURPAIR, bound to the
current pair, and $CURCOMP, bound to the current component within the
list.}#
   #{/* start $eachlist */
   for ($curpair = melt_list_first($lis);
	melt_magic_discr($curpair) == OBMAG_PAIR;
        $curpair = melt_pair_tail($curpair)) {
	$curcomp = melt_pair_head($curpair); }#
   #{ } /* end $eachlist */}#
)

;;; full iterator on a list
(defun list_every (lis f)
  :doc #{Given a list $LIS and a function $F, apply $F to every element of the list. Return nil.}#
  (if (is_list lis)
      (if (is_closure f)
	  (foreach_in_list
	   (lis)
	   (curpair curcomp)
	   (f curcomp)
	   ))))

;;; iterator on a list, if the called f returns nil the iteration is stopped
(defun list_iterate_test (lis f)
  :doc #{Given a list $LIS and a function $F, apply $F to every
  element and its pair in the list. If it returns nil with an other
  secondary value, return the element and the other.}#
  (if (is_list lis)
      (if (is_closure f)
	  (foreach_in_list
	   (lis)
	   (curpair curcomp)
	   (multicall
	    (test other)
	    (f curcomp curpair)
	    (if (null test) (return curcomp other))
	    )))))

;; add to a destination list a source list
(defun list_append2list (dlist slist)
  :doc #{Add to the destination list $DLIST the source list $SLIST:
add every element of the source list at end of the destination. Return
the $DLIST.}#
  (if (not (is_list slist)) (return dlist))
  (if (not (is_list dlist)) (setq dlist (make_list discr_list)))
  (foreach_in_list
   (slist)
   (curpair curcomp)
   (list_append dlist curcomp))
  (return dlist))



;;; map on a list (list_map lis f) where lis is (e1 ... en) is ((f e1) .... (f en))
(defun list_map (lis f)
  (if (is_list lis)
      (if (is_closure f)
	  (let ( (reslis (make_list discr_list)) 
		 (curpair (list_first lis)) )
	    (forever lisloop
		     (if (not (is_pair curpair)) (exit lisloop reslis))
		     (let ( (curelem (pair_head curpair)) )
		       (list_append reslis (f curelem)))
		     (setq curpair (pair_tail curpair)))
	    ))))


;; find in a list LIS an element E verifying F E X or E == X if F is null
(defun list_find (lis x f)
  (if (is_list lis)
      (let ( (curpair (list_first lis)) )
	(if (is_closure f)
	    (forever lisloop
		     (if (not (is_pair curpair)) (exit lisloop))
		     (let ( (curelem (pair_head curpair)) 
			    (t (f curelem x)) )
		       (if t (return t))
		       (setq curpair (pair_tail curpair)))
		     )
	  (forever memloop
		   (if (not (is_pair curpair)) (exit memloop))
		   (let ( (curelem (pair_head curpair)) )
		     (if (== curelem x) (return curelem))
		     (setq curpair (pair_tail curpair)))
		   )
	  )
	)))
 
;;; translate a list to a multiple - with each element transformed by a function f (default the identity)
(defun list_to_multiple (lis disc f)
  (if (null disc) (setq disc discr_multiple))
  (if (is_list lis)
      (let ( (:long ln (list_length lis))
	     (tup (make_multiple disc ln))
	     (ixb (make_integerbox discr_integer 0))
	     (curpair (list_first lis)) )
	(list_every 
	 lis
	 (lambda (c) 
	   (let ( (:long ix (get_int ixb)) 
		  (tc (if (is_closure f) (f c) c))
		  )
	     (put_int ixb (+i ix 1))
	     (multiple_put_nth tup ix tc))
	   ))
	tup
	)))

;;; translate a pairlist to a tuple - with each element transformed by a function f (default the identity)
(defun pairlist_to_multiple (pair disc f)
  :doc #{Make a multiple from a list of pairs: given a pair list
starting with $PAIR and a multiple discriminant $DISC and an
optional function $F [by default the identity], return a multiple of
discriminant $DISC made of the result of applying $F to every head
of pairs.}#
  (if (null disc) (setq disc discr_multiple))
  (let ( (:long ln 0) )
    (let ( (curpair pair) )
      (forever loopln
	       (if (not (is_pair curpair)) (exit loopln))
	       (setq ln (+i ln 1))
	       (setq curpair (pair_tail curpair))))
    (let ( (tup (make_multiple disc ln))
	   (:long ix 0) 
	   (curpair pair)
	   )
      (forever loopfi
	       (if (not (is_pair curpair)) (exit loopfi))
	       (let ( (c (pair_head curpair))
		      (tc (if (is_closure f) (f c) c)) )
		 (multiple_put_nth tup ix tc)
		 (setq ix (+i ix 1))
		 (setq curpair (pair_tail curpair))))
      (return tup)
      )))


;;;;;;;;;;;;;;;;
;; citerator on tuple
(defciterator foreach_in_multiple 
  (tup)					;start formal
  eachtup				;state
  (comp :long ix)			;local formals
  :doc #{Iterate in the given tuple $TUP for each component $COMP at index $IX}#
  #{ /* start $eachtup: */
   long  $eachtup#_ln = melt_multiple_length((melt_ptr_t)$tup);
   long  $eachtup#_ix = 0;
   for ($eachtup#_ix = 0;  
	$eachtup#_ix <  $eachtup#_ln;  
	$eachtup#_ix++) {
   $comp = melt_multiple_nth((melt_ptr_t)($tup),  $eachtup#_ix);
   $ix  =  $eachtup#_ix;
   }#
   #{ } /* end $eachtup */ }#
)

(defciterator foreach_in_multiple_backward
  (tup)					;start formal
  eachtupback				;state
  (comp :long ix)			;local formals
  :doc #{Iterate backwards from last to first in the given tuple $TUP
  for each component $COMP at index $IX}#
  #{ /* start $eachtupback: */
   long  $eachtupback#_ln = melt_multiple_length((melt_ptr_t)$tup);
   long  $eachtupback#_ix = 0;
   for ($eachtupback#_ix = $eachtupback#_ln - 1;  
	$eachtupback#_ix >= 0;  
	$eachtupback#_ix--) {
   $comp = melt_multiple_nth((melt_ptr_t)($tup),  $eachtupback#_ix);
   $ix  =  $eachtupback#_ix;}#
   #{ } /* end $eachtupback */ }#
  )

;;; full iterator on tuple - 
;;; the function is called with the component and its index
(defun multiple_every (tup f)
  :doc #{Apply to every component of tuple $TUP and its index the given
function $F. Return nil.}#
  (if (is_multiple tup)
      (if (is_closure f)
	  (foreach_in_multiple
	   (tup)
	   (comp :long ix)
	   (f comp ix)))))

;; full iterator backward
(defun multiple_backward_every (tup f)
  :doc #{Apply to every component (from last to first) of tuple $TUP
backwards, and its index the given function $F. Return nil.}#
  (if (is_multiple tup)
      (if (is_closure f)
	  (foreach_in_multiple_backward
	   (tup)
	   (comp :long ix)
	   (f comp ix)))))


;; iterator on two tuples
(defun multiple_every_both (tup1 tup2 f)
  :doc #{Given two tuples $TUP1 and $TUP2, apply function $F to every component of $TUP1 
with component of $TUP2 and index. Stop when either end is reached. Return nil.}#
  (if (is_multiple tup1)
      (if (is_multiple tup2)
	  (if (is_closure f)
	      (let ( (:long ln1 (multiple_length tup1))
		     (:long ln2 (multiple_length tup2))
		     (:long ix 0) )
		(forever tuploop
			 (if (>=i ix ln1) (exit tuploop))
			 (if (>=i ix ln2) (exit tuploop))
			 (f (multiple_nth tup1 ix) (multiple_nth tup2 ix) ix)
			 (setq ix (+i ix 1))))))))

;;; iterator on tuple , if the called f returns nil the iteration is stopped
;;; the function is called with the component and its index
(defun multiple_iterate_test (tup f)
  :doc #{Given a multiple $TUP and a function $F, find the first
component on which $F returns nil and some other value. Return the
component, its index, and that other value.}#
  (if (is_multiple tup)
      (if (is_closure f)
	  (foreach_in_multiple
	   (tup)
	   (comp :long ix)
	   (multicall 
	    (test other)
	    (f comp ix)
	    (if (null test) (return comp ix other)))))))

;;; map on tuple -- with tup= (t0 t1 ... t_n-1) return ((f t0 0) (f t1 1) ... (f t_n-1 n-1)
(defun multiple_map (tup f)
  :doc #{Given a multiple $TUP and a function $F, make a multiple made
of the application of $F to every component and its index.}#
  (if (is_multiple tup)
      (if (is_closure f)
	  (let ( (:long ln (multiple_length tup))
		 (:long ix 0) 
		 (res (make_multiple discr_multiple ln))
		 )
	    (forever tuploop
		     (if (>=i ix ln) (exit tuploop res))
		     (let ( (curcomp (multiple_nth tup ix)) )
		       (multiple_put_nth res ix (f curcomp ix)))
		     (setq ix (+i ix 1)))
	    ))))


(defun multiple_to_list (tup disc transf)
  :doc #{Given a multiple $TUP, a list discriminant $DISC [by default
$DISCR_LIST], a function $TRANSF [by default the identity], make a
list of every element of the tuple transformed by $TRANSF.}#
  (if (null disc) (setq disc discr_list))
  (if (is_multiple tup)
      (let ( (lis (make_list disc)) )
	(foreach_in_multiple 
	 (tup)
	 (comp :long ix)
	 (if (is_closure transf)
	     (list_append lis (transf comp))
	   (list_append lis comp)))
	(return lis)
	)))
  
;;; full iterator on closures  
;;; the function is called with the component and its index
(defun closure_every (clo f)
  :doc #{Apply to every value inside closure $CLO the function $F}#
  (if (is_closure clo)
      (if (is_closure f)
	  (let ( (:long ln (closure_size clo))
		 (:long ix 0) )
	    (forever cloloop
		     (if (>=i ix ln) (exit cloloop))
		     (f  (closure_nth clo ix) ix)
		     (setq ix (+i ix 1)))))))	     

;;; full iterator on routine  
;;; the function is called with the component and its index
(defun routine_every (rou f)
  :doc #{Apply to every value inside routine $ROU the function $F}#
  (if (is_routine rou)
      (if (is_closure f)
	  (let ( (:long ln (routine_size rou))
		 (:long ix 0) )
	    (forever rouloop
		     (if (>=i ix ln) (exit rouloop))
		     (f  (routine_nth rou ix) ix)
		     (setq ix (+i ix 1)))))))	     

;; utility function to make a list of 1
(defun list1 (v1)
  :doc #{Make a list of one value $V1}#
  (let ( (lis (make_list discr_list))
	 )
    (list_append lis v1)
    lis))

;; utility function to make a list of 2
(defun list2 (v1 v2)
  :doc #{Make a list of two values $V1 and $V2}#
  (let ( (lis (make_list discr_list))
	 )
    (list_append lis v1)
    (list_append lis v2)
    lis))

;; utility function to make a list of 3
(defun list3 (v1 v2 v3)
  :doc #{Make a list of 3 values $V1 $V2 $V3.}#
  (let ( (lis (make_list discr_list))
	 )
    (list_append lis v1)
    (list_append lis v2)
    (list_append lis v3)
    lis))

;; utility function to make a list of 4
(defun list4 (v1 v2 v3 v4)
  :doc #{Make a list of 4 values $V1 $V2 $V3 $V4.}#
  (let ( (lis (make_list discr_list))
	 )
    (list_append lis v1)
    (list_append lis v2)
    (list_append lis v3)
    (list_append lis v4)
    lis))

;; utility function to make a list of 5
(defun list5 (v1 v2 v3 v4 v5)
  :doc #{Make a list of 5 values $V1 $V2 $V3 $V4 $V5.}#
  (let ( (lis (make_list discr_list))
	 )
    (list_append lis v1)
    (list_append lis v2)
    (list_append lis v3)
    (list_append lis v4)
    (list_append lis v5)
    lis))

;; utility function to make a list of 6
(defun list6 (v1 v2 v3 v4 v5 v6)
  :doc #{Make a list of 6 values $V1 $V2 $V3 $V4 $V5 $V6.}#
  (let ( (lis (make_list discr_list))
	 )
    (list_append lis v1)
    (list_append lis v2)
    (list_append lis v3)
    (list_append lis v4)
    (list_append lis v5)
    (list_append lis v6)
    lis))


;;; installation of a method in a class or discriminant
(defun install_method (cla sel fun)
  :doc #{Install in class or discriminant $CLA for selector $SEL the function $FUN as method body.}#
  (if (is_a cla class_discriminant)
      (if (is_a sel class_selector)
	  (if (is_closure fun)
	      (let 
		  ( (mapdict 
		     (unsafe_get_field :disc_methodict cla)) )
		(if (is_mapobject mapdict)
		    (mapobject_put mapdict sel fun)
		  (let ( (newmapdict (make_mapobject discr_method_map 35)) )
		    (unsafe_put_fields cla :disc_methodict newmapdict)
		    (mapobject_put newmapdict sel fun)
		    ))))))
  )



;;; selector to output for debugging
;;; reciever: any object or value
;;; arguments: the debuginfo (instance of class_debug_information), the depth (long)
(defselector dbg_output class_selector
  :formals (recv dbginfo :long depth)
  :doc #{Selector for debug output. Output for debugging the $RECV into $DBGINFO (of $CLASS_DEBUG_INFORMATION) at given $DEPTH.}#
  )


;;; selector to output again for debugging
;;; reciever: any object (already output)
;;; arguments: the debuginfo (instance of class_debug_information), the depth (long)
(defselector dbg_outputagain class_selector
  :formals (recv dbginfo :long depth)
  :doc #{Selector for debug output again, used to output a value
  already encountered. Output again for debugging the $RECV into
  $DBGINFO (of $CLASS_DEBUG_INFORMATION) at given $DEPTH.}# )



(defun dbg_outobject (obj dbgi :long depth)
  :doc #{Output for debugging object $OBJ using debug information
$DBGI at given $DEPTH}#
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (occmap (unsafe_get_field :dbgi_occmap dbgi)) )
    (if (is_mapobject occmap)
	(let ( (occ (mapobject_get occmap obj)) )
	  (checkcallstack_msg "in dbg_outobject")
	  (if (is_integerbox occ)
	      (progn
		(dbg_outputagain obj dbgi depth)
		(put_int occ (+i (get_int occ) 1))
		)
	    (let ( (newocc (make_integerbox discr_integer 1)) )
	      (mapobject_put occmap obj newocc)
	      (checkcallstack_msg "in dbg_outobject output")
	      (dbg_output obj dbgi depth)
	      )))))
  )

(defun dbg_out (obj dbgi  :long depth) 
  :doc #{Output for debugging value $OBJ using debug information
$DBGI at given $DEPTH}#
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (checkcallstack_msg "start dbg_out")
  (let ( (out (unsafe_get_field :dbgi_out dbgi))
	 (discr (discrim obj))
	 )
    (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
	(if (is_object obj)
	    (progn
	      ;; (checkcallstack_msg "start dbg_out outobject")
	      (dbg_outobject obj dbgi depth)
	      )
	  (if obj
	      (progn
		;; (checkcallstack_msg "start dbg_out output")
		(dbg_output obj dbgi depth)
		)
	    (if out (add2out_strconst out "()")
	      )))
      (if out
	  (add2out_strconst out "..")
	))))

;; utility to dump fields in an object from a given rank to a given rank
(defun dbgout_fields (obj dbgi :long depth fromrank torank)
  :doc #{Utility to output for debugging value in $OBJ using debug information
$DBGI at given $DEPTH the fields from $FROMRANK to $TORANK}#
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (assert_msg "check obj" (is_object obj))
  (let ( (:long nbf (object_length obj)) 
	 (cla (discrim obj))
	 (:long ix fromrank)
	 (:long fldcnt 0)
	 (clafieldseq (unsafe_get_field :class_fields cla))
	 (out  (unsafe_get_field :dbgi_out dbgi))
	 )
    (if (<i ix 0) (setq ix 0))
    (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
	(forever fldloop
		 (if (>=i ix nbf)
		     (exit fldloop))
		 (and (>i torank 0)
		      (>i ix torank)
		      (exit fldloop))
		 (let ( (curfld (multiple_nth clafieldseq ix))
			(curval (object_nth_field obj ix))
			)
		   (if curval
		       (progn
			 (if (%iraw fldcnt 2) (add2out_indentnl out depth))
			 (setq fldcnt (+i fldcnt 1))
			 (add2out_string out (unsafe_get_field :named_name curfld))
			 (add2out_strconst out "=")
			 (dbg_out curval dbgi (+i depth 1))
			 (add2out_indent out depth))
			 ))
		 (setq ix (+i ix 1))
		 )
      )))

;; utility to dump again fields in an object from a given rank to a given rank
(defun dbgoutagain_fields (obj dbgi :long depth fromrank torank)
  :doc #{Utility to output again for debugging value in $OBJ using
debug information $DBGI at given $DEPTH the fields from $FROMRANK to
$TORANK}#
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (assert_msg "check obj" (is_object obj))
  (let ( (:long nbf (object_length obj)) 
	 (cla (discrim obj))
	 (:long ix fromrank)
	 (clafieldseq (unsafe_get_field :class_fields cla))
	 (out  (unsafe_get_field :dbgi_out dbgi))
	 )
    (assert_msg "check out" (is_out out))
    (if (<i ix 0) (setq ix 0))
    (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
	(forever fldloop
		 (if (>=i ix nbf)
		     (exit fldloop))
		 (and (>i torank 0)
		      (>i ix torank)
		      (exit fldloop))
		 (let ( (curfld (multiple_nth clafieldseq ix))
			(curval (object_nth_field obj ix))
			)
		   (if curval
		       (progn 
			 (add2out_indent out depth)
			 (add2out_string out
					 (unsafe_get_field :named_name curfld))
			 (add2out_strconst out "=")
			 (dbg_outputagain curval dbgi (+i depth 1))
			 (add2out_indent out depth))
		     )
		   (setq ix (+i ix 1))
		   )
		 ))))

;; null debug output
(defun dbgout_null_method  (self dbgi :long depth)
  (let (  (out  (unsafe_get_field :dbgi_out dbgi))
	  )
    (add2out_strconst out "()")))
(install_method discr_null_receiver dbg_output dbgout_null_method)
(install_method discr_null_receiver dbg_outputagain dbgout_null_method)

;; string debug output
(defun dbgout_string_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (dis (discrim self)) 
	 (sbuf  (unsafe_get_field :dbgi_out dbgi))
	 )
    (if (== dis DISCR_STRING)
	(progn
	  (add2sbuf_strconst sbuf " \"")
	  (add2sbuf_cencstring sbuf self)
	  (add2sbuf_strconst sbuf "\"")
	  )
      (progn
	(add2sbuf_strconst sbuf " |")
	(add2sbuf_string sbuf (unsafe_get_field :named_name dis))
	(add2sbuf_strconst sbuf "\"")
	(add2sbuf_cencstring sbuf self)
	(add2sbuf_strconst sbuf "\"")
	))))

(install_method discr_string  dbg_output dbgout_string_method)
					;(install_method discr_name_string  dbg_output dbgout_string_method)
					;(install_method discr_verbatim_string  dbg_output dbgout_string_method)

;; integer debug output
(defun dbgout_integer_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (dis (discrim self)) 
	 (sbuf  (unsafe_get_field :dbgi_out dbgi))
	 )
    (if (== dis DISCR_INTEGER)
	(progn 
	  (add2sbuf_strconst sbuf " #")
	  (add2sbuf_longdec sbuf (get_int self)))
      (progn
	(add2sbuf_strconst sbuf " |")
	(add2sbuf_string sbuf (unsafe_get_field :named_name dis))
	(add2sbuf_strconst sbuf "#")
	(add2sbuf_longdec sbuf (get_int self)))
      )))

(install_method discr_integer dbg_output dbgout_integer_method)
(install_method discr_character_integer dbg_output dbgout_integer_method)

;; mixint debug value
(defun dbgout_mixint_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (dis (discrim self)) 
	 (sbuf  (unsafe_get_field :dbgi_out dbgi))
	 )
    (if (== dis discr_mixed_integer)
	(progn 
	  (add2sbuf_strconst sbuf " #[")
	  (add2sbuf_longdec sbuf (get_int self)))
      (progn
	(add2sbuf_strconst sbuf " |")
	(add2sbuf_string sbuf (unsafe_get_field :named_name dis))
	(add2sbuf_strconst sbuf "#[")
	(add2sbuf_longdec sbuf (get_int self)))
      )
    (if  (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
	(progn
	  (add2sbuf_strconst sbuf ",")
	  (dbg_out (mixint_val self) dbgi (+i depth 1))
	  )
      (add2sbuf_strconst sbuf ",..")
      )
    (add2sbuf_strconst sbuf "]")
    ))
(install_method discr_mixed_integer dbg_output dbgout_mixint_method)

;; mixloc debug value
(defun dbgout_mixloc_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (assert_msg "check self mixloc" (is_mixloc self))
  (let ( (dis (discrim self)) 
	 (sbuf  (unsafe_get_field :dbgi_out dbgi))
	 )
    (if (== dis DISCR_MIXED_LOCATION)
	(progn 
	  (add2sbuf_strconst sbuf " #![")
	  (add2sbuf_longdec sbuf (get_int self)))
      (progn
	(add2sbuf_strconst sbuf " |")
	(add2sbuf_string sbuf (unsafe_get_field :named_name dis))
	(add2sbuf_strconst sbuf "#![")
	(add2sbuf_longdec sbuf (get_int self)))
      )
    (if  (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
	(progn
	  (add2sbuf_strconst sbuf ",")
	  (add2sbuf_mixloc sbuf self)
	  )
      (add2sbuf_strconst sbuf ",..")
      )
    (add2sbuf_strconst sbuf "]")
    ))
(install_method discr_mixed_location dbg_output dbgout_mixloc_method)


;; mixbigint debug value
(defun dbgout_mixbigint_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (assert_msg "check self mixbigint" (is_mixbigint self))
  (let ( (dis (discrim self)) 
	 (sbuf  (unsafe_get_field :dbgi_out dbgi))
	 )
    (add2sbuf_strconst sbuf " |")
    (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
    (add2sbuf_strconst sbuf "#![")
  (if  (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
      (progn
	(dbg_out (mixbigint_val self) dbgi (+i depth 1))
	(add2sbuf_strconst sbuf ",")
	(ppstrbuf_mixbigint sbuf (+i depth 1) self)
	)
    (add2sbuf_strconst sbuf ",..")
    )
  (add2sbuf_strconst sbuf "]")
  ))
(install_method discr_mixed_bigint dbg_output dbgout_mixbigint_method)

;; multiple debug out
(defun dbgout_multiple_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (dis (discrim self)) 
	 (sbuf (unsafe_get_field :dbgi_out dbgi))
	 )
    (if (== dis DISCR_MULTIPLE)
	(add2sbuf_strconst sbuf " *")
      (progn
	(add2sbuf_strconst sbuf " |")
	(add2sbuf_string sbuf (unsafe_get_field :named_name dis))
	(add2sbuf_strconst sbuf "*")))
    (let ( (:long ln (multiple_length self)) )
      (add2sbuf_longdec sbuf ln)
      (add2sbuf_strconst sbuf "[")
      (if (need_dbg depth)
	  (let ( (:long ix 0) )
	    (forever comploop
		     (if (>=i ix ln) (exit comploop))
		     (add2sbuf_indent sbuf depth)
		     (let ( (:long curulen (strbuf_usedlength sbuf)) )
		       (dbg_out  (multiple_nth self ix) dbgi (+i 1 depth))
		       (and (>i (-i (strbuf_usedlength sbuf) curulen) 100)
			    (<i ix (-i ln 1))
			    (add2sbuf_indentnl sbuf (+i 1 depth))))
		     (setq ix (+i ix 1))
		     ))
	(add2sbuf_strconst sbuf "..")
	)
      (add2sbuf_strconst sbuf "]")
      )))

(install_method discr_multiple dbg_output dbgout_multiple_method)

;; routine debug out - don't print the routine components if depth is >0
(defun dbgout_routine_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (dis (discrim self)) 
	 (sbuf (unsafe_get_field :dbgi_out dbgi))
	 (boxdepthp1 (make_integerbox discr_integer (+i depth 1)))
	 )
    (if (== dis DISCR_ROUTINE)
	(add2sbuf_strconst sbuf " *rou[%")
      (progn
	(add2sbuf_strconst sbuf " |")
	(add2sbuf_string sbuf (unsafe_get_field :named_name dis))
	(add2sbuf_strconst sbuf "[%")))
    (add2sbuf_routinedescr sbuf self)
    (if (<i depth 2)
	(routine_every self 
		       (lambda (comp :long ix)
			 (add2sbuf_indent sbuf (get_int boxdepthp1))
			 (dbg_out comp dbgi (get_int boxdepthp1))
			 ))
      )
    (add2sbuf_strconst sbuf "%]")
    )
  )

(install_method discr_routine dbg_output dbgout_routine_method)

;; closure debug out 
(defun dbgout_closure_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (dis (discrim self)) 
	 (:long oldmaxdepth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
	 (sbuf  (unsafe_get_field :dbgi_out dbgi)) )
    (if (== dis DISCR_CLOSURE)
	(add2sbuf_strconst sbuf " *clo<")
      (progn
	(add2sbuf_strconst sbuf " |")
	(add2sbuf_string sbuf (unsafe_get_field :named_name dis))
	(add2sbuf_strconst sbuf "*clo<")))
    (put_int (unsafe_get_field :dbgi_maxdepth dbgi) 3)
    (dbg_out (closure_routine self) dbgi depth)
    (put_int (unsafe_get_field :dbgi_maxdepth dbgi) oldmaxdepth)
    (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
	(let ((:long ix 0))
	  (add2sbuf_strconst sbuf "/")
	  (add2sbuf_longdec sbuf (closure_size self))
	  (forever outloop
		   (if (>=i ix (closure_size self))
		       (exit outloop))
		   (add2sbuf_indent sbuf depth)
		   (let ( (:long curulen (strbuf_usedlength sbuf)) )
		     (dbg_out (closure_nth self ix) dbgi (+i depth 1))
		     (if (>i (-i (strbuf_usedlength sbuf) curulen) 100)
			 (add2sbuf_indentnl sbuf (+i 1 depth))))
		   (setq ix (+i ix 1))
		   )))
    (add2sbuf_strconst sbuf ">")
    ))

(install_method discr_closure dbg_output dbgout_closure_method)      



;; list debug out 
(defun dbgout_list_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (dis (discrim self)) 
	 (sbuf  (unsafe_get_field :dbgi_out dbgi)) )
    (if (== dis DISCR_LIST)
	(add2sbuf_strconst sbuf " *li(")
      (progn
	(add2sbuf_strconst sbuf " |")
	(add2sbuf_string sbuf (unsafe_get_field :named_name dis))
	(add2sbuf_strconst sbuf "(")))
    (let (
	  (curpair (list_first self))
	  (:long ix 0) 
	  )
      (checkcallstack_msg "before loop dbgout_list_method")
      (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
	  (forever listloop
		   (checkcallstack_msg "start loop dbgout_list_method")
		   (if (>i ix 300)
		       (progn
			 (add2sbuf_strconst sbuf "...")
			 (exit listloop)))
		   (if (not (is_pair curpair)) (exit listloop))
		   (add2sbuf_indent sbuf depth)
		   (let ( (:long curulen (strbuf_usedlength sbuf)) )
		     (dbg_out (pair_head curpair) dbgi (+i depth 1))
		     (setq curpair (pair_tail curpair))
		     (checkcallstack_msg "near endloop dbgout_list_method")
		     (if (null curpair)
			 (exit listloop))
		     (setq ix (+i ix 1))
		     (if (>i (-i (strbuf_usedlength sbuf) curulen) 100)
			 (add2sbuf_indentnl sbuf (+i 1 depth))))
		   ))
      (checkcallstack_msg "end dbgout_list_method")
      (add2sbuf_strconst sbuf ")")))
  )
(install_method discr_list dbg_output dbgout_list_method)      

;; pair debug output
(defun dbgout_pair_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (dis (discrim self)) 
	 (sbuf  (unsafe_get_field :dbgi_out dbgi)) )
    (if (== dis DISCR_PAIR)
	(add2sbuf_strconst sbuf " *pa(.")
      (progn
	(add2sbuf_strconst sbuf " |")
	(add2sbuf_string sbuf (unsafe_get_field :named_name dis))
	(add2sbuf_strconst sbuf "(.")))
    (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
	(progn
	  (dbg_out (pair_head self) dbgi (+i depth 1))
	  (add2sbuf_indent sbuf depth)
	  (dbg_out (pair_tail self) dbgi (+i depth 1))))
    (add2sbuf_strconst sbuf ".)")))

(install_method discr_pair dbg_output dbgout_pair_method)      

;; box debug output
(defun dbgout_box_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (dis (discrim self)) 
	 (sbuf  (unsafe_get_field :dbgi_out dbgi)) )
    (if (== dis DISCR_BOX)
	(add2sbuf_strconst sbuf " *box[<")
      (progn
	(add2sbuf_strconst sbuf " |")
	(add2sbuf_string sbuf (unsafe_get_field :named_name dis))
	(add2sbuf_strconst sbuf "[<")))
    (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
	(dbg_out (box_content self) dbgi (+i depth 1)))
    (add2sbuf_strconst sbuf ">]")))

(install_method discr_box dbg_output dbgout_box_method)      



;; an internal compare function used to display mapobject-s & mapstring-s in a canonical order.
(defun compare_obj_ranked (x1 bxrk1 x2 bxrk2 vless veq vgreat)
  (if (== x1 x2)
      (return veq)
    (let ( (x1dis (discrim x1))
	   (x2dis (discrim x2))
	   (:long rk1 (get_int bxrk1))
	   (:long rk2 (get_int bxrk2))
	   )
      (cond ( (!= x1dis x2dis)
	      (if (string< (unsafe_get_field :named_name x1dis) 
			   (unsafe_get_field :named_name x2dis))
		  (return vless)
		(return vgreat)
		))
	    ( (is_a x1 class_cloned_symbol)
	      (let ( (n1 (unsafe_get_field :named_name x1))
		     (n2 (unsafe_get_field :named_name x2)) )
		(cond ( (string< n1 n2)
			(return vless))
		      ( (string> n1 n2)
			(return vgreat))
		      (:else 
		       (let (
			     (yr1 (unsafe_get_field :csym_urank x1))
			     (yr2 (unsafe_get_field :csym_urank x2))
			     (:long nr1 (get_int yr1))
			     (:long nr2 (get_int yr2))
			     )
			 (cond ( (<i nr1 nr2)
				 (return vless))
			       ( (>i nr1 nr2)
				 (return vgreat))
			       (:else 
				;; this should not happen, two distinct cloned symbols with same name & rank
				(assert_msg "corrupted same cloned symbols" ())
				(return ()))
			       ))))
		))
	    ( (is_a x1 class_named)
	      (let ( (n1 (unsafe_get_field :named_name x1))
		     (n2 (unsafe_get_field :named_name x2))
		     )
		(cond ( (string< n1 n2)
			(return vless))
		      ( (string> n1 n2)
			(return vgreat))
		      ( (<i rk1 rk2)
			(return vless))
		      ( (>i rk1 rk2)
			(return vgreat))
		      (:else 
		       (return veq)))
		)
	      )
	    ( (is_a x1 class_any_binding)
	      (let ( (bsy1 (unsafe_get_field :binder x1))
		     (bsy2 (unsafe_get_field :binder x1)) )
		(return (compare_obj_ranked bsy1 bxrk1 bsy2 bxrk2 vless veq vgreat))))
	    ( (is_string x1)
	      (cond ( (string< x1 x2)
		      (return vless))
		    ( (string> x1 x2)
		      (return vgreat))
		    ( (<i rk1 rk2)
		      (return vless))
		    ( (>i rk1 rk2)
		      (return vgreat))
		    (:else 
		     (return veq))))
	    ( (<i rk1 rk2)
	      (return vless))
	    ( (>i rk1 rk2)
	      (return vgreat))
	    (:else
	     (return veq))
	    ))))




(defun dbgout_mapobject_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (dis (discrim self)) 
	 (out  (get_field :dbgi_out dbgi))
	 (:long mapcount (mapobject_count self))
	 )
    (assert_msg "check out at start" (is_out out))
    (if (== dis DISCR_MAP_OBJECTS)
	(add2out_strconst out " {")
      (progn
	(add2out_strconst out " |")
	(add2out_string out (unsafe_get_field :named_name dis))
	(add2out_strconst out "{")))
    (add2out_strconst out "/")
    (add2out_longdec out (mapobject_count self))
    (if (need_dbglim (+i depth 2) (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
	(let (
	      (nextdepthbox (make_integerbox discr_integer (+i 2 depth)))
	      (countbox (make_integerbox discr_integer 0))
	      (boxedone (make_integerbox discr_integer 1))
	      (boxedzero (make_integerbox discr_integer 0))
	      (boxedminusone (make_integerbox discr_integer -1))
	      (tupl (make_multiple discr_multiple mapcount))
	      )
	  ;; fill the tupl with (attribute value rank) entries
	  (mapobject_every
	   self
	   (lambda (at va)
	     (let ( (:long curcount (get_int countbox)) 
		    (ent (make_tuple3 discr_multiple 
				      at va 
				      (make_integerbox discr_integer curcount)))
		    )
	       (multiple_put_nth tupl curcount ent)
	       (put_int countbox (+i curcount 1))
	       )))
	  (assert_msg "check tupl" (is_multiple tupl))
;;; sort the tuple and output in sorted order
	  (let ( (sortupl 
		  (multiple_sort 
		   tupl
		   (lambda (e1 e2)
		     (let ( (e1at (multiple_nth e1 0))
			    (e1va (multiple_nth e1 1))
			    (e1rk (multiple_nth e1 2))
			    (e2at (multiple_nth e2 0))
			    (e2va (multiple_nth e2 1))
			    (e2rk (multiple_nth e2 2))
			    )
		       (compare_obj_ranked e1at e1rk e2at e2rk boxedminusone boxedzero boxedone)
		       ))
		   discr_multiple
		   ))
		 )
	    (assert_msg "check sortupl" (is_multiple sortupl))
	    (multiple_every 
	     sortupl
	     (lambda (el :long ix)
	       (let ( (elat (multiple_nth el 0))
		      (elva (multiple_nth el 1)) )
		 (let ( (:long nextdepth (get_int nextdepthbox))
			(:long oldmaxdepth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
			)

		   (assert_msg "check out" (is_out out))
		   (add2out_indentnl out nextdepth)
		   (add2out_strconst out "**")  
		   (put_int (unsafe_get_field :dbgi_maxdepth dbgi) 0)
		   (dbg_outobject elat dbgi nextdepth)
		   (put_int (unsafe_get_field :dbgi_maxdepth dbgi) oldmaxdepth)
		   (add2out_strconst out " ==")  
		   (add2out_indent out (+i nextdepth 1))
		   (dbg_out elva dbgi (+i nextdepth 2))
		   (add2out_strconst out "; ")
		   )))))
	  (add2out_strconst out "}")))))
(install_method discr_map_objects dbg_output dbgout_mapobject_method)



;; utility to give a "sorted" tuple of attributes in a mapobject
(defun mapobject_sorted_attribute_tuple (mapo)
  :doc #{Give the alphabetically sorted tuple of attributes in a 
given object map $MAPO}#
  (let ( 
	(:long mapcount (mapobject_count mapo)) 
	(countbox (make_integerbox discr_integer 0))
	(boxedone (make_integerbox discr_integer 1))
	(boxedzero (make_integerbox discr_integer 0))
	(boxedminusone (make_integerbox discr_integer -1))
	(tupl (make_multiple discr_multiple mapcount))
	)
    ;; fill the tupl with (attribute value rank) entries
    (mapobject_every
     mapo
     (lambda (at va)
       (let ( (:long curcount (get_int countbox)) 
	      (ent (make_tuple3 discr_multiple 
				at va 
				(make_integerbox discr_integer curcount)))
	      )
	 (multiple_put_nth tupl curcount ent)
	 (put_int countbox (+i curcount 1))
	 )))
;;; sort the tuple and output in sorted order
    (let ( (sortupl 
	    (multiple_sort 
	     tupl
	     (lambda (e1 e2)
	       (let ( (e1at (multiple_nth e1 0))
		      (e1va (multiple_nth e1 1))
		      (e1rk (multiple_nth e1 2))
		      (e2at (multiple_nth e2 0))
		      (e2va (multiple_nth e2 1))
		      (e2rk (multiple_nth e2 2))
		      )
		 (compare_obj_ranked e1at e1rk e2at e2rk boxedminusone boxedzero boxedone)
		 ))
	     discr_multiple
	     ))
	   )
      (multiple_map sortupl (lambda (el) (multiple_nth el 0)))
      )
    )
  )



;; multiple debug out
(defun dbgout_mapstring_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (dis (discrim self)) 
	 (sbuf (unsafe_get_field :dbgi_out dbgi))
	 (:long ix 0)
	 (:long mapcount (mapstring_count self))
	 (nextdepthbox (make_integerbox discr_integer (+i 2 depth)))
	 (countbox (make_integerbox discr_integer 0))
	 (boxedone (make_integerbox discr_integer 1))
	 (boxedzero (make_integerbox discr_integer 0))
	 (boxedminusone (make_integerbox discr_integer -1))
	 (tupl (make_multiple discr_multiple mapcount))
	 )
    (if (== dis DISCR_MAP_STRINGS)
	(add2sbuf_strconst sbuf " <(")
      (progn
	(add2sbuf_strconst sbuf " |")
	(add2sbuf_string sbuf (unsafe_get_field :named_name dis))
	(add2sbuf_strconst sbuf "<(")))
    (add2sbuf_strconst sbuf "/")
    (add2sbuf_longdec sbuf mapcount)
    (if (need_dbg (+i depth 2))
	(progn
	  ;; fill the tuple with string, value, rank triples
	  (mapstring_every 
	   self
	   (lambda (str val)
	     (let ( (:long curcount (get_int countbox)) 
		    (ent (make_tuple3 discr_multiple 
				      str val 
				      (make_integerbox discr_integer curcount)))
		    )
	       (multiple_put_nth tupl curcount ent)
	       (put_int countbox (+i curcount 1))
	       )))
	  ;; sort the tuple and display it
	  (let ( (sortupl
		  (multiple_sort 
		   tupl
		   (lambda (e1 e2)
		     (let ( (e1at (multiple_nth e1 0))
			    (e1va (multiple_nth e1 1))
			    (e1rk (multiple_nth e1 2))
			    (e2at (multiple_nth e2 0))
			    (e2va (multiple_nth e2 1))
			    (e2rk (multiple_nth e2 2))
			    )
		       (compare_obj_ranked e1at e1rk e2at e2rk boxedminusone boxedzero boxedone)
		       ))
		   discr_multiple
		   ))
		 )
	    (assert_msg "check sortupl" (is_multiple sortupl)) 
	    (multiple_every 
	     sortupl
	     (lambda (el :long ix)
	       (let ( (curstr (multiple_nth el 0))
		      (curval (multiple_nth el 1)) 
		      (:long nextdepth (get_int nextdepthbox))
		      )
		 (if (and (is_string curstr) (notnull curval))
		     (progn
		       (add2sbuf_indentnl sbuf nextdepth)
		       (add2sbuf_strconst sbuf "!*")
		       (dbg_out curstr dbgi nextdepth)
		       (add2sbuf_strconst sbuf " => ")  
		       (add2sbuf_indent sbuf nextdepth)
		       (dbg_out curval dbgi (+i nextdepth 2))
		       ))))))))
    (add2sbuf_strconst sbuf " )>")))
(install_method discr_map_strings dbg_output dbgout_mapstring_method)


;;;; generic object debug
(defun dbgout_anyobject_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (dis (discrim self)) 
	 (sbuf  (unsafe_get_field :dbgi_out dbgi)) ) 
    (add2sbuf_strconst sbuf "|")
    (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
    (add2sbuf_strconst sbuf "/")
    (add2sbuf_longhex sbuf (obj_hash self))
    (let ( (:long onum (obj_num self)) 
	   (:long oserial (obj_serial self))
	   )
      (if onum
	  (progn
	    (add2sbuf_strconst sbuf "#")
	    (add2sbuf_longdec sbuf onum)))
      (if oserial
	  (progn
	    (add2sbuf_strconst sbuf "##")
	    (add2sbuf_longdec sbuf oserial)))
      )
    (add2sbuf_strconst sbuf "{")
    (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
	(dbgout_fields self dbgi (+i depth 1) 0 0)
      )
    (add2sbuf_strconst sbuf "}")
    ))
(install_method class_root  dbg_output dbgout_anyobject_method)

;;;; generic value debug
(defun dbgout_anyrecv_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (dis (discrim self)) 
	 (sbuf  (unsafe_get_field :dbgi_out dbgi)) ) 
    (add2sbuf_strconst sbuf " ?.")
    (if (is_a dis class_named) (add2sbuf_string sbuf (unsafe_get_field :named_name dis)))
    (add2sbuf_strconst sbuf ".? ")
    ))
(install_method discr_any_receiver dbg_output dbgout_anyrecv_method)

;;; generic object debug outputagain
(defun dbgoutagain_anyobject_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (dis (discrim self)) 
	 (sbuf  (unsafe_get_field :dbgi_out dbgi)) 
	 (:long onum (obj_num self)) 
	 (:long oserial (obj_serial self))
	 )  
    (add2sbuf_strconst sbuf " ^^|")
    (add2sbuf_string sbuf (unsafe_get_field :named_name dis))
    (add2sbuf_strconst sbuf "/")
    (add2sbuf_longhex sbuf (obj_hash self))
    (if onum
	(progn
	  (add2sbuf_strconst sbuf "#")
	  (add2sbuf_longdec sbuf onum)))
    (if oserial 
	(progn
	  (add2sbuf_strconst sbuf "##")
	  (add2sbuf_longdec sbuf oserial)
	  ))
    ))
(install_method class_root  dbg_outputagain dbgoutagain_anyobject_method)

;;;; named object debug
(defun dbgout_namedobject_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (dis (discrim self)) 
	 (out  (unsafe_get_field :dbgi_out dbgi))
	 (onam (unsafe_get_field :named_name self))
	 (oprop (unsafe_get_field :prop_table self))
	 ) 
    (assert_msg "check out" (is_out out))
    (add2out_strconst out "`")
    (add2out_string out onam)
    (add2out_strconst out "|")
    (add2out_string out (unsafe_get_field :named_name dis))
    (add2out_strconst out "/")
    (add2out_longhex out (obj_hash self))
    (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
	(let ( (:long onum (obj_num self)) 
	       (:long oserial (obj_serial self)) )
	  (if onum
	      (progn
		(add2out_strconst out "#")
		(add2out_longdec out onum)))
	  (if oserial
	      (progn
		(add2out_strconst out "##")
		(add2out_longdec out oserial)))
	  (add2out_strconst out "{")
	  (if oprop
	      (progn 
		(add2out_strconst out "prop=")
		(dbg_out oprop dbgi (+i depth 3))
		))
	  (dbgout_fields self dbgi (+i depth 3) 2 0)
	  (add2out_strconst out "}")
	  ))))
(install_method class_named  dbg_output dbgout_namedobject_method)
;;; we explicitly export dbgout_namedobject_method needed afterwards
(export_values dbgout_namedobject_method)

;;;; named object debug outputagain
(defun dbgoutagain_namedobject_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (let ( (dis (discrim self)) 
	 (out  (unsafe_get_field :dbgi_out dbgi))
	 (onam (unsafe_get_field :named_name self)) 
	 (:long oserial (obj_serial self))
	 )
    (add2out_strconst out " ^^`")
    (add2out_string out onam)
    (add2out_strconst out "|")
    (add2out_string out (unsafe_get_field :named_name dis))
    (add2out_strconst out "/")
    (add2out_longhex out (obj_hash self))
    (if oserial
	(progn
	  (add2out_strconst out "##")
	  (add2out_longdec out oserial)
	  ))
    ))
(install_method class_named dbg_outputagain dbgoutagain_namedobject_method)

;;;; symbol output debug & again
(defun dbgout_symbol_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (assert_msg "check self" (is_a self class_symbol))
  (if (<=i depth 0)
      (dbgout_namedobject_method self dbgi 0)
    (dbgoutagain_symbol_method self dbgi depth)))
(install_method class_symbol dbg_output dbgout_symbol_method)

(defun dbgoutagain_symbol_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (assert_msg "check self" (is_a self class_symbol))
  (let ( (out  (unsafe_get_field :dbgi_out dbgi))
	 (onam (unsafe_get_field :named_name self))
	 (:long oserial (obj_serial self))
	 )	
    (add2out_strconst out " $")
    (add2out_string out onam)
    (add2out_strconst out "/")
    (add2out_longhex out (obj_hash self))
    (if oserial
	(progn
	  (add2out_strconst out "##")
	  (add2out_longdec out oserial)
	  ))
    ))
(install_method class_symbol dbg_outputagain dbgoutagain_symbol_method)

;;;; class output debug & again
(defun dbgout_class_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (assert_msg "check self" (is_a self class_class))
  (if (<=i depth 0)
      (dbgout_namedobject_method self dbgi 0)
    (dbgoutagain_namedobject_method self dbgi depth)))
(install_method class_class dbg_output dbgout_class_method)

;;;; keyword output debug & again
(defun dbgout_keyword_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (assert_msg "check self" (is_a self class_keyword))
  (if (<=i depth 0)
      (dbgout_namedobject_method self dbgi 0)
    (dbgoutagain_keyword_method self dbgi depth)))
(install_method class_keyword dbg_output dbgout_keyword_method)

(defun dbgoutagain_keyword_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (assert_msg "check self" (is_a self class_keyword))
  (let ( (out  (unsafe_get_field :dbgi_out dbgi))
	 (onam (unsafe_get_field :named_name self))
	 (:long oserial (obj_serial self))
	 )	
    (add2out_strconst out " $:")
    (add2out_string out onam)
    (add2out_strconst out "/")
    (add2out_longhex out (obj_hash self))
    (if oserial
	(progn
	  (add2out_strconst out "##")
	  (add2out_longdec out oserial)
	  ))
    ))
(install_method class_keyword dbg_outputagain dbgoutagain_keyword_method)

;;;; cloned_symbol output debug & again
(defun dbgout_cloned_symbol_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (assert_msg "check self" (is_a self class_cloned_symbol))
  (if (<=i depth 0)
      (dbgout_namedobject_method self dbgi 0)
    (dbgoutagain_cloned_symbol_method self dbgi depth)
    ))
(install_method class_cloned_symbol dbg_output dbgout_cloned_symbol_method)

(defun dbgoutagain_cloned_symbol_method (self dbgi :long depth)
  (let ( (dis (discrim self)) 
	 (out  (unsafe_get_field :dbgi_out dbgi))
	 (ourank (unsafe_get_field :csym_urank self))
	 (:long lrk (get_int ourank))
	 (:long oserial (obj_serial self))
	 (onam (unsafe_get_field :named_name self)) )
    (add2out_strconst out " $$")
    (add2out_string out onam)
    (add2out_strconst out ":")
    (add2out_longdec out lrk)
    (add2out_strconst out "/")
    (add2out_longhex out (obj_hash self))
    (if oserial
	(progn
	  (add2out_strconst out "##")
	  (add2out_longdec out oserial)
	  ))
    ))
(install_method class_cloned_symbol dbg_outputagain dbgoutagain_cloned_symbol_method)


;;;; environment output debug
(defun dbgout_environment_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (assert_msg "check self" (is_a self class_environment))
  (let ( (dis (discrim self)) 
	 (out (unsafe_get_field :dbgi_out dbgi)) 
	 (:long oserial (obj_serial self))
	 (:long onum (obj_num self)) 
	 )  
    (if (== dis class_environment)
	(add2out_strconst out "env")
      (progn
	(add2out_strconst out "|")
	(add2out_string out (unsafe_get_field :named_name dis))
	))
    (add2out_strconst out "/")
    (add2out_longhex out (obj_hash self))
    (if onum
	(progn
	  (add2out_strconst out "#")
	  (add2out_longdec out onum)))
    (if oserial
	(progn
	  (add2out_strconst out "##")
	  (add2out_longdec out oserial)))
    (add2out_strconst out "{")
    (let ( (:long offprev (get_int env_prev)) 
	   (:long oldmaxdepth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
	   (:long newmaxdepth  (-i (/i oldmaxdepth 2) 1))
	   )
      (if (<i newmaxdepth 0) (setq newmaxdepth 0))
      (if (need_dbglim depth oldmaxdepth)
	  (progn
	    (and (>i depth 0) (>i oldmaxdepth 3)
		 (put_int (unsafe_get_field :dbgi_maxdepth dbgi) newmaxdepth))
	    (dbgout_fields self dbgi (+i depth 1) 0 offprev)
	    (if (need_dbglim (+i depth 2) newmaxdepth)
		(dbgoutagain_fields self dbgi (+i depth 2) offprev 0)
	      (add2out_strconst out ".._.."))
	    (put_int (unsafe_get_field :dbgi_maxdepth dbgi) oldmaxdepth)
	    )))
    (add2out_strconst out "}")
    ))
(install_method class_environment dbg_output dbgout_environment_method)


;;;; ctype output debug & again
(defun dbgout_ctype_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (assert_msg "check self" (is_a self class_ctype))
  (if (<=i depth 0)
      (dbgout_namedobject_method self dbgi 0)
    (dbgoutagain_ctype_method self dbgi depth)
    ))
(install_method class_ctype dbg_output dbgout_ctype_method)

(defun dbgoutagain_ctype_method (self dbgi :long depth)
  (let ( (dis (discrim self)) 
	 (out  (unsafe_get_field :dbgi_out dbgi))
	 (:long oserial (obj_serial self))
	 (onam (unsafe_get_field :named_name self)) )
    (add2out_strconst out " $!")
    (add2out_string out onam)
    (add2out_strconst out "!/")
    (add2out_longhex out (obj_hash self))
    (if oserial
	(progn
	  (add2out_strconst out "##")
	  (add2out_longdec out oserial)
	  ))
    ))
(install_method class_ctype dbg_outputagain dbgoutagain_ctype_method)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; make a fresh environment 
(defun fresh_env (parenv descr)		;usually descr is not given
  :doc #{Make a fresh environment of parent $PARENV and optional
description $DESCR. See also $CLASS_ENVIRONMENT and
$CLASS_DESCRIBED_ENVIRONMENT.}#
  (if (or (null parenv) (is_a parenv class_environment))
      (if descr
	  (instance class_described_environment
		    :env_bind (make_mapobject discr_map_objects 26)
		    :env_prev parenv
		    :denv_descr descr)
	(instance class_environment 
		  :env_bind (make_mapobject discr_map_objects 6)
		  :env_prev parenv))))

;; the initial environment
(definstance initial_environment class_described_environment
  :doc #{The initial environment of $CLASS_DESCRIBED_ENVIRONMENT.}#
  :env_bind  (make_mapobject discr_map_objects 500)
  :denv_descr '"Initial Environment"
  )

;; find a binding inside an environment
(defun find_env (env binder)
  :doc #{Find a binding inside environement $ENV for binder symbol $BINDER}#
  (assert_msg "check arg env" (is_a env class_environment))
  (assert_msg "check arg binder" (is_object binder))
  (forever
   findloop
   (if (null env)
       (exit findloop ()))
   (assert_msg "check env obj" (is_object env))
   (assert_msg "check good env" (is_a env class_environment))
   (let ( (bindmap 
	   (unsafe_get_field :env_bind env)) )
     (assert_msg "check bindmap" (is_mapobject bindmap))
     (let ( (bnd 
	     (mapobject_get bindmap binder)) )
       (if bnd 
	   (exit findloop bnd))
       ))
   (setq env (unsafe_get_field :env_prev env))
   )
  )

;; find a binding inside an environment with debugging 
(defun find_env_debug (env binder)
  (assert_msg "check arg env" (is_a env class_environment))
  (assert_msg "check arg binder" (is_object binder))
  (debug_msg env "find_env_debug initial env")
  (debug_msg binder "find_env_debug binder")
  (forever
   findloop
   (if (null env)
       (exit findloop ()))
   (debug_msg env "find_env_debug current env")
   (assert_msg "check env obj" (is_object env))
   (assert_msg "check good env" (is_a env class_environment))
   (let ( (bindmap 
	   (unsafe_get_field :env_bind env)) )
     (assert_msg "check bindmap" (is_mapobject bindmap))
     (let ( (bnd 
	     (mapobject_get bindmap binder)) )
       (debug_msg bnd "find_env_debug current bnd")
       (if bnd 
	   (exit findloop bnd))
       ))
   (debug_msg binder "find_env_debug at end of loop binder")
   (setq env (unsafe_get_field :env_prev env))
   )
  )

;; find a binding inside an environment and also returns the reversed list of enclosing procedures
(defun find_enclosing_env (env binder)
  :doc #{Find the binding in environment $ENV for given $BINDER symbol 
and secondarily return the reversed list of enclosing procedures.}#
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check binder" (is_object binder))
  (let ( (proclist (make_list discr_list)) )
    (forever findloop
	     (if (is_not_a env class_environment) (exit findloop))
	     (let ( (bindmap (unsafe_get_field :env_bind env)) 
		    (eproc (unsafe_get_field :env_proc env))
		    )
	       (assert_msg "check bindmap" (is_mapobject bindmap))
	       (let ( (bnd (mapobject_get bindmap binder)) )
		 (if bnd (return bnd proclist)))
	       (if eproc (list_prepend proclist eproc))
	       (setq env (unsafe_get_field :env_prev env))
	       ))))

;; put a binding at top of an environment
(defun put_env (env binding)
  :doc #{Put into environment $ENV the given $BINDING. 
See also $CLASS_ANY_BINDING and $CLASS_ENVIRONMENT.}#
  (assert_msg "check binding is obj" (is_object binding))
  (assert_msg "check env is obj" (is_object env))
  (assert_msg "check env" (is_a env class_environment))
  (if (not (is_a binding class_any_binding))
      (progn
	(debug_msg binding "put_env invalid binding")
	(shortbacktrace_dbg "put_env invalid binding" 15)))
  (assert_msg "check binding" (is_a binding class_any_binding))
  (let ( (bindmap (unsafe_get_field :env_bind env)) 
	 (binderv (unsafe_get_field :binder binding))
	 )
    (if (not (is_object binder))
	(progn
	  (debug_msg binding "put_env bad binder in binding")
	  (debug_msg binderv "put_env bad binderv")
	  (shortbacktrace_dbg "put_env  bad binder in binding" 5)))
    (assert_msg "check bindmap" (is_mapobject bindmap))
    (assert_msg "check binderv" (is_object binderv))
    (mapobject_put bindmap binderv binding)
    ))

;; overwrite a binding in the environment where it has been already bound
(defun overwrite_env (env binding)
  :doc #{Overwrite in environment $ENV or its ancestor the given
$BINDING, in the environment where it has already been bound.  See
also $CLASS_ANY_BINDING and $CLASS_ENVIRONMENT.}#
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check binding" (is_a binding class_any_binding))
  (let ( (binderv  (unsafe_get_field :binder binding)) )
    (assert_msg "check binderv" (is_object binderv))
    (forever findloop
	     (if (not (is_a env class_environment)) (exit findloop))
	     (let ( (bindmap (unsafe_get_field :env_bind env)) )
	       (assert_msg "check bindmap" (is_mapobject bindmap))
	       (let ( (oldbinding (mapobject_get bindmap binder)) )
		 (if oldbinding 
		     (progn 
		       (mapobject_put bindmap binderv binding)
		       (exit findloop oldbinding))
		   ))
	       (setq env (unsafe_get_field :env_prev env))
	       ))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; debug_msg support is done by calling this debug_msg_fun 
(defun debug_msg_fun (val :cstring msgstr :long count :cstring filenam :long lineno)
  :doc #{Internal function called by $DEBUG_MSG macro to output for
debugging the value $VAL with message $MSGSTR, given $COUNT, at
$FILENAM and $LINENO}#
  (code_chunk incrdbgcounter #{++melt_dbgcounter}#)
  (if (need_dbg 0) 
      (let ( (:long dbgcounter 0)
	     (out (get_field :sysdata_dumpfile initial_system_data)) 
	     (occmap (make_mapobject discr_map_objects 50))
	     (boxedmaxdepth (make_integerbox discr_integer 17)) ;;;; @@@ DEBUGDEPTH
	     )
	(code_chunk getdbgcounter #{$dbgcounter = melt_dbgcounter}#)
	;; it may happen that OUT is null, e.g. because the dumpfile
	;; is not yet initialized in initial_system_data...
	(if (null out)
	    (setq out (make_strbuf discr_strbuf)))
	(assert_msg "check good out" (is_out out))
	(let ( (:long nulloutfile 0) )
	  (code_chunk getfile #{ 
		      if (melt_is_file($out))
		      $nulloutfile = (melt_get_file($out)==NULL)?1:0	;
		      }#)
	  (if nulloutfile 
	      (progn 
		(shortbacktrace_dbg "debug_msg_fun null output file" 5)
		(setq out (get_field :sysdata_stderr initial_system_data))
		)))
	(let ( 
	      (dbgi (instance class_debug_information
			      :dbgi_out out
			      :dbgi_occmap occmap
			      :dbgi_maxdepth boxedmaxdepth))
	      (:long framdepth (the_framedepth)) 
	      )
	  (add2out_strconst out "!!!!****####")
	  (add2out_longdec out dbgcounter)
	  (add2out_strconst out "#^")
	  (add2out_longdec out (-i framdepth 1))
	  (add2out_strconst out ":")
	  (if filenam
	      (progn
		(add2out_strconst out filenam)
		(add2out_strconst out ":")
		(add2out_longdec out lineno)
		(add2out_strconst out ":")
		))
	  (add2out_strconst out msgstr)
	  (if (>i count 0) 
	      (progn
		(add2out_strconst out " !")
		(add2out_longdec out count)
		(add2out_strconst out ": ")
		))
	  (if val 
	      (dbg_out val dbgi 0)
	    (add2out_strconst out "() ;;;NIL!!!")
	    )
	  (add2out_indentnl out 0)
	  )
	(if (is_strbuf out)
	    (progn
	      (code_chunk debugstrbuf #{
			  fprintf (stderr, "\n**debug_msg thru strbuffer:\n%s\n",
					   melt_strbuf_str ($out)) ;
			  fflush (stderr) ;
			  }#)
	      ))
	)))

;;;; any binding debug output
(defun dbgout_anybinding_method (self dbgi :long depth)
  (assert_msg "check dbgi" (is_a dbgi class_debug_information))
  (assert_msg "check self" (is_a self class_any_binding))
  (let ( (dis (discrim self)) 
	 (out  (unsafe_get_field :dbgi_out dbgi)) 
	 (binderv (unsafe_get_field :binder self))
	 ) 
    (add2out_indent out depth)
    (add2out_strconst out "[~")
    (add2out_string out (unsafe_get_field :named_name dis))
    (add2out_strconst out "/")
    (add2out_longhex out (obj_hash self))
    (add2out_strconst out ":")
    (dbg_outputagain binderv dbgi (+i depth 2))
    (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi)))
	(progn
	  (add2out_strconst out "; ")
	  (dbgout_fields self dbgi (+i depth 1) 1 0)
	  ))
    (add2out_strconst out "~]")
    ))
(install_method class_any_binding dbg_output dbgout_anybinding_method)
(install_method class_any_binding dbg_outputagain dbgout_anybinding_method)

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

;; before the update_current_module_environment_container below, most
;; constants for current_module_environment_container or
;; parent_module_environment are null because there is not enough
;; stuff yet to build them.
(update_current_module_environment_container)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; a special function to be called when compiling with compilinit mode.
;;; which magically adds a call to it at end of the read list
(defun post_initialization (unusedarg :cstring meltfilnam)
  (let ( (curmodenvcont (current_module_environment_container)) )
    (if (not (is_a curmodenvcont class_container))
	(progn
	  (warningmsg_strv "post_initialization strange curmodenvcont of discr"
			   (unsafe_get_field :named_name (discrim curmodenvcont)))
	  (return)
	  ))
    (debug_msg curmodenvcont "post_initialization curmodenvcont at start")
					;(shortbacktrace_dbg "post_initialization" 10)
    (assert_msg "check curmodenvcont" (is_a curmodenvcont class_container))
    (let ( (curmodenv (unsafe_get_field :container_value curmodenvcont)) )
      (if (is_a curmodenv class_environment)
	  (let ( (curbindmap (unsafe_get_field :env_bind curmodenv))
		 )
	    (informsg_long "post_initialization boundvars num" 
			   (mapobject_count curbindmap))
	    )
	(let ( (curmenvdiscr (discrim curmodenv)) )
	  (informsg_strv "post_initialization strange curmodenv of discr" 
			 (unsafe_get_field :named_name curmenvdiscr)))
	)))
  )


(put_fields
 initial_system_data
 :sysdata_stdout (let ( (f ())
			(d discr_rawfile) 
			)
		   (code_chunk makestdout 
			       #{ $f = meltgc_new_file($d, stdout) ; }#
			       )
		   f)
 :sysdata_stderr (let ( (f ())
			(d discr_rawfile) 
			)
		   (code_chunk makestderr
			       #{ $f = meltgc_new_file($d, stderr) ; }#
			       )
		   f)
 :sysdata_dumpfile (let ( (f ())
			  (d discr_rawfile) 
			  )
		     ;; the FILE* of dumpfile is also set in pass executions.
		     (code_chunk makedump
				 #{ $f = meltgc_new_file($d, dump_file)	; }#
				 )
		     f)
 )


;;;;;; export the above classes
(export_class ;;in alphabetical order, one per line, for convenience
 class_any_binding
 class_any_matcher
 class_citerator
 class_citerator_binding
 class_class
 class_class_binding
 class_cloned_symbol
 class_container
 class_cmatcher_binding
 class_cmatcher
 class_ctype
 class_debug_information 
 class_described_environment
 class_discriminant 
 class_environment
 class_exported_binding
 class_field
 class_field_binding
 class_fixed_binding
 class_formal_binding
 class_function_binding
 class_funmatcher
 class_funmatcher_binding
 class_c_generation_context
 class_gcc_gimple_pass
 class_gcc_pass
 class_gcc_rtl_pass
 class_gcc_simple_ipa_pass
 class_initial_generation_context
 class_instance_binding
 class_keyword
 class_label_binding
 class_let_binding
 class_located
 class_macro_binding
 class_melt_mode
 class_module_context
 class_named
 class_normalization_context
 class_normal_let_binding
 class_generated_c_code
 class_patmacro_binding
 class_primitive
 class_primitive_binding
 class_proped 
 class_root
 class_selector
 class_selector_binding 
 class_sexpr
 class_source
 class_symbol
 class_system_data
 class_value_binding 
 )					;end of export class



;;;;;;;;;;;;;;;;
;;;; export the above primitives
(export_values				;in alphanumerical order
 !=
 !=i
 %i
 %iraw
 *i
 +i
 -i
 /i
 /iraw
 <=i
 <i
 ==
 ==i
 ==s
 >=i
 >i
 add2out_ccomconst
 add2out_ccomstrbuf
 add2out_ccomstring 
 add2out_cencstrbuf
 add2out_cencstring
 add2out_cident
 add2out_cidentprefix
 add2out_indent
 add2out_indentnl
 add2out_longdec
 add2out_longhex
 add2out_mixloc
 add2out_routinedescr
 add2out_sbuf
 add2out_strconst
 add2out_string
 add2sbuf_ccomconst
 add2sbuf_ccomstrbuf
 add2sbuf_ccomstring 
 add2sbuf_cencstrbuf
 add2sbuf_cencstring
 add2sbuf_cident
 add2sbuf_cidentprefix
 add2sbuf_indent
 add2sbuf_indentnl
 add2sbuf_longdec
 add2sbuf_longhex
 add2sbuf_mixloc
 add2sbuf_routinedescr
 add2sbuf_sbuf
 add2sbuf_short_mixloc
 add2sbuf_texi_mixloc
 add2sbuf_strconst
 add2sbuf_string
 andi
 assert_failed
 box_content
 box_put
 cbreak_msg
 checkcallstack_msg
 checkval_dbg
 closure_nth
 closure_routine
 closure_size
 create_keywordstr
 create_symbolstr
 discrim
 debugcstring
 error_plain
 error_strv
 errormsg_plain
 errormsg_strv
 full_garbcoll
 generate_melt_module
 get_globpredef
 get_int
 get_keywordstr
 get_symbolstr
 ignore
 inform_plain
 inform_strv
 informsg_long
 informsg_plain
 informsg_strv
 is_a
 is_box
 is_closure
 is_integerbox
 is_list
 is_list_or_null
 is_mapobject
 is_mapstring
 is_mixbigint
 is_mixint
 is_mixloc
 is_multiple
 is_multiple_or_null
 is_not_a
 is_not_object
 is_object
 is_pair
 is_routine
 is_strbuf
 is_string
 is_stringconst
 list_append
 list_first
 list_find
 list_last
 list_length
 list_popfirst
 list_prepend
 load_melt_module
 longbacktrace_dbg
 make_box
 make_integerbox
 make_list
 make_mapobject
 make_mapstring
 make_multiple
 make_mixint
 make_mixloc
 make_pair
 make_strbuf
 make_string
 make_string_nakedbasename
 make_string_tempname_suffixed
 make_stringconst
 make_tuple1
 make_tuple2
 make_tuple3
 make_tuple4
 make_tuple5
 make_tuple6
 make_tuple7
 mapobject_count
 mapobject_get
 mapobject_nth_attr
 mapobject_nth_val
 mapobject_put
 mapobject_remove
 mapobject_size
 mapstring_count
 mapstring_getstr
 mapstring_nth_attrstr
 mapstring_nth_val
 mapstring_putstr
 mapstring_rawget
 mapstring_rawput
 mapstring_rawremove
 mapstring_removestr
 mapstring_size
 message_dbg
 messagenum_dbg
 messageval_dbg
 minor_garbcoll
 mixbigint_val
 mixint_val
 mixloc_location
 mixloc_locline
 mixloc_locfile
 mixloc_val
 multiple_length
 multiple_nth
 multiple_put_nth
 multiple_sort
 need_dbg
 need_dbglim
 negi
 nonzero_hash
 not
 noti
 notnull
 null
 obj_hash
 obj_len
 obj_num
 obj_serial
 object_length
 object_nth_field
 ori
 out_cplugin_compiled_timestamp_err
 out_cplugin_md5_checksum_err
 outcstring_dbg
 outcstring_err
 outnewline_dbg
 outnewline_err
 outnum_dbg
 outnum_err
 output_sbuf_strconst
 output_sbuf_strval
 outstr_dbg
 outstr_err
 outstrbuf_dbg
 outstrbuf_err
 pair_head
 pair_listlength
 pair_set_head
 pair_tail
 ppstrbuf_mixbigint
 put_int
 read_file
 routine_descr
 routine_nth
 routine_size
 shortbacktrace_dbg
 split_string_colon
 split_string_comma
 split_string_space
 strbuf2string
 strbuf_usedlength
 string<
 string=
 string>
 string_length
 stringconst2val
 subclass_of
 subclass_or_eq
 subseq_multiple
 the_callcount
 the_framedepth
 the_null_cstring
 void
 warning_plain
 warning_strv
 xori
 zerop
 )
;; export the discriminants and instances and selectors defined above
(export_values				;alphabetical order
 ctype_basic_block
 ctype_cstring     
 ctype_edge                   
 ctype_gimple
 ctype_gimple_seq
 ctype_long   
 ctype_ppl_coefficient
 ctype_ppl_constraint
 ctype_ppl_constraint_system
 ctype_ppl_linear_expression
 ctype_tree                           
 ctype_value                          
 ctype_void  
 dbg_output
 dbg_outputagain
 discr_any_receiver                        
 discr_basic_block   
 discr_box 
 discr_character_integer                    
 discr_class_sequence                       
 discr_closure                        
 discr_constant_integer
 discr_edge
 discr_field_sequence                       
 discr_file
 discr_gimple
 discr_gimple_seq
 discr_integer                        
 discr_list                           
 discr_map_basic_blocks
 discr_map_edges
 discr_map_gimples
 discr_map_gimple_seqs
 discr_map_objects                     
 discr_map_strings                     
 discr_map_trees
 discr_method_map 
 discr_mixed_bigint
 discr_mixed_integer                       
 discr_mixed_location                       
 discr_multiple                       
 discr_name_string                     
 discr_null_receiver                       
 discr_pair  
 discr_ppl_constraint_system 
 discr_ppl_polyhedron 
 discr_rawfile
 discr_routine                        
 discr_strbuf                         
 discr_string                         
 discr_tree
 discr_verbatim_string  
 initial_environment                  
 initial_system_data
 ) ;;;end export discriminants, instances, selectors


;; export the functions & matchers defined above
(export_values
 at_exit_first
 at_exit_last
 at_finish_unit_first
 at_finish_unit_last
 at_start_unit_first
 at_start_unit_last
 clone_symbol
 closure_every
 compare_named_alpha
 compare_obj_ranked
 cstring_length
 cstring_same
 dbg_out				
 dbg_outobject	
 dbgout_fields
 dbgoutagain_fields
 debug_msg_fun				
 debugmsg				
 display_debug_message			
 find_enclosing_env			
 find_env				
 find_env_debug
 fresh_env				
 install_ctype_descr				
 install_method				
 list1					
 list2					
 list3	
 list4
 list5
 list6
 list_append2list			
 list_every				
 list_iterate_test			
 list_map				
 list_to_multiple			
 mapobject_every			
 mapobject_iterate_test	
 mapobject_sorted_attribute_tuple		
 mapstring_every			
 mapstring_iterate_test			
 multiple_backward_every		
 multiple_every				
 multiple_every_both				
 multiple_iterate_test			
 multiple_map				
 multiple_to_list
 overwrite_env				
 pairlist_to_multiple	
 post_initialization
 put_env
 routine_every
 tuple_nth
 tuple_sized
 )


;; export the citerators & cmatchers defined above
(export_values
 foreach_in_list
 foreach_in_mapobject
 foreach_in_mapstring
 foreach_in_multiple
 foreach_in_multiple_backward
 foreach_long_upto
 integerbox_of 
 )

;; we predefine :true as the TRUE. Currently no handcoded C function
;; uses it, but perhaps that could change!!

(let ( ( truekeyword :true) )
  (code_chunk storetruekeyword #{MELT_STORE_PREDEF(TRUE,$truekeyword)}#))

;; we export displaydebugmsg because a previous version of warmelt-genobj-0 used it
(export_synonym displaydebugmsg display_debug_message)
;; eof warmelt-first.melt