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

;; file warmelt-macro.melt -*- Lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(comment "***
    Copyright 2008, 2009, 2010 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-macro.melt and 
;; to the generated file or warmelt-macro*.c
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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




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


(defselector is_recursively_constructible class_selector
  :doc #{The selector $IS_RECURSIVELY_CONSTRUCTIBLE tests if an expression can appear in $LETREC bindings.}#
  :formals (recv)
)
  

;;; superclass for source with a sequence of argument subexpressions
(defclass class_source_argumented_operator
  :doc #{The internal super-class $CLASS_SOURCE_ARGUMENTED_OPERATOR is
the super-class of many abstract syntax with a sequence of argument
subexpressions. Field $SARGOP_ARGS is the tuple of arguments.}#
  :super class_source
  :fields (sargop_args))
	
;;; source application 
(defclass class_source_apply
  :doc #{The internal $CLASS_SOURCE_APPLY is for function application abstract syntax. $SAPP_FUN is
  the applied function, $SARGOP_ARGS is the tuple of arguments.}#
  :super class_source_argumented_operator
  :fields (sapp_fun			;the function to apply
;	   sapp_args			;the arguments tuple
	   ))


;;; source message sending 
(defclass class_source_msend
  :doc #{The internal $CLASS_SOURCE_MSEND for message sending abstract
  syntax. $MSEND_SELSYMB is the message selector symbol, $MSEND_RECV
  is the reciever, $SARGOP_ARGS is the tuple of arguments.}#
  :super class_source_argumented_operator
  :fields ( 
	   msend_selsymb		;the selector symbol
	   msend_recv			;the reciever
	   ))

;;; source primitive call
(defclass class_source_primitive
  :doc #{The internal $CLASS_SOURCE_PRIMITIVE is for primitive
invocation abstract syntax. $SPRIM_OPER is the primitive operation,
$SARGOP_ARGS is the tuple of arguments.}#
  :super class_source_argumented_operator
  :fields (sprim_oper			;the primitive operation
	   ))

;;; source citerator invocation
(defclass class_source_citeration
  :doc #{The intenal $CLASS_SOURCE_CITERATION is for c-iteration
  abstract syntax. $SCRITER_OPER is the c-iterator, $SARGOP_ARGS is
  the tuple of arguments, $SCITER_VARBIND is the tuple of formal local
  bindings, and $SCITER_BODY is the tuple for the abstract body.}#
  :super class_source_argumented_operator
  :fields (sciter_oper			;the citerator operation
	   sciter_varbind		;tuple of formal local var bindings
	   sciter_body			;tuple for body
	   ))

;;; source cmatcher expression
(defclass class_source_cmatchexpr
  :doc #{The internal $CLASS_SOURCE_CMATCHEXPR is for c-matcher
expression abstract syntax. $SCMATX_CMATCHER is for the c-matcher,
$SCMATX_ARGS is for arguments.}#
  :super class_source_argumented_operator
  :fields (scmatx_cmatcher		;the cmatcher
	   ))

;; source funmatcher expression
(defclass class_source_funmatchexpr
  :doc #{The internal $CLASS_SOURCE_FUNMATCHEXPR is for funmatcher
expression abstract syntax. $SFMATX_FMATCHER is the funmatcher
$SFMATX_FMATBIND is the funmatcher binding, $SARGOP_ARGS is the
tuple of arguments.}#
  :super class_source_argumented_operator
  :fields (sfmatx_fmatcher		;the funmatcher
	   sfmatx_fmatbind		;the funmatcher binding
))

;;; source tuple
(defclass class_source_tuple
  :doc #{The internal $CLASS_SOURCE_TUPLE is for $TUPLE expression
 abstract syntax.  $SARGOP_ARGS is the tuple of arguments.}#
  :super class_source_argumented_operator
  :fields ())

;;; source list
(defclass class_source_list
  :doc #{The internal $CLASS_SOURCE_LIST is for $LIST expression
 abstract syntax.  $SARGOP_ARGS is the tuple of arguments.}#
  :super class_source_argumented_operator
  :fields ())

;;; source progn
(defclass class_source_progn
  :doc #{The internal $CLASS_SOURCE_PROGN is for $PROGN expression abstract syntax. 
$SPROGN_BODY is the body tuple.}#
  :super class_source
  :fields (sprogn_body			;the body tuple
	   ))

;;; source return
(defclass class_source_return
:doc #{The internal $CLASS_SOURCE_RETURN is for $RETURN expression
abstract syntax. The tuple of returned stuff is $SARGOP_ARGS.}#
  :super class_source_argumented_operator
  :fields ())

;;;; source setq
(defclass class_source_setq
  :doc #{The internal $CLASS_SOURCE_SETQ is for $SETQ expression
abstract syntax. $SSTQ_VAR is the assigned variable, $SSTQ_EXPR is
the expression.}#
  :super class_source
  :fields (sstq_var
	   sstq_expr))

;;;; source comment
(defclass class_source_comment
  :doc #{The internal $CLASS_SOURCE_COMMENT is for $COMMENT abstract
  syntax. $SCOMM_STR is the comment string.}#
  :super class_source
  :fields (scomm_str
	   ))

;;;; source quote
(defclass class_source_quote
  :doc #{The internal $SCLASS_SOURCE_QUOTE is for $QUOTE abstract syntax. $SQUOTED is the quoted stuff.}#
  :super class_source
  :fields (squoted
	   ))

;; source export 
(defclass class_source_exportcommon
  :doc #{The internal $CLASS_SOURCE_EXPORTCOMMON is the common
super-class of abstract syntax of name-exporting directives. $SEXPORT_NAMES is the
tuple of exported names.}#
  :super class_source
  :fields (sexport_names
	   ))

;; export value
(defclass class_source_export_values
  :doc #{The internal $CLASS_SOURCE_EXPORT_VALUES is for the $EXPORT_VALUES directive.}#
  :super class_source_exportcommon
  :fields (
	   ))

;; export classes
(defclass class_source_export_class
  :doc #{The internal $CLASS_SOURCE_EXPORT_CLASS is for abstract
syntax of $EXPORT_CLASS directives.}#
  :super class_source_exportcommon
  :fields (
	   ))

;; export one macro - (export_macro <macroname> <value>)
;; beware that the evaluation of the value is done near end of initial routine!
(defclass class_source_export_macro
  :doc #{The internal $CLASS_SOURCE_EXPORT_MACRO is for abstract syntax of
$EXPORT_MACRO directives. $SEXPMAC_MNAME is the macro-name,
$SEXPMAC_MVAL is the expanser value, and $SEXPMAC_DOC is the
documentation.}#
  :super class_source
  :fields (sexpmac_mname
	   sexpmac_mval
	   sexpmac_doc
	   ))

;; export one pattern - (export_patmacro <macroname> <patexpvalue> <macexpvalue>)
;; beware that the evaluation of the value is done near end of initial routine!
(defclass class_source_export_patmacro
  :doc #{The internal $CLASS_SOURCE_EXPORT_PATMACRO is for abstract
syntax of $EXPORT_PATMACRO directive. $SEXPPAT_PVAL is the pattern
expander.}#
  :super class_source_export_macro
  :fields (
	   sexppat_pval			;value of patternexpander
	   ))



;;; export a synonym (export_synonym <newname> <oldname> [:doc <docum>)
(defclass class_source_export_synonym
  :doc #{$CLASS_SOURCE_EXPORT_SYNONYM represent synonym declarations: the
$SEXPSYN_NEWNAME is a new name synonym of $EXPSYN_OLDNAME and
documentation $SEXPSYN_DOC.}#
  :super class_source
  :fields (sexpsyn_newname
	   sexpsyn_oldname
	   sexpsyn_doc))


;;; superclass for all source definitions
(defclass class_source_definition
  :doc #{The internal common super-class for abstract syntax of all source definitions is
  $CLASS_SOURCE_DEFINITION. The field $SDEF_NAME is the defined name. The field
  $SDEF_DOC gives the optional documentation.}#  
  :super class_source
  :fields (sdef_name			;defined name
	   sdef_doc			;documentation string or list
	   ))

;;; superclass for all definitions with formal arglist
(defclass class_source_definition_formal
  :doc #{The internal $CLASS_SOURCE_DEFINITION_FORMAL is the super-class of all definitions
with a formal arguments binding tuple given in $SFORMAL_ARGS.}# 
  :super class_source_definition
  :fields (sformal_args			;formal arguments binding tuple
	   ))

;;;; define a function
(defclass class_source_defun
  :doc #{The internal $CLASS_SOURCE_DEFUN is the abstract syntax of $DEFUN. $SFUN_BODY is the body tuple.}#
  :super class_source_definition_formal
  :fields (sfun_body			;body sequence
	   ))

;;; define a primitive
(defclass class_source_defprimitive
  :doc #{The internal $CLASS_SOURCE_DEFPRIMITIVE is the abstact syntax of $DEFPRIMITIVE. 
$SPRIM_TYPE is the result ctype, $SPRIM_EXPANSION is the tuple of its expansion.}#
  :super class_source_definition_formal
  :fields (sprim_type			;result type of primitive
	   sprim_expansion		;primitive expansion
	   ))

;;; define a citerator
(defclass class_source_defciterator
  :doc #{The internal $CLASS_SOURCE_DEFCITERATOR is the abstact syntax of $DEFCITERATOR.
$SCITERDEF_CITERATOR is the c-iterator.}#
  :super class_source_definition_formal		;the sformal_args is the start arguments
  :fields (sciterdef_citerator		;the citerator
	   ))

;;; define a cmatcher
(defclass class_source_defcmatcher
  :doc #{The internal $CLASS_SOURCE_DEFCMATCHER is the abstract syntax
of $DEFCMATCHER. $SCMATDEF_CMATCHER is the c-matcher.}#
  :super class_source_definition_formal
  :fields (;;loca_location is the location
	   ;;sdef_name is the new cmatcher name
	   ;;sformal_args is for the matched formal & input arguments
	   ;;;;the first formal is for the matched stuff. The rest is for input
	   scmatdef_cmatcher		;the cmatcher
	   ))

;;; define a funmatcher
(defclass class_source_defunmatcher
  :doc #{The internal $CLASS_SOURCE_DEFUNMATCHER is the abstract
syntax of $DEFUNMATCHER. $SFUMATDEF_INS is the input formals
tuple. $SFUNMATDEF_OUTS is the output formals tuple. $SFUMATDEF_MATCHF
is the matcher function expression. $SFUNMATDEF_APPLYF is the the
applying function expression. $SFUMATDEF_DATA is some extra data.}#
  :super class_source_definition_formal
  :fields (;;loca_location is the location
	   ;;sdef_name is the new cmatcher name
	   ;;sformal_args is for matched formal & input arguments
	   ;;;;the first formal is for the matched stuff. The rest is for input
	   sfumatdef_ins		;the ins formals (rest of sformal_args)
	   sfumatdef_outs		;output argument list
	   sfumatdef_matchf		;the matcher function expr
	   sfumatdef_applyf		;the applying function expr
	   sfumatdef_data		;supplementary data expr
	   ))


;; define an object (common to instance, class, selector)
(defclass class_source_defobjcommon
  :doc #{The internal $CLASS_SOURCE_DEFOBJCOMMON is the common superclass for
  object definitions. $SOBJ_PREDEF is the predefined rank if any.}#
  :super class_source_definition
  :fields (sobj_predef			;the predefined rank
	   ))

;; define a class 
;;;; the class has been built (at compile time), but we need a
;;;; srcdefclass to actually generate code
(defclass class_source_defclass
  :doc #{The internal $CLASS_SOURCE_DEFCLASS is the $DEFCLASS
abstract syntax. $SCLASS_CLABIND is the binding of the class,
$SCLASS_SUPERBIND is the binding of the superclass, $SCLASS_FLDBIND is
the sequence of own field bindings.}#
  :super class_source_defobjcommon
  :fields (sclass_clabind		;the binding of the class
	   sclass_superbind		;binding of superclass (or nil if none)
	   sclass_fldbinds		;the sequence of (own field bindings)
	   ))


;; define an instance
(defclass class_source_definstance
  :doc #{The internal $CLASS_SOURCE_DEFINSTANCE is the $DEFINSTANCE
abstract syntax. $SINST_CLASS the class of the defined instance,
$SINST_CLABIND is its binding, $SINST_OBJNUM if for the object magic
number, $SINST_FIELDS is the sequence of field assignments of
$CLASS_SOURCE_FIELDASSIGN.}#
  :super class_source_defobjcommon
  :fields (sinst_class			;the class of the instance
	   sinst_clabind		;the classbinding of the instance
	   sinst_objnum			;the object number symbol or integer
	   sinst_fields			;the sequence of field assignment
	   ))

;; define a selector 
(defclass class_source_defselector
  :doc #{The internal $CLASS_SOURCE_DEFSELECTOR is the $DEFSELECTOR abstract syntax. $SDEFSEL_FORMALS
is the formal argument bindings signature sequence, if any.}#
  :super class_source_definstance
  :fields (sdefsel_formals		;the formal arguments as signature
	   )
  )

;; a field assignment
(defclass class_source_fieldassign
  :doc #{The internal $CLASS_SOURCE_FIELDASSIGN is the abstract syntax
for field assigments inside e.g. $DEFINSANCE. $SFLA_FIELD is the
field, $SFLA_EXPR is the expression.}#
  :super class_source
  :fields (sfla_field			;the field 
	   sfla_expr			;the expression
	   ))


;; make an instance
(defclass class_source_instance
  :doc #{The internal $CLASS_SOURCE_INSTANCE is the abstract
syntax of $INSTANCE expressions.  $SMINS_CLASS is the class of the new
object, $SMINS_CLABIND is the class binding, $SMINS_FIELDS is the
sequence of $CLASS_SOURCE_FIELDASSIGN.}#
  :super class_source
  :fields (smins_class			;the class to be instantiated
	   smins_clabind		;its (class|value) binding
	   smins_fields			;the sequence of field assignment
	   ))

;;; source  get field
(defclass class_source_get_field
  :doc #{The internal $CLASS_SOURCE_GET_FIELD is the abstract syntax
  of $GET_FIELD. $SUGET_OBJ is the object expression, $SUGET_FIELD is
  the field keyword.}#
  :super class_source
  :fields (suget_obj	     ;the object expression
	   suget_field	     ;the field keyword
	   ))


;;; source unsafe get field
(defclass class_source_unsafe_get_field
  :doc #{The internal $CLASS_SOURCE_UNSAFE_GET_FIELD is the abstract
syntax of $UNSAFE_GET_FIELD. See $CLASS_SOURCE_GET_FIELD.}#
  :super class_source_get_field
  :fields ())

;;; source get field

;; source put fields
(defclass class_source_put_fields
  :doc #{The internal $CLASS_SOURCE_UNSAFE_PUT_FIELDS is the abstract
syntax of $PUT_FIELDS. $SUPUT_OBJ is the object expression,
$SUPU_FIELDS is the sequence of $CLASS_SOURCE_FIELDASSIGN.}#
  :super class_source
  :fields (suput_obj	     ;the object expression
	   suput_fields			;the sequence of field assignment
	   ))

;; source unsafe put fields
(defclass class_source_unsafe_put_fields
  :doc #{The internal $CLASS_SOURCE_UNSAFE_PUT_FIELDS is the abstract
syntax of $UNSAFE_PUT_FIELDS. See $CLASS_SOURCE_PUT_FIELDS.}#
  :super class_source_put_fields
  :fields (
	   ))


;; a conditional (if, and, cond)
(defclass class_source_if
  :doc #{The internal $CLASS_SOURCE_IF is the abstract syntax of
  conditionals like $IF $AND $COND. $SIF_TEST is the test, and
  $SIF_THEN is the then part. See also $CLASS_SOURCE_IFELSE.}#
  :super class_source
  :fields (sif_test
	   sif_then
	   ))

(defclass class_source_ifelse
  :doc #{The internal $CLASS_SOURCE_IFELSE is the abstract syntax of
conditionals with else part like some $IF $AND $COND. The $SIF_ELSE
is the else part. See also $CLASS_SOURCE_IF.}#
  :super class_source_if
  :fields ( sif_else
	    ))

;; an or
;;; since (OR a1 a2) is (IF a1 a1 a2) we need to normalize it to avoid evaluating twice a1
;;; so there is no normalized or... (only normalized if-s)
(defclass class_source_or
  :doc #{The internal $CLASS_SOURCE_OR is the abstract syntax of $OR
conditionals. $SOR_DISCJ is the tuple of disjuncts. See also
$CLASS_SOURCE_IF.}#
;;; we don't use class_source_argumented_operator because the
;;; arguments are used lazily, so they are really disjuncts...
  :super class_source
  :fields (sor_disj			;tuple of disjuncts
	   ))


;; preprocessor conditional
(defclass class_source_cppif
  :doc #{The internal $CLASS_SOURCE_CPPIF is the abstract syntax of $CPPIF preprocessor conditionals. 
$SIFP_COND is the preprocessor symbol. $SIFP_THEN is the then part. $SIFP_ELSE is the else part.}#
  :super class_source
  :fields (sifp_cond			;C preprocessor symbol or verbatim string to test
	   sifp_then			;then clause
	   sifp_else			;else clause
	   ))

;;;;;;;;;;;;;;;;
;; match 
(defclass class_source_match
  :doc #{The internal $CLASS_SOURCE_MATCH is the abtract syntax of
$MATCH expressions.  $SMAT_MATCHEDX is the matched
expression. $SMAT_CASES is the tuple of match-cases of
$CLASS_SOURCE_CASEMATCH.}#
  :super class_source
  :fields (smat_matchedx		;matched expression
	   smat_cases			;match case tuple
	   ))

;; match case
(defclass class_source_match_case
  :doc #{The internal $CLASS_SOURCE_MATCH_CASE is the abstract syntax of match-cases. $SCAM_PATT is the pattern, $SCAM_BODY is the body tuple.}#
  :super class_source
  :fields (scam_patt			;pattern
	   scam_body			;body
	   ))

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

;;; letbinding source - not a binding, just abstract syntax for them
(defclass class_source_let_binding
  :doc #{The internal $CLASS_SOURCE_LET_BINDING is abstract syntax for
  $LET bindings in the source. The $SLETB_TYPE gives the type of the
  binding, the $SLETB_BINDER gives the binder, and the $SLETB_EXPR
  gives the bound expression.}#
  :super class_source
  :fields (sletb_type			;the type of the binding
	   sletb_binder			;the binder (variable)
	   sletb_expr			;the expression
	   ))

(defclass class_source_letrec_binding
  :doc #{The internal $CLASS_SOURCE_LETREC_BINDING is abstract syntax for $LETREC bindings in the source.}#
  :super class_source_let_binding
  :fields ())

;; let source
(defclass class_source_let
  :doc #{The internal $CLASS_SOURCE_LET is for abstract syntax of
$LET. The $SLET_BINDINGS field is the tuple of bindings as instances
of $CLASS_SOURCE_LET_BINDING and the $SLET_BODY field is the tuple of
body.}#
  :super class_source
  :fields (slet_bindings		;the tuple of letbinding-s
	   slet_body			;the body tuple 
	   ))

(defclass class_source_letrec
  :doc #{The internal $CLASS_SOURCE_LETREC is for abstract syntax of
  $LETREC. The $SLET_BINDINGS are restricted to constructible
  expressions bindings}#
  :super class_source_let
  :fields ())

;; lambda
(defclass class_source_lambda
  :doc #{The internal $CLASS_SOURCE_LAMBDA is for abstract syntax of
  $LAMBDA. The $SLAM_ARGBIND is the tuple of formals
  $CLASS_FORMAL_BINDING and the $SLAM_BODY is the tuple of body
  expressions.}#
  :super class_source 
  :fields (slam_argbind			;tuple of argument bindings
	   slam_body			;tuple for body
	   ))


;; multicall
(defclass class_source_multicall
  :doc #{The internal $CLASS_SOURCE_MULTICALL is for abstract syntax
of $MULTICALL. The tuple of formal bindings of result variables is
$SMULC_RESBIND. The called abstract syntac is $SMULC_CALL, and the
body is $SMULC_BODY.}#
  :super class_source
  :fields (smulc_resbind		;tuple of argument bindings for multiple results
	   smulc_call			;called stuff
	   smulc_body			;tuple for body
	   ))

;;; forever & exit share a common label
(defclass class_source_labelled
  :doc #{The internal $CLASS_SOURCE_LABELLED is the super-class of
abstract syntax dealing with labels like $FOREVER and $EXIT. The
field $SLABEL_BIND gives the label binding.}#
  :super class_source
  :fields (slabel_bind			;the label binding
	   ))

;; forever
(defclass class_source_forever
  :doc #{The internal $CLASS_SOURCE_FOREVER is for abstract syntax of
  $FOREVER loops. The field $SFRV_BODY is the body sequence.}#
  :super class_source_labelled
  :fields (sfrv_body			;tuple for body
	   ))

;; exit
(defclass class_source_exit
  :doc #{The internal $CLASS_SOURCE_EXIT is for abstract syntax of
$EXIT loops. The field $SEXI_BODY is the body sequence.}#
  :super class_source_labelled
  :fields ( sexi_body			;tuple for body
	    ))

(compile_warning "should document below.")
;; compile time warning
(defclass class_source_compilewarning
  :super class_source
  :fields (scwarn_msg
	   scwarn_expr))

;; the fresh current module environment box, returning the newly build
;; module environment result of the generated start_module_melt
(defclass class_source_current_module_environment_container
  :super class_source
  :fields (
	   cmec_comment		;extra comment
	   ))

;; the fres previous module environment, returning the argument passed
;; to the generated start_module_melt
(defclass class_source_parent_module_environment
  :super class_source
  :fields (
	   ))


;; update the current module environment container - only callable at
;; toplevel
(defclass class_source_update_current_module_environment_container
  :super class_source
  :fields (
	   sucme_comment		;optional comment, only used
					;for internally generated ...
	   ))


;;; fetch a predefined by its name or rank
(defclass class_source_fetch_predefined
  :super class_source
  :fields (sfepd_predef
	   ))

;; store into a predefined
(defclass class_source_store_predefined
  :super class_source
  :fields (sstpd_predef
	   sstpd_value
	   ))


;; source code chunk
(defclass class_source_codechunk
  :super class_source
  :fields (sch_gensym			;generating symbol
	   sch_chunks			;the chunks
))

;;;;;;;;;;;;;;;;
;;; source patterns
(defclass class_source_pattern
  :doc #{Common internal super-class $CLASS_SOURCE_PATTERN for
abstract syntax of patterns. The $PAT_WEIGHT field contains the weight
of the pattern, in a boxed integer.}#
  :super class_source
  :fields (pat_weight
	   ))

;;; or patterns
(defclass class_source_pattern_or
  :doc #{The internal $CLASS_SOURCE_PATTERN_OR is for abstract syntax
of $OR patterns. Pattern syntax is ?(OR subpattern...). Field
$ORPAT_DISJ gives the tuple of pattern disjuncts.}#
  :super class_source_pattern
  :fields (orpat_disj		    ;tuple of pattern disjuncts
))

;;; and patterns
(defclass class_source_pattern_and
  :super class_source_pattern
  :doc #{The internal $CLASS_SOURCE_PATTERN_AND is for abstract syntax
of $AND patterns. Pattern syntax is ?(AND subpattern...). Field
$ANDPAT_CONJ gives the tuple of pattern conjuncts.}#
  :fields (andpat_conj			;tuple of pattern conjoncts
))

;;; when patterns
(defclass class_source_pattern_when
  :super class_source_pattern
  :doc #{The internal $CLASS_SOURCE_PATTERN_WHEN is for abstract
syntax of tested patterns. Pattern syntax is ?(WHEN sub-pattern
condition). Field $WHENPAT_SUBPAT is the sub-pattern and $WHENPAT_COND
is the condition.}#
  :fields (whenpat_subpat 
	   whenpat_cond))



;;; simple source pattern variable
(defclass class_source_pattern_variable
  :doc #{The internal $CLASS_SOURCE_PATTERN_VARIABLE is for pattern
variable abstract syntax. The field $SPATVAR_SYMB gives the variable symbol. 
The field $SPATVAR_NBOCC is the boxed occurrence count.}#
  :super class_source_pattern
  :fields (spatvar_symb
	   spatvar_nbocc
	   ))
(export_synonym spat_var spatvar_symb)

;;; the joker source pattern variable
(defclass class_source_pattern_joker_variable
  :doc #{The internal $CLASS_SOURCE_PATTERN_JOKER_VARIABLE is for joker pattern abstract syntax.}#
  :super class_source_pattern_variable
  :fields (
	   ))

;;; simple source pattern constant
(defclass class_source_pattern_constant
  :doc #{The internal $CLASS_SOURCE_PATTERN_CONSTANT is for constant
pattern abstract syntax. The field $SPAT_CONSTX is the expression
giving the constant.}#
  :super class_source_pattern
  :fields (spat_constx			;expression giving the constant
	   ))
;;; simple source pattern constant

(defclass class_source_pattern_construct
  :doc #{The internal $CLASS_SOURCE_PATTERN_CONSTRUCT is the superclass for
constructive pattern abstract syntax. The field $CTPAT_SUBPA is for
sub-patterns abstract syntax.}#
  :super class_source_pattern
  :fields (ctpat_subpa			;sub-patterns
	   ))

;; tuple patterns
(defclass class_source_pattern_tuple
  :doc #{The internal $CLASS_SOURCE_PATTERN_TUPLE is for $TUPLE
pattern abstract syntax.}#
  :super class_source_pattern_construct
  :fields ())

;; list patterns
(defclass class_source_pattern_list
  :doc #{The internal $CLASS_SOURCE_PATTERN_LIST is for $LIST
pattern abstract syntax.}#
  :super class_source_pattern_construct
  :fields ())

;; simple source pattern for objects - with a sequence of fieldpatterns
;; matches an object whose class is spat_class or a subclass of it
(defclass class_source_pattern_object
  :doc #{The internal $CLASS_SOURCE_PATTERN_OBJECT is for $OBJECT
pattern abstract syntax. $SPAT_CLASS gives the class, and
$SPAT_FIELDS give the sequence of field patterns. See also
$CLASS_SOURCE_PATTERN_INSTANCE and $CLASS_SOURCE_FIELD_PATTERN.}#
  :super class_source_pattern
  :fields (spat_class			;required [super*] class
	   spat_fields			;sequence of fieldpatterns
	   ))

;; simple source pattern for exact instance
;; matches an object whose class is exactly spat_class
(defclass class_source_pattern_instance
  :doc #{The internal $CLASS_SOURCE_PATTERN_INSTANCE is for $INSTANCE
pattern abstract syntax. See also $CLASS_SOURCE_PATTERN_OBJECT for
field details.}#
  :super class_source_pattern_object
  :fields ( ))

;; simple field pattern
(defclass class_source_field_pattern
  :doc #{The internal $CLASS_SOURCE_FIELD_PATTERN is for abstract
syntax of fields inside patterns like $INSTANCE or $OBJECT. The
$SPAF_FIELD is the required field, and the $SPAF_PATTERN gives the
matching sub-pattern.}#
  :super class_source
  :fields (spaf_field			;the required field
	   spaf_pattern			;the pattern matching the field
	   ))

;; abstract composite source pattern
(defclass class_source_pattern_composite
  :doc #{The internal $CLASS_SOURCE_PATTERN_COMPOSITE is abstract
syntax for composite patterns with matchers. The $SPAC_OPERATOR field
gives the pattern operator, the $SPAC_OPERBIND is an optional operator
binding. The $SPAC_INARGS are the input sub-expressions. The
$SPAC_OUTARGS are the output sub-patterns.}#
  :super class_source_pattern_object
  :fields (spac_operator		;pattern operator
	   ;;;; the operator binding is useful to compile some
	   ;;;; composites (e.g. funmatching) and is better here,
	   ;;;; since it is closely related to the operator
	   spac_operbind		;operator binding (if any)
	   spac_inargs			;input expressions
	   spac_outargs			;output subpatterns
	   ))

;; anymatcher composite source pattern
(defclass class_source_pattern_matcher
  :doc #{The internal $CLASS_SOURCE_PATTERN_MATCHER is for abstract syntax of pattern with any kind of matchers.}#
  :super class_source_pattern_composite
  :fields ())

;; cmatcher composite source pattern
(defclass class_source_pattern_c_match
  :doc #{The internal $CLASS_SOURCE_PATTERN_C_MATCH is for abstract syntax of pattern with c-matchers.}#
  :super class_source_pattern_matcher
  :fields ())

;; funmatcher composite source pattern
(defclass class_source_pattern_fun_match
  :doc #{The internal $CLASS_SOURCE_PATTERN_FUN_MATCH is for abstract syntax of pattern with fun-matchers.}#
  :super class_source_pattern_matcher
  :fields ())

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;; first pass, macro expansion
(compile_warning "perhaps should document below")

;;expand all but the first element of a list as a tuple
(defun expand_restlist_as_tuple (arglist env mexpander)
  (assert_msg "check end" (is_a env class_environment))
  (assert_msg "check mexpander" (is_closure mexpander))
  (assert_msg "check arglist" (is_list arglist))
  (let ( (:long nbarg (list_length arglist))
	 (:long ix 0)
	 (curpair (pair_tail (list_first arglist)))
	 (tup (make_multiple discr_multiple (-i nbarg 1)))
	 )
    (forever exploop
	     (if (null curpair) (exit exploop))
	     (assert_msg "check curpair" (is_pair curpair))
	     (let ( (curarg (pair_head curpair)) 
		    (curexp (macroexpand_1 curarg env mexpander))
		    )
	       (multiple_put_nth tup ix curexp)
	       (setq ix (+i ix 1))
	       (setq curpair (pair_tail curpair))
	       ))
    tup
    ))

;;expand all of a pairlist as a tuple
(defun expand_pairlist_as_tuple (pair env mexpander)
  (assert_msg "check end" (is_a env class_environment))
  (assert_msg "check mexpander" (is_closure mexpander))
  (let ( (:long nbarg (pair_listlength pair))
	 (:long ix 0)
	 (tup (make_multiple discr_multiple nbarg)) )
    (forever exploop
	     (if (not (is_pair pair)) (exit exploop))
	     (let ( (curarg (pair_head pair)) 
		    (curexp (macroexpand_1 curarg env mexpander))
		    )
	       (multiple_put_nth tup ix curexp)
	       (setq ix (+i ix 1))
	       (setq pair (pair_tail pair))
	       ))
    tup 
    ))


;;; expand an s-expression known to be an application
(defun expand_apply (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check end" (is_a env class_environment))
  (assert_msg "check mexpander" (is_closure mexpander))
  (let ( (scont (unsafe_get_field :sexp_contents sexpr))
	 (sloc (unsafe_get_field :loca_location sexpr))
	 (soper (pair_head (list_first scont)))
	 (xargtup (expand_restlist_as_tuple scont env mexpander))
	 (xoper (if (is_a soper class_sexpr) 
		    (macroexpand_1 soper env mexpander) 
		  soper))
	 )
    (instance class_source_apply
	      :loca_location sloc
	      :sapp_fun xoper
	      :sargop_args xargtup)))


;;; expand an s-expression known to be a message send
(defun expand_msend  (opnam sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check end" (is_a env class_environment))
  (assert_msg "check mexpander" (is_closure mexpander))
  (assert_msg "check opnam" (is_a opnam class_symbol))
  (debug_msg sexpr "expand_msend sexpr")
  (let ( (scont (unsafe_get_field :sexp_contents sexpr))
	 (sloc (unsafe_get_field :loca_location sexpr))
	 (spair (pair_tail (list_first scont)))
	 )
    (if (not (is_pair spair))
	(error_plain sloc "missing reciever expression in message send"_))
    (let ( (xrecv (pair_head spair))
	   (argtup (expand_pairlist_as_tuple (pair_tail spair) env mexpander)) 
	   (res (instance class_source_msend
			  :loca_location sloc
			  :msend_selsymb opnam
			  :msend_recv (if (is_a xrecv class_sexpr)
					  (macroexpand_1 xrecv env mexpander)
					xrecv)
			  :sargop_args argtup
			  ))
	   )
      (debug_msg res "expand_msend res")
      res
      )))


;; every citeration is (symbol (startargs) (varformals) body...)
;; expand an s-expression known to be a citeration
(defun expand_citeration (citer sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check mexpander" (is_closure mexpander))
  (assert_msg "check citer" (is_a citer class_citerator))
  (debug_msg sexpr "expand_citeration sexpr")
  (let ( (scont (unsafe_get_field :sexp_contents sexpr))
	 (sloc (unsafe_get_field :loca_location sexpr))
	 (spair (pair_tail (list_first scont)))
	 (stargs ())		;set to the tuple of start expressions
	 (varformals ())	;set to the varformals binding tuple
	 (bodytup ())		;set to the body tuple
	 )
    ;; parse the startargs
    (if  (is_pair spair)
	(let ( (starexp (pair_head spair)) )
	  (if (is_a starexp class_sexpr)
	      (let ( (stacont (unsafe_get_field :sexp_contents starexp))
		     )
		(setq stargs (expand_pairlist_as_tuple (list_first stacont) env mexpander))
		)
	    (setq stargs (if starexp (tuple
						  (macroexpand_1 starexp env mexpander)
						  ))))
	  (setq spair (pair_tail spair))
	  )
      (progn
	(error_strv sloc "missing startargs expression in citeration"_
		    (unsafe_get_field :named_name citer))
	(return)
	))
    ;; parse the varformals
    (if  (is_pair spair)
	(let ( (varexp (pair_head spair)) )
	  (setq spair (pair_tail spair))
	  (setq varformals (lambda_arg_bindings varexp))
	  )
      (progn
	(error_strv sloc "missing varformals in citeration"_
		    (unsafe_get_field :named_name citer))
	(return)
	))
    ;; parse the body
    (setq bodytup (expand_pairlist_as_tuple spair env mexpander))
    ;; build & return the result
    (let ( (sciter (instance class_source_citeration
			     :loca_location sloc
			     :sciter_oper citer
			     :sargop_args stargs
			     :sciter_varbind varformals
			     :sciter_body bodytup))
	   )
      (debug_msg sciter "expand_citeration result sciter")
      (return sciter)
      )))


;; expand a cmatcher expression
;;; this is for cmatcher in expression contexts (not as patterns!)
(defun expand_cmatchexpr (cmat sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check mexpander" (is_closure mexpander))
  (assert_msg "check cmat" (is_a cmat class_cmatcher))
  (debug_msg sexpr "expand_cmatchexpr sexpr")
  (let ( (scont (unsafe_get_field :sexp_contents sexpr))
	 (sloc (unsafe_get_field :loca_location sexpr))
	 (spair (pair_tail (list_first scont)))
	 (soper (pair_head (list_first scont)))
	 (xargtup (expand_restlist_as_tuple scont env mexpander))
	 (cmatin (unsafe_get_field :amatch_in cmat))
	 (cmatexp (unsafe_get_field :cmatch_expoper cmat))
	 )
    (if (!=i (multiple_length xargtup)
	     (multiple_length cmatin))
	(progn
	  (debug_msg xargtup "expand_cmatchexpr bad xargtup")
	  (debug_msg cmatin "expand_cmatchexpr bad cmatin")
	  (warning_strv sloc
		      "bad argument number for cmatcher expression"_
		      (unsafe_get_field :named_name cmat))))
    (if (null cmatexp)
	(progn
	  (error_strv sloc
		      "cmatcher used without operation expansion"_
		      (unsafe_get_field :named_name cmat))
	  (return)))
    ;; should build a class_source_cmatchexpr
    (let ( (res
	    (instance class_source_cmatchexpr
		      :loca_location sloc
		      :scmatx_cmatcher cmat
		      :sargop_args xargtup)
	    ) )
      (debug_msg res "expand_cmatchexpr res")
      (return res)
)))


;;; expand a funmatcher expression
;;;; this is for funmatcher in expression contexts (not as patterns) 
(defun expand_funmatchexpr (fmat sexpr env mexpander opbind)
  (debug_msg sexpr "expand_funmatchexpr sexpr")
  (debug_msg fmat "expand_funmatchexpr fmat")
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check mexpander" (is_closure mexpander))
  (assert_msg "check fmat" (is_a fmat class_funmatcher))
  (let ( (scont (unsafe_get_field :sexp_contents sexpr))
	 (sloc (unsafe_get_field :loca_location sexpr))
	 (spair (pair_tail (list_first scont)))
	 (soper (pair_head (list_first scont)))
	 (xargtup (expand_restlist_as_tuple scont env mexpander))
	 (fmatapp (unsafe_get_field :fmatch_applyf fmat))
	 )
    (debug_msg xargtup "expand_funmatchexpr xargtup")
    (debug_msg fmatapp "expand_funmatchexpr fmatapp")
    (debug_msg opbind "expand_funmatchexpr opbind")
    ;; we need to build a specific funmatchexpr, because it is handled
    ;; differently from a simple application
    (let ( (res (instance class_source_funmatchexpr
			  :loca_location sloc
			  :sfmatx_fmatcher fmat
			  :sfmatx_fmatbind opbind
			  :sargop_args xargtup)) )
      (debug_msg res "funmatcher result")
      (return res)
    )))


;;; expand a keywordfun s-expression
;;; not implemented yet, but might later be useful for stuff like
;;;;; (:fieldname obj) to get a field
;;;;; (:selector recv arg...) to send a message
(defun expand_keywordfun (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check end" (is_a env class_environment))
  (assert_msg "check mexpander" (is_closure mexpander))
  (error_plain (unsafe_get_field :loca_location sexpr) "keywordoper not implemented"_)
  (assert_msg "@@@  expand_keywordfun NOT IMPLEMENTED" 0)
  )

(defun macroexpand_1 (sexpr env mexpander)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check mexpander" (is_closure mexpander))
  (if (is_a sexpr class_sexpr)
      (let ( (scont (unsafe_get_field :sexp_contents sexpr))
	     (sloc (unsafe_get_field :loca_location sexpr))
	     (soper (pair_head (list_first scont))) )
	(debug_msg sexpr "macroexpand_1 sexpr")
	(debug_msg soper "macroexpand_1 soper")
	(cond ( (is_a soper class_symbol)
		(let ( (opbind (find_env env soper)) )
		  (debug_msg opbind "macroexpand_1 opbind")
		  (cond ( (is_a opbind class_macro_binding)
			  (let ( (mexp (unsafe_get_field :mbind_expanser opbind)) )
			    (assert_msg "check mexp" (is_closure mexp))
			    (let ( (resm (mexp sexpr env mexpander)) )
			      (debug_msg resm "macroexpand_1 result for macro resm")
			      (return resm)
			      )))
			( (is_a opbind class_selector_binding)
			  (let ( (ress (expand_msend soper sexpr env mexpander)) )
			    (debug_msg ress "macroexpand_1 result for send ress")
			    (return ress)
			    ))
			( (is_a opbind class_primitive_binding)
			  (let ( (resp (expand_primitive (unsafe_get_field :pbind_primitive opbind) sexpr env mexpander)) )
			    (debug_msg resp "macroexpand_1 result for primitive resp")
			    (return resp)
			    ))
			( (is_a opbind class_citerator_binding)
			  (let ( (citer (unsafe_get_field :cbind_citerator opbind))
				 (resc (expand_citeration citer sexpr env mexpander))
				 )
			    (debug_msg resc "macroexpand_1 result for citerator resc")
			    (return resc)
			    ))
			( (is_a opbind class_cmatcher_binding)
			  (let ( (cmatch (unsafe_get_field :cmbind_matcher opbind))
				 (resc (expand_cmatchexpr cmatch sexpr env mexpander))
				 )
			    (debug_msg resc "macroexpand_1 result for cmatcher resc")
			    (return resc)
			    ))
			( (is_a opbind class_funmatcher_binding)
			  (let ( (fmatch (unsafe_get_field :fmbind_funmatcher opbind)) 
				 (resf (expand_funmatchexpr fmatch sexpr env mexpander opbind))
				 )
			    (debug_msg resf "macroexpand_1 result for funmatcher resf")
			    (return resf)
			    ))
			( (is_a opbind class_value_binding)
			  (let ( (val (unsafe_get_field :vbind_value opbind))
				 )
			    (cond
			     ( (is_closure val)
			       (expand_apply sexpr env mexpander)
			       )
			     ( (is_a val class_primitive)
			       (expand_primitive val sexpr env mexpander)
			       )
			     ( (is_a val class_selector) 
			       (let ( (ress (expand_msend soper sexpr env mexpander)) )
				 (debug_msg ress "macroexpand_1 result for send ress")
				 (return ress)
				 )
			       )
			     ( (is_a val class_citerator)
			       (let ( (resc (expand_citeration val sexpr env mexpander)) )
				 (debug_msg resc "macroexpand_1 result for send resc")
				 (return resc)))
			     ( (is_a val class_cmatcher)
			       (let ( (resc (expand_cmatchexpr val sexpr env mexpander)) )
				 (debug_msg resc "macroexpand_1 result for cmatch resc")
				 (return resc)))
			     ( (is_a val class_funmatcher)
			       (let ( (resf (expand_funmatchexpr val sexpr env mexpander opbind)) )
				 (debug_msg resf "macroexpand_1 result for funmatch resf")
				 (return resf)))
			     (:else
			      (error_strv sloc "macroexpand_1 bad valued operation symbol"_
					  (unsafe_get_field :named_name soper))
			      (inform_strv sloc "macroexpand_1 bad symbol value discr"
					   (unsafe_get_field :named_name (discrim val)))
			      (return)
			      )
			     )))
			(:else 
			 ;; this is to catch the case when DEFUN or
			 ;; DEFCLASS is not bound... which only happens
			 ;; on big errors
			 (assert_msg "check soper not symbol DEFUN" (!= soper 'defun))
			 (assert_msg "check soper not symbol DEFCLASS" (!= soper 'defclass))
			 (assert_msg "check soper not named DEFUN" (not (is_stringconst (unsafe_get_field :named_name soper) "DEFUN")))
			 (assert_msg "check soper not named DEFCLASS" (not (is_stringconst (unsafe_get_field :named_name soper) "DEFCLASS")))
			 (let ( (resa (expand_apply sexpr env mexpander))) 
			   (debug_msg resa "macroexpand_1 result for apply resa")
			   (return resa)
			   )
			 ))))
	      ( (is_a soper class_keyword)
		(let ( (resk (expand_keywordfun sexpr env mexpander)) )
		  (debug_msg resk "macroexpand_1 result for keywordfun resk")
		  (return resk)))
	      ;; the empty list is expanded as nil
	      ( (==i (list_length scont) 0)
		(debug_msg () "macroexpand_1 result for null")
		(return ()))
	      (:else 
	       (let ( (resca (expand_apply sexpr env mexpander)) )
		 (debug_msg resca "macroexpand_1 result complex apply resca")
		 (return resca)
		 ))))
    ;; if the sexpr is not an sexpr return itself
    (return sexpr)))

;;; expand a primitive s-expression
(defun expand_primitive (sprim sexpr env mexpander)
  (assert_msg "check sprim" (is_a sprim class_primitive))
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check end" (is_a env class_environment))
  (assert_msg "check mexpander" (is_closure mexpander))
  (let ( (scont (unsafe_get_field :sexp_contents sexpr))
	 (sloc (unsafe_get_field :loca_location sexpr))
	 (soper (pair_head (list_first scont)))
	 (xargtup (expand_restlist_as_tuple scont env mexpander))
	 )
    (instance class_source_primitive
	      :loca_location sloc
	      :sprim_oper sprim
	      :sargop_args xargtup)))


;;; class for pattern expansion context
(defclass class_pattern_expansion_context
  :doc #{The internal $CLASS_PATTERN_EXPANSION_CONTEXT is for
expansion of patterns. $PCTX_MEXPANDER is the macroexpander for
expressions, $PCTX_PEXANDER is the pattern expander, $PCTX_VARMAP is
the object-map for pattern variables.}#
  :super class_root
  :fields (pctx_mexpander      	;macroexpander
	   pctx_pexpander      	;pattern expander
	   pctx_varmap	        ;objmap for pattern variables [symbols => srcpattern_variable]
	   ))


(defun patternexpand_pairlist_as_tuple (pairlist env pctx psloc)
  (debug_msg pairlist "patternexpand_pairlist_as_tuple pairlist")
  (let ( (restup (pairlist_to_multiple 
		  pairlist discr_multiple
		  (lambda (x) (patternexpand_1 x env pctx psloc))))
	 )
    (debug_msg restup "patternexpand_pairlist_as_tuple return restup")
    (return restup)
    ))


;; utility function to expand a pairlist for a pattern matcher with both input & output arguments
;; the primary result is the tuple of argexpr
;; the secondary result is the tuple of subpatterns
(defun patmacexpand_for_matcher (pairs matcher env psloc pctx)
  (assert_msg "check matcher" (is_a matcher class_any_matcher))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context))
  (let ( (mins (unsafe_get_field :amatch_in matcher))
	 (mouts (unsafe_get_field :amatch_out matcher))
	 (mexpander (unsafe_get_field :pctx_mexpander pctx))
	 (:long nbmins (multiple_length mins))
	 (:long nbouts (multiple_length mouts))
	 (pairbox (make_box discr_box pairs))
	 (inargs (multiple_map 
		  mins
		  (lambda (curfbind :long inix)
		    (assert_msg "check curfbind" (is_a curfbind class_formal_binding))
		    (let ( (curpair (box_content pairbox)) )
		      (if (is_pair curpair)
			  (let ( (curin (pair_head curpair)) )
			    (box_put pairbox (pair_tail curpair))
			    (macroexpand_1 curin env mexpander))
			(error_strv psloc "missing in argument for matcher"
				    (get_field :named_name matcher))
			)))))
	 (outpats (multiple_map
		   mouts 
		   (lambda (curformal :long outix)
		     (let ( (curpair (box_content pairbox)) )
		       (if (is_pair curpair)
			   (let ( (curout (pair_head curpair)) )
			     (box_put pairbox (pair_tail curpair))
			     (patternexpand_1 curout env pctx psloc))
			 (error_strv psloc "missing out argument for matcher"
				     (get_field :named_name matcher))
			 )))))
	 )
    (let ( (curpair (box_content pairbox)) )
      (if (is_pair curpair)
	  (warning_strv psloc "ignored extra sub-{pattern | expression} in matcher"
			(get_field :named_name matcher))))
    (return inargs outpats)
    ))

(defun pattern_weight_tuple (spats)
  :doc #{The function $PATTERN_WEIGHT_TUPLE compute the tuple, and
  their maximum, their minimum, and their sum, of the pattern weights of
  the $SPATS tuple argument made of instances of
  $CLASS_SOURCE_PATTERN.}#
  (assert_msg "check spats" (is_multiple spats))
  (let
      ( (bsum (make_integerbox discr_integer 0))
	(bmax (make_integerbox discr_integer 0))
	(bmin (make_integerbox discr_integer 0))
	(restup
	 (multiple_map 
	  spats
	  (lambda (subpat :long subix)
	    (let ( (boxsubw (get_field :pat_weight subpat))
		   (:long subw (get_int boxsubw))
		   (:long isum (get_int bsum))
		   (:long imin (get_int bmin))
		   (:long imax (get_int bmax))
		   )
	      (if subw
		  (progn 
		    (setq isum (+i isum subw))
		    (setq imin (mini imin subw))
		    (setq imax (maxi imax subw))
		    (put_int bsum isum)
		    (put_int bmin imin)
		    (put_int bmax imax)
		    (return (make_integerbox discr_constant_integer subw))))))))
	)
    (return restup (get_int bmax) (get_int bmin) (get_int bsum))))


;; pattern expansion of a pattern expression like (question SEXPR)
(defun patternexpand_expr (sexpr env pctx psloc)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context))
  (debug_msg sexpr "patternexpand_expr sexpr")
  (let ( (scont (unsafe_get_field :sexp_contents sexpr))
	 (sloc (unsafe_get_field :loca_location sexpr))
	 (curpair (list_first scont))
	 (soper (pair_head curpair)) )
    (if (is_not_a soper class_symbol)
	(progn
	  (debug_msg soper "patternexpand_expr bad soper")
	  (error_plain sloc "pattern expression requires symbol operator")
	  (return)))
    (let ( (opbind (find_env env soper))
	   (opnam (unsafe_get_field :named_name soper))
	   )
      (debug_msg opbind "patternexpand_expr opbind")
      (cond 
       ( (null opbind)
	 (error_strv sloc "unbound pattern operator" opnam)
	 )
       ( (is_a opbind class_patmacro_binding)
	 (let ( (patexp (unsafe_get_field :patbind_expanser opbind)) )
	   (assert_msg "check patexp" (is_closure patexp))
	   (let ( (resp (patexp sexpr env pctx)) )
	     (debug_msg resp "patternexpand_expr patmacro so return resp")
	     (return resp)
	     )))
       ( (is_a opbind class_cmatcher_binding)
	 (let ( (cmat (unsafe_get_field :cmbind_matcher opbind)) )
	   (debug_msg cmat "patternexpand_expr cmat")
	   (assert_msg "check cmat-cher" (is_a cmat class_cmatcher))
	   (multicall
	    (args pats)
	    (patmacexpand_for_matcher (pair_tail curpair) cmat env sloc pctx)
	    (debug_msg args "patternexpand_expr cmatcher args")
	    (debug_msg pats "patternexpand_expr cmatcher pats")
	    (multicall
	     (subpatw :long imax imin isum)
	     (pattern_weight_tuple pats)
	     (let ( (pcomp (instance class_source_pattern_c_match
				     :loca_location sloc
				     :pat_weight 
				     (make_integerbox discr_constant_integer (+i 1 isum))
				     :spac_operator cmat
				     :spac_operbind opbind
				     :spac_inargs args
				     :spac_outargs pats
				     ))
		    )
	       (debug_msg pcomp "patternexpand_expr cmatcher return pcomp")
	       (return pcomp)
	       )))))
       ;; funmatcher binding
       ( (is_a opbind class_funmatcher_binding)
	 (let ( (fmat (unsafe_get_field :fmbind_funmatcher opbind)) 
		(defm (unsafe_get_field :fmbind_defunmatcher opbind))
		)
	   (debug_msg fmat "patternexpand_expr funmatcher fmat")
	   (debug_msg defm "patternexpand_expr funmatcher defm")
	   (debug_msg opbind "patternexpand_expr funmatcher opbind")
	   (assert_msg "check fmat-cher" (is_a fmat class_funmatcher))
	   (multicall
	    (args pats)
	    (patmacexpand_for_matcher (pair_tail curpair) fmat env sloc pctx)
	    (debug_msg args "patternexpand_expr funmatcher args")
	    (debug_msg pats "patternexpand_expr funmatcher pats")
	    (multicall
	     (subpatw :long imax imin isum)
	     (pattern_weight_tuple pats)
	     (let ( (pcomp (instance class_source_pattern_fun_match
				     :loca_location sloc
				     :pat_weight 
				     (make_integerbox discr_constant_integer (+i 1 isum))
				     :spac_operator fmat
				     :spac_operbind opbind
				     :spac_inargs args
				     :spac_outargs pats
				     )) )
	       (debug_msg pcomp "patternexpand_expr funmatcher return pcomp")
	       (return pcomp)
	       )))))
       ;; imported values 
       ( (is_a opbind class_value_binding)
	 (let ( (opval (unsafe_get_field :vbind_value opbind)) )
	   (debug_msg opval "patternexpand_expr imported opval")
	   (cond 
	    ( (is_a opval class_cmatcher) 
	      (multicall
	       (args pats)
	       (patmacexpand_for_matcher (pair_tail curpair) opval env sloc pctx)
	       (debug_msg args "patternexpand_expr imported cmatcher args")
	       (debug_msg pats "patternexpand_expr imported cmatcher pats")
	       (multicall
		(subpatw :long imax imin isum)
		(pattern_weight_tuple pats)
		(let ( (pcomp (instance class_source_pattern_c_match
					:loca_location sloc
					:pat_weight 
					(make_integerbox discr_constant_integer (+i 1 isum))
					:spac_operator opval
					:spac_operbind opbind
					:spac_inargs args
					:spac_outargs pats
					))
		       (aouts (get_field :amatch_out opval))
		       )
		  (debug_msg pats "patternexpand_expr imported cmatcher pats again")
		  (debug_msg aouts "patternexpand_expr aouts")
		  (if (!=i (multiple_length pats) (multiple_length aouts))
		      (warning_strv sloc "incompatible number of formal and actual subpatterns of cmatcher"
				    (get_field :named_name opval)))
		  (debug_msg pcomp "patternexpand_expr cmatcher value pcomp")
		  (return pcomp)
		  ))))
	    ( (is_a opval class_funmatcher) 
	      (debug_msg opval "patternexpand_expr funmatcher value opval")
	      (multicall
	       (args pats)
	       (patmacexpand_for_matcher (pair_tail curpair) opval env sloc pctx)
	       (debug_msg args "patternexpand_expr imported funmatcher args")
	       (debug_msg pats "patternexpand_expr imported funmatcher pats")
	       (multicall
		(subpatw :long imax imin isum)
		(pattern_weight_tuple pats)
		(let ( (pcomp (instance class_source_pattern_fun_match
					:loca_location sloc
					:pat_weight
					(make_integerbox discr_constant_integer (+i 1 isum))
					:spac_operator opval
					:spac_operbind opbind
					:spac_inargs args
					:spac_outargs pats
					))
		       )
		  (debug_msg pcomp "patternexpand_expr funmatcher value pcomp")
		  (return pcomp)
		  ))
	       ))
	    (:else
	     (error_strv sloc "invalid pattern operator value" opnam)
	     (return)))))
       (:else
	(error_strv sloc
		    "pattern operator badly bound - patternmacro expected"
		    opnam)
	)
       )
      ))
  )

;; pattern expansion
(defun patternexpand_1 (sexpr env pctx psloc)
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context))
  (cond
   ( (is_a sexpr class_sexpr)
     (let ( (scont (unsafe_get_field :sexp_contents sexpr))
	    (sloc (unsafe_get_field :loca_location sexpr))
	    (curpair (list_first scont))
	    (soper (pair_head curpair)) )
       (debug_msg sexpr "patternexpand_1 sexpr")
       (debug_msg soper "patternexpand_1 soper")
       (if (!= soper 'question)
	   ;; non-question expr: return the constant pattern with...
	   (let ( (mexpander (unsafe_get_field :pctx_mexpander pctx)) 
		  (exp (macroexpand_1 sexpr env mexpander))
		  (pat (instance class_source_pattern_constant
				 :loca_location sloc
				 :pat_weight '1
				 :spat_constx exp))
		  )
	     (debug_msg pat "patternexpand_1 return const pat")
	     (return pat)
	     )
	 ;; question expr
	 (let ( (parg1 (pair_head (setq curpair (pair_tail curpair)))) )
	   (if (pair_tail curpair)
	       (error_plain sloc "QUESTION should have one argument"))
	   (cond
	    ((== parg1 '_)		;  ?_ is a joker
	     (let ( (jokp (instance class_source_pattern_joker_variable
				    :loca_location sloc
				    :pat_weight '1
				    :spatvar_symb parg1
				    :spatvar_nbocc (make_integerbox discr_integer 0)
				    )) )
	       (debug_msg jokp "patternexpand_1 return jokervar")
	       (return jokp)
	       ))
	    ((is_a parg1 class_symbol)
	     ;; if parg1 is a symbol, make a patternvariable and add it
	     ;; into pctx
	     (let ( (vamp (unsafe_get_field :pctx_varmap pctx))
		    (pavr (mapobject_get vamp parg1))
		    )
	       (if pavr 
		   (progn
		     (debug_msg pavr "patternexpand_1 return found pavr")
		     (return pavr)
		     )
		 (let ( (newpavr (instance class_source_pattern_variable
					   :pat_weight '1
					   :loca_location sloc
					   :spatvar_symb parg1
					   :spatvar_nbocc (make_integerbox discr_integer 0)
					   )) 
			)
		   (mapobject_put vamp parg1 newpavr)
		   (debug_msg newpavr "patternexpand_1 return nexpavr")
		   (return newpavr))
		 ))
	     )
	    ((is_a parg1 class_sexpr)
	     (debug_msg parg1 "patternexpand_1 sexpr parg1")
	     (let ( (patex (patternexpand_expr parg1 env pctx sloc)) )
	       (debug_msg patex "patternexpand_1 return patex")
	       (return patex))
	     )
	    (:else
	     (error_plain sloc "unexpected pattern QUESTION - neither symbol nor pattern expr")))
	   )
	 ))
     )
   (:else
    ;; not an s-expr, return the constant pattern with...
    (let ( (mexpander (unsafe_get_field :pctx_mexpander pctx)) 
	   (pat (instance class_source_pattern_constant
			  :pat_weight '1
			  :loca_location psloc
			  :spat_constx sexpr))
	   )
      (debug_msg pat "patternexpand_1 return const pat as source")
      (return pat)
      ))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; we add an additional hack in toplevel macro-expansion. If an s-expr
;; macroexpands to a tuple, that tuple is handled as several source
;; expressions... In particular, this allows a (load "filename")
;; macro.
(defun macroexpand_toplevel_list (slist env mexpander)
  ;; (messageval_dbg "macroexpand_toplevel_list Env" env)
  ;;  (debug_msg  env "macroexpand_toplevel_list env"(the_meltcallcount)) 
  (debug_msg slist "macroexpand_toplevel_list slist") 
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check slist" (is_list slist))
  (if (null mexpander) (setq mexpander macroexpand_1))
  (let ( (reslist (make_list discr_list)) 
	 (prevloc ())
	 )
    (foreach_in_list
     (slist)
     (curpair sexp)
     (debug_msg sexp "macroexpand_toplevel_list sexp")
     ;; When a simple literal or symbol appears erronously at the
     ;; toplevel, we have no location to make the error, so we issue a
     ;; warning for the *previous* s-expression!
     (if (is_a sexp class_located)
	 (let ( (sexploc (unsafe_get_field :loca_location sexp)) )
	   (if sexploc (setq prevloc sexploc)))
       (warning_plain prevloc
		      "Top-level s-expression followed by an unexpected atom"))
     ;;
     (let ( (mex (mexpander sexp env mexpander)) 
	    )
       (debug_msg mex "macroexpand_toplevel_list mex")
       (cond
	( (is_multiple mex)
	  (foreach_in_multiple
	   (mex)
	   (curm :long curix)
	   (list_append reslist curm))
	  )
	(:else (list_append reslist mex)
	       ))))
    (debug_msg reslist "macroexpand_toplevel_list reslist")
    (return reslist)
    )
  )


;;; expand an s-expression into a tuple of formal bindings
;;; the formalsexp is the sexpr of formals 
;;; the [optional] checkargs should be set to non-null to check arguments type
;;; usually checkargs is just missing
(defun lambda_arg_bindings (formalsexp checkargs)
  ;; special case for null arglist
  (if (null formalsexp)
      (progn
	(return (make_multiple discr_multiple 0))))
  (assert_msg "check formalsexp" (is_a formalsexp class_sexpr))
  (let ( (:long argrk 0)
	 (argtype ctype_value)
	 (arglist (unsafe_get_field :sexp_contents formalsexp))
	 (argloc (unsafe_get_field :loca_location formalsexp))
	 (argmap (make_mapobject discr_map_objects (+i 4 (list_length arglist))))
	 (bndlist (make_list discr_list)) 
	 (curpair (list_first arglist))
	 )
;;; first loop on arg
    (forever argloop
	     (if (null curpair) (exit argloop))
	     (assert_msg "check curpair" (is_pair curpair))
	     (let ( (curarg (pair_head curpair)) )
	       (cond
		( (is_a curarg class_keyword)
		  (let ( (cty (unsafe_get_field :symb_data curarg)) 
			 (curargname (unsafe_get_field :named_name curarg))
			 )
		    (cond 
		     ( (is_not_a cty class_ctype)
		       (error_strv argloc "invalid keyword in formal arglist"_
				   curargname))
		     ( (== (unsafe_get_field :ctype_keyword cty) curarg)
		       (setq argtype cty))
		     ( (== (unsafe_get_field :ctype_altkeyword cty) curarg)
		       (warning_strv argloc "usage of alternate keyword as formal's ctype is deprecated"
				     curargname)
		       (inform_strv argloc "prefered ctype keyword is"
				    (get_field :named_name (get_field :ctype_keyword cty)))
		       (setq argtype cty))
		     (:else
		      (error_strv argloc "invalid keyword in formal arglist"_
				  (unsafe_get_field :named_name curarg))
		      ())
		     )
		    () ;to make the compiler happy we explicitly gives nil
		    ))
		( (is_a curarg class_symbol)
		  (if (mapobject_get argmap curarg)
		      (error_strv argloc "duplicate argument in formal arglist"_
				  (unsafe_get_field :named_name curarg)))
		  (let ( (curbind
			  (instance class_formal_binding 
				    :binder curarg
				    :fbind_type argtype)) )
		    (if checkargs
			(if (or (not (is_a argtype class_ctype))
				(not (is_string (unsafe_get_field :ctype_parstring argtype))))
			    (error_strv argloc "invalid argument type in formal arglist"_
					(unsafe_get_field :named_name curarg))))
		    (put_int curbind argrk)
		    (mapobject_put argmap curarg curbind)
		    (list_append bndlist curbind)
		    (setq argrk (+i argrk 1))
		    )
		  ()
		  )
		(:else 
		 (debug_msg curarg "unexpected argument in formal arglist")
		 (let ( (discrarg  (discrim curarg) ))
		   (error_strv argloc "unexpected argument in formal arglist"_
			       (unsafe_get_field :named_name discrarg))
		   )
		 ()
		 ))
	       (setq curpair (pair_tail curpair))))
;;; second loop to fill the bindings tuple
    (let ( (bndtup (make_multiple discr_multiple argrk)) 
	   (:long ix 0)
	   (bndpair (list_first bndlist))
	   )
      (forever bndloop
	       (if (null bndpair) (exit bndloop))
	       (assert_msg "check bndpair" (is_pair bndpair))
	       (let ( (curbnd (pair_head bndpair)) )
		 (assert_msg "check curbnd" (is_a curbnd class_formal_binding))
		 (multiple_put_nth bndtup ix curbnd)
		 )
	       (setq ix (+i ix 1))
	       (setq bndpair (pair_tail bndpair))
	       )
      (return bndtup)
      )))




;;;;;;;;;;;;;;;; install an initial macro expanser
(defun install_initial_macro (symb expander)
  (debug_msg symb "install_initial_macro symb")
  (if (is_not_a symb class_symbol)
      (progn
	(debug_msg (discrim symb) "install_initial_macro bad symb class")
	(debug_msg class_symbol "install_initial_macro expected class_symbol")
	(debug_msg install_initial_macro "install_initial_macro itself Install_Initial_Macro")
	(debug_msg (closure_routine install_initial_macro) "install_initial_macro routine in Install_Initial_Macro")
	(messageval_dbg "install_initial_macro bad symb is" symb)
	(messageval_dbg "install_initial_macro bad symb class is" (discrim symb))
	(messageval_dbg "install_initial_macro bad class_symbol is" class_symbol)
	(messageval_dbg "install_initial_macro itself is Install_Initial_Macro" install_initial_macro)
	(assert_msg "check good symb" (is_a symb class_symbol))
	))
  (assert_msg "check symb" (is_a symb class_symbol))
  (assert_msg "check expander" (is_closure expander))
					;  (debug_msg expander "install_initial_macro expander")
  (let ( (mbind (instance class_macro_binding 
			  :binder symb
			  :mbind_expanser expander
			  )) )
    (put_env initial_environment mbind)
    (debug_msg symb "install_initial_macro done symb")
    ))

;;;;;;;;;;;;;;;; install an initial patmacro expanser
(defun install_initial_patmacro (symb patexpander macexpander)
  (debug_msg symb "install_initial_patmacro symb")
  (assert_msg "check symb" (is_a symb class_symbol))
  (assert_msg "check patexpander" (is_closure patexpander))
  (assert_msg "check macexpander" (is_closure macexpander))
					;  (debug_msg expander "install_initial_patmacro expander")
  (let ( (mbind (instance class_patmacro_binding 
			  :binder symb
			  :mbind_expanser macexpander
			  :patbind_expanser patexpander
			  )) )
    (put_env initial_environment mbind)
    (debug_msg symb "install_initial_patmacro done symb")
    (debug_msg mbind "install_initial_patmacro done mbind")
    ))



(defprimitive warn_shadow () :long
  "warn_shadow")
;;;;;;;;;;;;;;;;
;;;;;; warn if a symbol redefines something
(defun warn_if_redefined (symb env loc)
  (assert_msg "check symb" (is_a symb class_symbol))
  (assert_msg "check env" (is_a env class_environment))
  (and 
   (warn_shadow)
   (find_env env symb)
   (warning_strv loc "symbol redefinition masks previous" 
		 (unsafe_get_field :named_name symb))
   ))

;;;;;;;;;;;;;;;;
;;;;;; parse a pairlist as a C code expansion, return a tuple

(defun flatten_for_c_code_expansion (loc comp flatlist)
  (assert_msg "check flatlist" (is_list flatlist))
  ;;(debug_msg comp "flatten_for_c_code_expansion comp")
  ;;(debug_msg flatlist "flatten_for_c_code_expansion initial flatlist")
  (cond    
   ( (null comp)
     ;;(shortbacktrace_dbg "flatten_for_c_code_expansion null comp" 15)
     (error_plain loc "null component for C chunk" )
     (return))
   ( (is_a comp class_symbol)
     (list_append flatlist comp)
     )
   ( (is_string comp)
     (list_append flatlist (make_string discr_verbatim_string comp))
     )
   ( (is_list comp)
     (foreach_in_list
      (comp)
      (curpair curcomp)
      ;;(debug_msg curcomp "flatten_for_c_code_expansion curcomp in list")
      (flatten_for_c_code_expansion loc curcomp flatlist)
      ;;(debug_msg curcomp "flatten_for_c_code_expansion done curcomp list")
      )
     )
   ( (is_a comp class_sexpr)
     (let ( (subloc (get_field :loca_location comp)) 
	    (subcontent (get_field :sexp_contents comp))
	    )
       (foreach_in_list 
	(subcontent)
	(cursubpair cursubcomp)
	;;(debug_msg cursubcomp "flatten_for_c_code_expansion cursubcomp in sexp")
	(flatten_for_c_code_expansion subloc cursubcomp flatlist)
	;;(debug_msg cursubcomp "flatten_for_c_code_expansion done cursubcomp sexp")
	))
     )
   (:else
    (shortbacktrace_dbg "flatten_for_c_code_expansion strange comp" 15)
    (error_strv loc "unexpected component for C chunk of discriminant " 
		(get_field :named_name (discrim comp)))
    )
   )
  ;;(debug_msg flatlist "flatten_for_c_code_expansion final flatlist")
  )

;; parse a pair list into a C code expansion, perhaps flattening it
(defun parse_pairlist_c_code_expansion (loc curpair)
  (debug_msg loc "parse_pairlist_c_code_expansion loc")
  (debug_msg curpair "parse_pairlist_c_code_expansion curpair")
  (let ( (flatlist (make_list discr_list)) )
    (forever 
     comploop
     (if (not (is_pair curpair)) (exit comploop))
     (let ( (pairhd (pair_head curpair)) )
       (debug_msg pairhd "parse_pairlist_c_code_expansion loop pairhd")
       (flatten_for_c_code_expansion loc pairhd flatlist))
     (setq curpair (pair_tail curpair))
     )
    (debug_msg flatlist "parse_pairlist_c_code_expansion flatlist")
    (let ( (tupexp (list_to_multiple flatlist discr_multiple)) )
      (debug_msg tupexp "parse_pairlist_c_code_expansion tupexp")
      (assert_msg "check tupexp" (is_multiple tupexp))
      (return tupexp)
      )))

;; utility to check that a C expansion has good symbols; every symbol
;; should be in the substitution map
(defun check_c_expansion (etuple loc substmap)
  (debug_msg etuple "check_c_expansion etuple")
  (debug_msg loc "check_c_expansion loc")
  (foreach_in_multiple
   (etuple)
   (ecomp :long ix)
   (cond 
   ( (null ecomp)
     (error_plain loc "null component in C expansion"))  
    ( (is_a ecomp class_symbol)
      (if (null (mapobject_get substmap ecomp))
	  (error_strv loc "unexpected symbol in C expansion"
		      (get_field :named_name ecomp)))
      ()
      )
    ( (is_string ecomp)
      ()
      )
    (:else 
     (warning_strv loc "unexpected C expansion component of " 
		   (get_field :named_name (discrim ecomp)))
     ()
     ))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;; macro expansers

;;; (defprimitive name bindings :type [:doc documentation] expansion...)
;; the defprimitive expander
(defun mexpand_defprimitive (sexpr env mexpander)
  (debug_msg sexpr "mexpand_defprimitive sexpr")
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (symb (pair_head curpair))
	 (docv ())
	 )
    (if (is_not_a symb class_symbol)
	(error_plain loc "missing symbol for (DEFPRIMITIVE symb args type  [:doc documentation] expansion...)"_))
    (setq curpair (pair_tail curpair))
    ;; parse the formal arguments
    (let ( (btup (lambda_arg_bindings (pair_head curpair) ())) )
      (setq curpair (pair_tail curpair))
      ;; parse the type keyword
      (let ( (typkw  (pair_head curpair)) )
	(if (is_not_a typkw class_keyword)
	    (error_plain loc "missing type keyword for (DEFPRIMITIVE symb args type [:doc documentation] expansion...)"_))
	(let ( (cty (unsafe_get_field :symb_data typkw)) 
	       (typknam (unsafe_get_field :named_name typkw))
	       )
	  (if (is_not_a cty class_ctype)
	      (progn
		(debug_msg typkw "mexpand_defprimitive bad cty")
		(error_strv loc "bad type keyword for "_  typknam)
		(return ())
		))
	  (cond ( (== (unsafe_get_field :ctype_keyword cty) typkw)
		  ()
		  )
		( (== (unsafe_get_field :ctype_altkeyword cty) typkw)
		  (warning_strv loc "using obsolete ctype keyword" typknam)
		  (inform_strv loc "prefererd ctype is" (get_field :named_name (get_field :ctype_keyword cty)))
		  )
		(:else
		 (debug_msg typkw "mexpand_defprimitive strange typkw")
		 (error_strv loc "invalid type keyword for DEFPRIMITIVE"_
			     typknam)
		 (return ())   
		 ))
	  ;; parse the rest as to be expanded
	  (setq curpair (pair_tail curpair))
	  (if (== (pair_head curpair) ':doc)
	      (progn
		(setq curpair (pair_tail curpair))
		(if docv (error_plain loc "duplicate :doc in DEFPRIMITIVE"))
		(setq docv (pair_head curpair))
		(setq curpair (pair_tail curpair))
		))
	  (let (
		(etuple (parse_pairlist_c_code_expansion loc curpair))
		(substmap (make_mapobject discr_map_objects
					  (+i 5 (*i 2 (multiple_length btup)))))
		(sdefpri
		 (instance class_source_defprimitive
			   :loca_location loc
			   :sdef_name symb
			   :sdef_doc docv
			   :sformal_args btup
			   :sprim_type cty
			   :sprim_expansion etuple))
		(primit
		 (instance class_primitive
			   :named_name (unsafe_get_field :named_name symb)
			   :prim_formals btup
			   :prim_type cty
			   :prim_expansion etuple))
		(pbind
		 (instance class_primitive_binding
			   :binder symb
			   :pbind_primdef sdefpri
			   :pbind_primitive primit
			   ))
		)
	    ;; fill the substmap according to btup to check the C expansion
	    (foreach_in_multiple
	     (btup)
	     (curbind :long bix)
	     (assert_msg "check curbind" (is_a curbind class_formal_binding))
	     (mapobject_put substmap (get_field :binder curbind) curbind)
	     )
	    (debug_msg primit "defprimitive primit")
	    (check_c_expansion etuple loc substmap)
	    ;;
	    (warn_if_redefined symb env loc)
	    (put_env env pbind)
	    (debug_msg sdefpri "mexpand_defprimitive result sdefpri")
	    (return sdefpri)
	    ))))))
(install_initial_macro 'defprimitive mexpand_defprimitive)
(export_macro defprimitive mexpand_defprimitive
	      :doc #{The $DEFPRIMITIVE macro defines new primitive
operations by their C expansion. Syntax is ($DEFPRIMITIVE @var{name}
@var{formals} @var{type} [:doc @var{documentation}] @var{expansion})
which defines a primitive of given @var{name} with formal arguments
@var{formals}, result c-type @var{type}, optional @var{documentation},
and given @var{expansion}. A macro is expanded into a C instruction if
its c-type is @code{:void}, otherwise into a C expression.  Primitives
have to be exported with $EXPORT_VALUES to be visible in other
modules.  See also the classes $CLASS_PRIMITIVE, and
$CLASS_PRIMITIVE_BINDING and the $CODE_CHUNK macro.}# )



;; the defciterator expander
;;(DEFCITERATOR symb startformals statesymb varformals [:doc documentation] expbefore expafter)
(defun mexpand_defciterator (sexpr env mexpander)
  (debug_msg sexpr "mexpand_defciterator sexpr")
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (symb (pair_head curpair))
	 ;; the following variables are set later by setq
	 (bstartup ())		     ;the start formals tuple
	 (statsymb ())		     ;the state symbol
	 (blocvtup ())		     ;the local var formals tuple
	 (docv ())
	 (expbef ())		     ;the tuple expansion before tuple
	 (expaft ())		     ;the tuple expansion after tuple
	 )
    (if (is_not_a symb class_symbol)
	(progn
	  (error_plain loc 
		       "missing symbol for (DEFCITERATOR symb startformals statesymb locformals expbefore expafter)"_)
	  (return)
	  ))
    (setq curpair (pair_tail curpair))
    ;; parse the formal start arguments
    (setq bstartup (lambda_arg_bindings (pair_head curpair)))
    (setq curpair (pair_tail curpair))
    (setq statsymb (pair_head curpair))
    (if (is_not_a statsymb class_symbol)
	(progn
	  (error_plain loc 
		       "missing statsymb for (DEFCITERATOR symb startformals statesymb locformals expbefore expafter)"_)
	  (return)))
    (setq curpair (pair_tail curpair))
    (setq blocvtup  (lambda_arg_bindings (pair_head curpair)))
    (setq curpair (pair_tail curpair))
    ;; parse the documentation, if any
    (if (== (pair_head curpair) ':doc)
	(progn
	  (setq curpair (pair_tail curpair))
	  (if docv (error_plain loc
				"duplicate documentation in DEFCITERATOR"))
	  (setq docv (pair_head curpair))
	  (setq curpair (pair_tail curpair))))
    ;; parse the before expansion
    (let ( (sexpbef (pair_head curpair)) )
      (if (is_not_a sexpbef class_sexpr)
	  (progn
	    (error_plain loc "missing before expansion for  (DEFCITERATOR symb startformals statesymb locformals expbefore expafter)"_)
	    (return)))
      (setq expbef (parse_pairlist_c_code_expansion loc (list_first (unsafe_get_field :sexp_contents sexpbef))))
      )
    (setq curpair (pair_tail curpair))
    ;; parse the after expansion
    (let ( (sexpaft (pair_head curpair)) )
      (if (is_not_a sexpaft class_sexpr)
	  (progn
	    (error_plain loc "missing after expansion for  (DEFCITERATOR symb startformals statesymb locformals expbefore expafter)"_)
	    (return)))
      (setq expaft  (parse_pairlist_c_code_expansion loc (list_first (unsafe_get_field :sexp_contents sexpaft))))
      )
    ;; make the citerator and binding
    (let ( (citer (instance class_citerator
			    :named_name (unsafe_get_field :named_name symb)
			    :citer_start_formals bstartup
			    :citer_state statsymb
			    :citer_body_formals blocvtup
			    :citer_expbefore expbef
			    :citer_expafter expaft
			    ))
	   (citbind (instance class_citerator_binding
			      :binder symb
			      ;; :cbind_citerdef bound later
			      :cbind_citerator citer
			      ))
	   (srcit (instance class_source_defciterator
			    :loca_location loc
			    :sdef_name symb
			    :sdef_doc docv
			    :sformal_args bstartup
			    :sciterdef_citerator citer))
	   (substmap (make_mapobject 
		      discr_map_objects
		      (+i 7 (+i (*i 2 (multiple_length bstartup))
				(*i 2 (multiple_length blocvtup))))))
	   )      ;; fill the substmap
      (debug_msg srcit "srcit citer")
      (mapobject_put substmap statsymb statsymb)
      (debug_msg bstartup "bstartup citer")
      (foreach_in_multiple
       (bstartup)
       (cursbind :long bsix)
       (assert_msg "check start cursbind" (is_a cursbind class_formal_binding))
       (mapobject_put substmap (get_field :binder cursbind) cursbind))
      (debug_msg blocvtup "blocvtup citer")
      (foreach_in_multiple
       (blocvtup)
       (curlbind :long blix)
       (debug_msg curlbind "curlbind local citer")
       (assert_msg "check local curlbind" (is_a curlbind class_any_binding))
       (mapobject_put substmap (get_field :binder curlbind) curlbind))
      ;;; check the expansions
      (check_c_expansion expbef loc substmap)
      (check_c_expansion expaft loc substmap)
      ;; fill the citerator binding
      (unsafe_put_fields citbind :cbind_citerdef srcit)
      (put_env env citbind)
      (debug_msg citer "parsed citerator citer")
      (return srcit)
      )))
(install_initial_macro 'defciterator mexpand_defciterator)
(export_macro defciterator mexpand_defciterator
	      :doc #{The $DEFCITERATOR macro defines a c-iterator
which itself implements iterative @code{for}-like loops. Syntax
is ($DEFCITERATOR @var{name} @var{start-formals} @var{state-symbol}
@var{variable-formals} [:doc @var{documentation}]
@var{before-expansion} @var{after-expansion}). To be visible outside
the module, the c-iterator should be exported using
$EXPORT_VALUES. See also $CLASS_CITERATOR. }#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the defcmatcher expander
;;(DEFCMATCHER  symb match&in-formals out-formals state-sym [:doc documentation]
;;              test-expansion fill-expansion oper-expansion)
(defun mexpand_defcmatcher (sexpr env mexpander)
  (debug_msg sexpr "mexpand_defcmatcher sexpr")
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (symb (pair_head curpair))
	 ;; the following variables are set later by setq
	 (sformals ())			;match & input fmals
	 (matchformal ())		;the match formal binding
	 (informals ())			;input formals tuple
	 (outformals ())		;output formals tuple
	 (statesym ())			;state symbol
	 (exptest ())			;test expansion tuple
	 (expfill ())			;fill expansion tuple
	 (expoper ())			;operand expansion tuple
	 (docv ())
	 )
    ;; check the symb
    (debug_msg symb "mexpand_defcmatcher symb")
    (if (is_not_a symb class_symbol)
	(progn 
	  (error_plain
	   loc 
	   "symbol expected for (DEFCMATCHER <symb> <ins> <outs> <statesym> <test> <fill> <oper>)"_)
	  (return)))
    (setq curpair (pair_tail curpair))
    ;; parse the match & in formals 
    (let ( (matinformals (lambda_arg_bindings (pair_head curpair)))
	   (:long nbmatinformals (multiple_length matinformals)) 
	   )
      (if (<i nbmatinformals 1)
	  (progn 
	    (error_plain loc "empty ins for (DEFCMATCHER <symb> <ins> <outs> <statesym> <test> <fill> <oper>)"_)
	    (return)))
      (setq sformals matinformals)
      (setq matchformal (multiple_nth matinformals 0))
      (debug_msg matchformal "mexpand_defcmatcher matchformal")
      (assert_msg "check matchformal" (is_a matchformal class_formal_binding))
      (setq informals (make_multiple discr_multiple (-i nbmatinformals 1)))
      (multiple_every 
       matinformals
       (lambda (comp :long ix) (if (>i ix 0) (multiple_put_nth informals (-i ix 1) comp))))
      (debug_msg informals "mexpand_defcmatcher informals")
      )
    ;; parse the out formals
    (setq curpair (pair_tail curpair))
    (setq outformals (lambda_arg_bindings (pair_head curpair)))
    (debug_msg outformals "mexpand_defcmatcher outformals")
    (if (not (is_multiple outformals))
	(progn
	  (error_plain loc "bad outs for (DEFCMATCHER <symb> <ins> <outs> <statesym> <test> <fill> <oper>)"_)
	  (return)))
    ;; parse the state symbol
    (setq curpair (pair_tail curpair))
    (setq statesym (pair_head curpair))
    (if (is_not_a statesym class_symbol)
	(progn
	  (debug_msg statesym "mexpand_defcmatcher bad statesym")
	  (error_plain loc "bad statesym for (DEFCMATCHER <symb> <ins> <outs> <statesym> <test> <fill> <oper>)"_)
	  (return)))
    (debug_msg statesym "mexpand_defcmatcher statesym")
    (setq curpair (pair_tail curpair))
    ;; parse the documentation if any
    (if (== (pair_head curpair) ':doc)
	(progn
	  (setq curpair (pair_tail curpair))
	  (if docv (error_plain loc "duplicate documentation in DEFCMATCHER"))
	  (setq docv (pair_head curpair))
	  (setq curpair (pair_tail curpair))
	  ))
    ;; parse the test expansion
    (let ( (sexptest (pair_head curpair)) )
      (if (and sexptest (is_not_a sexptest class_sexpr))
	  (progn
	    (debug_msg sexptest "mexpand_defcmatcher bad sexptest")
	    (error_plain loc "bad test expansion in (DEFCMATCHER <symb> <ins> <outs> <statesym> <test> <fill> <oper>)"_)
	    (return))
	(if sexptest
	    (setq exptest 
		  (parse_pairlist_c_code_expansion 
		   loc
		   (list_first (unsafe_get_field :sexp_contents sexptest)))))
	))
    (debug_msg exptest "mexpand_defcmatcher exptest")
    ;; parse the fill expansion
    (setq curpair (pair_tail curpair))
    (let ( (sexpfill (pair_head curpair)) )
      (if (and sexpfill (is_not_a sexpfill class_sexpr))
	  (progn
	    (error_plain loc "bad fill expansion in (DEFCMATCHER <symb> <ins> <outs> <statesym> <test> <fill> <oper>)"_)
	    (return))
	(if sexpfill
	    (setq expfill
		  (parse_pairlist_c_code_expansion 
		   loc (list_first (unsafe_get_field :sexp_contents sexpfill)))))
	))
    (debug_msg expfill "mexpand_defcmatcher expfill")
    ;; parse the operate expansion
    (setq curpair (pair_tail curpair))
    (let ( (sexpoper (pair_head curpair)) )
      (if (and sexpoper (is_not_a sexpoper class_sexpr))
	  (progn
	    (error_plain loc "bad oper expansion in (DEFCMATCHER <symb> <ins> <outs> <statesym> <test> <fill> <oper>)"_)
	    (return))
	(setq expoper
	      (if sexpoper
		  (parse_pairlist_c_code_expansion loc (list_first (unsafe_get_field :sexp_contents sexpoper)))))
	))
    (debug_msg expoper "mexpand_defcmatcher expfill")
    ;; check nothing more
    (setq curpair (pair_tail curpair))
    (if curpair
	(warning_plain loc "extra in (DEFCMATCHER <symb> <ins> <outs> <statesym> <test> <fill> <oper>)"_))
    (assert_msg "check matchformal again" (is_a matchformal class_formal_binding))
    ;; build the defcmatcher
    (let (
	  (cmatch (instance class_cmatcher
			    :named_name (unsafe_get_field :named_name symb)
			    :amatch_in informals
			    :amatch_matchbind matchformal
			    :amatch_out outformals
			    :cmatch_state statesym
			    :cmatch_exptest exptest
			    :cmatch_expfill expfill
			    :cmatch_expoper expoper
			    ))
	  (sdefcmatch (instance  class_source_defcmatcher
				 :loca_location loc
				 :sdef_name symb
				 :sdef_doc docv
				 :sformal_args sformals
				 :scmatdef_cmatcher cmatch)) 
	  (cmbind (instance class_cmatcher_binding
			    :binder symb
			    :cmbind_matcher cmatch))
	  (substmap 
	   (make_mapobject 
	    discr_map_objects
	    (+i 7 (*i 2 (+i (multiple_length informals)
			    (multiple_length outformals))))))
	  )
      ;; fill the substmap
      (mapobject_put substmap statesym statesym)
      (mapobject_put substmap (get_field :binder matchformal) matchformal)
      (foreach_in_multiple
       (informals)
       (curibind :long ibix)
       (assert_msg "check input curibind" (is_a curibind class_formal_binding))
       (mapobject_put substmap (get_field :binder curibind) curibind))
      (foreach_in_multiple
       (outformals)
       (curobind :long obix)
       (assert_msg "check output curbind" (is_a curobind class_formal_binding))
       (mapobject_put substmap (get_field :binder curobind) curobind))
      ;; check the expansions
      (check_c_expansion exptest loc substmap)
      (check_c_expansion expfill loc substmap)
      (check_c_expansion expoper loc substmap)
      (debug_msg sdefcmatch "mexpand_defcmatcher sdefcmatch")
      (put_env env cmbind)
      (return sdefcmatch)
      )
    ))
(install_initial_macro 'defcmatcher mexpand_defcmatcher)
(export_macro defcmatcher mexpand_defcmatcher
 :doc #{The $DEFCMATCHER macro defines pattern-matching operator by
 their C expansion. Syntax is (DEFCMATCHER symbol match&ins-formals
 out-formals state-symbol [:doc documentation] test-expansion
 fill-expansion [operator-expansion]).}# )



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; probably (DEFUNMATCHER <symb> <informals> <outformals> [:doc documentation] <matchfun> <applyfun> [<data>])
(defun mexpand_defunmatcher (sexpr env mexpander)
  (debug_msg sexpr "mexpand_defunmatcher sexpr")
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (symb (pair_head curpair))
	 ;; the following variables are set later by setq
	 (sformals ())			;match & input fmals
	 (matchformal ())		;the match formal binding
	 (informals ())			;input formals tuple
	 (outformals ())		;output formals tuple
	 (matchfunx ())			;the matcher function expr
	 (applyfunx ())			;the apply function expr
	 (datax ())			;extra data expr
	 (docv ())
	 )
    ;; check symb
    (debug_msg symb "mexpand_defunmatcher symb")
    (if (is_not_a symb class_symbol)
	(progn 
	  (error_plain
	   loc 
	   "symbol expected for (DEFUNMATCHER <symb> <ins> <outs> [:doc docum] <matchfun> <applyfun> [<data>])"_)
	  (return)))
    (setq curpair (pair_tail curpair))
    ;; parse the match & in formals 
    (let ( (matinformals (lambda_arg_bindings (pair_head curpair)))
	   (:long nbmatinformals (multiple_length matinformals)) 
	   )
      (if (<i nbmatinformals 1)
	  (progn 
	    (error_plain loc "empty ins for (DEFUNMATCHER <symb> <ins> <outs> [:doc docum] <matchfun> <applyfun> [<data>])"_)
	    (return)))
      (setq sformals matinformals)
      (setq matchformal (multiple_nth matinformals 0))
      (debug_msg matchformal "mexpand_defunmatcher matchformal")
      (setq informals (make_multiple discr_multiple (-i nbmatinformals 1)))
      (multiple_every 
       matinformals
       (lambda (comp :long ix) (if (>i ix 0) (multiple_put_nth informals (-i ix 1) comp))))
      (debug_msg informals "mexpand_defunmatcher informals")
      )
    ;; parse the out formals
    (setq curpair (pair_tail curpair))
    (setq outformals (lambda_arg_bindings (pair_head curpair)))
    (if (not (is_multiple outformals))
	(progn
	  (error_plain loc "bad outs for (DEFUNMATCHER <symb> <ins> <outs>[:doc docum]  <matchfun> <applyfun> [<data>])"_)
	  (return)))
    (setq curpair (pair_tail curpair))
    ;; parse the documentation if any
    (if (== (pair_head curpair) ':doc)
	(progn
	  (setq curpair (pair_tail curpair))
	  (if docv (error_plain loc "duplicate documentation for DEFUNMATCHER"))
	  (setq docv (pair_head curpair))
	  (setq curpair (pair_tail curpair))
	  ))
    ;; parse & macroexpand the matchfun expr
    (let ( (mfa (pair_head curpair)) )
      (if mfa
	  (setq matchfunx (macroexpand_1 mfa env mexpander))
	(error_plain loc "bad matchfun for (DEFUNMATCHER <symb> <ins> <outs> <matchfun> <applyfun> [<data>])"_))
      )
    (debug_msg matchfunx "mexpand_defunmatcher matchfunx")
    ;; parse & macroexpand the applyfun expr
    (setq curpair (pair_tail curpair))
    (let ( (afa (pair_head curpair)) )
      (if afa
	  (setq applyfunx (macroexpand_1 afa env mexpander))
	(error_plain loc "bad applyfun for (DEFUNMATCHER <symb> <ins> <outs> <matchfun> <applyfun> [<data>])"_))
      )
    (debug_msg applyfunx "mexpand_defunmatcher applyfunx")
    ;; parse & macroexpand the data expr
    (setq curpair (pair_tail curpair))
    (let ( (dta (pair_head curpair)) )
      (if dta
	  (setq datax (macroexpand_1 dta env mexpander))
	;; data is optional, so no error if missing
	))
    (debug_msg datax "mexpand_defunmatcher datax")
    ;; check for no extra stuff
    (setq curpair (pair_tail curpair))
    (if curpair 
	(error_plain loc "extra for (DEFUNMATCHER <symb> <ins> <outs> <matchfun> <applyfun> [<data>])"_))
    (let (
	  ;; make a class_source_defunmatcher with :loca_location :sdef_name
	  ;; :sformal_args :sfumatdef_matchf :sfumatdef_applyf
	  ;; :sfumatdef_data
	  (sdfum (instance class_source_defunmatcher
			   :loca_location loc
			   :sdef_name symb
			   :sdef_doc docv
			   :sformal_args sformals
			   :sfumatdef_ins informals
			   :sfumatdef_outs outformals
			   :sfumatdef_matchf matchfunx
			   :sfumatdef_applyf applyfunx
			   :sfumatdef_data datax))
	  ;; make an (uncompletely filled) funmatcher
	  (fuma (instance class_funmatcher
			  :named_name (unsafe_get_field :named_name symb)
			  :amatch_in informals
			  :amatch_matchbind matchformal
			  :amatch_out outformals
			  :fmatch_matchf ()
			  :fmatch_applyf ()
			  :fmatch_data ()
			  ))
	  ;; make the binding
	  (fmbind (instance class_funmatcher_binding
			    :binder symb
			    :fmbind_funmatcher fuma
			    :fmbind_defunmatcher sdfum
			    ))
	  )
      (put_env env fmbind)
      (debug_msg fuma "mexpand_defunmatcher made fuma")
      (debug_msg fmbind "mexpand_defunmatcher fmbind")
      (debug_msg sdfum "mexpand_defunmatcher return sdfum")
      (return sdfum)
      )
    ))
(install_initial_macro 'defunmatcher mexpand_defunmatcher)
(export_macro defunmatcher mexpand_defunmatcher
:doc #{The $DEFUNMATCHER syntax defines a matcher thru a MELT
function. Syntax is (DEFUNMATCHER <symbol> <in-formals> <out-formals>
[:doc docum] <match-function> <apply-function> [<data>])}#)

;;;;;;;;;;;;;;;;;; the defun expander
;;;(DEFUN funame formals [:doc documentation] body...)
(defun mexpand_defun (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexp.defun sexpr")
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (symb (pair_head curpair))
	 (newenv (fresh_env env))
	 (docv ())
	 )
    (if (is_not_a symb class_symbol)
	(error_plain loc "missing symbol for DEFUN"_))
    (setq curpair (pair_tail curpair))
    ;; parse the formal arguments
    (let ( (curpairhead (pair_head curpair)) 
	   (btup 
	    (cond ( (null curpairhead) 
		    (make_multiple discr_multiple 0) )
		  ( (is_a curpairhead class_sexpr)
		    (lambda_arg_bindings (pair_head curpair) sexpr))
		  (:else
		   (debug_msg curpairhead "mexpand_defun strange arglist curpairhead")
		   (error_plain loc "missing or invalid arglist for DEFUN"_)
		   ()
		   )))
	   )
      (if (not (is_multiple btup))
	  (progn
	    (debug_msg btup "mexpand_defun strange btup")
	    (error_plain loc "missing formal arguments for DEFUN"_)))
      (multiple_every btup (lambda (fb) (put_env newenv fb)))
      (setq curpair (pair_tail curpair))
      ;; handle the optional :doc documentationvalue
      (if (== (pair_head curpair) ':doc)
	  (progn
	    (setq curpair (pair_tail curpair)) ;; consume :doc
	    ;; the documentation is NOT macro-expanded
	    (setq docv (pair_head curpair))    ;; get the docv
	    (setq curpair (pair_tail curpair))  ;; consume it
	    ))
      ;; handle the body
      (let ( (bodytup (expand_pairlist_as_tuple curpair newenv mexpander)) 
	     (sdefun
	      (instance class_source_defun
			:loca_location loc
			:sdef_name symb
			:sdef_doc docv
			:sformal_args btup
			:sfun_body bodytup
			))
	     (fbind 
	      (instance class_function_binding
			:binder symb
			:fubind_defun sdefun
			))
	     )
	(warn_if_redefined symb env loc)
	(put_env env fbind)
	sdefun
	))))
(install_initial_macro 'defun mexpand_defun)
(export_macro defun mexpand_defun
	      :doc #{The $DEFUN macro defines a function. Syntax
is ($DEFUN @var{funame} @var{formals} [:doc @var{documentation}]
@var{body}...). The first formal argument, if any, is required to be
of ctype @code{:value}. The expressions in the @var{body} are evaluated
in sequence. The value of the last is returned. See also $RETURN and
$LAMBDA macros. A function defined by $DEFUN has to be exported with $EXPORT_VALUES to be visible outside its module.}#)


;;;;;;;;;;;;;;;; the defclass expander

;; internal routine with multiple results to scan the defclass
(defun scan_defclass (sexpr env mexpander)
  (let ( (predef ())
	 (supernam ())
	 (superbind ())
	 (superclass ())
	 (fieldnams ())
	 (docv ())
	 (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (fieldsloc ())
	 (curpair (pair_tail (list_first cont)))
	 (symb (pair_head curpair))
	 )
    (debug_msg sexpr "scan_defclass sexpr")
    (if (is_not_a symb class_symbol)
	(error_plain loc "missing symbol for DEFCLASS"_))
    (setq curpair (pair_tail curpair))
    (forever scanloop
	     (if (not (is_pair curpair)) (exit scanloop))
	     (let ( (curkw (pair_head curpair)) )
	       (if (not (is_a curkw class_keyword)) 
		   (error_plain loc "expecting keyword in DEFCLASS"_))
	       (setq curpair (pair_tail curpair))
	       (let ( (curval (pair_head curpair)) )
		 (setq curpair (pair_tail curpair))
		 (cond 
		  ( (== curkw ':super)
		    (if supernam (error_plain loc "duplicate super in DEFCLASS"_))
		    (if (not (is_a curval class_symbol))
			(error_plain loc "bad super in DEFCLASS"_))
		    (setq supernam curval)
		    (debug_msg supernam "scan_defclass supernam")
		    (let ( (superb (find_env env supernam)) )
;;; should handle the case when the class is bound in the start environment
;;; to a value which happens to be a class
		      (cond ( (is_a superb class_class_binding)
			      (setq superbind superb) 
			      (setq superclass (unsafe_get_field :cbind_class superb))
			      )
			    ( (is_a superb class_value_binding)
			      (let ((superval (unsafe_get_field :vbind_value superb)))
				(if (is_a superval class_class)
				    (progn
				      (setq superbind superb)
				      (setq superclass superval)
				      )
				  (error_strv loc "super is not a class in defclass"_ 
					      (unsafe_get_field :named_name supernam))))
			      )
			    (:else 
			     (debug_msg superb "scan_defclass superb")
			     (debug_msg env "scan_defclass env")
			     (error_strv loc "invalid super in defclass"_
					 (unsafe_get_field :named_name supernam))
			     )
			    )
		      ))
		  ( (== curkw ':fields)
		    (if fieldnams (error_plain loc "duplicate fields in defclass"_))
		    (if curval
			(if (is_not_a curval class_sexpr)
			    (error_plain loc "bad fields in defclass"_)))
		    (let ( (namlist (if curval (unsafe_get_field :sexp_contents curval)))
			   (namloc (if curval (unsafe_get_field :loca_location curval)))
			   (:long nbnam  (list_length namlist))
			   (:long ix 0)
			   (nampair (list_first namlist))
			   (namtupl (make_multiple discr_multiple nbnam)) )
		      (setq fieldsloc namloc)
		      (forever namloop
			       (if (not (is_pair nampair)) (exit namloop))
			       (let ( (curnam (pair_head nampair)) )
				 (if (not (is_a curnam class_symbol))
				     (error_plain namloc "non name field in DEFCLASS"_))
				 (multiple_put_nth namtupl ix curnam)
				 )
			       (setq nampair (pair_tail nampair))
			       (setq ix (+i ix 1))
			       )
		      (setq fieldnams namtupl)
		      ))
		  ( (== curkw ':predef)
		    (if predef (error_plain loc "duplicate predef in DEFCLASS"_))
		    (setq predef (macroexpand_1 curval env mexpander))
		    (cond
		     ( (is_integerbox predef) 
		       ()
		       )
		     ( (is_a predef class_symbol)
		       ()
		       )
		     (:else
		      (error_plain loc "bad predef in DEFCLASS"_)
		      )
		     )
		    )
		  ( (== curkw ':doc)
		    (if docv (error_plain loc "duplicate doc in DEFCLASS"_))
		    ;; the documentation is NOT macro-expanded!
		    (setq docv curval)
		    )
		  (:else
		   (error_strv loc "invalid keyword in DEFCLASS"_ 
			       (unsafe_get_field :named_name curkw))
		   )
		  ))))
    (debug_msg symb "scan_defclass returns symb")
    (debug_msg loc "scan_defclass returns loc")
    (debug_msg supernam "scan_defclass returns supernam")
    (debug_msg superbind "scan_defclass returns superbinds")
    (debug_msg superclass "scan_defclass returns superclass")
    (debug_msg predef "scan_defclass returns predef")
    (debug_msg fieldnams "scan_defclass returns fieldnams")
    (debug_msg fieldsloc "scan_defclass returns fieldsloc")
    (debug_msg docv "scan_defclass returns docv")
    (warn_if_redefined symb env loc)
    (return symb loc supernam superbind superclass predef fieldnams fieldsloc docv)
    ))


(defun mexpand_defclass (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg  sexpr "mexp.defclass sexpr")
  (multicall 
   (symb loc supernam superbind superclass predef fieldnams fieldsloc docv)
   (scan_defclass sexpr env mexpander)
   (debug_msg symb "mexp.defclass scanned symb")
   (debug_msg loc "mexp.defclass scanned loc")
   (debug_msg supernam "mexp.defclass scanned supernam")
   (debug_msg superbind "mexp.defclass scanned superbind")
   (debug_msg superclass "mexp.defclass scanned superclass")
   (debug_msg predef "mexp.defclass scanned predef")
   (debug_msg fieldnams "mexp.defclass scanned fieldnams")
   (debug_msg fieldsloc "mexp.defclass scanned fieldsloc")
   (debug_msg docv "mexp.defclass scanned docv")
   (assert_msg "check symb" (is_a symb class_symbol))
   (and (null predef)
	(null superclass)
	(warning_strv loc 
		      "DEFCLASS of a non-predefined class without superclass"
		      (unsafe_get_field :named_name symb))
	)
   (let ( 
	 (ancestors (if (is_object superclass)
			(let ( (superancestors (unsafe_get_field :class_ancestors superclass))
			       (:long nbsuperanc (multiple_length superancestors))
			       (anctuple (make_multiple discr_class_sequence (+i 1 nbsuperanc)))
			       (:long ix 0)
			       )
			  (assert_msg "check superclass" (is_a superclass class_class))
			  (assert_msg "check superancestors" (is_multiple superancestors))
			  (forever ancloop
				   (if (>=i ix nbsuperanc) (exit ancloop))
				   (multiple_put_nth anctuple ix (multiple_nth superancestors ix))
				   (setq ix (+i ix 1))
				   )
			  (multiple_put_nth anctuple nbsuperanc superclass)
			  anctuple
			  )
		      (make_multiple discr_class_sequence 0)))
	 (superfields (if (is_object superclass)
			  (unsafe_get_field :class_fields superclass)))
	 (:long nbsuperfields (multiple_length superfields))
	 (:long nbfieldnames (multiple_length fieldnams))
	 (boxnbsuperfields (make_integerbox discr_integer nbsuperfields))
	 (fieldstrmap (make_mapstring discr_map_strings (+i 3 (*i 2 (+i nbsuperfields nbfieldnames)))))
	 (fieldtup (make_multiple discr_field_sequence (+i nbsuperfields nbfieldnames)))
	 (ownfieldbindings (make_multiple discr_multiple nbfieldnames))
	 (newclass (instance class_class
			     :named_name (unsafe_get_field :named_name symb)
			     :class_ancestors ancestors
			     ;; other fields to be set later
			     ))
	 (clabind (instance class_class_binding
			    :binder symb
			    :cbind_class newclass))
	 )
     (put_env env clabind)
     (debug_msg superfields "expdefclas superfields")
     (multiple_every 
      superfields 
      (lambda (sfld :long ix)
	(messagenum_dbg "expdefclasupflds ix" ix)
	(messageval_dbg "expdefclasupfldsval sfld" sfld)
	(assert_msg "check superfield" (is_a sfld class_field))
	(multiple_put_nth fieldtup ix sfld)
	(mapstring_putstr fieldstrmap (unsafe_get_field :named_name sfld) sfld)
	))
     (multiple_every
      fieldnams
      (lambda (fldnam :long ix)
	(messagenum_dbg "expdefclafldnam ix" ix)
	(assert_msg "check fldnam" (is_a fldnam class_symbol))
	(let ( (fldstr (unsafe_get_field :named_name fldnam)) 
	       (fldprevbind (find_env env fldnam))
	       )
	  (if (mapstring_getstr fieldstrmap fldstr)
	      (error_strv fieldsloc "duplicate field in DEFLCLASS"_ fldstr))
	  (cond
	   ( (null fldprevbind)
	     (void)
	     )
	   ( (is_a fldprevbind class_field_binding)
	     (debug_msg fldprevbind "mexpand_defclass fldprevbind !field")
	     (error_strv fieldsloc "field name already defined in DEFCLASS"_ fldstr)
	     )
	   ( (is_a fldprevbind class_value_binding)
	     (debug_msg fldprevbind "mexpand_defclass fldprevbind !value")
	     (debug_msg symb "mexpand_defclass symb !value")
	     (let ( (prevalue (get_field :vbind_value fldprevbind))
		    )
	       ;; this test avoids warnings when recompiling
	       ;; warmelt-*.melt files
	       (if (or (is_not_a prevalue class_field)
		       (string!= (get_field :named_name (get_field :fld_ownclass prevalue))
				 (get_field :named_name symb)))
		   (warning_strv fieldsloc "field name already bound to a value in DEFCLASS"_ fldstr)
		 )))
	   (:else
	    (debug_msg fldprevbind "mexpand_defclass fldprevbind !other")
	    (warning_strv  fieldsloc "field name previously bound in DEFCLASS"_ fldstr))
	   )
	  (let ( (:long fldoff (+i ix (get_int boxnbsuperfields))) 
		 (newfld (instance class_field
				   :named_name fldstr
				   :fld_ownclass newclass
				   )) )
	    (put_int newfld fldoff)
	    (messagenum_dbg "expdefclafldnam fldoff" fldoff)
	    (multiple_put_nth fieldtup fldoff newfld)
	    (mapstring_putstr fieldstrmap fldstr newfld)
	    (let ( (newfldbind (instance class_field_binding
					 :binder fldnam
					 :flbind_clabind clabind
					 :flbind_field newfld)) )
	      (warn_if_redefined fldnam env loc)
	      (put_env env newfldbind)
	      (multiple_put_nth ownfieldbindings ix newfldbind)
	      )
	    ))))
     (unsafe_put_fields newclass
			:class_fields fieldtup)
     ;; we need to put the object magic to MELTOBMAG_OBJECT now
     (code_chunk setobjmagic
		 #{((meltobject_ptr_t)$newclass)->obj_num = MELTOBMAG_OBJECT ;
		 }#)
     (debug_msg newclass "mexp.defclass newclass" )
     (instance class_source_defclass
	       :loca_location loc
	       :sdef_name symb
	       :sdef_doc docv
	       :sobj_predef predef
	       :sclass_clabind clabind
	       :sclass_superbind superbind
	       :sclass_fldbinds ownfieldbindings
	       ))))
(install_initial_macro 'defclass mexpand_defclass)
(export_macro defclass mexpand_defclass
	      :doc #{The $DEFCLASS macro defines a class. Syntax
is (DEFCLASS symbol [:doc documentation] :super super-class :fields
fields-list). Conventionally, the class name (i.e. the symbol) should
preferably start with CLASS_. The fields' names should preferably be
globally unique, and usually share a common prefix. See also
$CLASS_ROOT $CLASS_CLASS $CLASS_FIELD etc.}#)

;;;;;;;;;;;;;;;; the definstance expander

;; internal to parse a field assignment in a given class (or without class, for put_field)
(defun parse_field_assignment (cla loc fldkw expr env mexpander)
  (debug_msg cla "start parse_field_assignment cla")
  (debug_msg loc "start parse_field_assignment loc")
  (debug_msg fldkw "start parse_field_assignment fldkw")
  (if (not (is_a fldkw class_keyword))
      (progn 
	(error_plain loc "expecting :fieldname"_)
	(return)
	))
  (assert_msg "check fldkw" (is_a fldkw class_keyword))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check mexpander" (is_closure mexpander))
  ;; expr is an sexpr or a symbol or a string or ...
  (let ( (fld ()) )
    ;; if we have a class, find the field inside
    (if (is_a cla class_class)
	(let ( (clafields (unsafe_get_field :class_fields cla)) 
	       )
	  (debug_msg clafields "parse_field_assignment clafields")
	  (multicall 
	   (foundfld :long ix :value foundname)
	   (multiple_iterate_test
	    clafields
	    (lambda (curfld :long ix)
	      (assert_msg "check fld" (is_a curfld class_field))
	      (let ( (curfldnam  (unsafe_get_field :named_name curfld)) )
		(cond
		 ;; found the field, so return nil & the fieldname
		 ( (==s curfldnam
			(unsafe_get_field :named_name fldkw))
		   (debug_msg curfld "parse_field_assignment found curfld")
		   (debug_msg curfldnam "parse_field_assignment found curfldnam")
		   (return () curfldnam))
		 (:else
		  ;; did not found the field, so return true
		  (return :true))))))
	   (if foundfld
	       (progn
		 (debug_msg foundfld "parse_field_assignment return foundfld")
		 (setq fld foundfld))))))
    (debug_msg fld "parse_field_assignment after class scanning fld")
    (if (null fld)
	;; othewise, find the field by its bound name
	(let ( (fldkwnam (unsafe_get_field :named_name fldkw))
	       (fldnam (create_symbolstr fldkwnam)) 
	       )
	  (debug_msg fldnam "parse_field_assignment fldnam")
	  (assert_msg "check fldnam symb" (is_a fldnam class_symbol))
	  (let ( (fldbind (find_env env fldnam)) )
	    (debug_msg fldbind "parse_field_assignment fldbind")
	    (cond 
	     ( (null fldbind)
	       (error_strv loc "unknown field name in field assignment"_ 
			   fldkwnam)
	       (return)
	       )
	     ( (is_a fldbind class_field_binding)
	       (setq fld (unsafe_get_field :flbind_field fldbind) )
	       (debug_msg fld "parse_field_assignment found fld in field binding")
	       )
	     ( (is_a fldbind class_value_binding)
	       (let ( (vfld (unsafe_get_field :vbind_value fldbind)) )
		 (debug_msg vfld "parse_field_assignment has vfld")
		 (if (is_a vfld class_field)
		     (let ( (vfldnam  (unsafe_get_field :named_name vfld))
			    (kwnam (unsafe_get_field :named_name fldkw)) 
			    )
		       (setq fld vfld)
		       (if (!=s vfldnam kwnam)
			   (progn
			     ;; this happen when a field is used by its synonym
			     (warning_strv loc "obsolete use of synonym field" kwnam)
			     (inform_strv loc "better use real field name" vfldnam)))
		       (debug_msg vfld "parse_field_assignment gives vfld")
		       vfld)) ))
	     (:else
	      (error_strv loc "bad field name in field assignment"_
			  fldkwnam)
	      (return)
	      ))
	    (debug_msg fld "parse_field_assignment fld from environment")
	    )))			  
    ;;end when fld has to be found in the environment
    (assert_msg "check fld" (is_a fld class_field))
    (let ( (xex (macroexpand_1 expr env mexpander)) 
	   (fa (instance class_source_fieldassign 
			 :loca_location loc
			 :sfla_field fld
			 :sfla_expr xex
			 ))
	   )
      (debug_msg fa "parse_field_assignment return fa")
      (return fa))
    ))

;; the definstance expanser
(defun mexpand_definstance (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexp.definstance sexpr")
  (let ( (predef ())
	 (objnum ())
	 (fields ())
	 (fieldnams ())
	 (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (symb (pair_head curpair))
	 (claname ())
	 (cla ())
	 (clabind ())
	 (docv ())
	 )
    (if (is_not_a symb class_symbol)
	(error_plain loc "missing symbol for DEFINSTANCE"_))
    (setq curpair (pair_tail curpair))
    (let ( (nam (pair_head curpair)) )
      (if (is_not_a nam class_symbol)
	  (error_plain loc "missing class name for DEFINSTANCE"_))
      (let ( (bnd (find_env env nam)) 
	     (fldlist (make_list discr_list))
	     )
	(cond 
	 ( (is_a bnd class_class_binding)
	   (setq clabind bnd)
	   (setq cla (unsafe_get_field :cbind_class bnd)) )
	 ( (and (is_a bnd class_value_binding)
		(is_a (unsafe_get_field :vbind_value bnd) class_class))
	   (setq clabind bnd)
	   (setq cla (unsafe_get_field :vbind_value bnd)))
	 (:else
	  (error_strv loc "invalid class name for DEFINSTANCE"_
		      (unsafe_get_field :named_name nam))
	  (return ())
	  ))
	(setq claname nam)
	(assert_msg "check cla" (is_a cla class_class))
	(setq curpair (pair_tail curpair))
	(forever insloop
		 (if (not (is_pair curpair)) (exit insloop))
		 (let ( (curfkw (pair_head curpair)) )
		   (if (is_not_a curfkw class_keyword)
		       (error_plain loc "expecting keyword in DEFINSTANCE"_))
		   (setq curpair (pair_tail curpair))
		   (let ( (curexp (pair_head curpair)) )
		     (cond  ( (== curfkw ':obj_num)
			      (if objnum (error_plain loc "duplicate :obj_num in DEFINSTANCE"_))
			      (setq objnum 
				    (if (is_a curexp class_sexpr)
					(macroexpand_1 curexp env mexpander)
				      curexp))
			      )
			    ( (== curfkw ':predef)
			      (if predef (error_plain loc "duplicate :predef in DEFINSTANCE"_))
			      (setq predef 
				    (if (is_a curexp class_sexpr)
					(macroexpand_1 curexp env mexpander)
				      curexp))
			      )
			    ( (== curfkw ':doc)
			      (if docv (error_plain loc "duplicate :doc in DEFINSTANCE"))
			      (setq docv curexp)
			      )
			    (:else 
			     (let  ( (flda (parse_field_assignment cla loc curfkw curexp env mexpander)) )
			       (if flda 
				   (list_append fldlist flda)
				 )
			       ))))
		   (setq curpair (pair_tail curpair))
		   ))
	(let ( (fastup (list_to_multiple fldlist discr_multiple)) 
	       (sinst 
		(instance class_source_definstance
			  :loca_location loc
			  :sdef_name symb
			  :sdef_doc docv
			  :sobj_predef predef
			  :sinst_class cla
			  :sinst_clabind clabind
			  :sinst_objnum objnum
			  :sinst_fields fastup
			  ))
	       (ibind 
		(instance class_instance_binding
			  :binder symb
			  :ibind_iclass cla
			  ))
	       )
	  (warn_if_redefined symb env loc)
	  (put_env env ibind)
	  (debug_msg sinst "mexp.definstance sinst")
	  (return sinst)
	  )))))
(install_initial_macro 'definstance mexpand_definstance)
(export_macro 
 definstance mexpand_definstance
 :doc #{The $DEFINSTANCE syntax defines a static instance bound by a
 symbol. Syntax is (DEFINSTANCE <symbol> <class> [:doc documentation]
 @{:<field> <value>@}*). The symbol is bound to the newly made
 instance.}#)


;; the defselector expanser
(defun mexpand_defselector (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexp.definstance sexpr")
  (let ( (predef ())
	 (objnum ())
	 (fields ())
	 (fieldnams ())
	 (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (symb (pair_head curpair))
	 (claname ())
	 (cla ())
	 (docv ())
	 (clabind ())
	 (formals ())
	 )
    (if (is_not_a symb class_symbol)
	(error_plain loc "missing symbol for (DEFSELECTOR <name> <class> ...)"_))
    (setq curpair (pair_tail curpair))
    (let ( (nam (pair_head curpair)) )
      (if (is_not_a nam class_symbol)
	  (error_plain loc "missing class name for (DEFSELECTOR <name> <class> ...)"_))
      (let ( (bnd (find_env env nam)) 
	     (fldlist (make_list discr_list))
	     )
	(cond 
	 ( (is_a bnd class_class_binding)
	   (setq clabind bnd)
	   (setq cla (unsafe_get_field :cbind_class bnd)) )
	 ( (and (is_a bnd class_value_binding)
		(is_a (unsafe_get_field :vbind_value bnd) class_class))
	   (setq clabind bnd)
	   (setq cla (unsafe_get_field :vbind_value bnd)))
	 (:else
	  (error_strv loc "invalid class name for (DEFSELECTOR <name> <class> ...)"_
		      (unsafe_get_field :named_name nam))
	  (return ())
	  ))
	;;
	(setq claname nam)
	(if (not (subclass_or_eq cla class_selector))
	    (progn
	      ;; strangely, this error happens in makedoc mode all the
	      ;; times. We disable it in that case...
	      (if (null (get_field :container_value melt_mode_container))
		  (error_strv loc "invalid class in (DEFSELECTOR <name> <class>); expecting CLASS_SELECTOR or its subclass"  (unsafe_get_field :named_name claname)))
	      (return)))
	;;
	(assert_msg "check cla" (is_a cla class_class))
	(setq curpair (pair_tail curpair))
	(forever insloop
		 (if (not (is_pair curpair)) (exit insloop))
		 (let ( (curfkw (pair_head curpair)) )
		   (if (is_not_a curfkw class_keyword)
		       (error_plain loc "expecting keyword in DEFSELECTOR"_))
		   (setq curpair (pair_tail curpair))
		   (let ( (curexp (pair_head curpair)) )
		     (cond  ( (== curfkw ':obj_num)
			      (if curexp (error_plain loc "duplicate :obj_num in DEFSELECTOR"_))
			      (setq objnum 
				    (if (is_a curexp class_sexpr)
					(macroexpand_1 curexp env mexpander)
				      curexp))
			      )
			    ( (== curfkw ':predef)
			      (if curexp (error_plain loc "duplicate :predef in DEFSELECTOR"_))
			      (setq predef 
				    (if (is_a curexp class_sexpr)
					(macroexpand_1 curexp env mexpander)
				      curexp))
			      )
			    ( (== curfkw ':doc)
			      (if docv (error_plain loc "duplicate :doc in DEFSELECTOR"))
			      (setq docv curexp)
			      )
			    ( (== curfkw ':formals)
			      (if formals (error_plain loc "duplicate :formals in DEFSELECTOR"))
			      ;; curfkw is non-null so we ask the
			      ;; arguments to be checked by
			      ;; lambda_arg_bindings
			      (setq formals (lambda_arg_bindings curexp curfkw))
			      (let ( (firstf (multiple_nth formals 0)) )
				(cond
				 ( (null firstf)
				   (error_plain loc ":formals of DEFSELECTOR should have at least one value argument for the reciever"))
				 ( (!= (get_field :fbind_type firstf) ctype_value)
				   (error_plain loc "first :formals of DEFSELECTOR should be a :value"))
			      )))
			    (:else 
			     (let  ( (flda (parse_field_assignment cla loc curfkw curexp env mexpander)) )
			       (if flda 
				   (list_append fldlist flda)
				 )
			       ))))
		   (setq curpair (pair_tail curpair))
		   ))
	(let ( ( fastup (list_to_multiple fldlist discr_multiple)) 
	       (res (instance class_source_defselector
			      :loca_location loc
			      :sdef_name symb
			      :sobj_predef predef
			      :sinst_class cla
			      :sinst_clabind clabind
			      :sinst_objnum objnum
			      :sinst_fields fastup
			      :sdefsel_formals formals
			      ))
	       (selbind (instance class_selector_binding
				  :binder symb
				  :sbind_selectordef res
				  ))
	       )
	  (warn_if_redefined symb env loc)
	  (put_env env selbind)
	  res
	  )))))
(install_initial_macro 'defselector mexpand_defselector)
(export_macro 
 defselector mexpand_defselector
 :doc #{The $DEFSELECTOR syntax defines a selector for sending
messages. Syntax is (DEFSELECTOR <symbol> <selector-class> [:doc
<documentation>] [:formals ( <formals>...)]).}#)


;;;; the [make_]instance expander
(defun mexpand_instance (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (fields ())
	 (fieldnams ())
	 (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (claname (pair_head curpair))
	 (cla ())
	 (clabind ())
	 )
    (debug_msg sexpr "mexpand_instance start sexpr")
    (if (is_not_a claname class_symbol)
	(error_plain loc "missing class symbol for INSTANCE"_))
    (let ( (bnd (find_env env claname)) 
	   (fldlist (make_list discr_list))
	   )
      (cond 
       ( (is_a bnd class_class_binding)
	 (setq clabind bnd)
	 (setq cla (unsafe_get_field :cbind_class bnd)) 
	 )
       ( (and (is_a bnd class_value_binding)
	      (is_a (unsafe_get_field :vbind_value bnd) class_class))
	 (setq clabind bnd)
	 (setq cla (unsafe_get_field :vbind_value bnd))
	 )
       (:else
	(error_strv loc "invalid class name for INSTANCE"_
		    (unsafe_get_field :named_name claname))
	(return ())
	))
      (debug_msg cla "mexpand_instance cla")
      (assert_msg "check cla" (is_a cla class_class))
      (setq curpair (pair_tail curpair))
      (forever insloop
	       (if (not (is_pair curpair)) (exit insloop))
	       (let ( (curfkw (pair_head curpair)) )
		 (if (is_not_a curfkw class_keyword)
		     (error_plain loc "expecting keyword in INSTANCE"_))
		 (setq curpair (pair_tail curpair))
		 (let ( (curexp (pair_head curpair)) )
		   (let  ( (flda (parse_field_assignment cla loc curfkw curexp env mexpander)) )
		     (debug_msg flda "mexpand_instance flda")
		     (if flda 
			 (list_append fldlist flda)
		       (error_strv loc "bad field name in INSTANCE"_
				   (unsafe_get_field :named_name curfkw))
		       ))))
	       (setq curpair (pair_tail curpair))
	       )
      (let ( ( fastup (list_to_multiple fldlist discr_multiple)) )
	(instance class_source_instance
		  :loca_location loc
		  :smins_class cla
		  :smins_clabind clabind
		  :smins_fields fastup)
	))))
(install_initial_macro 'instance mexpand_instance)
(export_macro 
 instance mexpand_instance
 :doc #{The $INSTANCE syntax is for making new objects. Syntax
 is (INSTANCE <class> @{:<field> <expression>@}*).}#)



;;;; the load expander should return the tuple of expanded stuff read from the file
(defun mexpand_load (sexpr env mexpander)
  (debug_msg sexpr "mexpand_load start sexpr")
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (filnam (pair_head curpair))
	 )
    (if (pair_tail curpair)
	(error_plain loc "LOAD expects one argument"))
    (if (is_a filnam class_sexpr)
	(setq filnam (macroexpand_1 filnam env mexpander)))
    (if (is_a filnam class_named)
	(setq filnam (unsafe_get_field :named_name filnam)))
    (cond 
     ( (is_string filnam)
       (inform_strv loc "; loading file " filnam)
       (let ( (curead (read_file filnam)) )
	 (debug_msg curead "mexpand_load curead")
	 (let ( (explist (macroexpand_toplevel_list curead env mexpander)) 
		(exptuple (list_to_multiple explist discr_multiple))
		)
	   (debug_msg exptuple "mexpand_load return exptuple")
	   (return exptuple)
	   )
	 )
       )
     (:else
      (debug_msg filnam "mexpand_load strange filnam")
      (error_plain loc "LOAD expects a string filename")))
    ))
(install_initial_macro 'load mexpand_load)
(export_macro 
 load mexpand_load
 :doc #{The $LOAD macro is for reading expressions from another
 file. Syntax is (LOAD <file-name>).}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; parse a field pattern
(defun parse_field_pattern (fkeyw cla flpsexp env pctx psloc)
  (debug_msg fkeyw "parse_field_pattern keyw")
  (assert_msg "check fkeyw" (is_a fkeyw class_keyword))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctc" (is_a pctx class_pattern_expansion_context))
  (assert_msg "check cla" (is_a cla class_class))
  (let (
	(clafields (unsafe_get_field :class_fields cla))
	(fldbox (make_box discr_box ())) 
	(flpat (patternexpand_1 flpsexp env pctx psloc)) 
	)
    (debug_msg clafields "parse_field_pattern clafields")
    ;; find the field inside the class
    (multiple_iterate_test
     clafields
     (lambda (cfld :long ix)
       (assert_msg "check fld" (is_a cfld class_field))
       (if (==s (unsafe_get_field :named_name cfld) 
		(unsafe_get_field :named_name fkeyw))
	   (progn 
	     (box_put fldbox cfld)
	     ()				; nil to exit to iteration
	     )
	 cfld))
     )
    (let ( (fld (box_content fldbox))
	   )
      (if (is_not_a fld class_field)
	  (progn
	    (debug_msg fld "parse_field_pattern bad fld")
	    (error_strv psloc "invalid :field in pattern"
			(unsafe_get_field :named_name fkeyw))
	    (return)))
      (let (
	    (patf (instance class_source_field_pattern
			    :loca_location psloc
			    :spaf_field fld
			    :spaf_pattern flpat
			    ))
	    )
	(debug_msg patf "parse_field_pattern return patf")
	(return patf)
	))))

(defun patexpand_instance (sexpr env pctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context))
  (debug_msg sexpr "patexpand_instance sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(fields ())
	(fieldnams ())
	(curpair (pair_tail (list_first cont)))
	(claname (pair_head curpair))
	(cla ())
	(clabind ())
	)
    (if (is_not_a claname class_symbol)
	(error_plain loc "missing class symbol for INSTANCE pattern"_))
    (let ( (bnd (find_env env claname)) 
	   (fldlist (make_list discr_list))
	   )
      (cond 
       ( (is_a bnd class_class_binding)
	 (setq clabind bnd)
	 (setq cla (unsafe_get_field :cbind_class bnd)) 
	 )
       ( (and (is_a bnd class_value_binding)
	      (is_a (unsafe_get_field :vbind_value bnd) class_class))
	 (setq clabind bnd)
	 (setq cla (unsafe_get_field :vbind_value bnd))
	 )
       (:else
	(error_strv loc "invalid class name for INSTANCE"_
		    (unsafe_get_field :named_name claname))
	(return ())
	))
      (assert_msg "check cla" (is_a cla class_class))
      (setq curpair (pair_tail curpair))
      ;; build the list of field patterns
      (forever 
       insloop
       (if (not (is_pair curpair)) (exit insloop))
       (let ( (curfkw (pair_head curpair)) )
	 (if (is_not_a curfkw class_keyword)
	     (error_plain loc "expecting keyword in INSTANCE"_))
	 (setq curpair (pair_tail curpair))
	 (let ( (curexp (pair_head curpair)) )
	   (let  ( (fldp (parse_field_pattern curfkw cla curexp env pctx loc)) )
	     (debug_msg fldp "patexpand_instance fldp")
	     (if fldp
		 (list_append fldlist fldp)
	       (error_strv loc "bad field name in INSTANCE"_
			   (unsafe_get_field :named_name curfkw))
	       ))))
       (setq curpair (pair_tail curpair))
       )
      (let (
	    (spatfields  (list_to_multiple fldlist discr_multiple))
	    (subpats (multiple_map spatfields 
				   (lambda (curpatfld :long curix)
				     (get_field :spaf_pattern curpatfld))))
	    (spati (instance class_source_pattern_instance
			      :loca_location loc
			      :pat_weight () ;; set below
			      :spat_class cla
			      :spat_fields  spatfields))
	     )
	(multicall 
	 (subpatw :long imax imin isum)
	 (pattern_weight_tuple subpats)
	 (unsafe_put_fields 
	  spati 
	  :pat_weight 
	  (make_integerbox discr_constant_integer (+i 1 isum)))
	 )
	(debug_msg spati "patexpand_instance return spati")
	(return spati)
	))
    ))
(install_initial_patmacro 'instance patexpand_instance mexpand_instance)
(export_patmacro 
instance patexpand_instance mexpand_instance
:doc #{The $INSTANCE pattern macro matches an instance when used as a
pattern, or creates an instance when used as an expression.  Pattern
syntax is ?($INSTANCE @var{class-name} @var{:field1} @var{pattern1}
@var{:field2} @var{pattern2}...) - there can be zero, one or more
distinct fields. A value matches such a pattern if the value is an
instance of @var{class-name} or a sub-class and if each specified
field matches its [sub-]pattern. Expression syntax is ($INSTANCE
@var{class-name} @var{:field1} @var{value1} @var{:field2}
@var{value2}...). All the fields should be acceptable for the
specified @var{class-name}. In expressions, missing fields are
initialized to nil. In patterns missing fields are not matched. The
given @var{class-name} is a fixed class (not a variable) possessing
all the specified fields.}# )

(defun patexpand_object (sexpr env pctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context))
  (debug_msg sexpr "patexpand_object sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(fields ())
	(fieldnams ())
	(curpair (pair_tail (list_first cont)))
	(claname (pair_head curpair))
	(cla ())
	(clabind ())
	)
    (if (is_not_a claname class_symbol)
	(error_plain loc "missing class symbol for  OBJECT pattern"_))
    (let ( (bnd (find_env env claname)) 
	   (fldlist (make_list discr_list))
	   )
      (cond 
       ( (is_a bnd class_class_binding)
	 (setq clabind bnd)
	 (setq cla (unsafe_get_field :cbind_class bnd)) 
	 )
       ( (and (is_a bnd class_value_binding)
	      (is_a (unsafe_get_field :vbind_value bnd) class_class))
	 (setq clabind bnd)
	 (setq cla (unsafe_get_field :vbind_value bnd))
	 )
       (:else
	(error_strv loc "invalid class name for OBJECT pattern"_
		    (unsafe_get_field :named_name claname))
	(return ())
	))
      (assert_msg "check cla" (is_a cla class_class))
      (setq curpair (pair_tail curpair))
      ;; build the list of field patterns
      (forever 
       insloop
       (if (not (is_pair curpair)) (exit insloop))
       (let ( (curfkw (pair_head curpair)) )
	 (if (is_not_a curfkw class_keyword)
	     (error_plain loc "expecting keyword in OBJECT pattern"_))
	 (setq curpair (pair_tail curpair))
	 (let ( (curexp (pair_head curpair)) )
	   (let  ( (fldp (parse_field_pattern curfkw cla curexp env pctx loc)) )
	     (debug_msg fldp "patexpand_object fldp")
	     (if fldp
		 (list_append fldlist fldp)
	       (error_strv loc "bad field name in OBJECT pattern"_
			   (unsafe_get_field :named_name curfkw))
	       ))))
       (setq curpair (pair_tail curpair))
       )
      (let ( 
	    (patfields  (list_to_multiple fldlist discr_multiple))
	    (subpats (multiple_map patfields
				   (lambda (curpatfld :long ix)
				     (get_field  :spaf_pattern curpatfld))))
	    (spati (instance class_source_pattern_object
			      :loca_location loc
			      :spat_class cla
			      :spat_fields patfields))
	     )
	(multicall 
	 (subpatw :long imax imin isum)
	 (pattern_weight_tuple subpats)
	 (unsafe_put_fields 
	  spati 
	  :pat_weight 
	  (make_integerbox discr_constant_integer (+i 1 isum)))
	(debug_msg spati "patexpand_object return spati")
	(return spati)
	)))
    ))

(defun mexpand_object (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_object sexpr")
  (let (
	(loc  (unsafe_get_field :loca_location sexpr))
	)
    (error_plain loc "OBJECT cannot be macro-expanded in expression context - use INSTANCE instead")
    (return)
))

(install_initial_patmacro 'object patexpand_object mexpand_object)
(export_patmacro object patexpand_object mexpand_object
		 :doc #{The $OBJECT pattern macro matches an instance
when used as a pattern.  Pattern syntax is ?($OBJECT @var{class-name}
@var{:field1} @var{pattern1} @var{:field2} @var{pattern2}...) - there
can be zero, one or more distinct fields. A value matches such a
pattern if the value is an instance of @emph{exactly}
@var{class-name} (not a sub-class) and if each specified field matches
its [sub-]pattern.  The $OBJECT pattern macro should not be used in
expression context.  See also $INSTANCE and $DEFCLASS.}# )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; the codechunk expander
(defun mexpand_code_chunk (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (sloc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (curchk ())
	 (gsym ())
	 (chklist (make_list discr_list))
	 (curel ())
	 )
    (setq curel (pair_head curpair))
    (if (is_a curel class_symbol)
	(setq gsym curel)
      (error_plain sloc "missing symbol in (CODE_CHUNK <state-symbol> <chunk>)"))
    (setq curpair (pair_tail curpair))
    (setq curchk (pair_head curpair))
    (if  (pair_tail curpair)
	(error_plain sloc "CODE_CHUNK expects one single chunk sexpr"))
    (if (is_not_a curchk class_sexpr)
	(error_plain sloc "CODE_CHUNK expects a chunk sexpr"))
    (let ( (loc (get_field :loca_location curchk)) 
	   (chkcont (get_field :sexp_contents curchk))
	   )
      (foreach_in_list
       (chkcont)
       (curpair curcomp)
       (cond ( (is_string curcomp)
	       (list_append chklist (make_string discr_verbatim_string curcomp))
	       )
	     ( (is_a curcomp class_symbol)
	       (list_append chklist curcomp))
	     (:else
	      (error_plain loc "bad content in CODE_CHUNK - expecting string or symbol")))
       )
      (let ( (mres (instance class_source_codechunk
			     :loca_location (or loc sloc)
			     :sch_gensym gsym
			     :sch_chunks (list_to_multiple chklist discr_multiple)
			     )) )
	(debug_msg mres "mexpand_code_chunk result")
	(return mres)
	))))

(install_initial_macro 'code_chunk mexpand_code_chunk)
(export_macro code_chunk mexpand_code_chunk
	      :doc #{The $CODE_CHUNK macro is for low-level C code chunks. The syntax is ($CODE_CHUNK @var{state-symbol} @var{chunk}) where @var{chunk} is a macro-string. It generates a C block. Since it does not make any type verification, it should be usually avoided. See $DEFPRIMITIVE etc.
}#)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; the unsafe_put_fields expander
(defun mexpand_unsafe_put_fields (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (fields ())
	 (fieldnams ())
	 (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (objsrc (pair_head curpair))
	 (objexp 
	  (if (is_a objsrc class_sexpr)
	      (macroexpand_1 objsrc env mexpander)
	    objsrc))
	 )
    (setq curpair (pair_tail curpair))
    (let ( (fldlist (make_list discr_list))
	   )
      (forever insloop
	       (if (not (is_pair curpair)) (exit insloop))
	       (let ( (curfkw (pair_head curpair)) )
		 (if (is_not_a curfkw class_keyword)
		     (error_plain loc "expecting heyword in UNSAFE_PUT_FIELDS"_))
		 (setq curpair (pair_tail curpair))
		 (let ( (curexp (pair_head curpair)) )
		   (let  ( (flda (parse_field_assignment () loc curfkw curexp env mexpander)) )
		     (if flda 
			 (list_append fldlist flda)
		       ))))
	       (setq curpair (pair_tail curpair))
	       )
      (let ( ( fastup (list_to_multiple fldlist discr_multiple)) )
	(instance class_source_unsafe_put_fields
		  :loca_location loc
		  :suput_obj objexp
		  :suput_fields fastup)
	))))
(install_initial_macro 'unsafe_put_fields mexpand_unsafe_put_fields)
(export_macro
 unsafe_put_fields mexpand_unsafe_put_fields
:doc #{The $UNSAFE_PUT_FIELDS is for expert use only, since it can
crash the running GCC MELT compilation. Syntax is (UNSAFE_PUT_FIELDS
<instance> @{:<field> <expression>@}). It sets fields in an instance
without any checks. Using $PUT_FIELDS is prefered.}#)

;;;; the put_fields expander
(defun mexpand_put_fields (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (fields ())
	 (fieldnams ())
	 (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (objsrc (pair_head curpair))
	 (objexp 
	  (if (is_a objsrc class_sexpr)
	      (macroexpand_1 objsrc env mexpander)
	    objsrc))
	 )
    (setq curpair (pair_tail curpair))
    (let ( (fldlist (make_list discr_list))
	   )
      (forever insloop
	       (if (not (is_pair curpair)) (exit insloop))
	       (let ( (curfkw (pair_head curpair)) )
		 (if (is_not_a curfkw class_keyword)
		     (error_plain loc "expecting heyword in PUT_FIELDS"_))
		 (setq curpair (pair_tail curpair))
		 (let ( (curexp (pair_head curpair)) )
		   (let  ( (flda (parse_field_assignment () loc curfkw curexp env mexpander)) )
		     (if flda 
			 (list_append fldlist flda)
		       ))))
	       (setq curpair (pair_tail curpair))
	       )
      (let ( ( fastup (list_to_multiple fldlist discr_multiple)) )
	(instance class_source_put_fields
		  :loca_location loc
		  :suput_obj objexp
		  :suput_fields fastup)
	))))
(install_initial_macro 'put_fields mexpand_put_fields)
(export_macro 
 put_fields mexpand_put_fields
 :doc #{The $PUT_FIELDS syntax is for safely setting fields in an
 object. Syntax is (PUT_FIELDS <instance-expression> @{:<field>
 <field-expression>@}*). If the instance is not an object of the class
 containing all the fields, no harm is done. See also
 $UNSAFE_PUT_FIELDS which does not produces checks.}# )

;;;; the UNSAFE_GET_FIELD macro expander
(defun mexpand_unsafe_get_field (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (curfkw (pair_head curpair)) 
	 )
    (if (is_not_a curfkw class_keyword)
	(progn
	  (error_plain loc "field keyword expected in UNSAFE_GET_FIELD"_)
	  (return ())))
    (setq curpair (pair_tail curpair))
    (let ( (curexp (pair_head curpair)) )
      (setq curpair (pair_tail curpair))
      (if curpair (error_plain loc "UNSAFE_GET_FIELD with more than two sons"_))
      ;; it is not a field assignment but we use the parse_field_assignment
      ;; routine to get the field and the expression
      (let  ( (flda (parse_field_assignment () loc curfkw curexp env mexpander)) )
	(if (not (is_a flda class_source_fieldassign))
	    (progn 
	      (error_plain loc "bad field and expression in UNSAFE_GET_FIELD"_)
	      (return ())))
	(let ( (fld (unsafe_get_field :sfla_field flda))
	       (exp (unsafe_get_field :sfla_expr flda)) )
	  (if (null exp)
	      (error_plain loc "missing object expression for (UNSAFE_GET_FIELD :field objexpr)"))
	  (instance class_source_unsafe_get_field
		    :loca_location loc
		    :suget_obj exp
		    :suget_field fld
		    ))))))
(install_initial_macro 'unsafe_get_field mexpand_unsafe_get_field)
(export_macro
 unsafe_get_field mexpand_unsafe_get_field
 :doc #{The $UNSAFE_GET_FIELD syntax retrieves dangerously a field
 from an instance and may crash when the instance is not an object of
 the appropriate class. Syntax is (UNSAFE_GET_FIELD :<field>
 <expression>). Using $GET_FIELD is preferrable.}#)

;;;; the GET_FIELD expander
(defun mexpand_get_field (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (curfkw (pair_head curpair)) 
	 )
    (if (is_not_a curfkw class_keyword)
	(progn
	  (error_plain loc "field keyword expected in GET_FIELD"_)
	  (return ())))
    (setq curpair (pair_tail curpair))
    (let ( (curexp (pair_head curpair)) )
      (setq curpair (pair_tail curpair))
      (if curpair (error_plain loc "UNSAFE_GET_FIELD with more than two sons"_))
      ;; it is not a field assignment but we use the parse_field_assignment
      ;; routine to get the field and the expression
      (let  ( (flda (parse_field_assignment () loc curfkw curexp env mexpander)) )
	(if (not (is_a flda class_source_fieldassign))
	    (progn 
	      (error_plain loc "bad field and expression in GET_FIELD"_)
	      (return ())))
	(let ( (fld (unsafe_get_field :sfla_field flda))
	       (exp (unsafe_get_field :sfla_expr flda)) )
	  (if (null exp)
	      (error_plain loc "missing object expression for (GET_FIELD :field objexpr)"))
	  (instance class_source_get_field
		    :loca_location loc
		    :suget_obj exp
		    :suget_field fld
		    ))))))
(install_initial_macro 'get_field mexpand_get_field)
(export_macro 
 get_field mexpand_get_field
 :doc #{The $GET_FIELD syntax safely access a field. Syntax
 is (GET_FIELD :<field> <expression>) which evaluates to nil if the
 expression is not of the class defining the field. See also
 $UNSAFE_GET_FIELD.}#)


;;;; the setq expander
(defun mexpand_setq (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (cursym (pair_head curpair)) 
	 )
    (if (is_not_a cursym class_symbol)
	(progn
	  (error_plain loc "var symbol name expected in SETQ"_)
	  (return ())))
    (setq curpair (pair_tail curpair))
    (let ( (curexp (pair_head curpair)) )
      (setq curpair (pair_tail curpair))
      (if curpair (error_plain loc "SETQ with more than two sons"_))
      (instance class_source_setq 
		:loca_location loc
		:sstq_var cursym
		:sstq_expr  (macroexpand_1 curexp env mexpander)
		)
      )))
(install_initial_macro 'setq mexpand_setq)
(export_macro 
 setq mexpand_setq
 :doc #{The $SETQ syntax is for assignment of local variables, usually
 bound by a LET in the same function. Syntax is (SETQ <symbol>
 <expr>).}#)

;;;;; the if expanser
(defun mexpand_if (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_if sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(curif (pair_head curpair)) )
    (if (not (is_pair curpair))
	(error_plain loc "missing condition in IF"_))
    (setq curpair (pair_tail curpair))
    (if (not (is_pair curpair))
	(error_plain loc "missing then in IF"_))
    (let ( (xcond (macroexpand_1 curif env mexpander)) )
      (debug_msg xcond "mexpand_if xcond")
      (let ( (curthen (pair_head curpair)) )
	(setq curpair (pair_tail curpair))
	(let ( (xthen (macroexpand_1 curthen env mexpander)) )
	  (debug_msg xthen "mexpand_if xthen")
	  (if (is_pair curpair)
	      (let ( (curelse (pair_head curpair)) 
		     (xelse (macroexpand_1 curelse env mexpander)) )
		(debug_msg xelse "mexpand_if xelse")
		(setq curpair (pair_tail curpair))
		(if (is_pair curpair)
		    (error_plain loc "IF with more than three sons"_))
		(let ( (rese
			(instance class_source_ifelse
				  :loca_location loc
				  :sif_test xcond
				  :sif_then xthen
				  :sif_else xelse
				  )) )
		  (debug_msg rese "mexpand_if with else return rese")
		  (return rese)))
	    (let ( (resp (instance class_source_if
				   :loca_location loc
				   :sif_test xcond
				   :sif_then xthen)) )
	      (debug_msg resp "mexpand_if plain return resp")
	      (return resp))
	    ))))))
(install_initial_macro 'if mexpand_if)
(export_macro 
 if mexpand_if
 :doc #{The $IF syntax is for simple conditional expressions. Syntax
 is (IF <test-expression> <then-expression> [<else-expression>]).}#)

;;;;; the cppif expander
(defun mexpand_cppif (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_cppif sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(curif (pair_head curpair)) 
	)
    (if (not (is_pair curpair))
	(error_plain loc "missing condition in CPPIF"_))
    (setq curpair (pair_tail curpair))
    (if (not (is_pair curpair))
	(error_plain loc "missing then in CPPIF"_))
    (let ( (xcond (macroexpand_1 curif env mexpander)) )
      (debug_msg xcond "mexpand_cppif xcond")
      (cond 
       ( (is_string xcond) ())
       ( (is_a xcond class_symbol) ())
       (:else
	(error_plain loc "invalid cpp-condition in CPPIF - string or symbol expected"_)
	(return ())))
      (let ( (curthen (pair_head curpair)) )
	(setq curpair (pair_tail curpair))
	(let ( (xthen (macroexpand_1 curthen env mexpander)) 
	       (xelse ())
	       )
	  (debug_msg xthen "mexpand_cppif xthen")
	  (if (is_pair curpair)
	      (let ( (curelse (pair_head curpair)) 
		     (gotxelse (macroexpand_1 curelse env mexpander)) )
		(debug_msg gotxelse "mexpand_cppif gotxelse")
		(setq curpair (pair_tail curpair))
		(setq xelse gotxelse)
		(if (is_pair curpair)
		    (error_plain loc "CPPIF with more than three sons"_))))
	  (let ( (resp (instance class_source_cppif
				 :loca_location loc
				 :sifp_cond xcond
				 :sifp_then xthen
				 :sifp_else xelse
				 ))
		 )
	    (debug_msg resp "mexpand_cppif return resp")
	    (return resp)
	    ))))))
(install_initial_macro 'cppif mexpand_cppif)
(export_macro 
 cppif mexpand_cppif
 :doc #{The $CPPIF macro expands to C-code with an #if condition, so
the condition is handled when compiling the generated C code into a
MELT module.  Syntax is (CPPIF <symbol> <then> [<else>]).}#)

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

(defun filtergccversion (versionstr)
  (assert_msg "check versionstr" (is_string versionstr))
  (let ( (:long versionlen (string_length versionstr))
	 (res ())
	 )
    (code_chunk 
     filtergcc
     #{ if ($VERSIONLEN>0 /*$FILTERGCC*/
	    && !strncmp (melt_string_str((melt_ptr_t)$VERSIONSTR),
			 melt_gccversionstr,
			 $VERSIONLEN))
        $RES = $VERSIONSTR; 
	}#)
    (return res)))

(defun mexpand_gccif (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_gccif sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(sloc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(curif (pair_head curpair)) 
	(restpair (pair_tail curpair))
	)
    (debug_msg curif "mexpand_gccif curif")
    (cond 
     ((is_string curif)
      (if (filtergccversion curif)
	  (let ( (exprest (expand_pairlist_as_tuple restpair env mexpander))
		 )
	    (debug_msg exprest "mexpand_gccif return exprest")
	    (return exprest))
	(progn
	  (debug_msg sexpr "mexpand_gccif sexpr gcc version mismatched")
	  (return))))
     ((is_list curif)
      (let ( (ok ())
	     )
	(foreach_in_list 
	 (curif)
	 (curpair curstr)
	 (if (not (is_string curstr))
	     (error_plain sloc "GCC-IF condition not a list of strings"))
	 (if (filtergccversion curif)
	     (setq ok :true))
	 )
	(if ok
	  (let ( (exprest (expand_pairlist_as_tuple restpair env mexpander))
		 )
	    (debug_msg exprest "mexpand_gccif return exprest multicond")
	    (return exprest))
	(progn
	  (debug_msg sexpr "mexpand_gccif sexpr gcc version multicond mismatched")
	  (return))))

	)
     (:else 
      (error_plain sloc "GCC-IF bad condition, should be a string or a list of strings")
      (return)
     ))))

(install_initial_macro 'gccif mexpand_gccif)
(export_macro 
 gccif mexpand_gccif
 :doc #{The $GCCIF macro expands the rest of the expression if the
version string of the GCC translating this MELT expression matches
the condition. Syntax is ($GCCIF condition expr...), where the
condition is a string such as "4.5." or a list of strings.}#)


;;;;; the cond expanser
(defun mexpand_cond (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_cond sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(cexptuple (pairlist_to_multiple 
		    (pair_tail (list_first cont))
		    discr_multiple
		    (lambda (c)
		      (if (is_not_a c class_sexpr)
			  (error_plain loc "COND with non-sexpr"_))
		      c
		      ))) 
	(:long nbcond (multiple_length cexptuple))
	(lastcexp (let ( (lx (multiple_nth cexptuple -1)) )
		    (debug_msg lx "mexpand_cond lastcexp lx")
		    lx))
	(:long ix (-i nbcond 1))
	(res ())
	)
    (debug_msg cexptuple "mexpand_cond cexptuple")
    (forever condloop
	     (if (<i ix 0) (exit condloop))
	     (let ( (curcond (multiple_nth cexptuple ix)) )
	       (debug_msg curcond "mexpand_cond curcond")
	       (cond  
		( (and (null res)
		       (is_a curcond class_sexpr)
		       (== ':else (pair_head (list_first 
					      (unsafe_get_field :sexp_contents curcond)))))
		  (let ( (restpairs 
			  (pair_tail (list_first (unsafe_get_field :sexp_contents curcond)))) 
			 )
		    (if restpairs 
			(setq res (pairlist_to_progn restpairs 
						     (unsafe_get_field :loca_location curcond) 
						     env mexpander)))
		    (debug_msg res "mexpand_cond res for :else")
		    ))
		( (is_a curcond class_sexpr)
		  (let ( (curcondcont (unsafe_get_field :sexp_contents curcond))
			 (curcondloc (unsafe_get_field :loca_location curcond)) 
			 (curcondtest (pair_head (list_first curcondcont)))
			 (curcondrestpairs (pair_tail (list_first curcondcont))) 
			 )
		    (cond ( (null curcondrestpairs)
			    (setq res (instance class_source_or
						:loca_location curcondloc
						:sor_disj (tuple
							   (macroexpand_1 curcondtest env mexpander)
							   res)))
			    (debug_msg res "mexpand_cond res for monoexp cond")
			    )
			  ( (null (pair_tail curcondrestpairs))
			    (setq res (instance class_source_ifelse
						:loca_location curcondloc
						:sif_test (macroexpand_1 curcondtest env mexpander)
						:sif_then (macroexpand_1 (pair_head curcondrestpairs) env mexpander)
						:sif_else res
						))
			    (debug_msg res "mexpand_cond res for biexp cond")
			    )
			  (:else 
			   (setq res (instance class_source_ifelse
					       :loca_location curcondloc
					       :sif_test (macroexpand_1 curcondtest env mexpander)
					       :sif_then (pairlist_to_progn curcondrestpairs curcondloc env mexpander)
					       :sif_else res))
			   (debug_msg res "mexpand_cond res for manyexp cond")
			   ))
		    ))
		(:else ;curcond is not a sexpr 
		 (setq res (instance class_source_or
				     :loca_location loc
				     :sor_disj (tuple curcond res)))
		 (debug_msg res "mexpand_cond res for nonsexp cond")
		 )
		)
	       )
	     (setq ix (-i ix 1))
	     )
    (debug_msg res "mexpand_cond final res")
    (return res)
    ))
(install_initial_macro 'cond mexpand_cond)
(export_macro 
 cond mexpand_cond
 :doc #{The usual lisp $COND conditional. Syntax is (COND
 <conditions>...). Each condition is a list of the form (<test>
 <expr>...). The last catch-all condition can be (:else <epxr>...).}#) 


;;;;;;;;;;;;;;;;
;;;; the AND macro expanser
;;; AND pseudo syntax
;;; (AND a1) is expanded into a1
;;; (AND a1 a2) is expansed into (IF a1 a2)
;;; (AND a1 a2 a3) is expansed into (IF a1 (IF a2 a3))
(defun mexpand_and (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_and sexpr:" )
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(cxtup (pairlist_to_multiple 
		curpair
		discr_multiple
		(lambda (c) (macroexpand_1 c env mexpander)
		  )))
	(:long nbcomp (multiple_length cxtup))
	)
    (debug_msg cxtup "mexpand_and cxtup")
    (if (<i nbcomp 1)
	(progn
	  (error_plain loc "AND without sons"_)
	  (return))
      (let ( (res (multiple_nth cxtup (-i nbcomp 1)))
	     (:long ix (-i nbcomp 2)) )
	(forever revloop
		 (if (<i ix 0) (exit revloop))
		 (let ( (curc (multiple_nth cxtup ix)) )
		   (setq res 
			 (instance class_source_if
				   :loca_location loc
				   :sif_test curc
				   :sif_then res))
		   )
		 (setq ix (-i ix 1))
		 )
	(debug_msg res "mexpand_and res:")
	(return res)))))


;;;; the AS pattern expander
(defun patexpand_as (sexpr env pctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context))
  (debug_msg sexpr "patexpand_as sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(argsp (patternexpand_pairlist_as_tuple curpair env pctx loc))
	)
    (if (!=i (multiple_length argsp) 2)
	(progn
	  (error_plain loc "AS pattern expects two arguments: ?patvar subpattern")
	  (return)))
    (let ( (argvar (multiple_nth argsp 0))
	   (argsub (multiple_nth argsp 1))
	   )
      (if (is_a argvar class_source_pattern_joker_variable)
	  (progn
	    (warning_plain loc "AS pattern with useless joker")
	    (return argsub)))
      (if (is_not_a argvar class_source_pattern_variable)
	  (progn
	    (error_plain loc "AS pattern needs a pattern variable as first argument")
	    (return)))
      (warning_plain loc "deprecated AS pattern - use AND pattern instead")
      (let (
	    (:long subw (get_int (get_field :pat_weight argsub)))
	    (res (instance class_source_pattern_and
			   :loca_location loc
			   :pat_weight (make_integerbox discr_constant_integer (+i 2 subw))
			   :andpat_conj (tuple argvar argsub)))
	    )
	(debug_msg res "patexpand_as returns res")
	(return res)
	))))

(defun mexpand_as (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_as sexpr")
  (let (
	(loc  (unsafe_get_field :loca_location sexpr))
	)
    (error_plain loc "AS cannot be macro-expanded in expression context")
    (return)
))
(install_initial_patmacro 'as patexpand_as mexpand_as)
(export_patmacro as patexpand_as mexpand_as)

;;;; the WHEN pattern expanser
(defun patexpand_when (sexpr env pctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context))
  (debug_msg sexpr "patexpand_when sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	)
    (compile_warning "patexpand_when not implemented yet")
    (error_plain loc "WHEN is not yet implemented in patterns")
    (assert_msg "@$@ unimplemented patexpand_when" ())
    (return)
    ))

(defun mexpand_when (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_when sexpr")
  (let (
	(loc  (unsafe_get_field :loca_location sexpr))
	)
    (error_plain loc "WHEN cannot be macro-expanded in expression context")
    (return)
))
(install_initial_patmacro 'when patexpand_when mexpand_when)
(export_patmacro when patexpand_when mexpand_when)


;;;; the AND pattern expanser
(defun patexpand_and (sexpr env pctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context))
  (debug_msg sexpr "patexpand_and sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(argsp (patternexpand_pairlist_as_tuple curpair env pctx loc))
	(res (instance class_source_pattern_and
		       :loca_location loc
		       :andpat_conj argsp))
	)
    (multicall
     (subpatw :long imax imin isum)
     (pattern_weight_tuple argsp)
     (unsafe_put_fields res
			:pat_weight (make_integerbox discr_constant_integer
						     (+i (+i 1 imax) isum))))
    (debug_msg res "patexpand_and res")
    (return res)
    ))

(install_initial_patmacro 
 'and patexpand_and mexpand_and)
(export_patmacro 
 and patexpand_and mexpand_and
 :doc #{The lispy $AND conjonction syntax is a short-circuit "and
 then" conjonction. Expression syntax is (AND
 <conjunct-subexpression>...) and can evaluate to a :value or a thing
 such as a :long or a :gimple which is null/zero iff any conjunct is
 null or zero. Pattern syntax is ?(AND <conjunct-subpattern>...) and
 matches if all conjunct-subpattern-s match. See also $COND $OR and
 $IF.}#)

;;;;;;;;;;;;;;;;
;;;; the OR macro expanser
(defun mexpand_or (sexpr env mexpander)
  (debug_msg sexpr "mexpand_or sexpr")
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(cxtup (pairlist_to_multiple 
		(pair_tail (list_first cont))
		discr_multiple
		(lambda (c) (macroexpand_1 c env mexpander)
		  )))
	(:long nbcomp (multiple_length cxtup))
	)
    (if (<i nbcomp 1)
	(progn 
	  (error_plain loc "OR without sons"_)
	  (return ()))
      (let ( (res 
	      (instance class_source_or
			:loca_location loc
			:sor_disj cxtup)) )
	 (debug_msg res "mexpand_or res")
	 (return res)
	 ))))

;;;; the OR pattern expander
(defun patexpand_or (sexpr env pctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context))
  (debug_msg sexpr "patexpand_or sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(argsp (patternexpand_pairlist_as_tuple curpair env pctx loc))
	(res (instance class_source_pattern_or
		       :loca_location loc
		       :orpat_disj argsp))
	)
    (multicall
     (subpatw :long imax imin isum)
     (pattern_weight_tuple argsp)
     (unsafe_put_fields
      res 
      :pat_weight (make_integerbox discr_constant_integer (+i 1 imin)))
     (debug_msg res "patexpand_or res")
     (return res)
     )))
(install_initial_patmacro 'or patexpand_or mexpand_or)
(export_patmacro 
 or patexpand_or mexpand_or
 :doc #{The lispy $OR disjunctive syntax is a short-circuit "or else"
 disjonction. Expression syntax is (OR <disjunct-subexpression>...)
 and can evaluate to a :value or a thing such as a :gimple or a :long
 etc. which is null/zero iff every disjunct is
 null/zero. Pattern-syntax is ?(OR <disjunct-subpattern>...) and
 matches if one of the disjunct-subpattern matches. See also $COND
 $AND and $IF.}# )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TUPLE 
;;;; the TUPLE macro expander
(defun mexpand_tuple  (sexpr env mexpander)
  (debug_msg sexpr "mexpand_tuple sexpr")
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(xargtup (expand_restlist_as_tuple cont env mexpander))
	(res (instance class_source_tuple
	      :loca_location loc
	      :sargop_args xargtup))
	)
    (debug_msg res "mexpand_tuple result")
    (return res)
    ))

;;;; the TUPLE pattern expander
(defun patexpand_tuple (sexpr env pctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context))
  (debug_msg sexpr "patexpand_tuple sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(argsp (patternexpand_pairlist_as_tuple curpair env pctx loc))
	(res (instance class_source_pattern_tuple
		       :loca_location loc
		       :ctpat_subpa argsp))
	)
    (debug_msg res "patexpand_tuple res")
    (return res)
))
(install_initial_patmacro 'tuple patexpand_tuple mexpand_tuple)
(export_patmacro 
 tuple patexpand_tuple mexpand_tuple
 :doc #{The $TUPLE syntax is for making or matching tuples. Expression
 syntax is (TUPLE <component-subexpression>...) to make a tuple of
 $DISCR_MULTIPLE with the given components. Pattern syntax is ?(TUPLE
 <component-subpattern>...) to match a tuple of given length with each
 component matching its corresponding <component-subpattern>. $TUPLE
 expressions are constructive, so can appear in $LETREC
 bindings.}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; LIST 
;;;; the LIST macro expander
(defun mexpand_list  (sexpr env mexpander)
  (debug_msg sexpr "mexpand_list sexpr")
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(xargtup (expand_restlist_as_tuple cont env mexpander))
	(res  (instance class_source_list
	      :loca_location loc
	      :sargop_args xargtup))
	)
    (debug_msg res "mexpand_list result")
    (return res)
    ))

;;;; the LIST pattern expander
(defun patexpand_list (sexpr env pctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context))
  (debug_msg sexpr "patexpand_or sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(argsp (patternexpand_pairlist_as_tuple curpair env pctx loc))
	(res (instance class_source_pattern_list
		       :loca_location loc
		       :ctpat_subpa argsp))
	)
    (debug_msg res "patexpand_list res")
    (return res)
))
(install_initial_patmacro 'list patexpand_list mexpand_list)
(export_patmacro 
 list patexpand_list mexpand_list
 :doc #{The $LIST syntax is for making or matching lists made of
 pairs. Expression syntax is (LIST <component-subexpression>...) to
 make a list of $DISCR_LIST with the given components going into the
 head of pairs of $DISCR_PAIR. Pattern syntax is ?(LIST
 <component-subpattern>...) to match a list of given length with each
 component matching its corresponding <component-subpattern>. $LIST
 expressions are constructive, so can appear in $LETREC bindings.}#)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; the match expander
(defun mexpand_match (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_match sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(msexp (pair_head (pair_tail (list_first cont))))
	(matsx (macroexpand_1 msexp env mexpander))
	(mexptuple (pairlist_to_multiple 
		    (pair_tail (pair_tail (list_first cont)))
		    discr_multiple
		    (lambda (c)
		      (if (is_not_a c class_sexpr)
			  (error_plain loc "MATCH with non-sexpr"_))
		      c
		      ))) 
	(:long nbmatch (multiple_length mexptuple))
	(lastmexp (let ( (lx (multiple_nth mexptuple -1)) )
		    (debug_msg lx "mexpand_match lastmexp lx")
		    lx))
	(:long ix (-i nbmatch 1))
	(caselist (make_list discr_list))
	)
    (debug_msg mexptuple "mexpand_match mexptuple")
    (forever matchloop
	     (if (<i ix 0) (exit matchloop))
	     (let ( (curmatch (multiple_nth mexptuple ix)) )
	       (debug_msg curmatch "mexpand_match curmatch")
	       (cond 
		;; handle ordinary (pattern ...) clauses
		( (is_a curmatch class_sexpr)
		  (let ( (curmatchcont (unsafe_get_field :sexp_contents curmatch))
			 (curmatchloc (unsafe_get_field :loca_location curmatch)) 
			 (curmatchpatx (pair_head (list_first curmatchcont)))
			 (curmatchrestpairs (pair_tail (list_first curmatchcont))) 
			 (curpatctx (instance class_pattern_expansion_context
					      :pctx_mexpander mexpander
					      :pctx_pexpander patternexpand_1
					      :pctx_varmap (make_mapobject discr_map_objects 13)))
			 (curpat (let ( (cp (patternexpand_1 curmatchpatx env curpatctx curmatchloc)) )
					(debug_msg cp "mexpand_match curpat")
					(assert_msg "check curpat" cp)
					cp))
			 (curbody (expand_pairlist_as_tuple curmatchrestpairs env mexpander))
			 (curcase (instance class_source_match_case
					    :loca_location curmatchloc
					    :scam_patt curpat
					    :scam_body curbody))
			 )
		    (debug_msg curcase "mexpand_match curcase")
		    (list_prepend caselist curcase)
		    ))
		;; detect non-sexp clauses
		(:else
		 (error_plain loc "(MATCH <expr> <match-case>...) with non sexpr matchcase") 
		 )))
	     (setq ix (-i ix 1)))
    (debug_msg caselist "mexpand_match caselist")
    (let ( (smat (instance class_source_match
			   :loca_location loc
			   :smat_matchedx matsx
			   :smat_cases (list_to_multiple caselist discr_multiple)) 
		 ))
      (debug_msg smat "mexpand_match result smat")
      (return smat)
      )))

(install_initial_macro 'match mexpand_match)
(export_macro 
 match mexpand_match
 :doc #{The $MATCH syntax is for pattern-matching expressions. Syntax
 is (MATCH <matched-expression> <match-case>...). Each match-case
 starts with a pattern followed by expressions. The catch-all pattern
 ?_ should appear in the last match-case if any. Pattern variables
 like ?x are bound by the matching in their match-case.}#)

;;;;;;;; for LET
;; internal routine to make a letbinding
(defun mexpand_letbinding (sexpr env mexpander)
  (debug_msg sexpr "mexpand_letbinding sexpr")
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(ctyp ctype_value)
	(var ())
	(expr ())
	(curpair (list_first cont))
	(curarg ())
	)
    (setq curarg (pair_head curpair))
    (if (is_a curarg class_keyword)
	(let ( (cty (unsafe_get_field :symb_data curarg)) 
	       (tynam (unsafe_get_field :named_name curarg))
	       )
	  (cond
	   ( (is_not_a cty class_ctype)
	     (error_strv loc "letbinding with invalid type keyword"_ tynam))
	   ( (== (unsafe_get_field :ctype_keyword cty) curarg)
	     (setq ctyp cty))
	   ( (== (unsafe_get_field :ctype_altkeyword cty) curarg)
	     (setq ctyp cty)
	     (warning_strv loc "obsolete alternate ctype keyword in let binding"
			   tynam)
	     (inform_strv loc "prefered ctype keyword" (get_field :named_name (get_field :ctype_keyword ctyp)))
	     )
	   (:else
	    (error_strv loc "letbinding with invalid type keyword"_
			tynam)))
	  (setq curpair (pair_tail curpair))
	  (setq curarg (pair_head curpair))
	  ))
    (cond ( (is_a curarg class_keyword)
	    (error_strv loc "letbinding cannot bind keyword"_  
			(unsafe_get_field :named_name curarg)))
	  ( (is_a curarg class_symbol)
	    (setq var curarg)
	    (setq curpair (pair_tail curpair))
	    (setq curarg (pair_head curpair))
	    ))
    (if (null var) 
	(error_plain loc "missing variable in letbinding"_))
    (if curarg
	(progn 
	  (setq expr (macroexpand_1 curarg env mexpander))
	  (setq curpair (pair_tail curpair))
	  (setq curarg (pair_head curpair))
	  (if curarg (error_plain loc "too long letbinding"_))
	  ))
    (let ( (prevbind (find_env env var)) )
      (cond
       ( (null prevbind) ())
       ( (is_a prevbind class_let_binding)
	 (let ( (prevloc (get_field :letbind_loc prevbind)) )
	   (warning_strv loc
			 "local let binding hides upper one"
			 (get_field :named_name var))
	   (if prevloc
	       (warning_strv prevloc
			     "here is the hidden binding" 
			     (get_field :named_name var)))
				  
	   ))
       ( (is_a prevbind class_fixed_binding)
	 (warning_strv loc
		       "local let binding hides definition"
		       (get_field :named_name var))
	 )
       ))
    (let ( (letb
	    (instance class_source_let_binding
		      :loca_location loc
		      :sletb_type ctyp
		      :sletb_binder var
		      :sletb_expr expr)) )
      (return letb)
      )))

;;; the LET expander itself
(defun mexpand_let (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(secpair (pair_tail (list_first cont)))
	(restpair (pair_tail secpair))
	(bindexpr (pair_head secpair))
	(newenv (fresh_env env))
	(bindtup ())
	(bodytup ())
	)
    (if bindexpr 
	(if (is_a bindexpr class_sexpr) 
	    (setq bindtup 
		  (pairlist_to_multiple 
		   (list_first (unsafe_get_field :sexp_contents bindexpr))
		   discr_multiple
		   (lambda (b) 
		     (if (is_not_a b class_sexpr)
			 (error_plain loc "sexpr expected in LET binding"))
		     (mexpand_letbinding b env mexpander))))
	  (error_plain loc "missing letbinding-s in LET"_))
      )
    (multiple_every
     bindtup
     (lambda (slb)
       (assert_msg "mexp.let. check slb" (is_a slb class_source_let_binding))
       (let (
	     (sx (unsafe_get_field :sletb_expr slb))
	     (lb (instance class_let_binding
			   :binder (unsafe_get_field :sletb_binder slb)
			   :letbind_type (unsafe_get_field :sletb_type slb)
			   :letbind_expr sx)) )
	 (assert_msg "mexp.let not list lb" (not (is_list lb)))
	 (put_env newenv lb)
	 )))
    (setq bodytup (pairlist_to_multiple restpair discr_multiple 
					(lambda (e) (macroexpand_1 e newenv mexpander))))
    (let ( (letr
	    (instance class_source_let
		      :loca_location loc
		      :slet_bindings bindtup
		      :slet_body bodytup)) )
      (return letr)
      )))
(install_initial_macro 'let mexpand_let)
(export_macro
 let mexpand_let
 :doc #{The $LET syntax is for sequential local bindings of
 expressions. Syntax is (LET ( <binding>... ) <body>...). Each binding
 is an optional ctype such as :long or :gimple or :value (which is the
 default), followed by a local variable name, followed by a single
 expression. The body is a non-empty sequence of expressions,
 evaluated in an environment enriched with the local bindings. The
 MELT LET syntax is sequential, like LET* in Scheme so a variable
 bound in a previous binding can appear in the expression of a later
 binding.}#)


;;;;;;;;;;;;;;;; install methods to detect recursively constructible
;;;;;;;;;;;;;;;; expressions which can appear in letrec bindings.
(defun yes_recursively_constructible (recv)
  (debug_msg recv "yes_recursively_constructible recv")
  (return recv))
(install_method class_source_lambda is_recursively_constructible yes_recursively_constructible)
(install_method class_source_instance is_recursively_constructible yes_recursively_constructible)
(install_method class_source_tuple is_recursively_constructible yes_recursively_constructible)
(install_method class_source_list is_recursively_constructible yes_recursively_constructible)




;;;;;;;;;;;;;;;;
;;; the LETREC expander itself
(defun mexpand_letrec (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_letrec sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(secpair (pair_tail (list_first cont)))
	(restpair (pair_tail secpair))
	(bindexpr (pair_head secpair))
	(newenv (fresh_env env))
	(:long nbind 0)	       ;later set to the number of recbindings
	(bindtup ())   ;later set to the tuple of environment bindings
	(srcbindtup ())	;later set to the tuple of let rec source bindings
	(vartup ())	;later set to the tuple of variables
	(exprtup ()) ;later set to the tuple of bound expressions in bindings
	(bodytup ())
	)
    ;; we are accepting the degenerate case (letrec () ....) 
    (if bindexpr 
	(if (is_a bindexpr class_sexpr) 
	    (let ( (recbindtup 
		    (pairlist_to_multiple 
		     (list_first (unsafe_get_field :sexp_contents bindexpr))
		     discr_multiple
		     (lambda (bx) 
		       (if (is_not_a bx class_sexpr)
			   (error_plain loc "sexpr expected in LETREC binding"))
		       bx)))
		   (:long nbrecbind (multiple_length recbindtup)) 
		   (recsexprtup (make_multiple discr_multiple nbrecbind))
		   )
	      (setq nbind nbrecbind)
	      (setq bindtup (make_multiple discr_multiple nbind))
	      (setq srcbindtup (make_multiple discr_multiple nbind))
	      (setq vartup (make_multiple discr_multiple nbind))
	      (setq exprtup (make_multiple discr_multiple nbind))
	      ;; first loop to compute the tuple of variables and s-expressions
	      (foreach_in_multiple
	       (recbindtup)
	       (curbindexpr :long bindix)
	       (debug_msg curbindexpr "mexpand_letrec firstloop curbindexpr")
	       (if (is_not_a curbindexpr class_sexpr)
		   ;; error message already given
		   (return))
	       (let ( (curcont (get_field :sexp_contents curbindexpr))
		      (curloc (get_field :loca_location curbindexpr))
		      (curpair (list_first curcont))
		      (curcomp (pair_head curpair))
		      (cursymb ())
		      (cursexpr ())
		      )
		 (cond ( (is_a curcomp class_keyword)
			 (error_plain curloc "keyword invalid in LETREC binding")
			 )
		       ( (is_a curcomp class_symbol)
			 (setq cursymb curcomp)
			 )
		       (:else 
			(error_plain curloc "invalid LETREC binding - expecting (<symbol> <constructive-expr>)"))
		       )
		 (setq curpair (pair_tail curpair))
		 (setq curcomp (pair_head curpair))
		 (if (is_a curcomp class_sexpr)
		     (if (is_a cursymb class_symbol)
			 (progn
			   (setq cursexpr curcomp)
			   (multiple_put_nth recsexprtup bindix cursexpr)
			   (multiple_put_nth vartup bindix cursymb)))
		   ;; else curcomp is not a symbol
		   (error_plain curloc "invalid LETREC binding - missing constructive expression"))
		 (if (pair_tail curpair)
		     (error_plain curloc "invalid LETREC binding - more than two components"))
		 ))
	      (debug_msg recsexprtup "mexpand_letrec recsexprtup after firstloop")
	      (debug_msg vartup "mexpand_letrec vartup after firstloop")
;;;
	      ;; second loop to fill the newenv with empty letrec bindings
	      (let ( (envmap (get_field :env_bind newenv)) ;; to ensure no repeated variable in letrec
		     )
		(foreach_in_multiple
		 (vartup)
		 (curvar :long varix)
		 (debug_msg curvar "mexpand_letrec second loop curvar")
		 (if (mapobject_get envmap curvar)
		     (error_strv loc "repeated variable in LETREC binding"
				 (get_field :named_name curvar)))
;;; make the binding
		 (let ( (curbind (instance class_letrec_binding
					   :binder curvar
					   :letbind_type ctype_value
					   :letbind_expr () ;filled later
					   )) 
			)
		   (put_env newenv curbind)
		   (multiple_put_nth bindtup varix curbind)
		   )))
	      (debug_msg bindtup "mexpand_letrec bindtup after secondloop")
;;;
	      ;; third loop to expand the bound expressions which should be recursively constructible
	      (foreach_in_multiple
	       (recsexprtup)
	       (cursexpr :long expix)
	       (let ( 
		     (curloc (or (get_field :loca_location cursexpr) loc))
		     (curexp (macroexpand_1 cursexpr newenv mexpander))
		     (curbind (multiple_nth bindtup expix))
		     )
		 (if (null (is_recursively_constructible curexp))
		     (progn
		       (error_plain curloc "invalid expression in LETREC binding [not recursively constructible]")
		       (return)))
		 (put_fields curbind :letbind_expr curexp)
		 (multiple_put_nth exprtup expix curexp)
		 (let ( (sbind
			 (instance class_source_letrec_binding
				   :loca_location (or (get_field :loca_location curexp) loc)
				   :sletb_type ctype_value
				   :sletb_binder (multiple_nth vartup expix)
				   :sletb_expr curexp
				   )
			 ) )
		   (multiple_put_nth srcbindtup expix sbind)
		   )))
	      (debug_msg exprtup "mexpand_letrec exprtup after thirdloop")
	      )		;end let recbindtup when bindexpr is an s-expr
	  (error_plain loc "missing letbinding-s in LETREC"_))
      )
    (debug_msg srcbindtup "mexpand_letrec srcbindtup")
    (setq bodytup (pairlist_to_multiple restpair discr_multiple 
					(lambda (e) (macroexpand_1 e newenv mexpander))))
    (if (<=i (multiple_length bodytup) 0)
	(error_plain loc "emptyy body in LETREC"))
	     (let ( (letr
	    (instance class_source_letrec
		      :loca_location loc
		      :slet_bindings srcbindtup
		      :slet_body bodytup)) )
      (debug_msg letr "mexpand_letrec result")
      (return letr)
      )))
(install_initial_macro 'letrec mexpand_letrec)
(export_macro 
 letrec mexpand_letrec
 :doc #{The $LETREC syntax is for mutually @b{recursive} local
 bindings. Syntax is (LETREC ( <binding>... ) <body>...). Each binding is
 an optional ctype such as :long or :gimple or :value (which is the
 default), followed by a local variable name, followed by a single
 @b{constructive} expression, like $LAMBDA $INSTANCE $TUPLE $LIST. The
 body is a non-empty sequence of sub-expressions evaluated in an
 augmented environment. MELT LETREC is similar to Scheme's LETREC.}#)

;;;;;;;; for LAMBDA
(defun mexpand_lambda (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (newenv (fresh_env env))
	 (formals (pair_head curpair))
	 )
    ;; parse the formal arguments
    (if (and (notnull formals) (is_not_a formals class_sexpr))
	(error_plain loc "missing formal argument list in (LAMBDA (arglist...) body...)"_))
    (let ( (argtup (lambda_arg_bindings formals sexpr)) )
      (setq curpair (pair_tail curpair))
      (multiple_every argtup 
		      (lambda (lb) (put_env newenv lb)))
      (let ( (bodytup (pairlist_to_multiple curpair discr_multiple 
					    (lambda (e) (macroexpand_1 e newenv mexpander)))) 
	     (lambr 
	      (instance class_source_lambda
			:loca_location loc
			:slam_argbind argtup
			:slam_body bodytup))
	     ) 
	(return lambr)
	))))
(install_initial_macro 'lambda mexpand_lambda)
(export_macro
 lambda mexpand_lambda
 :doc #{The $LAMBDA syntax is for anonymous functions e.g. closures,
 with closed values (however closing things like :gimple or :long is
 not permitted, you have to box them explicitly as :value-s.). Syntax
 is (LAMBDA ( <formals> ) <body>...). The formal argument list should
 have its first formal be a :value. Other arguments can bec(-typed
 with keywords like :value :gimple :long etc. which applies to all
 succeeding arguments up to the next ctype keyword. The body is a
 non-empty sequence of expressions. $LAMBDA functions can $RETURN a
 value with possible secondary results. See also $MULTICALL. $LAMBDA
 expressions are @b{construcitive} so can appear in $LETREC
 bindings.}# )

;;;;;;;; for MULTICALL
(defun mexpand_multicall (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (newenv (fresh_env env))
	 )
    ;; parse the formal results
    (let ( (restup (lambda_arg_bindings (pair_head curpair) sexpr)) )
      (setq curpair (pair_tail curpair))
      (let ( (curcallexp (pair_head curpair)) )
	(if (not (is_a curcallexp class_sexpr))
	    (error_plain loc "missing called expression in MULTICALL"_))
	(setq curpair (pair_tail curpair))
	(let ( (curcall (macroexpand_1 curcallexp env mexpander)) )
	  ;; check the called subexpression
	  (cond 
	   ((or (is_a curcall class_source_apply)
		(is_a curcall class_source_msend)) 
	    ())
	   (:else 
	    (debug_msg curcall "mexpand_multicall bad curcall")
	    (error_plain loc "called expression in MULTICALL is invalid, expecting application or send")
	    (return)))
	  (multiple_every restup 
			  (lambda (lb) (put_env newenv lb)
			    ))
	  (let ( (bodytup (pairlist_to_multiple curpair discr_multiple 
						(lambda (e) (macroexpand_1 e newenv mexpander)))) 
		 (mulcr
		  (instance class_source_multicall
			    :loca_location loc
			    :smulc_resbind restup
			    :smulc_call curcall
			    :smulc_body bodytup
			    )) 
		 )
	    (return mulcr)
	    ))))))
(install_initial_macro 'multicall mexpand_multicall)
(export_macro 
 multicall mexpand_multicall
 :doc #{The $MULTICALL syntax is for accumulating the primary and
 secondary results of a function application or a message
 sending. Syntax is (MULTICALL ( <formals> ) <application-or-sending>
 <body>...). The first formal is bound to the primary result and
 should be a :value. Other are for secondary results. The body is
 evaluated with these results of the given application or sending
 expression bound by the formals. Inspired by Scheme's
 CALL-WITH-VALUES or CommonLisp's MULTIPLE-VALUE-BIND.}#)


;;;;;;;; for QUOTE (only of symbols or keywords, strings, or integers)
(defun mexpand_quote (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (quoted (pair_head curpair))
	 )
    (if (pair_tail curpair)
	(error_plain loc "QUOTE should have only one argument"_))
    (cond ( (is_a quoted class_symbol) 
	    ()
	    )
	  ( (is_string quoted)
	    ()
	    )
	  ( (is_integerbox quoted)
	    ()
	    )
	  (:else
	   (error_plain loc "QUOTE should have a symbol, string, or integer argument"_))
	  )
    (if (is_a quoted class_keyword)
	(return quoted))
    (let ( (squ (instance class_source_quote
			  :loca_location loc
			  :squoted quoted)) )
      (return squ)
      )))
(install_initial_macro 'quote mexpand_quote)
(export_macro
 quote mexpand_quote
 :doc #{The $QUOTE syntax (usually noted with a prefix
 quote-character) is for quotations. Only symbols or literals can be
 quoted. A quoted literal reifies a value, so '2 is a value of
 $DISCR_CONSTANT_INTEGER.}#)

;;;;;;;; for COMMENT (only of strings)
(defun mexpand_comment  (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (comstr (pair_head curpair))
	 )
    (if (pair_tail curpair)
	(warning_plain loc "COMMENT should have only one string argument"_))
    (if (not (is_string comstr))
	(progn
	  (warning_plain loc "COMMENT without string is ignored"_)
	  (return)
	  )
      )
    (let ( (scom (instance class_source_comment
			   :loca_location loc
			   :scomm_str comstr)) )
      (return scom)
      )))
(install_initial_macro 'comment mexpand_comment)
(export_macro 
 comment mexpand_comment
 :doc #{The $COMMENT syntax inserts comment in the generated code, or
 skips MELT code. Syntax is (COMMENT <string>) to insert a comment in
 the generated C code, or (COMMENT ...) to skip some syntax.}#)

;;;;;;;; for PROGN
;; internal routine to make a progn from a pairlist at a location
(defun pairlist_to_progn (pair loc env mexpander)
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg pair "pairlist_to_progn pair")
  (assert_msg "check_pair" (is_pair pair))
  (let ( (bodytup (pairlist_to_multiple 
		   pair 
		   discr_multiple
		   (lambda (e) (macroexpand_1 e env mexpander)))) 
	 (sprogn
	  (instance class_source_progn
		    :loca_location loc
		    :sprogn_body bodytup
		    )) )
    (debug_msg sprogn "pairlist_to_progn sprogn")
    (return sprogn)
    ))

;; internal routine to make a return from a pairlist at a location
(defun pairlist_to_return (pair loc env mexpander)
  (assert_msg "check env" (is_a env class_environment))
  (let ( (bodytup (pairlist_to_multiple 
		   pair 
		   discr_multiple
		   (lambda (e) (macroexpand_1 e env mexpander)))) )
    (instance class_source_return
	      :loca_location loc
	      :sargop_args bodytup
	      )
    ))

;;;; the progn expanser
(defun mexpand_progn (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (let ( (sloc (unsafe_get_field :loca_location sexpr))
	 (pairs  (pair_tail
		  (list_first (unsafe_get_field :sexp_contents sexpr)))) 
	 )
    (if (not (is_pair pairs))
	(progn
	  (error_plain sloc "empty PROGN"_)
	  (return)))
    (let ( (progr
	    (pairlist_to_progn pairs
			       sloc
			       env
			       mexpander)) )
      (return progr)
      )))
(install_initial_macro 'progn mexpand_progn)
(export_macro 
 progn mexpand_progn
 :doc #{The $PROGN syntax evaluate a sequence of expressions ignoring
 all but the last which is the result. Syntax is (PROGN
 <expression>...).}# )

;;;; the return expanser
(defun mexpand_return (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (let ( (retr
	  (pairlist_to_return (pair_tail (list_first (unsafe_get_field :sexp_contents sexpr)))
			      (unsafe_get_field :loca_location sexpr)
			      env
			      mexpander)) 
	 )
    (return retr)
    ))
(install_initial_macro 'return mexpand_return)
(export_macro 
 return mexpand_return
 :doc #{The $RETURN syntax is for returning a primary and possibly
 secondary results. Syntax is (RETURN <expression>...). If no
 expression is given, returns nil.}#)


;;;; the forever expanser
(defun mexpand_forever (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (slabnam (pair_head curpair))
	 (xlabnam (macroexpand_1 slabnam env mexpander))
	 (newenv (fresh_env env))
	 )
    (if (is_not_a xlabnam class_symbol)
	(progn
	  (error_plain loc "missing label in FOREVER"_)
	  (return ())))
    (setq curpair (pair_tail curpair))
    (let ( (labind (instance class_label_binding
			     :binder xlabnam
			     :labind_loc loc)) )
      (put_env newenv labind)
      (let ( (bodytup (pairlist_to_multiple
		       curpair
		       discr_multiple
		       (lambda (e) (macroexpand_1 e newenv mexpander)))) 
	     (forr
	      (instance class_source_forever
			:loca_location loc
			:slabel_bind labind
			:sfrv_body bodytup)) 
	     )
	(return forr)
	))))
(install_initial_macro 'forever mexpand_forever)
(export_macro
 forever mexpand_forever
 :doc #{The $FOREVER syntax is for infinite loops exited thru
 $EXIT. Syntax is (FOREVER <loop-name> <expr>...). Use $EXIT to go out
 of the loop with a result.}#)

;;;; the exit expanser
(defun mexpand_exit (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (slabnam (pair_head curpair))
	 (xlabnam (macroexpand_1 slabnam env mexpander))
	 (newenv (fresh_env env))
	 )
    (if (is_not_a xlabnam class_symbol)
	(progn
	  (error_plain loc "missing label in EXIT"_)
	  (return ())))
    (setq curpair (pair_tail curpair))
    (let ( (labind (find_env env xlabnam)) )
      (if (is_not_a labind class_label_binding)
	  (progn 
	    (error_strv loc "bad label in EXIT"_
			(unsafe_get_field :named_name xlabnam))
	    (return ())))
      (let ( (bodytup (pairlist_to_multiple
		       curpair
		       discr_multiple
		       (lambda (e) (macroexpand_1 e newenv mexpander)))) 
	     (exr
	      (instance class_source_exit
			:loca_location loc
			:slabel_bind labind
			:sexi_body bodytup)) 
	     )
	(return exr)
	))))
(install_initial_macro 'exit mexpand_exit)
(export_macro
 exit mexpand_exit
 :doc #{The $EXIT syntax is for exitting a local $FOREVER loop in the
 same function. Syntax is (EXIT <loop-name> <expression>...).}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; compile time warning (compile_warning msg expr)
;; we don't issue the warning at expansion phase, but at normalization phase.
(defun  mexpand_compile_warning (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (debug_msg sexpr "mexpand_compile_warning sexpr")
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (smsg (pair_head curpair))
	 (xmsg (macroexpand_1 smsg env mexpander))
	 )
    (if (not (is_string xmsg))
	(progn
	  (error_plain loc "missing message string in (COMPILE_WARNING <msg> <exp>)"_)
	  (return ())))
    (setq curpair (pair_tail curpair))
    (let ( (sexp (pair_head curpair))
	   (xexp (macroexpand_1 sexp env mexpander))
	   )
      (setq curpair (pair_tail curpair))
      (if (notnull curpair)
	  (error_plain loc "too many arguments in (COMPILE_WARNING <msg> [<exp>])"_))
      (let ( (res (instance  class_source_compilewarning
			     :loca_location loc
			     :scwarn_msg xmsg
			     :scwarn_expr xexp
			     ))
	     )
	(debug_msg res "mexpand_compile_warning result")
	(return res)
	))))
(install_initial_macro 'compile_warning mexpand_compile_warning)
(export_macro 
 compile_warning mexpand_compile_warning
 :doc #{The $COMPILE_WARNING syntax issues a warning, inspired by GCC
 #warning. Syntax is (COMPILE_WARNING <string> [<expression>]).}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; assert_msg macro is expanded into other src..
;;;;;; (assert_msg msg check)
;;; becomes
;;;;;; (cppif ENABLE_CHECKING (if check (assert_failed msg filename lineno)) ())
;;; where assert_failed is a primitive

(defun mexpand_assert_msg (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_assert_msg sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(xmsg (macroexpand_1 (pair_head curpair)  env mexpander))
	(xtest ())
	(assfail_symb 'assert_failed)
	(assfail_binding (find_env env assfail_symb))
	)
    (if (not (is_string xmsg))
	(error_plain loc "non string message in (ASSERT_MSG <msg> <test>)"_))
    (setq curpair (pair_tail curpair))
    (cond ( (is_pair curpair)
	    (if (pair_tail curpair)
		(error_plain loc "extra arg for (ASSERT_MSG <msg> <test>)"_))
	    (setq xtest (macroexpand_1 (pair_head curpair) env mexpander)))
	  (:else
	   (setq xtest ())
	   (warning_strv loc "empty ASSERT_MSG" xmsg)
	   ))
    (let (
	  (afprim 
	   (cond 
	    ( (null assfail_binding)
	      (error_plain loc "unbound ASSERT_FAILED in (ASSERT_MSG <msg> <test>)"_)
	      (debug_msg env "mexpand_assert_msg env without assert_failed")
	      (debug_msg (discrim env) "mexpand_assert_msg env's class without assert_failed")
	      (debug_msg  (find_env_debug env assfail_symb) "mexpand_assert_msg findenvdbg give")
	      (debug_msg assfail_symb "mexpand_assert_msg ASSERT_FAILED symbol")
	      (assert_msg "assfail_binding nul! @@" ())
	      (return))
	    ( (is_a assfail_binding class_primitive_binding)
	      (unsafe_get_field :pbind_primitive assfail_binding))
	    ( (and (is_a assfail_binding class_value_binding)
		   (is_a (unsafe_get_field :vbind_value assfail_binding) 
			 class_primitive))
	      (unsafe_get_field :vbind_value assfail_binding))
	    (:else
	     (debug_msg assfail_binding "bad assfail_binding")
	     (error_plain loc "ASSERT_FAILED not bound to a primitive in  (ASSERT_MSG <msg> <test>)"_)
	     (return)
	     )))
	  (filnam (cond
		   ((is_mixint loc) (mixint_val loc))
		   ((is_mixloc loc) (mixloc_val loc))))
	  (aprim (instance 
		  class_source_primitive
		  :loca_location loc
		  :sprim_oper afprim
		  :sargop_args (tuple
				xmsg
				filnam
				(make_integerbox discr_integer (get_int loc)))))
	  (atest (instance
		  class_source_ifelse
		  :loca_location loc
		  :sif_test xtest
		  :sif_then ()
		  :sif_else aprim))
	  (acppif (instance class_source_cppif
			    :loca_location loc
			    :sifp_cond 'ENABLE_CHECKING
			    :sifp_then atest
			    :sifp_else ()
			    )) 
	  )
      (debug_msg acppif "mexpand_assert_msg result acppif")
      (return acppif)
      )))
(install_initial_macro 'assert_msg mexpand_assert_msg)
(export_macro assert_msg mexpand_assert_msg
	      :doc #{$ASSERT_MSG macro with a message cstring and an
	      optional condition. Generates an assertion -if checking
	      is enabled- and also issues a compile warning if
	      condition is missing so false.}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; debug_msg macro is expanded into other src..
;;;;;; (debug_msg val msg [count]) 
;;; becomes
;;;;;; (cppif ENABLE_CHECKING (debug_msg_fun val msg count filename lineno) ())
;;; where count is (the_meltcallcount) if not given

(defun mexpand_debug_msg (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_debug_msg sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(xval (macroexpand_1 (pair_head curpair)  env mexpander)) 
	(xmsg ())
	(xcount ())
	)
    (setq curpair (pair_tail curpair))
    (if (not (is_pair curpair))
	(error_plain loc "missing message in DEBUG_MSG"_))
    (setq xmsg  (macroexpand_1 (pair_head curpair) env mexpander))
    (setq curpair (pair_tail curpair))
    (if (is_pair curpair)
	(progn
	  (setq xcount (macroexpand_1 (pair_head curpair) env mexpander))
	  (setq curpair (pair_tail curpair))))
    (if curpair
	(error_plain loc "too many arguments to DEBUG_MSG"_))
    (if (not (is_string xmsg))
	(error_plain loc "message argument should be string in DEBUG_MSG"_))
    (if (null xcount)
	(let ( (conlis (make_list discr_list)) )
	  (list_append conlis 'the_meltcallcount)
	  (setq xcount (macroexpand_1 (instance class_sexpr 
						:sexp_contents conlis
						:loca_location loc)
				      env mexpander))))
    (let (
	  (dfilnam (cond
		    ((is_mixint loc) (mixint_val loc))
		    ((is_mixloc loc) (mixloc_val loc))))
	  (dcall (instance 
		  class_source_apply
		  :loca_location loc
		  :sapp_fun 'debug_msg_fun
		  :sargop_args (tuple
				xval
				xmsg
				xcount
				dfilnam
				(make_integerbox discr_integer (get_int loc)))))
	  (dcppif (instance class_source_cppif
			    :loca_location loc
			    :sifp_cond 'ENABLE_CHECKING
			    :sifp_then dcall
			    :sifp_else ()
			    )) 
	  )
      (debug_msg dcppif "mexpand_debug_msg result dcppif")
      (return dcppif)
      )))
(install_initial_macro 'debug_msg mexpand_debug_msg)
(export_macro debug_msg mexpand_debug_msg)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; export_values macro (export_values <symbol> ...)
(defun mexpand_export_values (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_export_values sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(symbtup (pairlist_to_multiple 
		  curpair discr_multiple
		  (lambda (s)
		    (let ( (sym  (macroexpand_1 s env mexpander)) )
		      (if (is_not_a sym class_symbol)
			  (progn
			    (debug_msg sym "mexpand_export_values bad sym")
			    (error_plain loc "(EXPORT_VALUES <sym>...) expecting symbol"_)))
		      sym
		      ))))
	(res (instance class_source_export_values
		       :loca_location loc
		       :sexport_names symbtup))
	)
    (debug_msg res "mexpand_export_values result res")
    (return res)
    ))
(install_initial_macro 'export_values mexpand_export_values)
(export_macro export_values mexpand_export_values)

;;;;
;;; export_macro macro (export_macro <symbol> <expander> [:doc <documentation>])
(defun mexpand_export_macro (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_export_macro sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(symb (macroexpand_1 (pair_head curpair) env mexpander))
	(doc ())
	)
    (if (is_not_a symb class_symbol)
	(error_plain loc "(EXPORT_MACRO <sym> <expander>) expecting symbol"_))
    (setq curpair (pair_tail curpair))
    (let ( (expv (macroexpand_1 (pair_head curpair) env mexpander)) 
	   )
      (setq curpair (pair_tail curpair))
      (if (== (pair_head curpair) ':doc)
	  (progn
	    (setq curpair (pair_tail curpair))
	    (setq doc (pair_head curpair))))
      (if (null expv)
	  (error_plain loc  "(EXPORT_MACRO <sym> <expander> [:doc <docum>]) expecting expander"_))
      (let ( (res (instance class_source_export_macro
			    :loca_location loc
			    :sexpmac_mname symb
			    :sexpmac_mval expv
			    :sexpmac_doc doc
			    ))
	     )
	(debug_msg res "mexpand_export_macro result res")
	(return res)
	))))
(install_initial_macro 'export_macro mexpand_export_macro)
(export_macro export_macro mexpand_export_macro)




;;;;
;;; export_patmacro macro (export_patmacro <symbol> <patexpander> <macexpander> [:doc <docum>])
(defun mexpand_export_patmacro (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_export_patmacro sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(symb (macroexpand_1 (pair_head curpair) env mexpander))
	(patexpv ())		    ;set later to the pattern expander
	(macexpv ())		    ;set later to the macro expander
	(doc ())		    ;set later to the documentation if any
	)
    (if (is_not_a symb class_symbol)
	(error_plain loc "(EXPORT_PATMACRO <sym> <patexpander> <macexpander> [:doc <docum>]) expecting symbol"_))
    (setq curpair (pair_tail curpair))
    (setq patexpv (macroexpand_1 (pair_head curpair) env mexpander))
    (if (null patexpv)
	(error_plain loc  "(EXPORT_PATMACRO <sym> <patexpander> <macexpander> [:doc <docum>]) expecting patexpander"_))
    (setq curpair (pair_tail curpair))
    (setq macexpv (macroexpand_1 (pair_head curpair) env mexpander))
    (if (null macexpv)
	(error_plain loc  "(EXPORT_PATMACRO <sym> <patexpander> <macexpander> [:doc <docum>]) expecting macexpander"_))
    (setq curpair (pair_tail curpair))
    (if (== (pair_head curpair) ':doc)
	(progn
	  (setq curpair (pair_tail curpair))
	  (setq doc (pair_head curpair))
	  ))
    ;;
    (let ( (res (instance class_source_export_patmacro
			  :loca_location loc
			  :sexpmac_mname symb
			  :sexppat_pval patexpv
			  :sexpmac_mval macexpv
			  :sexpmac_doc doc
			  ))
	   )
      (debug_msg res "mexpand_export_patmacro result res")
      (return res)
      )))
(install_initial_macro 'export_patmacro mexpand_export_patmacro)
(export_macro export_patmacro mexpand_export_patmacro)

;;;;
;;; export_class macro (export_class <symbol> ...)
(defun mexpand_export_class (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_export_class sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(symbtup (pairlist_to_multiple 
		  curpair discr_multiple
		  (lambda (s)
		    (let ( (sym  (macroexpand_1 s env mexpander)) )
		      (if (is_not_a sym class_symbol)
			  (error_plain loc "(EXPORT_CLASS <sym>...) expecting symbol"_))
		      sym
		      ))))
	(res (instance class_source_export_class
		       :loca_location loc
		       :sexport_names symbtup))
	)
    (debug_msg res "mexpand_export_class result res")
    (return res)
    ))
(install_initial_macro 'export_class mexpand_export_class)
(export_macro export_class mexpand_export_class)

;;; export_synonym macro (export_synonym <newname> <oldname>  [:doc <documentation>])
(defun mexpand_export_synonym (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_export_synonym sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(newsymb ())
	(oldsymb ())
	(doc ())
	)
    ;; handle the newsymb
    (setq newsymb (macroexpand_1 (pair_head curpair) env mexpander))
    (debug_msg newsymb "mexpander_export_synonym newsymb")
    (if (is_not_a newsymb class_symbol)
	(error_plain loc "bad new name in (EXPORT_SYNONYM <newname> <oldname> [:doc <docum>])"))	
    (setq curpair (pair_tail curpair))
    ;; handle the oldsymb
    (setq oldsymb (macroexpand_1 (pair_head curpair) env mexpander))
    (debug_msg oldsymb "mexpander_export_synonym oldsymb")
    (if (is_not_a oldsymb class_symbol)
	(error_plain loc "bad old name in (EXPORT_SYNONYM <newname> <oldname> [:doc <docum>])"))	
    (setq curpair (pair_tail curpair))
    (if (== (pair_head curpair) ':doc)
	(progn
	  (setq curpair (pair_tail curpair))
	  (setq doc (pair_head curpair))
	  ))
    (debug_msg doc "mexpander_export_synonym doc")
    (let ( 
	  (res (instance class_source_export_synonym
			 :loca_location loc
			 :sexpsyn_newname newsymb
			 :sexpsyn_oldname oldsymb
			 :sexpsyn_doc doc))
	  )
      (debug_msg res "mexpander_export_synonym result")
      (return res)
      )))
(install_initial_macro 'export_synonym mexpand_export_synonym)
(export_macro export_synonym mexpand_export_synonym)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; current_module_environment_container macro 
(defun mexpand_current_module_environment_container (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_current_module_environment_container sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(res (instance class_source_current_module_environment_container
		       :loca_location loc))
	)
    (if (notnull curpair)
	(error_plain loc "(CURRENT_MODULE_ENVIRONMENT_CONTAINER) should not have any argument"_))
    (debug_msg res "mexpand_current_module_environment_container return res")
    (return res)
    ))

(install_initial_macro 'current_module_environment_container mexpand_current_module_environment_container)
(export_macro current_module_environment_container mexpand_current_module_environment_container)


;;;;;;;;;;;;;;;;
;;;; parent_module_environment macro 
(defun mexpand_parent_module_environment (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_parent_module_environment sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(res (instance class_source_parent_module_environment
		       :loca_location loc))
	)
    (if (notnull curpair)
	(error_plain loc "(PARENT_MODULE_ENVIRONMENT) should not have any argument"_))
    (debug_msg res "mexpand_parent_module_environment return res")
    (return res)
    ))
(install_initial_macro 'parent_module_environment mexpand_parent_module_environment)
(export_macro parent_module_environment mexpand_parent_module_environment)



;;;;;;;;;;;;;;;;
;;;; update_current_module_environment_container macro 
(defun mexpand_update_current_module_environment_container  (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_update_current_module_environment_container sexpr")
  (let (
	(loc  (unsafe_get_field :loca_location sexpr))
	(cont (unsafe_get_field :sexp_contents sexpr))
	(curpair (pair_tail (list_first cont)))
	(res (instance class_source_update_current_module_environment_container
		       :loca_location loc))
	)
    (if (notnull curpair)
	(error_plain loc "(UPDATE_CURRENT_MODULE_ENVIRONMENT_CONTAINER) should not have any argument"_))
    (debug_msg res "mexpand_update_current_module_environment_container return res")
    (return res)
    ))

(install_initial_macro 'update_current_module_environment_container mexpand_update_current_module_environment_container)
(export_macro update_current_module_environment_container mexpand_update_current_module_environment_container)



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

(defun mexpand_fetch_predefined (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_fetch_predefined sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(spredef (macroexpand_1 (pair_head curpair) env mexpander))
	)
    (if (null curpair) 
	(error_plain loc "(FETCH_PREDEFINED <predef-name-or-rank>) missing argument"_))
    (if (notnull (pair_tail curpair))
	(error_plain loc "(FETCH_PREDEFINED <predef-name-or-rank>) extra argument"_))
    (if (not (or (is_a spredef class_symbol) (is_integerbox spredef)))
	(error_plain loc "(FETCH_PREDEFINED <predef-name-or-rank>) invalid argument"_))
    (let ( (res (instance class_source_fetch_predefined
			  :loca_location loc
			  :sfepd_predef spredef)) )
      (debug_msg res "mexpand_fetch_predefined result")
      (return res)
      )))
(install_initial_macro 'fetch_predefined mexpand_fetch_predefined)
(export_macro fetch_predefined mexpand_fetch_predefined)

;;;;;;;;;;;;;;;;
(defun mexpand_store_predefined (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_store_predefined sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(spredef (macroexpand_1 (pair_head curpair) env mexpander))
	(sval ())
	)
    (if (null curpair) 
	(error_plain loc "(STORE_PREDEFINED <predef-name-or-rank> <value>) missing predef"_))
    (setq curpair (pair_tail curpair))
    (if (null curpair) 
	(error_plain loc "(STORE_PREDEFINED <predef-name-or-rank> <value>) missing predef"_))
    (setq sval (macroexpand_1 (pair_head curpair) env mexpander))
    (if (notnull (pair_tail curpair))
	(error_plain loc "(STORE_PREDEFINED <predef-name-or-rank> <value>) extra argument"_))
    (if (not (or (is_a spredef class_symbol) (is_integerbox spredef)))
	(error_plain loc "(STORE_PREDEFINED <predef-name-or-rank> <value>) invalid predef"_))
    (let ( (res (instance class_source_store_predefined
			  :loca_location loc
			  :sstpd_predef spredef
			  :sstpd_value sval
			  )) )
      (debug_msg res "mexpand_store_predefined result")
      (return res)
      )))
(install_initial_macro 'store_predefined mexpand_store_predefined)
(export_macro store_predefined mexpand_store_predefined)

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

(export_class  ;classes for source representations, alphabetical order
 class_pattern_expansion_context
 class_source_apply
 class_source_argumented_operator
 class_source_citeration
 class_source_cmatchexpr
 class_source_codechunk
 class_source_comment
 class_source_compilewarning
 class_source_cppif
 class_source_current_module_environment_container
 class_source_defciterator
 class_source_defclass
 class_source_defcmatcher
 class_source_definition
 class_source_definition_formal
 class_source_definstance
 class_source_defobjcommon
 class_source_defprimitive
 class_source_defselector
 class_source_defun
 class_source_defunmatcher
 class_source_exit
 class_source_export_class
 class_source_export_macro
 class_source_export_patmacro
 class_source_export_synonym
 class_source_export_values
 class_source_exportcommon
 class_source_fetch_predefined
 class_source_field_pattern
 class_source_fieldassign
 class_source_forever
 class_source_funmatchexpr
 class_source_get_field
 class_source_if
 class_source_ifelse
 class_source_instance
 class_source_labelled
 class_source_lambda
 class_source_let
 class_source_let_binding
 class_source_letrec
 class_source_letrec_binding
 class_source_list
 class_source_match
 class_source_match_case
 class_source_msend
 class_source_multicall
 class_source_or
 class_source_parent_module_environment
 class_source_pattern
 class_source_pattern_and
 class_source_pattern_c_match
 class_source_pattern_composite
 class_source_pattern_constant 
 class_source_pattern_construct
 class_source_pattern_instance
 class_source_pattern_joker_variable
 class_source_pattern_list
 class_source_pattern_matcher
 class_source_pattern_object
 class_source_pattern_or
 class_source_pattern_tuple
 class_source_pattern_variable
 class_source_primitive
 class_source_progn
 class_source_put_fields
 class_source_quote
 class_source_return
 class_source_setq
 class_source_store_predefined
 class_source_tuple
 class_source_unsafe_get_field
 class_source_unsafe_put_fields
 class_source_update_current_module_environment_container
 )			       ;end classes for source representations

(export_values			 ;values for source representations
 expand_apply
 expand_msend  
 expand_pairlist_as_tuple
 expand_primitive
 install_initial_macro
 is_recursively_constructible
 lambda_arg_bindings
 macroexpand_1
 macroexpand_toplevel_list
 patternexpand_1
 patternexpand_expr
 patternexpand_pairlist_as_tuple
 pattern_weight_tuple
 )			  ;end of values for source representations


;; eof