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

;; -*- Lisp -*-
;; file warmelt-first.melt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(comment "***
    Copyright 2008, 2009, 2010, 2011 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. Actually its super
discriminant is $DISCR_ANY_RECEIVER.}# )

;; 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.}# )

;; subclass of source expressions for macrostrings
(defclass class_sexpr_macrostring
  :predef CLASS_SEXPR_MACROSTRING
  :super class_sexpr
  :fields ()
  :doc #{The $CLASS_SEXPR_MACROSTRING has the same fields as
$CLASS_SEXPR but is used for macrostring s-expressions, written in
MELT source with the #$.@{ #$.@} notation.}# )



;; superclass for infix syntax lexemes
(defclass class_infix_lexeme
  :super class_located
  :fields (lexeme_data)
  :doc #{The $CLASS_INFIX_LEXEME is the common super-class for infix
  lexemes [other than $CLASS_SEXPR_MACROSTRING]. The $LEXEME_DATA is the occurring data.}#
)

;; infix string literal
(defclass class_infix_string_literal
  :predef CLASS_INFIX_STRING_LITERAL
  :super class_infix_lexeme
  :fields ()
  :doc #{The $CLASS_INFIX_STRING_LITERAL is for infix string
literals. $LEXEME_DATA is the parsed string.}# )

;; infix integer literal
(defclass class_infix_integer_literal
  :predef CLASS_INFIX_INTEGER_LITERAL
  :super class_infix_lexeme
  :fields ()
  :doc #{The $CLASS_INFIX_INTEGER_LITERAL is for infix integer
literals. $LEXEME_DATA is the parsed boxed constant integer.}# )

(defclass class_infix_any_symbol
  :super class_infix_lexeme
  :doc #{The $CLASS_INFIX_SYMBOL is the superclass of all infix symbol occurrences. $LEXEME_DATA is the parsed symbol.}#
)

(defclass class_infix_symbol
  :predef CLASS_INFIX_SYMBOL
  :super class_infix_any_symbol
  :fields ()
  :doc #{The $CLASS_INFIX_SYMBOL is for infix symbol
occurrences. $LEXEME_DATA is the parsed symbol. A symbol starts with a
letter, or with an ignored backslash @code{\} to parse special symbols as ordinary
ones.}#)

(defclass class_infix_additive_symbol
  :predef CLASS_INFIX_ADDITIVE_SYMBOL
  :super class_infix_any_symbol
  :fields ()
  :doc #{The $CLASS_INFIX_ADDITIVE_SYMBOL is for infix additive
symbols, starting with @code{+} or @code{-} or @code{|}. Prefix them with an
ignored backslash @code{\} to have them parsed as an ordinary
  symbol.}#)

(defclass class_infix_multiplicative_symbol
  :predef CLASS_INFIX_MULTIPLICATIVE_SYMBOL
  :super class_infix_any_symbol
  :fields ()
  :doc #{The $CLASS_INFIX_MULTIPLICATIVE_SYMBOL is for infix
multiplicative symbols, starting with @code{*} or @code{/} or @code{&}
or @code{%}. Prefix them with an ignored backslash @code{\} to have
them parsed as an ordinary symbol.}#)

(defclass class_infix_relational_symbol
  :predef CLASS_INFIX_RELATIONAL_SYMBOL
  :super class_infix_any_symbol
  :fields ()
  :doc #{The $CLASS_INFIX_RELATIONAL_SYMBOL is for infix
relational symbols, starting with @code{<} @code{>} @code{=} @code{!} @code{~} @code{@@}. Prefix them with an ignored backslash @code{\} to have
them parsed as an ordinary symbol.}#
)

(defclass class_infix_delimiter
  :predef CLASS_INFIX_DELIMITER
  :super class_infix_lexeme
  :fields ()
  :doc #{The $CLASS_INFIX_DELIMIER is for delimiters. $LEXEME_DATA is
  the parsed delimiter.}#)

(defclass class_infix_keyword
  :predef CLASS_INFIX_KEYWORD
  :super class_infix_lexeme
  :fields ()
  :doc #{The $CLASS_INFIX_KEYWORD is for infix keyword occurrences
-keywords start with a colon @code{:}. $LEXEME_DATA is the parsed keyword symbol.}#)

;; 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 MELTBPAR_LONG)
	   ctype_parstring ;the name of the melt parameter string (eg MELTBPARSTR_LONG)
	   ctype_argfield ;the name of the melt argument union field (eg meltbp_long)
	   ctype_resfield ;the name of the melt result union field (eg meltbp_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!}# )

;;; the class describing ctype which are GTY-ed, like tree-s
(defclass class_ctype_gty
  :predef CLASS_CTYPE_GTY
  :super class_ctype
  :fields (
;;; obmag are object magic like MELTOBMAG_INT inside melt-runtime.h
	   ctypg_boxedmagic		;MELT obmag for boxed values
	   ctypg_mapmagic		;MELT obmag for magic values
;;; structnames are C struct like meltint_st for boxed
	   ctypg_boxedstruct		;struct name for boxed values
	   ctypg_boxedunimemb		;union member name for boxed values
	   ctypg_entrystruct 		;struct name for hash entry
	   ctypg_mapstruct 		;struct name map values
	   ctypg_boxdiscr		;discriminant for boxed values
	   ctypg_mapdiscr		;discriminant for map values
	   ctypg_mapunimemb		;union member name for map values
	   ctypg_boxfun			;name of boxing function
	   ctypg_unboxfun		;name of content unboxing function
	   ctypg_updateboxfun		;name of box updating function
	   ctypg_newmapfun		;name of map creating function
	   ctypg_mapgetfun		;name of map getting function
	   ctypg_mapputfun		;name of map putting function
	   ctypg_mapremovefun		;name of map removing function
	   ctypg_mapcountfun		;name of map counting function
	   ctypg_mapsizefun		;name of map size function
	   ctypg_mapnattfun		;name of map nth attr function
	   ctypg_mapnvalfun		;name of map nth value function 

	   )
  :doc #{The $CLASS_CTYPE_GTY is a subclass of $CLASS_CTYPE and
describes C types which are GTY-ed, that is handled by the Ggc [the
existing Gcc Garbage Collector].}#
)



;; 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
	   sysdata_option_set 		;closure to set a MELT option
	   sysdata_passexec_hook	;internal closure if any to be
					;called using PLUGIN_PASS_EXECUTION
	   sysdata_meltpass_after_hook	;closure to be called after
					;MELT pass execution
					;functions, it is
					;automatically cleared after
					;usage.
	   sysdata_meltpragmas		;a list or tuple of pragma
					;descriptor object of
					;CLASS_GCC_PRAGMA
	   ;;;keep these spare slots to ease the addition of other slots
	   sysdata___spare1
	   sysdata___spare2
	   sysdata___spare3
	   sysdata___spare4
	   ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ================ 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 $LETBIND_EXPR, the source location
  if any is $LEBIND_LOC.}# )

;; letrec binding
(defclass class_letrec_binding
  :doc #{The internal $CLASS_LETREC_BINDING is for internal letrec
  bindings. See the $LETREC macro. The bound expression should be
  recursively constructible (like $LAMBDA $TUPLE $LIST $INSTANCE
  ...)}#
  :super class_let_binding
  :fields ())

;; 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 pragmas
;;;@@@@ for Pierre Vittet
(defclass class_gcc_pragma
  :predef CLASS_GCC_PRAGMA
  :super class_named
  ;; keep the fields list in sync with melt-runtime.h FGCCPRAGMA_*
  :fields (gccpragma_handler            ;the closure to handle the pragma
           gccpragma_data               ;extra data
           )
  :doc #{The $CLASS_GCC_PRAGMA is for objects describing GCC pragmas,
  as provided by MELT code. Once correctly instanciated, such a pragma
  descriptor should be registered thru the $INSTALL_MELT_GCC_PRAGMA
  primitive.  MELT pragmas are named, and all belong to the same MELT
  pragma namespace.  C code using them will use: #pragma MELT name ...
  and the name there is the string given by the $NAMED_NAME field of
  the pragma descriptor.}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ================ 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_any_ipa_pass
  :super class_gcc_pass
  :fields ()
  :doc #{  The $CLASS_GCC_ANY_IPA_PASS is the common class for every GCC 
inter procedural analysis [IPA] pass descriptors. }#)

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

(defclass class_gcc_transform_ipa_pass
  :predef CLASS_GCC_TRANSFORM_IPA_PASS
  :super class_gcc_any_ipa_pass
  ;; keep the fields list in sync with melt-runtime.h FGCCTRIPAPASS_*
  :fields ( gcctripapass_stmt_fixup
	    gcctripapass_function_transform
	    gcctripapass_variable_transform )
  :doc #{ The $CLASS_GCC_TRANSFORM_IPA_PASS is for GCC full IPA pass
descriptors which don't read or write any LTO information but are
plain transforming IPA passes. }#)

;;;; 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
	   mocx_funcount		;a boxed counter for defined functions
	   mocx_filetuple		;vector for different generated files
	   mocx_cflags			;cflags of generated module
	   mocx_linkflags		;linkflags of generated module
	   )
  :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. $MOCX_FUNCOUNT is a boxed
integer counting the defined functions (excluding $LAMBDA-s, counting
only $DEFUN), used to help generate C code in several files, described
in $MOCX_FILETUPLE.  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 
;;****************************************************************
;;; many primitives have moved to warmelt-base.melt


;; 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)) == MELTOBMAG_OBJECT)}#)


;; 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 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_meltcallcount () :long "meltcallcount")
(defprimitive the_callcount () :long "meltcallcount")
;;; the current frame depth
(defprimitive the_framedepth () :long "(melt_curframdepth())")



;; 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)}#)
(defprimitive get_raw_symbol (:cstring cstr) :value
  :doc #{Get an existing symbol of given cstring $CSTR or else null.}#
#{meltgc_named_symbol((char*) $cstr, MELT_GET)}#)

;; 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__);
}#)


;;; most compare primitives moved to warmelt-base.melt; we keep here
;;; those that are useful in this warmelt-first.melt file.

;;; compare of longs  
(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 greater than $B.}# 
  #{(($a) > ($b))}#)
(defprimitive >=i (:long a b) :long :doc #{Integer test that $A greater or equal to $B.}#
  #{(($a) >= ($b))}#)
;;; integer arithmetic, most is moved to warmelt-base.melt
(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 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))}#)

(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)))}#
  )


;; cmatchers on integers


;;; match an integer i greater than a given number n
(defcmatcher integer_greater_than
  (:long i n)
  ()
  intgreathan
  :doc #{The $INTEGER_GREATER_THAN matcher with input number $N matches
an integer $I if $I is greater than $N.}#
  ;; test expansion
  #{ /*$INTGREATHAN ?*/ ($I > $N) }#
  ;; no fill expansion
)


;;; nullity test (for values)
(defprimitive null (v) :long :doc #{Test that $V is the null value.}#
  #{(($v) == NULL)}#)
;; 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))}#)

(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 the_null_cstring () :cstring
  :doc #{The null const cstring.}#
  #{(char*)0}#
)

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



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; 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)) == MELTOBMAG_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))}#)
(defprimitive !=s (s1 s2) :long
  :doc #{Test that $S1 and $S2 are not both string equal values.}#
  #{!melt_string_same((melt_ptr_t)($s1), (melt_ptr_t)($s2))}#)

(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 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))}#)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; MULTIPLEs primitives
;;;; test
(defprimitive is_multiple (mul) :long
  :doc #{Safely test if $MUL is a tuple.}#
  #{(melt_magic_discr((melt_ptr_t)($mul)) == MELTOBMAG_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)))}#)


;; 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))}#)






;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; MAPOBJECTs primitives
;;;; test
(defprimitive is_mapobject (map) :long
  :doc #{Test if given $MAP is an object map.}#
  #{(melt_magic_discr((melt_ptr_t)($map)) == MELTOBMAG_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((meltmapobjects_ptr_t)$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)) == MELTOBMAG_MAPSTRINGS)}#)
;; 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)))}#)
(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))))}#)
(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)) == MELTOBMAG_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)) == MELTOBMAG_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)))}#)

(defcmatcher closure
  (clo)
  ()
  closurematch
  :doc #{The $CLOSURE patterns matches a closure.}#
  #{ /* $closurematch ? */ $clo && melt_magic_discr($clo) == MELTOBMAG_CLOSURE }#
  #{ /* $closurematch ! */ }#
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; 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)) == MELTOBMAG_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 patern 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) == MELTOBMAG_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)) == MELTOBMAG_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))}#)
;;; pattern
(defcmatcher box_of 
  (:value bx)
  (:value v)
  boxof
  :doc #{The $BOX_OF patern matches a value box $BX. If indeed it
  is a box, its content should match the subpattern $V.
  It fails if $BX is not a boxed integer. See also $MAKE_BOX $BOX_CONTENT.}#
  ;; test
  #{ /* $BOXOF ?*/ $BX && melt_magic_discr($bx) == MELTOBMAG_BOX }#
  ;; fill
  #{ /* $BOXOF !*/ $V = ((struct meltbox_st*)$bx)->val; }#
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; LIST primitives
;; test
(defprimitive is_list (li) :long
  :doc #{Test if value $LI is a list.}#
  #{(melt_magic_discr((melt_ptr_t)($li)) == MELTOBMAG_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)) == MELTOBMAG_LIST))}#)
;; test if a list is non-empty
(defprimitive is_non_empty_list (li) :long
  :doc #{Test if value $LI is a non-empty list.}#
  #{(melt_magic_discr((melt_ptr_t)($li)) == MELTOBMAG_LIST && NULL != melt_list_first((melt_ptr_t)($li)))}#)
;; 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)))}#)
;;  first element of list
(defprimitive list_first_element (li) :value
  :doc #{Safely retrieve the first element of list value $LI, or null.}#
  #{(melt_pair_head (melt_list_first((melt_ptr_t)($li))))}#)
;; length of list
(defprimitive list_last_element (li) :value
  :doc #{Safely retrieve the last element of list value $LI, or null.}#
  #{(melt_pair_head (melt_list_last((melt_ptr_t)($li))))}#)
(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)) == MELTOBMAG_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)))}#)




;; 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)))}#
  )


(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 MELTOBMAG_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 MELTOBMAG_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 MELTOBMAG_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)
(unsafe_put_fields class_root :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 MELTOBMAG_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 MELTOBMAG_INT 
  :disc_super discr_any_receiver
  :named_name '"DISCR_INTEGER")

;;; The discriminant for boxed reals.
(definstance discr_real class_discriminant
  :doc #{The $DISCR_REAL is the discriminant of boxed reals. }#
  :predef DISCR_REAL
  :obj_num MELTOBMAG_REAL
  :disc_super discr_any_receiver
  :named_name '"DISCR_REAL")

;;; the discriminant for constant integers, like '123
(definstance discr_constant_integer class_discriminant
  :predef DISCR_CONSTANT_INTEGER
  :obj_num MELTOBMAG_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 MELTOBMAG_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 MELTOBMAG_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 MELTOBMAG_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 MELTOBMAG_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 MELTOBMAG_BOX
  :disc_super discr_any_receiver
  :named_name '"DISCR_BOX")

;;; the discriminant for tree-s
(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 MELTOBMAG_TREE
  :disc_super discr_any_receiver
  :named_name '"DISCR_TREE")

;;; the discriminant for gimple-s
(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 MELTOBMAG_GIMPLE
  :disc_super discr_any_receiver
  :named_name '"DISCR_GIMPLE")

;;; the discriminant for gimple_seq-s
(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 MELTOBMAG_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 MELTOBMAG_EDGE
  :disc_super discr_any_receiver
  :named_name '"DISCR_EDGE")

;;; the discriminant for boxed basic blocks
(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 MELTOBMAG_BASICBLOCK
  :disc_super discr_any_receiver
  :named_name '"DISCR_BASIC_BLOCK")


;;; the discriminant for boxed loops
(definstance discr_loop class_discriminant
  :doc #{The $DISCR_LOOP is the discriminant of boxed GCC loop_p values. See
also $CTYPE_LOOP.}#
  :predef DISCR_LOOP
  :obj_num MELTOBMAG_LOOP
  :disc_super discr_any_receiver
  :named_name '"DISCR_LOOP")


;;; the discriminant for boxed bitmap-s
(definstance discr_bitmap class_discriminant
  :doc #{The $DISCR_BITMAP is the discriminant of boxed GCC bitmap values. See
also $CTYPE_BITMAP.}#
  :predef DISCR_BITMAP
  :obj_num MELTOBMAG_BITMAP
  :disc_super discr_any_receiver
  :named_name '"DISCR_BITMAP")


;;; the discriminant for boxed rtx-s
(definstance discr_rtx class_discriminant
  :doc #{The $DISCR_RTX is the discriminant of boxed GCC rtx values. See
also $CTYPE_RTX.}#
  :predef DISCR_RTX
  :obj_num MELTOBMAG_RTX
  :disc_super discr_any_receiver
  :named_name '"DISCR_RTX")

;;; the discriminant for boxed rtvec-s
(definstance discr_rtvec class_discriminant
  :doc #{The $DISCR_RTVEC is the discriminant of boxed GCC rtvec values. See
also $CTYPE_RTVEC.}#
  :predef DISCR_RTVEC
  :obj_num MELTOBMAG_RTVEC
  :disc_super discr_any_receiver
  :named_name '"DISCR_RTVEC")

;;; 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 MELTOBMAG_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 MELTOBMAG_MAPSTRINGS
  :disc_super discr_any_receiver
  :named_name '"DISCR_MAP_STRINGS")

;;; the discriminant for maps of tree-s
(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 MELTOBMAG_MAPTREES
  :disc_super discr_any_receiver
  :named_name '"DISCR_MAP_TREES")

;;; the discriminant for maps of gimple-s
(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 MELTOBMAG_MAPGIMPLES
  :disc_super discr_any_receiver
  :named_name '"DISCR_MAP_GIMPLES")

;;; the discriminant for maps of gimple_seq-s
(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 MELTOBMAG_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 values. See also $CTYPE_EDGE.}#
  :predef DISCR_MAP_EDGES
  :obj_num MELTOBMAG_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 values. See also $CTYPE_BASIC_BLOCK.}#
  :predef DISCR_MAP_BASIC_BLOCKS
  :obj_num MELTOBMAG_MAPBASICBLOCKS
  :disc_super discr_any_receiver
  :named_name '"DISCR_MAP_BASIC_BLOCKS")

;;; the discriminant for maps of loop-s
(definstance discr_map_loops class_discriminant
  :doc #{The $DISCR_MAP_LOOPS is the discriminant of hash-map values associating raw GCC loop-s 
to non-nil values. See also $CTYPE_LOOP.}#
  :predef DISCR_MAP_LOOPS
  :obj_num MELTOBMAG_MAPLOOPS
  :disc_super discr_any_receiver
  :named_name '"DISCR_MAP_LOOPS")

;;; the discriminant for maps of bitmap-s
(definstance discr_map_bitmaps class_discriminant
  :doc #{The $DISCR_MAP_BITMAPS is the discriminant of hash-map values associating raw GCC bitmap-s 
to non-nil values. See also $CTYPE_BITMAP.}#
  :predef DISCR_MAP_BITMAPS
  :obj_num MELTOBMAG_MAPBITMAPS
  :disc_super discr_any_receiver
  :named_name '"DISCR_MAP_BITMAPS")

;;; the discriminant for maps of rtx-s
(definstance discr_map_rtxs class_discriminant
  :doc #{The $DISCR_MAP_RTXS is the discriminant of hash-map values associating raw GCC rtx-s 
to non-nil values. See also $CTYPE_RTX.}#
  :predef DISCR_MAP_RTXS
  :obj_num MELTOBMAG_MAPRTXS
  :disc_super discr_any_receiver
  :named_name '"DISCR_MAP_RTXS")

;;; the discriminant for maps of rtvec-s
(definstance discr_map_rtvecs class_discriminant
  :doc #{The $DISCR_MAP_RTVECS is the discriminant of hash-map values associating raw GCC rtvec-s 
to non-nil values. See also $CTYPE_RTVEC.}#
  :predef DISCR_MAP_RTVECS
  :obj_num MELTOBMAG_MAPRTVECS
  :disc_super discr_any_receiver
  :named_name '"DISCR_MAP_RTVECS")


;;; the discriminant for PPL constraint system (not predefined)
(definstance discr_ppl_constraint_system class_discriminant
  :obj_num MELTOBMAG_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 MELTOBMAG_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 MELTOBMAG_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 MELTOBMAG_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 MELTOBMAG_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 MELTOBMAG_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 MELTOBMAG_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 MELTOBMAG_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 MELTOBMAG_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 MELTOBMAG_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 MELTOBMAG_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 MELTOBMAG_ROUTINE
  :disc_super discr_any_receiver
  :named_name '"DISCR_ROUTINE")


(definstance container_ctype_gty_dict class_container
  :container_value (make_mapstring discr_map_strings 60))

(definstance container_ctype_dict class_container
  :container_value (make_mapstring discr_map_strings 60))

;;; 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.}#
  (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))
    (mapstring_putstr (get_field :container_value container_ctype_dict)
		      (get_field :named_name ckw)
		      ctyp)
    (if (is_a ctyp class_ctype_gty)
	(mapstring_putstr (get_field :container_value container_ctype_gty_dict)
			  (get_field :named_name ckw)
			  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 '"MELTBPAR_PTR"
  :ctype_parstring '"MELTBPARSTR_PTR"
  ;; value have to be passed specially, we need to pass the address of the pointer
  :ctype_argfield '"meltbp_vptr"
  :ctype_resfield '"meltbp_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 '"MELTBPAR_LONG"
  :ctype_parstring '"MELTBPARSTR_LONG"
  :ctype_argfield '"meltbp_long"
  :ctype_resfield '"meltbp_longptr"
  )
(install_ctype_descr ctype_long "C long unboxed integer")

;; the C type for gcc trees
(definstance ctype_tree class_ctype_gty
  :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 '"MELTBPAR_TREE"
  :ctype_parstring '"MELTBPARSTR_TREE"
  :ctype_argfield '"meltbp_tree"
  :ctype_resfield '"meltbp_treeptr"
  :ctype_marker '"gt_ggc_mx_tree_node"
;; GTY ctype
  :ctypg_boxedmagic '"MELTOBMAG_TREE"
  :ctypg_mapmagic '"MELTOBMAG_MAPTREES"
  :ctypg_boxedstruct '"melttree_st"
  :ctypg_boxedunimemb '"u_tree"
  :ctypg_entrystruct '"entrytreemelt_st"
  :ctypg_mapstruct '"meltmaptrees_st"
  :ctypg_boxdiscr  discr_tree
  :ctypg_mapdiscr  discr_map_trees
  :ctypg_mapunimemb    '"u_maptrees"
  :ctypg_boxfun        '"meltgc_new_tree"
  :ctypg_unboxfun      '"melt_tree_content"
  :ctypg_updateboxfun  '"meltgc_tree_updatebox"
  :ctypg_newmapfun     '"meltgc_new_maptrees"
  :ctypg_mapgetfun     '"melt_get_maptrees"
  :ctypg_mapputfun     '"melt_put_maptrees"
  :ctypg_mapremovefun  '"melt_remove_maptrees"
  :ctypg_mapcountfun   '"melt_count_maptrees"
  :ctypg_mapsizefun    '"melt_size_maptrees"
  :ctypg_mapnattfun    '"melt_nthattr_maptrees"
  :ctypg_mapnvalfun    '"melt_nthval_maptrees"	
  )
(install_ctype_descr ctype_tree "GCC tree pointer")

;; the C type for gcc gimples
(definstance ctype_gimple class_ctype_gty
  :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 '"MELTBPAR_GIMPLE"
  :ctype_parstring '"MELTBPARSTR_GIMPLE"
  :ctype_argfield '"meltbp_gimple"
  :ctype_resfield '"meltbp_gimpleptr"
  :ctype_marker '"gt_ggc_mx_gimple_statement_d"
;; GTY ctype
  :ctypg_boxedmagic '"MELTOBMAG_GIMPLE"
  :ctypg_mapmagic '"MELTOBMAG_MAPGIMPLES"
  :ctypg_boxedstruct '"meltgimple_st"
  :ctypg_boxedunimemb '"u_gimple"
  :ctypg_entrystruct '"entrygimplemelt_st"
  :ctypg_mapstruct '"meltmapgimples_st"
  :ctypg_boxdiscr  discr_gimple
  :ctypg_mapdiscr  discr_map_gimples
  :ctypg_mapunimemb    '"u_mapgimples"
  :ctypg_boxfun        '"meltgc_new_gimple"
  :ctypg_unboxfun      '"melt_gimple_content"
  :ctypg_updateboxfun  '"meltgc_gimple_updatebox"
  :ctypg_newmapfun     '"meltgc_new_mapgimples"
  :ctypg_mapgetfun     '"melt_get_mapgimples"
  :ctypg_mapputfun     '"melt_put_mapgimples"
  :ctypg_mapremovefun  '"melt_remove_mapgimples"
  :ctypg_mapcountfun   '"melt_count_mapgimples"
  :ctypg_mapsizefun    '"melt_size_mapgimples"
  :ctypg_mapnattfun    '"melt_nthattr_mapgimples"
  :ctypg_mapnvalfun    '"melt_nthval_mapgimples"	
  )
(install_ctype_descr ctype_gimple "GCC gimple pointer")

;; the C type for gcc gimple_seq-s
(definstance ctype_gimple_seq class_ctype_gty
  :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 '"MELTBPAR_GIMPLESEQ"
  :ctype_parstring '"MELTBPARSTR_GIMPLESEQ"
  :ctype_argfield '"meltbp_gimpleseq"
  :ctype_resfield '"meltbp_gimpleseqptr"
  :ctype_marker '"gt_ggc_mx_gimple_seq_d"
;; GTY ctype
  :ctypg_boxedmagic '"MELTOBMAG_GIMPLESEQ"
  :ctypg_mapmagic '"MELTOBMAG_MAPGIMPLESEQS"
  :ctypg_boxedstruct '"meltgimpleseq_st"
  :ctypg_boxedunimemb '"u_gimpleseq"
  :ctypg_entrystruct '"entrygimpleseqmelt_st"
  :ctypg_mapstruct '"meltmapgimpleseqs_st"
  :ctypg_boxdiscr  discr_gimple_seq
  :ctypg_mapdiscr  discr_map_gimple_seqs
  :ctypg_mapunimemb    '"u_mapgimpleseqs"	
  :ctypg_boxfun        '"meltgc_new_gimpleseq"
  :ctypg_unboxfun      '"melt_gimpleseq_content"
  :ctypg_updateboxfun  '"meltgc_gimpleseq_updatebox"
  :ctypg_newmapfun     '"meltgc_new_mapgimpleseqs"
  :ctypg_mapgetfun     '"melt_get_mapgimpleseqs"
  :ctypg_mapputfun     '"melt_put_mapgimpleseqs"
  :ctypg_mapremovefun  '"melt_remove_mapgimpleseqs"
  :ctypg_mapcountfun   '"melt_count_mapgimpleseqs"
  :ctypg_mapsizefun    '"melt_size_mapgimpleseqs"
  :ctypg_mapnattfun    '"melt_nthattr_mapgimpleseqs"
  :ctypg_mapnvalfun    '"melt_nthval_mapgimpleseqs"	
  )
(install_ctype_descr ctype_gimple_seq "GCC gimple_seq pointer")

;; the C type for gcc basic_blocks
(definstance ctype_basic_block class_ctype_gty
  :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 '"MELTBPAR_BB"
  :ctype_parstring '"MELTBPARSTR_BB"
  :ctype_argfield '"meltbp_bb"
  :ctype_resfield '"meltbp_bbptr"
  :ctype_marker '"gt_ggc_mx_basic_block_def"
;; GTY ctype
  :ctypg_boxedmagic '"MELTOBMAG_BASICBLOCK"
  :ctypg_mapmagic '"MELTOBMAG_MAPBASICBLOCKS"
  :ctypg_boxedstruct '"meltbasicblock_st"
  :ctypg_boxedunimemb '"u_basicblock"
  :ctypg_entrystruct '"entrybasicblockmelt_st"
  :ctypg_mapstruct '"meltmapbasicblocks_st"
  :ctypg_boxdiscr  discr_basic_block
  :ctypg_mapdiscr  discr_map_basic_blocks
  :ctypg_mapunimemb    '"u_mapbasicblocks"
  :ctypg_boxfun        '"meltgc_new_basicblock"
  :ctypg_unboxfun      '"melt_basicblock_content"
  :ctypg_updateboxfun  '"meltgc_basicblock_updatebox"
  :ctypg_newmapfun     '"meltgc_new_mapbasicblocks"
  :ctypg_mapgetfun     '"melt_get_mapbasicblocks"
  :ctypg_mapputfun     '"melt_put_mapbasicblocks"
  :ctypg_mapremovefun  '"melt_remove_mapbasicblocks"
  :ctypg_mapcountfun   '"melt_count_mapbasicblocks"
  :ctypg_mapsizefun    '"melt_size_mapbasicblocks"
  :ctypg_mapnattfun    '"melt_nthattr_mapbasicblocks"
  :ctypg_mapnvalfun    '"melt_nthval_mapbasicblocks"	
  )
(install_ctype_descr ctype_basic_block "GCC basic_block")

;; the C type for gcc edges
(definstance ctype_edge class_ctype_gty
  :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 '"MELTBPAR_EDGE"
  :ctype_parstring '"MELTBPARSTR_EDGE"
  :ctype_argfield '"meltbp_edge"
  :ctype_resfield '"meltbp_edgeptr"
  :ctype_marker '"gt_ggc_mx_edge_def"
;; GTY ctype
  :ctypg_boxedmagic '"MELTOBMAG_EDGE"
  :ctypg_mapmagic '"MELTOBMAG_MAPEDGES"
  :ctypg_boxedstruct '"meltedge_st"
  :ctypg_boxedunimemb '"u_edge"
  :ctypg_entrystruct '"entryedgemelt_st"
  :ctypg_mapstruct '"meltmapedges_st"
  :ctypg_boxdiscr  discr_edge
  :ctypg_mapdiscr  discr_map_edges
  :ctypg_mapunimemb    '"u_mapedges"
  :ctypg_boxfun        '"meltgc_new_edge"
  :ctypg_unboxfun      '"melt_edge_content"
  :ctypg_updateboxfun  '"meltgc_edge_updatebox"
  :ctypg_newmapfun     '"meltgc_new_mapedges"
  :ctypg_mapgetfun     '"melt_get_mapedges"
  :ctypg_mapputfun     '"melt_put_mapedges"
  :ctypg_mapremovefun  '"melt_remove_mapedges"
  :ctypg_mapcountfun   '"melt_count_mapedges"
  :ctypg_mapsizefun    '"melt_size_mapedges"
  :ctypg_mapnattfun    '"melt_nthattr_mapedges"
  :ctypg_mapnvalfun    '"melt_nthval_mapedges"	
  )
(install_ctype_descr ctype_edge "GCC edge")

;; the C type for gcc loop-s
(definstance ctype_loop class_ctype_gty
  :doc #{The $CTYPE_LOOP is the c-type of raw GCC loop stuff. See also $DISCR_LOOP.
Keyword is :loop.}#
  :predef CTYPE_LOOP
  :named_name  '"CTYPE_LOOP"
  :ctype_keyword ':loop
  :ctype_cname '"loop_p"
  :ctype_parchar '"MELTBPAR_LOOP"
  :ctype_parstring '"MELTBPARSTR_LOOP"
  :ctype_argfield '"meltbp_loop"
  :ctype_resfield '"meltbp_loopptr"
  :ctype_marker '"gt_ggc_mx_loop"
;; GTY ctype
  :ctypg_boxedmagic '"MELTOBMAG_LOOP"
  :ctypg_mapmagic '"MELTOBMAG_MAPLOOPS"
  :ctypg_boxedstruct '"meltloop_st"
  :ctypg_boxedunimemb '"u_loop"
  :ctypg_entrystruct '"entryloopmelt_st"
  :ctypg_mapstruct '"meltmaploops_st"
  :ctypg_boxdiscr  discr_loop
  :ctypg_mapdiscr  discr_map_loops
  :ctypg_mapunimemb    '"u_maploops"
  :ctypg_boxfun        '"meltgc_new_loop"
  :ctypg_unboxfun      '"melt_loop_content"
  :ctypg_updateboxfun  '"melt_loop_updatebox"
  :ctypg_newmapfun     '"meltgc_new_maploops"
  :ctypg_mapgetfun     '"melt_get_maploops"
  :ctypg_mapputfun     '"melt_put_maploops"
  :ctypg_mapremovefun  '"melt_remove_maploops"
  :ctypg_mapcountfun   '"melt_count_maploops"
  :ctypg_mapsizefun    '"melt_size_maploops"
  :ctypg_mapnattfun    '"melt_nthattr_maploops"
  :ctypg_mapnvalfun    '"melt_nthval_maploops"	
  )
(install_ctype_descr ctype_loop "GCC loop")

;; the C type for gcc rtx-s
(definstance ctype_rtx class_ctype_gty
  :doc #{The $CTYPE_RTX is the c-type of raw GCC rtx stuff. See also $DISCR_RTX.
Keyword is :rtx.}#
  :predef CTYPE_RTX
  :named_name  '"CTYPE_RTX"
  :ctype_keyword ':rtx
  :ctype_cname '"rtx"
  :ctype_parchar '"MELTBPAR_RTX"
  :ctype_parstring '"MELTBPARSTR_RTX"
  :ctype_argfield '"meltbp_rtx"
  :ctype_resfield '"meltbp_rtxptr"
  :ctype_marker '"gt_ggc_mx_rtx"
;; GTY ctype
  :ctypg_boxedmagic '"MELTOBMAG_RTX"
  :ctypg_mapmagic '"MELTOBMAG_MAPRTXS"
  :ctypg_boxedstruct '"meltrtx_st"
  :ctypg_boxedunimemb '"u_rtx"
  :ctypg_entrystruct '"entryrtxmelt_st"
  :ctypg_mapstruct '"meltmaprtxs_st"
  :ctypg_boxdiscr  discr_rtx
  :ctypg_mapdiscr  discr_map_rtxs
  :ctypg_mapunimemb    '"u_maprtxs"
  :ctypg_boxfun        '"meltgc_new_rtx"
  :ctypg_unboxfun      '"melt_rtx_content"
  :ctypg_updateboxfun  '"meltgc_rtx_updatebox"
  :ctypg_newmapfun     '"meltgc_new_maprtxs"
  :ctypg_mapgetfun     '"melt_get_maprtxs"
  :ctypg_mapputfun     '"melt_put_maprtxs"
  :ctypg_mapremovefun  '"melt_remove_maprtxs"
  :ctypg_mapcountfun   '"melt_count_maprtxs"
  :ctypg_mapsizefun    '"melt_size_maprtxs"
  :ctypg_mapnattfun    '"melt_nthattr_maprtxs"
  :ctypg_mapnvalfun    '"melt_nthval_maprtxs"	
  )
(install_ctype_descr ctype_rtx "GCC rtx")

;; the C type for gcc bitmap-s
(definstance ctype_bitmap class_ctype_gty
  :doc #{The $CTYPE_BITMAP is the c-type of raw GCC bitmap stuff. See also $DISCR_BITMAP.
Keyword is :bitmap.}#
  :predef CTYPE_BITMAP
  :named_name  '"CTYPE_BITMAP"
  :ctype_keyword ':bitmap
  :ctype_cname '"bitmap"
  :ctype_parchar '"MELTBPAR_BITMAP"
  :ctype_parstring '"MELTBPARSTR_BITMAP"
  :ctype_argfield '"meltbp_bitmap"
  :ctype_resfield '"meltbp_bitmapptr"
  :ctype_marker '"gt_ggc_mx_bitmap"
;; GTY ctype
  :ctypg_boxedmagic '"MELTOBMAG_BITMAP"
  :ctypg_mapmagic '"MELTOBMAG_MAPBITMAPS"
  :ctypg_boxedstruct '"meltbitmap_st"
  :ctypg_boxedunimemb '"u_bitmap"
  :ctypg_entrystruct '"entrybitmapmelt_st"
  :ctypg_mapstruct '"meltmapbitmaps_st"
  :ctypg_boxdiscr  discr_bitmap
  :ctypg_mapdiscr  discr_map_bitmaps
  :ctypg_mapunimemb    '"u_mapbitmaps"
  :ctypg_boxfun        '"meltgc_new_bitmap"
  :ctypg_unboxfun      '"melt_bitmap_content"
  :ctypg_updateboxfun  '"meltgc_bitmap_updatebox"
  :ctypg_newmapfun     '"meltgc_new_mapbitmaps"
  :ctypg_mapgetfun     '"melt_get_mapbitmaps"
  :ctypg_mapputfun     '"melt_put_mapbitmaps"
  :ctypg_mapremovefun  '"melt_remove_mapbitmaps"
  :ctypg_mapcountfun   '"melt_count_mapbitmaps"
  :ctypg_mapsizefun    '"melt_size_mapbitmaps"
  :ctypg_mapnattfun    '"melt_nthattr_mapbitmaps"
  :ctypg_mapnvalfun    '"melt_nthval_mapbitmaps"	
  )
(install_ctype_descr ctype_bitmap "GCC bitmap")

;; the C type for gcc rtvec-s
(definstance ctype_rtvec class_ctype_gty
  :doc #{The $CTYPE_RTVEC is the c-type of raw GCC rtvec stuff. See also $DISCR_RTVEC.
Keyword is :rtvec.}#
  :predef CTYPE_RTVEC
  :named_name  '"CTYPE_RTVEC"
  :ctype_keyword ':rtvec
  :ctype_cname '"rtvec"
  :ctype_parchar '"MELTBPAR_RTVEC"
  :ctype_parstring '"MELTBPARSTR_RTVEC"
  :ctype_argfield '"meltbp_rtvec"
  :ctype_resfield '"meltbp_rtvecptr"
  :ctype_marker '"gt_ggc_mx_rtvec"
;; GTY ctype
  :ctypg_boxedmagic '"MELTOBMAG_RTVEC"
  :ctypg_mapmagic '"MELTOBMAG_MAPRTVECS"
  :ctypg_boxedstruct '"meltrtvec_st"
  :ctypg_boxedunimemb '"u_rtvec"
  :ctypg_entrystruct '"entryrtvecmelt_st"
  :ctypg_mapstruct '"meltmaprtvecs_st"
  :ctypg_boxdiscr  discr_rtvec
  :ctypg_mapdiscr  discr_map_rtvecs
  :ctypg_mapunimemb    '"u_maprtvecs"
  :ctypg_boxfun        '"meltgc_new_rtvec"
  :ctypg_unboxfun      '"melt_rtvec_content"
  :ctypg_updateboxfun  '"meltgc_rtvec_updatebox"
  :ctypg_newmapfun     '"meltgc_new_maprtvecs"
  :ctypg_mapgetfun     '"melt_get_maprtvecs"
  :ctypg_mapputfun     '"melt_put_maprtvecs"
  :ctypg_mapremovefun  '"melt_remove_maprtvecs"
  :ctypg_mapcountfun   '"melt_count_maprtvecs"
  :ctypg_mapsizefun    '"melt_size_maprtvecs"
  :ctypg_mapnattfun    '"melt_nthattr_maprtvecs"
  :ctypg_mapnvalfun    '"melt_nthval_maprtvecs"
  )
(install_ctype_descr ctype_rtvec "GCC rtvec")

;;; 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 '"MELTBPAR_PPL_COEFFICIENT"
  :ctype_parstring '"MELTBPARSTR_PPL_COEFFICIENT"
  :ctype_argfield '"meltbp_ppl_coefficient"
  :ctype_resfield '"meltbp_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 '"MELTBPAR_PPL_LINEAR_EXPRESSION"
  :ctype_parstring '"MELTBPARSTR_PPL_LINEAR_EXPRESSION"
  :ctype_argfield '"meltbp_ppl_linear_expression"
  :ctype_resfield '"meltbp_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 '"MELTBPAR_PPL_CONSTRAINT"
  :ctype_parstring '"MELTBPARSTR_PPL_CONSTRAINT"
  :ctype_argfield '"meltbp_ppl_constraint"
  :ctype_resfield '"meltbp_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 '"MELTBPAR_PPL_CONSTRAINT_SYSTEM"
  :ctype_parstring '"MELTBPARSTR_PPL_CONSTRAINT_SYSTEM"
  :ctype_argfield '"meltbp_ppl_constraint_system"
  :ctype_resfield '"meltbp_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 '"MELTBPAR_PPL_POLYHEDRON"
  :ctype_parstring '"MELTBPARSTR_PPL_POLYHEDRON"
  :ctype_argfield '"meltbp_ppl_polyhedron"
  :ctype_resfield '"meltbp_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 '"MELTBPAR_CSTRING"
  :ctype_parstring '"MELTBPARSTR_CSTRING"
  :ctype_argfield '"meltbp_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) 
	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")
	      (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 (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 end of MELT pass execution
(definstance end_melt_pass_execution_delayed_queue class_delayed_queue
  :named_name '"end_melt_pass_execution_delayed_queue"
  ;; the first and last are filled lazily!
  :delqu_first ()
  :delqu_last ()
)

(defun end_melt_pass_runner (noarg :cstring passname :long passnumber)
  (let ( (firstlist (unsafe_get_field :delqu_first end_melt_pass_execution_delayed_queue))
	 (lastlist (unsafe_get_field :delqu_last end_melt_pass_execution_delayed_queue))
	 (revlastlist (make_list discr_list))
	 (rescont (instance class_container))
	 (valpassname (make_stringconst discr_string passname))
	 (valpassnumber (make_integerbox discr_constant_integer passnumber))
	 )
    ;; clear the delayed_queue to ensure that this function will be
    ;; registered again
    (put_fields
     end_melt_pass_execution_delayed_queue
     :delqu_first ()
     :delqu_last ())
;;; call the first routines in natural order
    (list_every 
     firstlist
     (lambda (firstproc)
       (let ( (prevres (unsafe_get_field :container_value rescont)) 
	      (nextres (firstproc prevres valpassname valpassnumber))
	      )
	 (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 valpassname valpassnumber))
	      )
	 (unsafe_put_fields rescont :container_value nextres)
	 )))
    ))


(defun at_end_melt_pass_first (fun)
  :doc #{Use $AT_END_MELT_PASS_FIRST to register a function $FUN to be
  run at end of MELT passes' execution, in first place. At the end of
  the currently active MELT pass execution function, $FUN will be
  called with the result of the previously executed function, the
  boxed pass name, the boxed pass number.}#
  (let ( (firstlist (unsafe_get_field :delqu_first final_delayed_queue))
	 )
    (if (null firstlist)
	(progn
	  (setq firstlist (make_list discr_list))
	  (put_fields 
	   end_melt_pass_execution_delayed_queue
	   :delqu_first  firstlist
	   :delqu_last (make_list discr_list))
	  (put_fields
	   initial_system_data
	   :sysdata_meltpass_after_hook end_melt_pass_runner)))
    (if (is_closure fun) (list_append firstlist fun)))
  )

(defun at_end_melt_pass_last (fun)
  :doc #{Use $AT_END_MELT_PASS_LAST to register a function to be run
  at end of MELT passes' execution, in last place. See also
  $AT_END_MELT_PASS_FIRST.}#
  (let ( (lastlist (unsafe_get_field :delqu_last final_delayed_queue))
	 )
    (if (null lastlist)
	(progn
	  (setq lastlist (make_list discr_list))
	  (put_fields 
	   end_melt_pass_execution_delayed_queue
	   :delqu_first (make_list discr_list)
	   :delqu_last lastlist)
	  (put_fields
	   initial_system_data
	   :sysdata_meltpass_after_hook end_melt_pass_runner)))
    (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)))
  )


(definstance option_map_container class_container 
  :container_value (make_mapobject discr_map_objects 41))

(defclass class_option_descriptor
  :doc #{The internal $CLASS_OPTION_DESCRIPTOR describes MELT
options. $OPTDESC_NAME is the option symbol name, $OPTDESC_FUN is the
function, and $OPTDESC_HELP is the help string.}#
  :super class_root
  :fields (optdesc_name 
	   optdesc_fun
	   optdesc_help)
)

(defun init_optionsetter (optsymb :cstring optval)
  (debug_msg optsymb "init_optionsetter optsymb")
  (let ( (optmap (unsafe_get_field :container_value option_map_container)) 
	 (optdec (mapobject_get optmap optsymb))
	 (optname (get_field :named_name optsymb))
	 )
    (assert_msg "check optsymb" (is_a optsymb class_symbol))
    (if optdec
	(let ( (optfun (get_field :optdesc_fun optdec)) 
	       )
	  (assert_msg "check optdec" (is_a optdec class_option_descriptor))
	  (debug_msg optdec "init_optionsetter optdec")
	  (let ( (optres (optfun optsymb optval)) 
		 )
	    (debug_msg optres "init_optionsetter optres")
	    (return optres)))
      (progn
	(code_chunk badoption 
		    #{ warning (0, "unrecognized MELT option %s. Use -f[plugin-arg-]melt-option=help", 
				   melt_string_str ($optname)) }#)
	(return)
	))))
	       
(defun register_option (optsymb opthelp optfun)
  :doc #{Registers a MELT option of symbol $OPTSYMB helpstring $OPTHELP and 
function $OPTFUN.}#
   (if (and (is_a optsymb class_symbol)
	    (is_string opthelp)
	    (is_closure optfun))
       (let ( (optmap (unsafe_get_field :container_value option_map_container)) 
	      (optdesc (instance class_option_descriptor
				 :optdesc_name optsymb
				 :optdesc_fun optfun
				 :optdesc_help opthelp))
	      )
	 (mapobject_put optmap optsymb optdesc)
	 )))

(defun option_helper_fun (helpsymb :cstring helpstr)
  (let ( (optmap (unsafe_get_field :container_value option_map_container))
	 (symb (if helpstr (get_raw_symbol helpstr)))
	 (optd (mapobject_get optmap symb))
	 )
    (cond
     ( (is_a optd class_option_descriptor)
       (let ( (opthelp (unsafe_get_field :optdesc_help optd)) 
	      )
	 (code_chunk givehelp
		     #{ inform (UNKNOWN_LOCATION, 
				"MELT help for option %s : %s",
				$HELPSTR, melt_string_str ((melt_ptr_t) $OPTHELP)) }#)
	 (return helpsymb)     
       ))
     (:else
      (let ( (sortedsymbtup (mapobject_sorted_attribute_tuple optmap))
	     (sortednametup (multiple_map sortedsymbtup
					  (lambda (sy) (get_field :named_name sy)))
			     )
	     (:long nbsymb (multiple_length sortedsymbtup))
	     )
	(code_chunk 
	 informoption
	 #{ int i=0;
	    inform (UNKNOWN_LOCATION, "There are %d MELT options", 
				      (int) $NBSYMB);
	    for (i=0;
		 i<(int) $NBSYMB;
		 i+=2) {
		 char *n1 = (char*) melt_string_str(melt_multiple_nth((melt_ptr_t) $SORTEDNAMETUP, i));
		 char *n2 = (char*) melt_string_str(melt_multiple_nth((melt_ptr_t) $SORTEDNAMETUP, i+1));
		 if (n1 && n2) 
		   inform (UNKNOWN_LOCATION, "possible MELT options: %s & %s", n1, n2);
		 else
		   inform (UNKNOWN_LOCATION, "possible MELT option: %s", n1);
            };
            inform (UNKNOWN_LOCATION, "Use -f[plugin-arg-]melt-option=help=X for help about MELT option X");
	  }#)
	(return helpsymb)
      )))
))


(register_option 'help
		 '"Gives help about recognized MELT options"
		 option_helper_fun)





(defprimitive melt_error_counter () :long 
  :doc #{The MELT error counter.}#
#{(long) (melt_error_counter)}#)

;;;;

;;;;;;;;;;;;;;;;;;;; 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 ()
  :sysdata_stdout ()			;initialized later
  :sysdata_stderr ()			;initialized later
  :sysdata_dumpfile ()			;initialized later
  :sysdata_unit_starter init_unitstarter
  :sysdata_unit_finisher init_unitfinisher
  :sysdata_option_set init_optionsetter
  :sysdata_passexec_hook ()		;initialized later, lazily
  :sysdata_meltpass_after_hook () 	;initialized lazily
  :sysdata_meltpragmas ()
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; 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)))))))


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


;;; 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) == MELTOBMAG_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)
  :doc #{$LIST_MAP $LIS $F maps $F to each element of list $LIS, so
returns the list (LIST (F E_1) ...(F E_n)) if $LIS is the (LIST E_1
... E_n).}#
  (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)
  :doc #{$LIST_FIND find in list $LIS the first element E such
  that ($F E $X), if $F is null use the identity test.}#
  (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);
   for ($ix = 0;  
	($ix >= 0) && ($ix <  $eachtup#_ln);  
	$ix++) {
   $comp = melt_multiple_nth((melt_ptr_t)($tup),  $ix);
   }#
   #{ if ($ix<0) break;
   } /* 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 */ }#
  )

;;; 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)))))))	     



;;; installation of a method in a class or discriminant
(defun install_method (dis sel fun)
  :doc #{Install in class or discriminant $DIS for selector $SEL the function $FUN as method body.}#
  (cond 
   ( (is_a dis class_discriminant)
     (let ( (disname (unsafe_get_field :named_name dis))
	    )
       (cond 
	( (is_a sel class_selector)
	  (let ( (selname (unsafe_get_field :named_name sel))
		 )
	    (cond
	     ( (is_closure fun)
	       (let 
		   ( (mapdict 
		      (unsafe_get_field :disc_methodict dis)) )
		 (if (is_mapobject mapdict)
		     (mapobject_put mapdict sel fun)
		   (let ( (newmapdict (make_mapobject discr_method_map 35)) )
		     (unsafe_put_fields dis :disc_methodict newmapdict)
		     (mapobject_put newmapdict sel fun)
		     ))))
	     (:else			; fun not a closure
	      (shortbacktrace_dbg "INSTALL_METHOD failing on non-function" 20)
	      (code_chunk 
	       error_non_fun
	       #{ /* $ERROR_NON_FUN */
	       error ("MELT INSTALL_METHOD ERROR [#%ld] non-function in discriminant %s for selector %s",
		      melt_dbgcounter,
		      melt_string_str((melt_ptr_t) $DISNAME),
		      melt_string_str((melt_ptr_t) $SELNAME)) ;
	       }#)
	      ))))
	( (is_a sel class_named)  ; sel is not a selector but is named
	  (let ( (badselnam (unsafe_get_field :named_name sel))
		 )
	    (shortbacktrace_dbg "INSTALL_METHOD failing with bad named selector" 20)
	    (code_chunk
	     error_bad_named_sel
	     #{ /* $ERROR_BAD_NAMED_SEL */
	     error ("MELT INSTALL_METHOD ERROR [#%ld] bad named selector %s in discriminant %s",
		    melt_dbgcounter,
		    melt_string_str((melt_ptr_t) $BADSELNAM),
		    melt_string_str((melt_ptr_t) $DISNAME)) ;
	     }#)
	    ))
	(:else				;selector is not even named
	 (shortbacktrace_dbg "INSTALL_METHOD failing with bad selector" 20)
	 (code_chunk
	  error_bad_sel
	  #{ /* $ERROR_BAD_SEL */
	  error ("MELT INSTALL_METHOD ERROR [#%ld] bad selector in discriminant %s",
		 melt_dbgcounter,
		 melt_string_str((melt_ptr_t) $DISNAME)) ;
	  }#)
	 )
	)				; end of cond about sel
       )
     )				  ;end when dis is a discriminant
   ( (is_a dis class_named)	  ;dis is named but not a discriminant
     (let ( (baddisnam (unsafe_get_field :named_name dis))
	    )
       (shortbacktrace_dbg "INSTALL_METHOD failing with bad named discriminant" 20)
       (code_chunk
	error_bad_named_dis
	#{ /* $ERROR_BAD_NAMED_DIS */
	error ("MELT INSTALL_METHOD ERROR [#%ld] bad named discriminant %s",
	       melt_dbgcounter, 
	       melt_string_str((melt_ptr_t) $BADDISNAM)) ;
	}#)
       ))				;end when dis is named
   (:else				;dis is not even named
    (shortbacktrace_dbg "INSTALL_METHOD failing with bad discriminant" 20)
    (code_chunk
     error_bad_dis
     #{ /* $ERROR_BAD_DIS */
     error ("MELT INSTALL_METHOD ERROR [#%ld] bad discriminant",
	    melt_dbgcounter)		;
     }#))		 
   )
  )



;; 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))
	    ))))





;; 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 (tuple 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)))
      )
    )
  )






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


;; 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))
	       ))))

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

;; 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)
 )

(defun retrieve_dictionnary_ctype_gty ()
  :doc #{Retrieve the dictionnary of GTY-ed ctypes.}#
  (get_field :container_value container_ctype_gty_dict)
)

(defun retrieve_dictionnary_ctype ()
  :doc #{Retrieve the dictionnary of all ctypes.}#
  (get_field :container_value container_ctype_dict)
)

;;;;;; 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_ctype_gty
 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_pragma
 class_gcc_rtl_pass
 class_gcc_any_ipa_pass
 class_gcc_simple_ipa_pass
 class_gcc_transform_ipa_pass
 class_initial_generation_context
 class_infix_additive_symbol
 class_infix_any_symbol
 class_infix_delimiter
 class_infix_integer_literal
 class_infix_keyword
 class_infix_lexeme 
 class_infix_multiplicative_symbol
 class_infix_relational_symbol
 class_infix_string_literal
 class_infix_symbol
 class_instance_binding
 class_keyword
 class_label_binding
 class_let_binding
 class_letrec_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_sexpr_macrostring
 class_source
 class_symbol
 class_system_data
 class_value_binding 
 )					;end of export class



;;;;;;;;;;;;;;;;
;;;; export the above primitives
(export_values				;in alphanumerical order
 !=
 %i
 %iraw
 +i
 /i
 /iraw
 <i
 >i
 ==
 !=s
 ==s
 >=i
 assert_failed
 box_content
 box_of
 box_put
 closure_nth
 closure_routine
 closure_size
 create_keywordstr
 create_symbolstr
 discrim
 get_int
 get_keywordstr
 get_symbolstr
 get_raw_symbol
 informsg_long
 informsg_strv
 is_a
 is_box
 is_closure
 is_integerbox
 is_list
 is_list_or_null
 is_mapobject
 is_mapstring
 is_multiple
 is_non_empty_list
 is_not_a
 is_object
 is_pair
 is_routine
 is_string
 list_append
 list_first
 list_first_element
 list_find
 list_last
 list_last_element
 list_length
 list_popfirst
 list_prepend
 make_box
 make_integerbox
 make_list
 make_mapobject
 make_mapstring
 make_multiple
 make_stringconst
 mapobject_count
 mapobject_get
 mapobject_nth_attr
 mapobject_nth_val
 mapobject_put
 mapobject_remove
 mapobject_size
 mapstring_getstr
 mapstring_nth_attrstr
 mapstring_nth_val
 mapstring_putstr
 mapstring_removestr
 multiple_length
 multiple_nth
 multiple_put_nth
 multiple_sort
 need_dbg
 need_dbglim
 not
 null
 pair_head
 pair_tail
 put_int
 routine_descr
 routine_nth
 routine_size
 shortbacktrace_dbg
 string<
 string>
 stringconst2val
 the_meltcallcount
 the_callcount
 the_framedepth
 the_null_cstring
 )



;; export the discriminants and instances and selectors defined above
(export_values				;alphabetical order
 ctype_basic_block
 ctype_bitmap
 ctype_cstring     
 ctype_edge                   
 ctype_gimple
 ctype_gimple_seq
 ctype_long 
 ctype_loop
 ctype_ppl_coefficient
 ctype_ppl_constraint
 ctype_ppl_constraint_system
 ctype_ppl_linear_expression
 ctype_rtvec
 ctype_rtx
 ctype_tree                           
 ctype_value                          
 ctype_void  
 discr_any_receiver                        
 discr_basic_block   
 discr_bitmap                       
 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_loop
 discr_map_basic_blocks
 discr_map_bitmaps
 discr_map_edges
 discr_map_gimple_seqs
 discr_map_gimples
 discr_map_objects                     
 discr_map_rtvecs
 discr_map_rtxs
 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_real
 discr_routine                        
 discr_rtvec
 discr_rtx
 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_end_melt_pass_first
 at_end_melt_pass_last
 at_finish_unit_first
 at_finish_unit_last
 at_start_unit_first
 at_start_unit_last
 clone_symbol
 closure_every
 compare_obj_ranked
 find_enclosing_env			
 find_env				
 find_env_debug
 fresh_env				
 install_ctype_descr				
 install_method	
 list_append2list			
 list_every				
 list_iterate_test			
 list_map				
 list_to_multiple			
 mapobject_every			
 mapobject_iterate_test	
 mapobject_sorted_attribute_tuple		
 multiple_iterate_test			
 multiple_map				
 multiple_to_list
 overwrite_env				
 pairlist_to_multiple	
 post_initialization
 put_env
 register_option
 retrieve_dictionnary_ctype
 retrieve_dictionnary_ctype_gty
 routine_every
 )


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

;; 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)}#))

;;; this definition is internal to this first file. It is here only to
;;; allow debug_msg macros in this warmelt-first.melt file. The real
;;; function is inside warmelt-debug.melt. It should not be exported
;;; (because it is exported in warmelt-debug.melt). This is a dirty
;;; trick to implement a circular reference.
(defun debug_msg_fun (val :cstring msgstr :long count :cstring filenam :long lineno)
  (let ( (dbgmsgfun (unsafe_get_field :sysdata_debugmsg initial_system_data)) )
    (if (is_closure dbgmsgfun)
	(dbgmsgfun val msgstr count filenam lineno))))

;; eof warmelt-first.melt