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

;; file warmelt-macro.melt -*- Lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(comment "***
    Copyright 2008 - 2014  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 files warmelt-macro*.c



;; This MELT module is GPL compatible since it is GPLv3+ licensed.
(module_is_gpl_compatible "GPLv3+")

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

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




;;****************************************************************
;; Variadic diagnostic support should be here, not in warmelt-base.melt

;;;;;;; variadic diagnostics
(defvar diagv_gimple)
(defvar diagv_gimple_seq)
(defvar diagv_tree)
(defvar diagv_basic_block)
(defvar diagv_edge)

(defun register_diag_gimple (c)
  :doc #{Register a closure to handle @code{:gimple} stuff in diagnostic messages.}#
  (if (is_closure c)
      (setq diagv_gimple c)))

(defun register_diag_gimple_seq (c)
  :doc #{Register a closure to handle @code{:gimple_seq} stuff in diagnostic messages.}#
  (if (is_closure c)
      (setq diagv_gimple_seq c)))

(defun register_diag_tree (c)
  :doc #{Register a closure to handle @code{:tree} stuff in diagnostic messages.}#
  (if (is_closure c)
      (setq diagv_tree c)))

(defun register_diag_basic_block (c)
  :doc #{Register a closure to handle @code{:basic_block} stuff in diagnostic messages.}#
  (if (is_closure c)
      (setq diagv_basic_block c)))

(defun register_diag_edge (c)
  :doc #{Register a closure to handle @code{:edge} stuff in diagnostic messages.}#
  (if (is_closure c)
      (setq diagv_edge c)))


(defclass class_diagnostic_state
  :super class_located
  :fields (diag_vect 
	   diag_position
	   diag_state)
  :doc #{The $CLASS_DIAGNOSTIC_STATE manage diagnostic handling by $ERROR and $WARNING ....}#
  )

;;; the discriminant for diagnostic closures
(definstance discr_diagnostic_closure class_discriminant
  :doc #{The $DISCR_DIAGNOSTIC_CLOSURE is the discriminant of MELT
  diagnostic manipulator functions, used in $ERROR, $WARNING,
  etc.... Use $CLONE_WITH_DISCRIMINANT on a closure, e.g. with
  $LAMBDA, to make it a diagnostic manipulator function.}#
  :disc_super discr_closure
  :named_name '"DISCR_DIAGNOSTIC_CLOSURE")


;;;;;;;;;;;;;;;;
;; usage (diagnostic_args_macro <nbargs-var> <vect-var>)
(defmacro diagnostic_args_macro (sexp env mexpander modctx)
  :doc #{Macro $DIAGNOSTIC_ARGS_MACRO to be invoked with two variables @var{nbargs} and @var{vect} to 
parse variadic arguments in diagnostic functions like $ERROR or $WARNING or $INFORM.}#
  (debug "diagnostic_args_macro sexp=" sexp)
  (shortbacktrace_dbg "diagnostic_args_macro" 12)
  (assert_msg "check sexp" (is_a sexp class_sexpr) sexp)
  (let (
	(sloc (get_field :loca_location sexp))
	(sexcont (get_field :sexp_contents sexp))
	)
    (assert_msg "check sexcont" (is_list sexcont) sexcont)
    (let ( 
	  (tcont (list_to_multiple sexcont discr_multiple))
	  (:long tcontlen (multiple_length tcont))
	  )
      (assert_msg "check tcont" (is_multiple tcont) tcont sexcont)
      (assert_msg "check tcontlen" (>i tcontlen 0) tcontlen tcont)
      (when (!=i tcontlen 3)
	(error_plain sloc "DIAGNOSTIC_ARGS_MACRO needs two args: <nbargs> <vect>")
	(code_chunk diagargbad_chk #{ /* diagnostic_args_macro $DIAGARGBAD_CHK */
		    melt_low_stderr_value ("diagnostic_args_macro sexp", $SEXP) ;
		    melt_low_stderr_value ("diagnostic_args_macro sexcont", $SEXCONT) ;
		    melt_low_stderr_value ("diagnostic_args_macro tcont", $TCONT) ;
		    melt_low_stderr_value ("diagnostic_args_macro sloc", $SLOC) ;
		    }#)
	(inform_strv sloc "DIAGNOSTIC_ARGS_MACRO called with " 
		     (string4out discr_string tcontlen " args == " tcont))
	(assert_msg "diagnostic_args_macro wrongly called when bootstrapping" 
		    (not (melt_is_bootstrapping)) sexp sexcont tcont)
	(return)
	)
      (let ( 
	    (sexpnbarg  (multiple_nth tcont 1))
	    (macrovarnbarg (mexpander sexpnbarg env mexpander modctx))
	    (sexpvarvect (multiple_nth tcont 2))
	    (macrovarvect (mexpander sexpvarvect env mexpander modctx))
	    )
	(when (is_not_a macrovarnbarg class_symbol)
	  (error_plain sloc 
		       "(DIAGNOSTIC_ARGS_MACRO <nbargs> <vect>) not variable <nbargs>")
	  (return))
	(when (is_not_a macrovarvect class_symbol)
	  (error_plain sloc 
		       "(DIAGNOSTIC_ARGS_MACRO <nbargs> <vect>) not variable <vect>")
	  (return))
	(let ( (resexp
		`(let ( 
		       (diagposbox (box 0))
		       (diagstate (instance class_diagnostic_state
					     :loca_location ,sloc
					     :diag_vect ,macrovarvect
					     :diag_position diagposbox
					     :diag_state (make_mapobject discr_map_objects 19)))
			)
		   (setq ,macrovarnbarg 0)
		   (forever 
		    argloop
		    (put_int diagposbox ,macrovarnbarg)
		    (variadic 
		     ( ()
		       (exit argloop))
		     ( (:cstring str)
		       (let ( (bs (constant_box str))
			      )
			 (setq ,macrovarnbarg (+ ,macrovarnbarg 1))
			 (multiple_put_nth ,macrovarvect ,macrovarnbarg bs)
			 )
		       (void)
		       )
		     ( (:long l)
		       (let ( (sn (string4out discr_string l))
			      )
			 (setq ,macrovarnbarg (+ ,macrovarnbarg 1))
			 (multiple_put_nth ,macrovarvect ,macrovarnbarg sn)
			 )
		       (void)
		       )
		     ( (:tree tr)
		       (assert_msg "check diagv_tree" (is_closure diagv_tree) diagv_tree)
		       (let ( (s (diagv_tree diagstate tr))
			      )
			 (setq ,macrovarnbarg (+ ,macrovarnbarg 1))
			 (multiple_put_nth ,macrovarvect ,macrovarnbarg s)
			 )
		       (void)
		       )
		     ( (:gimple gi)
		       (assert_msg "check diagv_gimple" (is_closure diagv_gimple) diagv_gimple)
		       (let ( (s (diagv_gimple diagstate gi))
			      )
			 (setq ,macrovarnbarg (+ ,macrovarnbarg 1))
			 (multiple_put_nth ,macrovarvect ,macrovarnbarg s)
			 )
		       (void)
		       )
		     ( (:gimple_seq gs)
		       (assert_msg "check diagv_gimple_seq" (is_closure diagv_gimple_seq) diagv_gimple_seq)
		       (let ( (s (diagv_gimple_seq diagstate gs))
			      )
			 (setq ,macrovarnbarg (+ ,macrovarnbarg 1))
			 (multiple_put_nth ,macrovarvect ,macrovarnbarg s)
			 )
		       (void)
		       )
		     ( (:basic_block bb)
		       (assert_msg "check diagv_basic_block" (is_closure diagv_basic_block) diagv_basic_block)
		       (let ( (s (diagv_basic_block diagstate bb))
			      )
			 (setq ,macrovarnbarg (+ ,macrovarnbarg 1))
			 (multiple_put_nth ,macrovarvect ,macrovarnbarg s)
			 )
		       (void)
		       )
		     ( (:edge ed)
		       (assert_msg "check diagv_edge" (is_closure diagv_edge) diagv_edge)
		       (let ( (s (diagv_edge diagstate ed))
			      )
			 (setq ,macrovarnbarg (+ ,macrovarnbarg 1))
			 (multiple_put_nth ,macrovarvect ,macrovarnbarg s)
			 )
		       (void)
		       )
		     ( (:value v)
		       (cond 
			( (is_integerbox v)
			  (let ( (sn (string4out discr_string (get_int v)))
				 )
			    (setq ,macrovarnbarg (+ ,macrovarnbarg 1))
			    (multiple_put_nth ,macrovarvect ,macrovarnbarg sn)
			    )
			  (void)
			  )
			( (is_string v)
			  (setq ,macrovarnbarg (+ ,macrovarnbarg 1))
			  (multiple_put_nth ,macrovarvect ,macrovarnbarg v)
			  (void)
			  )
			( (is_a v discr_diagnostic_closure)
			  (v diagstate)
			  (void)
			  )
			( (and (is_a v class_keyword)
			       (is_a (get_field :symb_data v) discr_diagnostic_closure)
			       )
			  ((get_field :symb_data v) diagstate)
			  (void)
			  )
			( (is_a v class_named)
			  (let ( (nam (unsafe_get_field :named_name v))
				 )
			    (assert_msg "check nam" (is_string nam) nam)
			    (setq ,macrovarnbarg (+ ,macrovarnbarg 1))
			    (multiple_put_nth ,macrovarvect ,macrovarnbarg nam)
			    )
			  (void)
			  )
			)
		       )
		     ( :else
		       (let ( (vcty (variadic_ctype 0))
			      )
			 (errormsg_strv "DIAGNOSTIC_ARGS_MACRO for unsupported ctype"
					(get_field :named_name vcty))
			 (assert_msg "invalid variadic argument to DIAGNOSTIC_ARGS_MACRO" () vcty))
		       (void)
		       )
		     ))			;end forever args
		   diagstate		;the result
		   )
		)			; end resexp binding
	       )
	  (let ( (mexp (mexpander resexp env mexpander modctx))
		 )
	    (put_fields mexp :loca_location sloc)
	    (debug "diagnostic_args_macro final mexp=" mexp)
	    (return mexp)
	    )
	  )
	)
      )
    )
  )
(export_macro diagnostic_args_macro)

(defun diagnostic_expand_message (diagstate :cstring sfmt)
  ;;(debug "diagnostic_expand_message diagstate=" diagstate " sfmt=" sfmt)
  (assert_msg "check diagstate" (is_a diagstate class_diagnostic_state) diagstate)
  (assert_msg "check sfmt" sfmt sfmt)
  (let ( (diagvec (get_field :diag_vect diagstate))
	 (:long dpos (get_int (get_field :diag_position diagstate)))
	 (:long spos 0)
	 (:long dollarpos 0)
	 (:long ixdoll -1)
	 (:long fmtlen 0)
	 (sbuf (make_strbuf discr_strbuf))
	 )
    (code_chunk slen_chk 
		#{/* diagnostic_expand_message $SLEN_CHK*/ $FMTLEN = (($SFMT)?strlen($SFMT):0);
		}#)
    (assert_msg "check diagvec" (is_multiple diagvec) diagvec)
    ;;(debug "diagnostic_expand_message sfmt=" sfmt " fmtlen=" fmtlen " diagvec=" diagvec)
    (assert_msg "check diagvec" (is_multiple diagvec) diagvec)
    (forever 
     diagloop
     (if (>=i spos fmtlen) 
	 (exit diagloop))
     (setq ixdoll -1)
     (code_chunk dolpos_chk
		 #{ /* diagnostic_expand_message $DOLPOS_CHK start */
		    const char *dp = strchr ($SFMT + $SPOS, '$$');
		    if (dp) {
                      $DOLLARPOS = dp - $SFMT;
		      if ($DOLLARPOS > $SPOS)
		         meltgc_add_out_cstr_len ($SBUF, $SFMT + $SPOS, $DOLLARPOS - $SPOS);
		      if (ISDIGIT(dp[1]))
		         $IXDOLL = dp[1] - '0';
		      else
		         meltgc_add_out_cstr_len ($SBUF, dp+1, 1);
		    } else {
		      meltgc_add_out_cstr ($SBUF, $SFMT + $SPOS);
                      $DOLLARPOS = -1;
		    }
		    /* end diagnostic_expand_message $DOLPOS_CHK */
		 }#)
     ;;(debug "diagnostic_expand_message dollarpos=" dollarpos " ixdoll=" ixdoll " dpos=" dpos)
     (when (<i dollarpos 0)
	 (exit diagloop))
     (if (<i ixdoll 0) 
	 (again diagloop))
     (if (<=i ixdoll dpos)
       (let ( (diagcomp (multiple_nth diagvec ixdoll))
	      )
	 ;;(debug "ixdoll=" ixdoll " diagcomp=" diagcomp)
	 (add2out sbuf diagcomp)))
     (setq spos (+i dollarpos 2))
     )					;end forever diagloop
    (let ( (diagmsg (strbuf2string discr_string sbuf))
	   )
      ;;(debug "diagnostic_expand_message gives diagmsg=" diagmsg)
      (return diagmsg))
  ))

(export_class class_diagnostic_state)
(export_values
 diagnostic_expand_message
 discr_diagnostic_closure
 register_diag_basic_block
 register_diag_edge 
 register_diag_gimple
 register_diag_gimple_seq 
 register_diag_tree 
 )

;; we use ERROR_AT, not error, because ERROR is a control exception
;; raising primitive in Common Lisp and we don't want that
;; confusion...
(defun error_at (loc :cstring fmt :rest) 
  :doc #{Variadic $ERROR_AT function to emit an error message for source location $LOC. The $FMT format
  string may contain @code{$$1} ... @code{$$9} to refer to the first,
  ... nineth argument (after $FMT).}#
  ;;(debug "error_at start loc=" loc " fmt=" fmt)
  (let ( (vect (make_multiple discr_multiple 9))
	 (:long nbargs 0)
	 (diagstate (diagnostic_args_macro nbargs vect))
	 )
    ;;(debug "error_at diagstate=" diagstate)
    (let ( (diagmsg (diagnostic_expand_message diagstate fmt))
	   )
      ;;(debug "error_at diagmsg=" diagmsg)
      (assert_msg "check diagmsg" (is_string diagmsg) diagmsg)
      (code_chunk error_chk
		  #{ /* start error_at $ERROR_CHK */
		  melt_error_str (($LOC), melt_string_str ($DIAGMSG), NULL);
		  /* end error_at $ERROR_CHK */ }#)
      (assert_msg "bootstrapping error" (not (melt_is_bootstrapping)))
    )))					;end ERROR_AT


(defun fatal_error_at (loc :cstring fmt :rest) 
  :doc #{Variadic $FATAL_ERROR_AT function to emit a fatal error message for source location $LOC. The $FMT format
  string may contain @code{$$1} ... @code{$$9} to refer to the first,
  ... nineth argument (after $FMT).}#
  ;;(debug "fatal_error_at start loc=" loc " fmt=" fmt)
  (let ( (vect (make_multiple discr_multiple 9))
	 (:long nbargs 0)
	 (diagstate (diagnostic_args_macro nbargs vect))
	 )
    ;;(debug "fatal_error_at diagstate=" diagstate)
    (let ( (diagmsg (diagnostic_expand_message diagstate fmt))
	   )
      ;;(debug "fatal_error_at diagmsg=" diagmsg)
      (assert_msg "check diagmsg" (is_string diagmsg) diagmsg)
      (code_chunk error_chk
		  #{ /* start fatal_error_at $ERROR_CHK */
		  if ($LOC)
		     melt_error_str (($LOC), "MELT fatal error", NULL);
		  melt_fatal_error ("fatal error: %s",
				    melt_string_str ($DIAGMSG));
		  /* end fatal_error_at $ERROR_CHK */ }#)
      (assert_msg "bootstrapping error" (not (melt_is_bootstrapping)))
    )))					;end ERROR_AT


(defun warning_at (loc :cstring fmt :rest) 
  :doc #{Variadic $WARNING_AT function to emit an warning message for source location $LOC. The $FMT format
  string may contain @code{$$1} ... @code{$$9} to refer to the first,
  ... nineth argument (after $FMT).}#
  ;;(debug "warning_at start loc=" loc " fmt=" fmt)
  (let ( (vect (make_multiple discr_multiple 9))
	 (:long nbargs 0)
	 (diagstate (diagnostic_args_macro nbargs vect))
	 )
    ;;(debug "warning_at diagstate=" diagstate)
    (let ( (diagmsg (diagnostic_expand_message diagstate fmt))
	   )
      ;;(debug "warning_at diagmsg=" diagmsg)
      (assert_msg "check diagmsg" (is_string diagmsg) diagmsg)
      (code_chunk warning_chk
		  #{ /* start warning_at $WARNING_CHK */
		  melt_warning_str (0, ($LOC), melt_string_str ($DIAGMSG), NULL);
		  /* end warning_at $WARNING_CHK */ }#)
    )))					;end WARNING_AT



(defun inform_at (loc :cstring fmt :rest) 
  :doc #{Variadic $INFORM function to emit an inform notice. The $FMT format
  string may contain @code{$$1} ... @code{$$9} to refer to the first,
  ... nineth argument (after $FMT).}#
  ;;(debug "inform_at start loc=" loc " fmt=" fmt)
  (let ( (vect (make_multiple discr_multiple 9))
	 (:long nbargs 0)
	 (diagstate (diagnostic_args_macro nbargs vect))
	 )
    ;;(debug "inform_at diagstate=" diagstate)
    (let ( (diagmsg (diagnostic_expand_message diagstate fmt))
	   )
      (debug "inform_at diagmsg=" diagmsg)
      (assert_msg "check diagmsg" (is_string diagmsg) diagmsg)
      (code_chunk inform_chk
		  #{ /* start inform_at $INFORM_CHK */
		  melt_inform_str (($LOC), melt_string_str ($DIAGMSG), NULL);
		  /* end inform_at $INFORM_CHK */ }#)
    )))					;end INFORM_AT

(export_values error_at fatal_error_at warning_at inform_at)

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



(defselector is_recursively_constructible class_selector
  :doc #{The selector $IS_RECURSIVELY_CONSTRUCTIBLE tests if an 
expression can appear in $LETREC bindings.}#
  :formals (recv)
)
  
(defclass class_source_generator_device
  :doc #{The internal $CLASS_SOURCE_GENERATOR_DEVICE accumulate C code
  generator devices to test syntactically that they produce good
  enough code. field $SRCGEN_DEFIN gives the definition and
  $SRCGEN_REPR gives the internal representation.}#
  :super class_source
  :fields (srcgen_defin srcgen_repr)
)

(defclass class_source_lazy_macro_expansion
  :doc #{The internal $CLASS_SOURCE_LAZY_MACRO_EXPANSION handles the
  common case of forward reference applications and other stuff. The
  normalization step will actually do the macro expansion. Field
  $SLAZYMACRO_FUN is a closure thunk returning the macro-expanded
  result. $SLAZYMACRO_OPER is the operator, usually a bound name.}#
  :super class_source
  :fields (
	   slazymacro_fun
	   slazymacro_oper
	   ))

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


;;; 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 receiver, $SARGOP_ARGS is the tuple of arguments.}#
  :super class_source_argumented_operator
  :fields ( 
	   msend_selsymb		;the selector symbol
	   msend_recv			;the receiver
	   ))

;;; source primitive invocation
(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
	   ))

(defclass class_source_hook_call
  :doc #{The internal $CLASS_SOURCE_HOOK_CALL is for hook
call abstract syntax. $SHOOK_CALLED is the called hook or hook definition,
$SARGOP_ARGS is the tuple of arguments.}#
  :super class_source_argumented_operator
  :fields (shook_called			;the called hook
	   ))


;;; source arithmetic variadic operation
(defclass class_source_arithmetic_variadic_operation
  :doc #{The internal $CLASS_SOURCE_ARITHMETIC_VARIADIC_OPERATION is
  for expansion of variadic arithmetic operations like + - * /.}#
  :super class_source_argumented_operator
  :fields (sarithvar_neutral
	  sarithvar_primitive))

  
;;; 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
  syntax. $SCOMM_STR is the comment string.}#
  :super class_source
  :fields (scomm_str
	   ))


;; superclass for cheader and cimplement
(defclass class_source_code_string
  :doc #{The internal abstract superclass $CLASS_SOURCE_CODE_STRING is
  for $C_HEADER and $C_IMPLEMENT }#
  :super class_source
  :fields (sc_codestring
	   )
)
;;; source module_is_gpl_compatible
(defclass class_source_module_is_gpl_compatible
  :doc #{The internal $CLASS_SOURCE_MODULE_IS_GPL_COMPATIBLE is for
  $MODULE_IS_GPL_COMPATIBLE syntax.}#
  :super class_source_code_string
  :fields ()
  )

;;;; source cheader
(defclass class_source_cheader
  :doc #{The internal $CLASS_SOURCE_CHEADER is for $C_HEADER abstract
syntax.  $S_CODESTRING gives the code string to add into the
declaration part. }#
  :super class_source_code_string
  :fields ()
)
;;;; source cimplement
(defclass class_source_cimplement
  :doc #{The internal $CLASS_SOURCE_CIMPLEMENT is for $C_IMPLEMENT abstract
syntax.  $S_CODESTRING gives the code string to add into the
implementation part. }#
  :super class_source_code_string
  :fields ()
)


;;;; source use_package_from_pkg_config
(defclass class_source_use_package_from_pkg_config
  :doc #{The internal $CLASS_SOURCE_USE_PACKAGE_FROM_PKG_CONFIG is for
$USE_PACKAGE_FROM_PKG_CONFIG abstract syntax.  $SUSEPACKAGE_PKGTUPLE
gives the tuple of pkg-config package string names. }#
  :super class_source
  :fields (susepackage_pkgtuple
	   )
)

;;;; 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 box
(defclass class_source_quasi_box
  :doc #{The internal super-class $SCLASS_SOURCE_QUASI_BOX is for $BOX and $CONSTANT_BOX abstract syntax. $SBOXED is the boxed stuff.}#
  :super class_source
  :fields (sboxed
	   ))

(defclass class_source_box
  :doc #{The internal $SCLASS_SOURCE_BOX is for $BOX abstract syntax. $SBOXED is the boxed stuff.}#
  :super class_source_quasi_box
  :fields ())

(defclass class_source_constant_box
  :doc #{The internal $SCLASS_SOURCE_CONSTANT_BOX is for $CONSTANT_BOX abstract syntax. $SBOXED is the boxed stuff.}#
  :super class_source_quasi_box
  :fields ())


;;; source unbox
(defclass class_source_unbox
  :doc #{The $CLASS_SOURCE_UNBOX is for $UNBOX abstract
  syntax. $SUNBOX_CTYPE gives the c-type, and $SUNBOX_EXPR gives the
  expression to unbox.}#
  :super class_source 
  :fields (sunbox_ctype
	   sunbox_expr
	   ))




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


(defclass class_source_export_any_macro
  :doc #{The internal $CLASS_SOURCE_EXPORT_ANY_MACRO is for abstract syntax of
$EXPORT_MACRO directives. $SEXPMAC_MNAME is the macro-name,
and $SEXPMAC_DOC is the
documentation.}#
  :super class_source
  :fields (sexpmac_mname
	   sexpmac_doc
	   ))

;; 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 with an explicit expanser.
$SEXPMAC_MVAL is the expanser value.}#
  :super class_source_export_any_macro
  :fields (sexpmac_mval
	   ))

;; export one defined macro - (export_macro <macroname>)
;; beware that the evaluation of the value is done near end of initial routine!
(defclass class_source_export_defmacro
  :doc #{The internal $CLASS_SOURCE_EXPORT_DEFMACRO is for abstract
syntax of $EXPORT_MACRO directives for macros defined with $DEFMACRO.}#
  :super class_source_export_any_macro
  :fields (
	   ))

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

;;;; define a module variable
(defclass class_source_defvar
  :super class_source_definition
  :doc #{The $CLASS_SOURCE_DEFVAR defines a module variable, initialized to the nil value.}#
)

;;;; define a value
(defclass class_source_define
  :super class_source_definition
  :doc #{The $CLASS_SOURCE_DEFINE is for value definitions. Field
 $SDEFINE_BODY is the tuple of expressions of the value bound to
 $SDEF_NAME.}#
  :fields (sdefine_body))

;;; 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, and superclass of abstract syntax of $DEFMACRO.  $SFUN_BODY
  is the body tuple.}#
  :super class_source_definition_formal
  :fields (sfun_body			;body sequence
	   ))


;; define a macro
(defclass class_source_defmacro
  :doc #{The internal $CLASS_SOURCE_DEFMACRO is the abstract syntax of $DEFMACRO. $SMACRO_BINDING is the binding.}#
  :super class_source_defun
  :fields (smacro_binding			;body sequence
	   ))

(defclass class_source_defmacro_in_let
  :doc #{The internal $CLASS_SOURCE_DEFMACRO_IN_LET is for delayed expansion of :macro let bindings.}#
  :super class_source_defmacro
  :fields (smacro_sourceletbinding)
  )

(defclass class_defined_macro_binding
  :doc #{The internal $CLASS_DEFINED_MACRO_BINDING is for macros defined with $DEFMACRO.}#
  :super class_macro_binding
  :fields (
	   mbind_defmacro
	   mbind_data
	   ))

(defclass class_source_macro_installation
  :super class_source
  :doc #{The $CLASS_SOURCE_MACRO_INSTALLATION, for gurus, is an
  internal class used to install macros. $SMACINST_DEFMACRO is the
  macro definition and $SMACINST_ENV is the environment.}#
  :fields (smacinst_defmacro
	   smacinst_env))

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

;; define a hook
(defclass class_source_defhook
  :doc #{The internal $CLASS_SOURCE_DEFHOOK is the abstract syntax for
  $DEFHOOK. Inherited $SFORMAL_ARGS are the input formals, and
  $SHOOK_OUT_FORMALS are the output formals, $SHOOK_CTYPE is the
  result ctype, $SHOOK_PREDEF is the optional predefined slot,
  $SHOOK_VARIABLE is the optional module variable, and $SHOOK_BODY is
  the body. }#
  :super class_source_definition_formal
  :fields (shook_out_formals shook_ctype shook_predef shook_variable shook_body))

;;; 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, $SCITERDEF_BEFORELOC is the location of the before chunk, and $SCRITERDEF_AFTERLOC is the location of the after chunk}#
  :super class_source_definition_formal		;the sformal_args is the start arguments
  :fields (sciterdef_citerator		;the citerator
	   sciterdef_beforeloc		;location of before
	   sciterdef_afterloc		;location of after
	   ))

;;; 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. $SCMATDEF_TESTLOC is the location of the test expansion,
$SCMATDEF_FILLLOC is the location of the fill expansion, and
$SCMATDEF_OPERLOC is the location of the optional operator
expansion.}#
  :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
	   scmatdef_testloc		;location of test expansion
	   scmatdef_fillloc 		;location of fill expansion
	   scmatdef_operloc		;location of operator expansion
	   ))

;;; 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 accessed field.}#
  :super class_source
  :fields (suget_obj	     ;the object expression
	   suget_field	     ;the field 
	   ))


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


;; NOTE [January 2013] We have a buggy match implementation. The
;; DSL2011 paper http://gcc-melt.org/MELT-Starynkevitch-DSL2011.pdf is
;; giving a better match implementation, still unfinished. To ease
;; development of the alternative (and better) match implementation we
;; use the temporary MATCHALT syntax.
(defclass class_source_matchalt 
  :doc #{the internal $CLASS_SOURCE_MATCHALT is temporary, for
  $MATCHALT expressions which should behave like $MATCH. See
  $CLASS_SOURCE_MATCH.}#
  :super class_source_match
  :fields ())

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

;; 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_any_let_binding
  :doc #{The internal $CLASS_SOURCE_ANY_LET_BINDING is abstract syntax for 
  $LET bindings in the source.}#
  :super class_source
  :fields (sletb_binder
	   ))

(defclass class_source_macro_let_binding
  :doc #{The internal $CLASS_SOURCE_MACRO_LET_BINDING is abstract syntax for macro $LET binding in the source.}#
  :super class_source_any_let_binding
  :fields (sletm_macro_formals
	   sletm_macro_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 [of things] 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_any_let_binding
  :fields (sletb_type			;the type of the binding
	   sletb_expr			;the expression
	   ))


(defclass class_source_let_binding_for_macro
  :doc #{The internal $CLASS_SOURCE_LET_BINDING_FOR_MACRO is abstract
  syntax for $LET bindings [of things] in the source. The $SLETB_TYPE
  is $CTYPE_VALUE, the $SLETB_BINDER gives the binder,
  and the $SLETB_EXPR gives the bound lambda-expression. Field
  $SLETM_MACROLETBIND gives the instance of
  $CLASS_SOURCE_MACRO_LET_BINDING.}#
  :super class_source_let_binding
  :fields (sletfm_macroletbind))


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

;; lambda
(defclass class_source_lambda_for_macro
  :doc #{The internal $CLASS_SOURCE_LAMBDA_FOR_MACRO is for abstract
  syntax of macro lambdas. Field $SLAM_ORIGMACRO gives the original
  macro or macrobinding}#
  :super class_source_lambda
  :fields (slam_origmacro)
  )

(defclass class_source_ifvariadic
  :doc #{The internal $CLASS_SOURCE_IFVARIADIC is for abstract syntax of
  $VARIADIC. The $SIFVARIADIC_ARGBIND is the tuple of formals of
  $CLASS_FORMAL_BINDING, and the $SIFVARIADIC_THEN is the tuple of body
  expressions evaluated with the variadics bound, otherwise $SIFVARIADIC_ELSE.}#
  :super class_source
  :fields (sifvariadic_argbind		;tuple for variadic formals
	   sifvariadic_then		;tuple for body
	   sifvariadic_else
	   ))

;; 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, again & 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
	   ))

;; again
(defclass class_source_again
  :doc #{The internal $CLASS_SOURCE_AGAIN is for abstract syntax of
  $AGAIN. $SLABEL_BIND gives the restarted loop label binding.}#
  :super class_source_labelled
  :fields ())

;; 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 time diagnostics
(defclass class_source_compile_diagnostic
  :doc #{The interal abstract $CLASS_SOURCE_COMPILER_DIAGNOSTIC is for
  compile time diagnostic message.}#
  :super class_source
  :fields (scdiag_msg
	   scdiag_expr))

;; compile time warning
(defclass class_source_compile_warning
  :doc #{The interal abstract $CLASS_SOURCE_COMPILER_WARNING is for
  compile time diagnostic message.}#
  :super class_source_compile_diagnostic
  :fields ())
(export_synonym class_source_compilewarning class_source_compile_warning)
;; compile time error
(defclass class_source_compile_error
  :super class_source_compile_diagnostic
  :fields ())

;; the fresh current module environment box, returning the newly build
;; module environment result of the generated initial routine
(defclass class_source_current_module_environment_reference
  :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_reference
  :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 protochunk
(defclass class_source_protochunk
  :super class_source
  :fields (sch_gensym			;generating symbol
	   sch_chunks			;the chunks
))


;; source code chunk
(defclass class_source_codechunk
  :super class_source_protochunk
  :fields (
))

;; source expression chunk
(defclass class_source_exprchunk
  :super class_source_protochunk
  :fields (sxch_ctype
	   ))

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



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; compute the recursive weight of an s-expr (or give :true if too big)
(defun s_expr_weight (topsexpr)
  :doc #{Return some weight of the given sexpr $TOPSEXPR or null if too big}#
  (letrec ( (recweight
	     (lambda (arg :long cum max)
	       (if (is_a arg class_sexpr)
		   (let ( (cont (get_field :sexp_contents arg))
			  (:long contlen (list_length cont))
			  (:long newcum (+i (+i contlen 1) cum))
			  )
		     (if (>i newcum max)
			 (return () newcum)
		       (progn
			 (foreach_pair_component_in_list
			  (cont)
			  (curpair curelem)
			  (multicall
			   (nres :long nw)
			   (recweight curelem newcum max)
			   (setq newcum nw)
			   (if (null nres) (return () newcum))))
			 (return :true newcum))))
		 (return :true cum))))
	    )
    (multicall
     (res :long w)
     (recweight topsexpr 0 6000)
     (if res (make_integerbox discr_constant_integer w) ()))))
	    
		       
		       
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;; first pass, macro expansion


(defun expand_restlist_as_list (arglist env mexpander modctx)
  :doc #{Expand all but the first in an argument list $ARGLIST in
  environment $ENV using expander $MEXPANDER as a list of macro
  expansions.}#
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check arglist" (is_list arglist) arglist)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (expreslist (list)) 
	 (:long count 0)
	 )
    (foreach_pair_component_in_list
     (arglist)
     (curpair curarg)
     (if (>i count 0)
	 (multicall 
	  (curexp xtraexp)
	  (mexpander curarg env mexpander modctx)
	  (cond ( (is_object curexp)
		  (list_append expreslist curexp))
		( (is_list curexp)
		  (list_append2list expreslist curexp))
		( (is_multiple curexp)
		  (foreach_in_multiple
		   (curexp)
		   (curcomp :long cix)
		   (list_append expreslist curcomp)))
		(:else
		 (list_append expreslist curexp)))
	  (cond 
	   ((is_multiple xtraexp)
	    (foreach_in_multiple
	     (xtraexp)
	     (curxtra :long xix)
	     (list_append expreslist curxtra)
	     ))
	   ((is_list xtraexp)
	    (foreach_pair_component_in_list
	     (xtraexp)
	     (xtrapair curxtra)
	     (list_append expreslist curxtra)
	     ))
	   (xtraexp
	    (list_append expreslist xtraexp))
	   )
	  )
       )
     (setq count (+i count 1))
     )
    (return expreslist)
    )
  )

;;expand all but the first element of a list as a tuple
(defun expand_restlist_as_tuple (arglist env mexpander modctx)
  :doc #{$EXPAND_RESTLIST_AS_TUPLE macro-expands all but the first element of a list as a tuple.}#
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check arglist" (is_list arglist) arglist)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (expreslist (expand_restlist_as_list arglist env mexpander modctx))
	 )
    (list_to_multiple expreslist discr_multiple)))



;;expand all of a pairlist as a list
(defun expand_pairlist_as_list (pair env mexpander modctx)
  :doc #{$EXPAND_RESTLIST_AS_TUPLE macro-expands a pair-list as a list.}#
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (expreslist (list)) 
	 )
    (forever exploop
	     (if (not (is_pair pair)) (exit exploop))
	     (let ( (curarg (pair_head pair))
		    )
	       (setq pair (pair_tail pair))
	       (multicall 
		(curexp xtraexp)
		(mexpander curarg env mexpander modctx)
		(cond ( (is_multiple curexp)
			(foreach_in_multiple
			 (curexp)
			 (curcomp :long cix)
			 (list_append expreslist curcomp))
			(void)
			)
		      ( (is_list curexp)
			(foreach_pair_component_in_list
			 (curexp)
			 (curpair curcomp)
			 (list_append expreslist curcomp)
			 )
			(void))
		      (:else
		       (list_append expreslist curexp)))
		(cond 
		 ((is_multiple xtraexp)
		  (foreach_in_multiple
		   (xtraexp)
		   (curxtra :long xix)
		   (list_append expreslist curxtra)
		   ))
		 ((is_list xtraexp)
		  (foreach_pair_component_in_list
		   (xtraexp)
		   (xtrapair curxtra)
		   (list_append expreslist curxtra)
		   ))
		 (xtraexp
		  (list_append expreslist xtraexp))
		 )
		)
	       )
	     )
    (return expreslist)
    )
  )


(defun expand_pairlist_as_tuple (pair env mexpander modctx)
  :doc #{$EXPAND_PAIRLIST_AS_TUPLE macroexpands a pair-list as a tuple.}#
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (if (is_pair pair)
      (let ( (expreslist (expand_pairlist_as_list pair env mexpander modctx))
	     )
	(list_to_multiple expreslist discr_multiple))))


(defun expand_tuple_slice_as_tuple (tuple :long startix endix :value env mexpander modctx)
  :doc #{$EXPAND_TUPLE_SLICE_AS_TUPLE macro-expands in given $TUPLE the slice from $STARTIX to $ENDIX}#
  (debug "expand_tuple_slice_as_tuple tuple=" tuple "\n ... startix#" startix " endix#" endix)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (if (is_multiple tuple)
      (let ( (:long tuplen (multiple_length tuple))
	     (expreslist (make_list discr_list))
	     )
	(if (<i startix 0) (setq startix (+i startix tuplen)))
	(if (<i endix 0) (setq endix (+i endix tuplen)))
	(debug "expand_tuple_slice_as_tuple updated startix=" startix " endix=" endix " tuplen=" tuplen)
	(if (>=i startix 0)
	    (if (<i endix tuplen)
		(when (<=i startix endix)
		  (foreach_long_upto
		   (startix endix)
		   (:long ix)
		   (let ( (curcomp (multiple_nth tuple ix))
			  )
		     (debug "expand_tuple_slice_as_tuple ix#" ix " curcomp=" curcomp)
		     (multicall 
		      (curexp xtraexp)
		      (mexpander curcomp env mexpander modctx)
		      (debug "expand_tuple_slice_as_tuple  ix#" ix " curexp=" curexp " xtraexp=" xtraexp)
		      (list_append expreslist curexp)
		      (cond 
		       ((is_multiple xtraexp)
			(foreach_in_multiple
			 (xtraexp)
			 (curxtra :long xix)
			 (list_append expreslist curxtra)
			 ))
		       ((is_list xtraexp)
			(foreach_pair_component_in_list
			 (xtraexp)
			 (xtrapair curxtra)
			 (list_append expreslist curxtra)
			 ))
		       (xtraexp
			(list_append expreslist xtraexp))
		       )
		      )
		     )
		   )
		  (let ( (restup (list_to_multiple expreslist discr_multiple))
			 )
		    (debug "expand_tuple_slice_as_tuple result=" restup)
		    (return restup)
		    )))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun register_generator_device (defin repr modctx)
  :doc #{Function to register some C generating device in the module
  context, to be able to generate for syntax correctness a dummy
  syntax-testing C function.}# 
  (debug "register_generator_device defin=" defin 
	 "\n* repr=" repr "\n* modctx=" modctx "\n")
  (assert_msg "check defin" (is_a defin class_source_definition) defin)
  (assert_msg "check repr" (is_object repr) repr)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (if (is_a modctx class_any_module_context)
      (let ( (sloc (get_field :loca_location defin))
	     (mgendevlist (get_field :mocx_gendevlist modctx))
	     (gendev (instance class_source_generator_device
			       :loca_location sloc
			       :srcgen_defin defin
			       :srcgen_repr repr))
	     )
	(list_append mgendevlist gendev)
	(debug "register_generator_device gendev=" gendev 
	       "\n* updated mgendevlist=" mgendevlist)
	)))



;;; expand an s-expression known to be an application
(defun expand_apply (sexpr env mexpander modctx)
  (debug "expand_apply" " sexpr=" sexpr " env=" debug_less env)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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 modctx))
	 (xoper (if (is_a soper class_sexpr) 
		    (mexpander soper env mexpander modctx) 
		  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 modctx)
  (debug "expand_msend sexpr=" sexpr "\n.. env=" debug_less env)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check opnam" (is_a opnam class_symbol) opnam)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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_at sloc "missing receiver expression in message passing"_))
    (let ( (xrecv (pair_head spair))
	   (argtup (expand_pairlist_as_tuple (pair_tail spair) env mexpander modctx)) 
	   (res (instance class_source_msend
			  :loca_location sloc
			  :msend_selsymb opnam
			  :msend_recv (if (is_a xrecv class_sexpr)
					  (mexpander xrecv env mexpander modctx)
					xrecv)
			  :sargop_args argtup
			  ))
	   )
      (debug "expand_msend res" res)
      res
      )))



;;; expand an s-expression known to be a safe field access
(defun expand_fieldexpr (fld sexpr env mexpander modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check fld" (is_a fld class_field) fld)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (debug "expand_fieldexpr sexpr" sexpr)
  (let ( (scont (unsafe_get_field :sexp_contents sexpr))
	 (sloc (unsafe_get_field :loca_location sexpr))
	 )
;;;;;;;; this don't work yet on january 25th 2011 svn rev 169278!
;;;;;;;;  ERRORed: unimplemented scan_pattern for pattern  - CLASS_SOURCE_PATTERN_LIST
    ;;     (match scont
    ;; 	   (?(list ?(and ?flnam ?(instance class_keyword))
    ;; 		   ?subexpr)
    ;; 	     (let (
    ;; 		   (mexp (mexpander subexpr env mexpander modctx))
    ;; 		   (res (instance class_source_get_field
    ;; 				  :loca_location sloc
    ;; 				  :suget_obj mexp
    ;; 				  :suget_field fld))
    ;; 		   )
    ;; 	       (debug "expand_fieldexpr result" res)
    ;; 	       (return res)
    ;; 	     ))
    ;; 	   (?_
    ;; 	    (error_plain sloc "bad field expression - expecting (:fieldname <expr>)")
    ;; 	    (return))
    ;; 	   )
    (let ( (scontup (list_to_multiple scont discr_multiple))
	   (operexp (multiple_nth scontup 0))
	   (subsexp (multiple_nth scontup 1))
	   )
      (debug "expand_fieldexpr scontup" scontup)
      (if (!=i (list_length scont) 2)
	  (progn
	    (error_at sloc "expecting one argument in (:field <subexpr>)")
	    (return)))
      (assert_msg "check operexp" (is_a operexp class_keyword) operexp)
      (assert_msg "same operexp as field"
		  (==s (get_field :named_name fld) (get_field :named_name operexp))
		  operexp fld)
      (let ( 
	    (mexp (mexpander subsexp env mexpander modctx))
	    (res (instance class_source_get_field
			   :loca_location sloc
			   :suget_obj mexp
			   :suget_field fld))
	    )
	(debug "expand_fieldexpr result" res)
	(return res)
	))))



    

;; every citeration is (symbol (startargs) (varformals) body...)
;; expand an s-expression known to be a citeration
(defun expand_citeration (citer sexpr env mexpander modctx)
  (debug "expand_citeration sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check citer" (is_a citer class_citerator) citer)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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
	 (newenv (fresh_env env))
	 )
    ;; 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 modctx))
		)
	    (setq stargs (if starexp (tuple
				      (mexpander starexp env mexpander modctx)
				      ))))
	  (setq spair (pair_tail spair))
	  )
      (progn
	(error_at sloc "missing startargs expression in citeration $1"_
		    (unsafe_get_field :named_name citer))
	(return)
	))
    ;; parse the varformals and bind them in the newenv
    (if  (is_pair spair)
	(let ( (varexp (pair_head spair)) )
	  (setq spair (pair_tail spair))
	  (setq varformals (lambda_arg_bindings varexp () env mexpander modctx))
	  )
      (progn
	(error_at sloc "missing varformals in citeration $1"_
		    (unsafe_get_field :named_name citer))
	(return)
	))
    (foreach_in_multiple 
     (varformals)
     (lb :long lix) (put_env newenv lb))
    ;; parse the body in the new environment
    (setq bodytup (expand_pairlist_as_tuple spair newenv mexpander modctx))
    ;; 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 "expand_citeration result sciter" sciter)
      (return sciter)
      )))


;; expand a cmatcher expression
;;; this is for cmatcher in expression contexts (not as patterns!)
(defun expand_cmatchexpr (cmat sexpr env mexpander modctx)
  (debug "expand_cmatchexpr sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check cmat" (is_a cmat class_cmatcher) cmat)
  (assert_msg "check modctx" (is_object modctx))
  (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 modctx))
	 (cmatin (get_field :amatch_in cmat))
	 (cmatout (get_field :amatch_out cmat))
	 (cmatexp (get_field :cmatch_expoper cmat))
	 (cmatname (get_field :named_name cmat))
	 (:long nbxargs (multiple_length xargtup))
	 (:long nbouts (multiple_length cmatout))
	 )
    (debug "expand_cmatchexpr xargtup=" xargtup "\n cmatin=" cmatin
	   "\n cmatout=" cmatout
	   "\n cmat=" cmat)
    (when (!=i nbxargs nbouts)
	  (debug "expand_cmatchexpr bad xargtup=" xargtup
		 "\n bad cmatin=" cmatin
		 "\n bad cmatout=" cmatout)
	  (error_at sloc
			"bad argument number $1 for cmatcher $2 expression wanting $3 outputs"_
			nbxargs cmatname nbouts))
    (when (null cmatexp)
      (error_at sloc
		      "cmatcher $1 used without operation expansion"_
		      cmatname)
	  (return))
    ;; should build a class_source_cmatchexpr
    (let ( (res
	    (instance class_source_cmatchexpr
		      :loca_location sloc
		      :scmatx_cmatcher cmat
		      :sargop_args xargtup)
	    ) )
      (debug "expand_cmatchexpr res" 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 modctx)
  (debug "expand_funmatchexpr sexpr=" sexpr " fmat=" fmat)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check fmat" (is_a fmat class_funmatcher) fmat)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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 "expand_funmatchexpr xargtup" xargtup)
    (debug "expand_funmatchexpr fmatapp" fmatapp)
    (debug "expand_funmatchexpr opbind" 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 "funmatcher result" res)
      (return res)
    )))


;;; expand a keywordfun s-expression
;;; handle stuff like
;;;;; (:fieldname obj) to get a field
(defun expand_keywordfun (soper sexpr env mexpander modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (debug "expand_keywordfun sexpr" sexpr)
  (debug "expand_keywordfun soper" soper)
  (let ( (scont (unsafe_get_field :sexp_contents sexpr))
	 (sloc (unsafe_get_field :loca_location sexpr))
	 (tupcont (list_to_multiple scont discr_multiple))
	 )
    (error_at sloc "expand_keywordfun not implemented"_)
    (assert_msg "@@@  expand_keywordfun NOT IMPLEMENTED" () soper sexpr)
    )
  )



;;;;;;;;;;;;;;;; the main macro expander of one expression
(defun macroexpand_1 (sexpr env mexpander modctx)
  :doc #{Function to macro-expand a single s-expr $SEXPR in
  environment $ENV using the macroexpander $MEXPAND in module context
  $MODCTX. Return the expanded form, subclass of $CLASS_SOURCE, and
  perhaps other such source expansions in a list or tuple secondary
  result.}#
  (debug "macroexpand_1 sexpr=" sexpr "\n.. env=" debug_less env)
  (shortbacktrace_dbg "macroexpand_1" 15)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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 "macroexpand_1 sexpr=" sexpr "\n.. soper" soper)
	(if (melt_call_deeper_than 64)
	    (warning_plain sloc "MELT quite deep macro expansion"))
	(cond 
;;;; first test for keywords, since they are also symbols
	 ( (is_a soper class_keyword)
	   (let ( (resk (expand_keywordfun soper sexpr env mexpander)) )
	     (debug "macroexpand_1 result for keywordfun resk" resk)
	     (return resk ())))
;;;; test for non-keyword symbols...
	 ( (is_a soper class_symbol)
	   (let ( (opbind (find_env env soper)) 
		  (opname (get_field :named_name soper))
		  )
	     (debug "macroexpand_1 opbind=" opbind "; for sloc=" debug_less sloc
		    "\n.. for soper=" soper)
	     (cond ( (is_a opbind class_macro_binding)
		     (let ( (mexp (unsafe_get_field :mbind_expanser opbind)) 
			    )
		       (shortbacktrace_dbg "macroexpand_1 macrobinding" 10)
		       (when (null mexp)
			 (error_at sloc "macro $1 cannot be expanded since not yet defined"_ opname)
			 (return () ()))
		       (debug "macroexpand_1 mexp=" mexp "\n.. sexpr=" sexpr "\n.. env=" debug_less env)
		       (assert_msg "check mexp" (is_closure mexp) mexp)
		       (multicall 
			(resm otherm)
			(mexp sexpr env mexpander modctx)
			(debug "macroexpand_1 result for macro resm=" resm "\n.. otherm=" otherm)
			(cppif MELT_HAVE_DEBUG
			       (if (null resm)
				   (debug "macroexpand_1 null result for macro sexpr=" sexpr)))
			 (return resm otherm)
			 )))
		   ( (is_a opbind class_selector_binding)
		     (let ( (ress (expand_msend soper sexpr env mexpander modctx)) )
		       (debug "macroexpand_1 result for send ress" ress)
		       (return ress ())
		       ))
		   ( (is_a opbind class_primitive_binding)
		     (let ( (resp (expand_primitive (unsafe_get_field :pbind_primitive opbind) 
						    sexpr env mexpander modctx)) )
		       (debug "macroexpand_1 result for primitive resp" resp)
		       (return resp ())
		       ))
		   ( (is_a opbind class_citerator_binding)
		     (let ( (citer (unsafe_get_field :cbind_citerator opbind))
			    (resc (expand_citeration citer sexpr env mexpander modctx))
			    )
		       (debug "macroexpand_1 result for citerator resc=" resc)
		       (return resc ())
		       ))
		   ( (is_a opbind class_hook_binding)
		     (let ( (hookdef (unsafe_get_field :hookbind_defhook opbind))
			    (resc (expand_hook hookdef sexpr env mexpander modctx))
			    )
		       (debug "macroexpand_1 result for hook resc=" resc)
		       (return resc ())
		       ))
		   ( (is_a opbind class_cmatcher_binding)
		     (let ( (cmatch (unsafe_get_field :cmbind_matcher opbind))
			    (resc (expand_cmatchexpr cmatch sexpr env mexpander modctx))
			    )
		       (debug "macroexpand_1 result for cmatcher resc" 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 modctx))
			    )
		       (debug "macroexpand_1 result for funmatcher resf" resf)
		       (return resf ())
		       ))
		   ( (is_a opbind class_field_binding)
		     (let ( (field (unsafe_get_field :flbind_field opbind)) 
			    (resf (expand_fieldexpr field sexpr env mexpander modctx))
			    )
		       (debug "macroexpand_1 result for field resf" resf)
		       (return resf ())
		       ))
		   ;; formals and local variables are always applied.
		   ( (is_a opbind class_formal_binding)
		     (return (expand_apply sexpr env mexpander modctx) ()))
		   ( (is_a opbind class_let_binding)
		     (return (expand_apply sexpr env mexpander modctx) ()))
;;; [imported] value bindings are handled case by case
		   ( (is_a opbind class_value_binding)
		     (let ( (val (unsafe_get_field :vbind_value opbind))
			    )
		       (cond
			( (is_closure val)
			  (return (expand_apply sexpr env mexpander modctx) ())
			  )
			( (is_a val class_primitive)
			  (return (expand_primitive val sexpr env mexpander modctx) ())
			  )
			( (is_hook val)
			  (return (expand_hook val sexpr env mexpander modctx) ())
			  )
			( (is_a val class_selector) 
			  (let ( (ress 
				  (expand_msend soper sexpr env mexpander modctx)) )
			    (debug "macroexpand_1 result for send ress" ress)
			    (return ress ())
			    )
			  )
			( (is_a val class_citerator)
			  (let ( (resc 
				  (expand_citeration val sexpr env mexpander modctx)) )
			    (debug "macroexpand_1 result for send resc" resc)
			    (return resc ())))
			( (is_a val class_cmatcher)
			  (let ( (resc
				  (expand_cmatchexpr val sexpr env mexpander modctx)) )
			    (debug "macroexpand_1 result for cmatch resc" resc)
			    (return resc ())))
			( (is_a val class_funmatcher)
			  (let ( (resf (expand_funmatchexpr val sexpr env mexpander opbind modctx)) )
			    (debug "macroexpand_1 result for funmatch resf" resf)
			    (return resf ())))
			( (is_a val class_field)
			  (let ( (resf (expand_fieldexpr val sexpr env mexpander modctx)) )
			    (debug "macroexpand_1 result for field resf" resf)
			    (return resf ())))
			(:else
			 (error_at sloc "macroexpand_1 bad valued operation symbol $1"_
				     (unsafe_get_field :named_name soper))
			 (inform_strv sloc "macroexpand_1 bad symbol value discr"
				      (unsafe_get_field :named_name (discrim val)))
			 (return () ())
			 )
			))) ;; end if opbind is a value binding
		   ( (and 
		      (null opbind)
		      (not (melt_is_bootstrapping))
		      )
		     (debug "macroexpand_1 null opbind for soper=" soper
			    "; sloc=" sloc
			    "\n.. sexpr=" sexpr
			    "\n.. env=" debug_more env)
		     (shortbacktrace_dbg "macroexpand_1 nullopbind" 15)
		     (let ( (macthunk (lambda ()
					(debug "macroexpand_1 macthunk sloc=" sloc)
					(shortbacktrace_dbg "macroexpand_1 macthunk" 15)
					(mexpander sexpr env mexpander modctx)
					))
			    (lazymac (instance class_source_lazy_macro_expansion
					       :loca_location sloc
					       :slazymacro_fun macthunk
					       :slazymacro_oper soper
					       ))
			    )
		       (debug "macroexpand_1 return lazymac" lazymac
			      "\n.. for sexpr=" debug_less sexpr
			      "\n.. in env=" env)
		       (shortbacktrace_dbg "macroexpand_1 lazymac" 15)
		       (return lazymac ())
		       ))
		   (:else 
		    (if (and 
			 (melt_is_bootstrapping)
			 (null opbind))
			(warning_strv
			 sloc 
			 "forward referenced operator handled as application when bootstrapping MELT"
			 (get_field :named_name soper)
			 ))
		    ;; if opbind is null, we should expand to a class_source_lazy_macro_expansion
		    (let ( (resa (expand_apply sexpr env mexpander modctx))) 
		      (debug "macroexpand_1 result for apply resa" resa)
		      (return resa ())
		      )
		    ))))
	 ;; the empty list is expanded as nil
	 ( (==i (list_length scont) 0)
	   (debug "macroexpand_1 result for null")
	   (return () ()))
	 (:else 
	  (let ( (resca (expand_apply sexpr env mexpander modctx)) )
	    (debug "macroexpand_1 result complex apply resca" resca)
	    (return resca ())
	    ))))
    ;; if the sexpr is not an sexpr return itself
    (progn 
      (debug "macroexpand_1 non-sexpr result sexpr=" sexpr)
      (return sexpr ()))))

;;;;;;;;;;;;;;;;
;;; expand a primitive s-expression
(defun expand_primitive (sprim sexpr env mexpander modctx)
  (assert_msg "check sprim" (is_a sprim class_primitive) sprim)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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 modctx))
	 )
    (instance class_source_primitive
	      :loca_location sloc
	      :sprim_oper sprim
	      :sargop_args xargtup)))

;;; expand a hook s-expression
(defun expand_hook (shook sexpr env mexpander modctx)
  (debug "expand_hook shook=" shook " sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (assert_msg "check shook" (or (is_hook shook) (is_a shook class_source_defhook)) shook)
  (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 modctx))
	 (resh (instance class_source_hook_call
			 :loca_location sloc
			 :sargop_args xargtup
			 :shook_called shook
			 ))
	 )
    (debug "expand_hook gives resh=" resh)
    (return resh ())
))

;;; 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. $PCTX_MODCTX is the module context.}#
  :super class_root
  :fields (pctx_mexpander      	;macroexpander
	   pctx_pexpander      	;pattern expander
	   pctx_varmap	        ;objmap for pattern variables [symbols => srcpattern_variable]
	   pctx_modctx		;module context
	   ))


(defun patternexpand_pairlist_as_tuple (pairlist env pctx psloc)
  (debug "patternexpand_pairlist_as_tuple pairlist" pairlist)
  (let ( (restup (pairlist_to_multiple 
		  pairlist discr_multiple
		  (lambda (x) (patternexpand_1 x env pctx psloc))))
	 )
    (debug "patternexpand_pairlist_as_tuple return restup" 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) matcher)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context) pctx)
  (let ( (mins (unsafe_get_field :amatch_in matcher))
	 (mouts (unsafe_get_field :amatch_out matcher))
	 (mexpander (unsafe_get_field :pctx_mexpander pctx))
	 (modctx (get_field :pctx_modctx pctx))
	 (matname (get_field :named_name matcher))
	 (:long nbmins (multiple_length mins))
	 (:long nbouts (multiple_length mouts))
	 (paircont (instance class_reference :referenced_value pairs))
	 (inargs (multiple_map 
		  mins
		  (lambda (curfbind :long inix)
		    (assert_msg "check curfbind" (is_a curfbind class_formal_binding) curfbind)
		    (let ( (curpair (get_field :referenced_value paircont)) )
		      (if (is_pair curpair)
			  (let ( (curin (pair_head curpair)) )
			    (put_fields paircont :referenced_value (pair_tail curpair))
			    (mexpander curin env mexpander modctx))
			(error_at psloc "missing input argument #$1 for matcher $2"
				    inix matname)
			)))))
	 (outpats (multiple_map
		   mouts 
		   (lambda (curformal :long outix)
		     (let ( (curpair (get_field :referenced_value paircont)) )
		       (if (is_pair curpair)
			   (let ( (curout (pair_head curpair)) )
			     (put_fields paircont :referenced_value (pair_tail curpair))
			     (patternexpand_1 curout env pctx psloc))
			 (error_at psloc "missing output argument #$1 for matcher $2"
				     outix matname)
			 )))))
	 )
    (let ( (curpair (get_field :referenced_value paircont)) )
      (when (is_pair curpair)
	    (debug "extra stuff in patmacexpand_for_matcher" curpair)
	    (error_at psloc "ignored extra sub-{pattern | expression} in matcher"
			matname)))
    (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) 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) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context) pctx)
  (debug "patternexpand_expr sexpr" sexpr)
  (let ( (scont (unsafe_get_field :sexp_contents sexpr))
	 (sloc (unsafe_get_field :loca_location sexpr))
	 (curpair (list_first scont))
	 (soper (pair_head curpair)) )
    (when (is_not_a soper class_symbol)
	  (debug "patternexpand_expr bad soper" soper)
	  (error_at sloc "pattern expression requires symbol operator")
	  (return))
    (let ( (opbind (find_env env soper))
	   (opnam (unsafe_get_field :named_name soper))
	   )
      (debug "patternexpand_expr opbind" opbind)
      (cond 
       ( (null opbind)
	 (error_at sloc "unbound pattern operator $1" opnam)
	 )
       ( (is_a opbind class_patmacro_binding)
	 (let ( (patexp (unsafe_get_field :patbind_expanser opbind)) )
	   (assert_msg "check patexp" (is_closure patexp) patexp)
	   (let ( (resp (patexp sexpr env pctx)) )
	     (debug "patternexpand_expr patmacro so return resp" resp)
	     (return resp)
	     )))
       ( (is_a opbind class_cmatcher_binding)
	 (let ( (cmat (unsafe_get_field :cmbind_matcher opbind)) )
	   (debug "patternexpand_expr cmat" cmat)
	   (assert_msg "check cmat-cher" (is_a cmat class_cmatcher) cmat)
	   (multicall
	    (args pats)
	    (patmacexpand_for_matcher (pair_tail curpair) cmat env sloc pctx)
	    (debug "patternexpand_expr cmatcher args" args)
	    (debug "patternexpand_expr cmatcher pats" 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 "patternexpand_expr cmatcher return pcomp" 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 "patternexpand_expr funmatcher fmat" fmat)
	   (debug "patternexpand_expr funmatcher defm" defm)
	   (debug "patternexpand_expr funmatcher opbind" opbind)
	   (assert_msg "check fmat-cher" (is_a fmat class_funmatcher) fmat)
	   (multicall
	    (args pats)
	    (patmacexpand_for_matcher (pair_tail curpair) fmat env sloc pctx)
	    (debug "patternexpand_expr funmatcher args" args)
	    (debug "patternexpand_expr funmatcher pats" 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 "patternexpand_expr funmatcher return pcomp" pcomp)
	       (return pcomp)
	       )))))
       ;; imported values 
       ( (is_a opbind class_value_binding)
	 (let ( (opval (unsafe_get_field :vbind_value opbind)) )
	   (debug "patternexpand_expr imported opval" opval)
	   (cond 
	    ( (is_a opval class_cmatcher) 
	      (multicall
	       (args pats)
	       (patmacexpand_for_matcher (pair_tail curpair) opval env sloc pctx)
	       (debug "patternexpand_expr imported cmatcher args" args)
	       (debug "patternexpand_expr imported cmatcher pats" 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 "patternexpand_expr imported cmatcher pats again" pats)
		  (debug "patternexpand_expr aouts" aouts)
		  (if (!=i (multiple_length pats) (multiple_length aouts))
		      (warning_at sloc "incompatible number of formal and actual subpatterns of cmatcher $1"
				    (get_field :named_name opval)))
		  (debug "patternexpand_expr cmatcher value pcomp" pcomp)
		  (return pcomp)
		  ))))
	    ( (is_a opval class_funmatcher) 
	      (debug "patternexpand_expr funmatcher value opval" opval)
	      (multicall
	       (args pats)
	       (patmacexpand_for_matcher (pair_tail curpair) opval env sloc pctx)
	       (debug "patternexpand_expr imported funmatcher args" args)
	       (debug "patternexpand_expr imported funmatcher pats" 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 "patternexpand_expr funmatcher value pcomp" pcomp)
		  (return pcomp)
		  ))
	       ))
	    (:else
	     (error_at sloc "invalid pattern operator $1 value" opnam)
	     (return)))))
       (:else
	(error_at sloc
		    "pattern operator $1 badly bound - patternmacro expected"
		    opnam)
	)
       )
      ))
  )

;; pattern expansion
(defun patternexpand_1 (sexpr env pctx psloc)
  (debug "patternexpand_1 start sexpr=" sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context) pctx)
  (cond
   ( (is_a sexpr class_sexpr)
     (let ( (scont (unsafe_get_field :sexp_contents sexpr))
	    (sloc (unsafe_get_field :loca_location sexpr))
	    (modctx (get_field :pctx_modctx pctx))
	    (curpair (list_first scont))
	    (soper (pair_head curpair)) )
       (debug "patternexpand_1 sexpr" sexpr)
       (debug "patternexpand_1 soper" soper)
       (if (!= soper 'question)
	   ;; non-question expr: return the constant pattern with...
	   (let ( (mexpander (unsafe_get_field :pctx_mexpander pctx)) 
		  (exp (mexpander sexpr env mexpander modctx))
		  (pat (instance class_source_pattern_constant
				 :loca_location sloc
				 :pat_weight '1
				 :spat_constx exp))
		  )
	     (debug "patternexpand_1 return const pat" pat)
	     (return pat)
	     )
	 ;; question expr
	 (let ( (parg1 (pair_head (setq curpair (pair_tail curpair)))) )
	   (if (pair_tail curpair)
	       (error_at 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 "patternexpand_1 return jokervar" jokp)
	       (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 "patternexpand_1 return found pavr" 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 "patternexpand_1 return nexpavr" newpavr)
		   (return newpavr))
		 ))
	     )
	    ((is_a parg1 class_sexpr)
	     (debug "patternexpand_1 sexpr parg1=" parg1)
	     (let ( (patex (patternexpand_expr parg1 env pctx sloc)) )
	       (debug "patternexpand_1 return patex" patex)
	       (return patex))
	     )
	    (:else
	     (error_at 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 "patternexpand_1 return const pat as source" pat)
      (return pat)
      ))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; we add an additional hack in toplevel macro-expansion. If an s-expr
;; macroexpands to a tuple or a list, that tuple is handled as several source
;; expressions... In particular, this allows a (load "filename")
;; macro.
(defun macroexpand_toplevel_list (slist env mexpander modctx)
  
  :doc #{The $MACRO_EXPAND_TOPLEVEL_LIST is macro-expanding a list
  $SLIST of top-level S-expressions, in environment $ENV, using the
  macro-expanded $MEXPANDER, in module context $MODCTX. Any such
  top-level S-expressions macroexpanded to nil is silently skipped,
  like $SKIP_NIL does.}#
  (debug "macroexpand_toplevel_list slist=" slist 
	 "\n* mexpander=" mexpander
	 "\n* modctx=" modctx)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check slist" (is_list slist) slist)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (:long slistlen (list_length slist)) 
	 (reslist (make_list discr_list)) 
	 (prevloc ())
	 )
    ;;
    ;;
    (foreach_pair_component_in_list
     (slist)
     (curpair sexp)
     (debug "macroexpand_toplevel_list sexp=" 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"))
     (debug "macroexpand_toplevel_list prevloc=" debug_less prevloc "; sexp=" sexp 
	    "\n... env=" env "\n")
     ;;
     (let ( (sexploc (get_field :loca_location sexp))
	    )
       (multicall
	(mex mxtra)
	(mexpander sexp env mexpander modctx)
	(debug "macroexpand_toplevel_list sexploc=" debug_less sexploc
	       "; mex=" mex "\n.. mxtra=" mxtra)
	;; process the primary result
	(cond
	 ( (null mex)
	   ;; if an S-expression at top level is expanded to nil, that
	   ;; nil is *not* considered.
	   (void)
	   )
	 ( (is_multiple mex)
	   (foreach_in_multiple
	    (mex)
	    (curm :long curix)
	    (list_append reslist curm))
	   )
	 ( (is_list mex)
	   (list_append2list reslist mex))
	 (:else (list_append reslist mex)
		))
	;; handle the secondary result
	(cond
	 ( (null mex)
	   ;; special case, if the primary result of top-level
	   ;; expansion is nil, any secondary result is ignored.
	   (void)
	   )
	 ( (null mxtra)
	   (void))
	 ( (is_multiple mxtra)
	   (foreach_in_multiple
	    (mxtra)
	    (curm :long curix)
	    (list_append reslist curm))
	   )
	 ( (is_list mxtra)
	   (list_append2list reslist mxtra)
	   )
	 (:else
	  (list_append reslist mxtra)))
	))
     )				   ;end foreach_pair_component_in_list
    (debug "macroexpand_toplevel_list reslist=" reslist)
    (let ( (:long reslistlen (list_length reslist))
	   )
      (if (or (<i reslistlen slistlen)
	      (<i reslistlen 2))
	  (code_chunk warnshortreschk
		      #{/*$WARNSHORTRESCHK*/
		      warning(0, "MELT expanded list of %ld s-expressions into short list of %ld source elements",
				 $SLISTLEN, $RESLISTLEN) ;
		      }#))
      )
    (return reslist)
    )
  )


;;; expand an s-expression into a tuple of formal bindings
;;; the formalsexp is the sexpr of formals 
;;; the [optional] argmode should be set :checkargs to check arguments type
;;; usually argmode is just missing
;;; TODO: perhaps consider a :macro argmode also??
(defun lambda_arg_bindings (formalsexp argmode env mexpander modctx)
  ;; special case for null arglist
  (when (null formalsexp)
    (return (make_multiple discr_formal_sequence 0)))
  (assert_msg "check formalsexp" (is_a formalsexp class_sexpr) formalsexp)
  (let ( (:long argrk 0)
	 (argtype ctype_value)
	 (rawarglist (unsafe_get_field :sexp_contents formalsexp))
	 (argloc (unsafe_get_field :loca_location formalsexp))
	 (arglist (expand_pairlist_as_list (list_first rawarglist) env mexpander modctx))
	 (argmap (make_mapobject discr_map_objects (+i 4 (list_length arglist))))
	 (bndlist (make_list discr_list)) 
	 (curpair (list_first arglist))
	 (tupdis discr_formal_sequence)
	 )
    ;; first loop on arg
    (forever argloop
	     (if (null curpair) (exit argloop))
	     (assert_msg "check curpair" (is_pair curpair) curpair)
	     (let ( (curarg (pair_head curpair)) )
	       (cond
		( (== curarg :rest)
		  (setq curpair (pair_tail curpair))
		  (when curpair
		    (error_at argloc ":REST should be last in variadic formals")
		    (return))
		  (setq tupdis discr_variadic_formal_sequence)
		  (void)
		  )
		( (== curarg :auto)
		  (error_at argloc ":AUTO is not permitted in formal arguments")
		  (setq curpair (pair_tail curpair))
		  (void)
		  )
		( (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_at argloc "non-ctype keyword $1 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_at argloc "invalid keyword $1 in formal arglist"_
				(unsafe_get_field :named_name curarg))
		      ())
		     )
		    )
		  (void)
		  )
		( (is_a curarg class_symbol)
		  (if (mapobject_get argmap curarg)
		      (error_at argloc "duplicate argument $1 in formal arglist"_
				(get_field :named_name curarg)))
		  (let ( (curbind
			  (instance class_formal_binding 
				    :binder curarg
				    :fbind_type argtype)) )
		    (if (== argmode :checkargs)
			(if (or (not (is_a argtype class_ctype))
				(not (is_string (unsafe_get_field :ctype_parstring argtype))))
			    (error_at argloc "invalid argument type $1 in formal arglist $2"_
				      (get_field :named_name argtype)
				      (get_field :named_name curarg))))
		    (put_int curbind argrk)
		    (mapobject_put argmap curarg curbind)
		    (list_append bndlist curbind)
		    (setq argrk (+i argrk 1))
		    )
		  (void)
		  )
		( (is_a curarg class_formal_binding)
		  (let ( (cursymb (get_field :binder curarg))
			 )
		    (if (mapobject_get argmap cursymb)
			(error_at argloc "duplicate macro-expanded argument $1 in formal arglist"_
				  (get_field :named_name cursymb)))
		    (put_int curarg argrk)
		    (mapobject_put argmap cursymb curarg)
		    (list_append bndlist curarg)
		    (setq argrk (+i argrk 1))
		    )
		  (void)
		  )
		(:else 
		 (debug "unexpected argument in formal arglist" curarg)
		 (let ( (discrarg  (discrim curarg) ))
		   (error_at argloc "unexpected argument of discriminant $1 in formal arglist"_
			     (unsafe_get_field :named_name discrarg))
		   )
		 (void)
		 ))
	       (setq curpair (pair_tail curpair))))
;;; second loop to fill the bindings tuple
    (let ( (bndtup (make_multiple tupdis argrk)) 
	   (:long ix 0)
	   (bndpair (list_first bndlist))
	   )
      (forever bndloop
	       (if (null bndpair) (exit bndloop))
	       (assert_msg "check bndpair" (is_pair bndpair) bndpair)
	       (let ( (curbnd (pair_head bndpair)) )
		 (assert_msg "check curbnd" (is_a curbnd class_any_binding) curbnd)
		 (multiple_put_nth bndtup ix curbnd)
		 )
	       (setq ix (+i ix 1))
	       (setq bndpair (pair_tail bndpair))
	       )
      (debug "lambda_arg_bindings result bndtup" bndtup)
      (return bndtup)
      )))




;;;;;;;;;;;;;;;; install an initial macro expanser
(defun install_initial_macro (symb expander)
  ;;(debug "install_initial_macro symb" symb)
  (assert_msg "check symb" (is_a symb class_symbol) symb)
  (assert_msg "check expander" (is_closure expander) expander)
  (let ( (mbind (instance class_macro_binding 
			  :binder symb
			  :mbind_expanser expander
			  )) )
    (put_env initial_environment mbind)
    ;;(debug "install_initial_macro done symb" symb)
    (return)
    ))

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



(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) symb)
  (assert_msg "check env" (is_a env class_environment) env)
  (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) flatlist)
  ;;(debug "flatten_for_c_code_expansion comp" comp)
  ;;(debug "flatten_for_c_code_expansion initial flatlist" flatlist)
  (cond    
   ( (null comp)
     ;;(shortbacktrace_dbg "flatten_for_c_code_expansion null comp" 15)
     (error_at 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_pair_component_in_list
      (comp)
      (curpair curcomp)
      ;;(debug "flatten_for_c_code_expansion curcomp in list" curcomp)
      (flatten_for_c_code_expansion loc curcomp flatlist)
      ;;(debug "flatten_for_c_code_expansion done curcomp list" curcomp)
      )
     )
   ( (is_a comp class_sexpr)
     (let ( (subloc (get_field :loca_location comp)) 
	    (subcontent (get_field :sexp_contents comp))
	    )
       (foreach_pair_component_in_list 
	(subcontent)
	(cursubpair cursubcomp)
	;;(debug "flatten_for_c_code_expansion cursubcomp in sexp" cursubcomp)
	(flatten_for_c_code_expansion subloc cursubcomp flatlist)
	;;(debug "flatten_for_c_code_expansion done cursubcomp sexp" cursubcomp)
	))
     )
   (:else
    (shortbacktrace_dbg "flatten_for_c_code_expansion strange comp" 15)
    (error_at loc "unexpected component for C chunk of discriminant $1" 
		(get_field :named_name (discrim comp)))
    )
   )
  ;;(debug "flatten_for_c_code_expansion final flatlist" flatlist)
  )

;; parse a pair list into a C code expansion, perhaps flattening it
(defun parse_pairlist_c_code_expansion (loc curpair)
  (debug "parse_pairlist_c_code_expansion loc" loc)
  (debug "parse_pairlist_c_code_expansion curpair" curpair)
  (let ( (flatlist (make_list discr_list)) )
    (forever 
     comploop
     (if (not (is_pair curpair)) (exit comploop))
     (let ( (pairhd (pair_head curpair)) )
       (debug "parse_pairlist_c_code_expansion loop pairhd" pairhd)
       (flatten_for_c_code_expansion loc pairhd flatlist))
     (setq curpair (pair_tail curpair))
     )
    (debug "parse_pairlist_c_code_expansion flatlist" flatlist)
    (let ( (tupexp (list_to_multiple flatlist discr_multiple)) )
      (debug "parse_pairlist_c_code_expansion tupexp" tupexp)
      (assert_msg "check tupexp" (is_multiple tupexp) 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 :cstring msg)
  (debug "check_c_expansion" " etuple=" etuple " loc=" loc " substmap=" substmap " msg=" msg)
  (shortbacktrace_dbg "check_c_expansion" 15)
  (foreach_in_multiple
   (etuple)
   (ecomp :long ix)
   (debug "check_c_expansion" " ecomp=" ecomp " #ix=" ix)
   (cond 
    ( (null ecomp)
      (error_at loc "null component in C expansion")
      (void)
      )
    ( (is_a ecomp class_keyword)
      (debug "check_c_expansion" " keyword ecomp" ecomp)
      (error_at loc "unexpected keyword $1 in C expansion, $2"
		  (unsafe_get_field :named_name ecomp) msg)
      )
    ( (is_a ecomp class_symbol)
      (if (null (mapobject_get substmap ecomp))
	  (progn
	    (debug "check_c_expansion" " ecomp" ecomp)
	    (error_at loc "unexpected symbol $1 in C expansion, $2"
		      (unsafe_get_field :named_name ecomp) msg)
	    ))
      ()
      )
    ( (is_string ecomp)
      ()
      )
    (:else 
     (warning_strv loc "unexpected C expansion component of " 
		   (get_field :named_name (discrim ecomp)))
     ()
     ))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;; register the melt_translate_run_macroexpansions_list
(defvar melt_transrunmacro_clos)
(defun melt_register_translator_runner_macroexpansions (clos)
  :doc #{$MELT_REGISTER_TRANSLATOR_RUNNER_MACROEXPANSIONS is an
  internal utility to enable forward reference to
  melt_translate_run_macroexpansions_list defined in
  @file{warmelt-outobj.melt}.}#
  (debug "melt_register_translator_runner_macroexpansions clos=" clos)
  (shortbacktrace_dbg "melt_register_translator_runner_macroexpansions" 15)
  (assert_msg "check clos" (or (is_closure clos) (null clos)) clos)
  (setq melt_transrunmacro_clos clos)
)


;; invoke the melt_translate_run_macroexpansions_list from warmelt-outobj.melt
(defun melt_invoke_translator_runner_macroexpansions (lismexp env modctx)
  (debug "melt_invoke_translator_runner_macroexpansions lismexp=" lismexp "\n.. env=" env 
	 "\n.. modctx=" modctx)
  (shortbacktrace_dbg "melt_invoke_translator_runner_macroexpansions" 32)
  (let ( (clos melt_transrunmacro_clos)
	 )
    (unless (is_closure clos)
      (error_at () "MELT has invalid macro translating running macroexpansions function - corruption")
      (return))
    (when (>i (melt_error_counter) 0)
      (error_at () "MELT won't translate running macroexpansions since got errors")
      (return))
    (debug "melt_invoke_translator_runner_macroexpansions melt_transrunmacro_clos=" clos
	   "\n... env=" debug_less env "\n... modctx=" debug_less modctx)
    (assert_msg "check clos" (is_closure clos) clos)
    (assert_msg "check lismexp" (is_list lismexp) lismexp)
    (let ( (res (clos lismexp env modctx))
	   )
    (when (>i (melt_error_counter) 0)
      (error_at () "MELT got errors after translate running macroexpansions")
      (return))
      (debug "melt_invoke_translator_runner_macroexpansions res=" res)
      (return res))))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;; macro expansers

;;; (defprimitive name bindings :type [:doc documentation] expansion...)
;; the defprimitive expander
(defun mexpand_defprimitive (sexpr env mexpander modctx)
  (debug "mexpand_defprimitive sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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_at loc "missing symbol for (DEFPRIMITIVE symb args type  [:doc documentation] expansion...)"_))
    (setq curpair (pair_tail curpair))
    ;; parse the formal arguments and check that they are not variadic
    (let ( (btup (lambda_arg_bindings (pair_head curpair) () env mexpander modctx))
	   )
      (when (is_a btup discr_variadic_formal_sequence)
	    (error_at 
	     loc
	     "(DEFPRIMITIVE $1 ...) cannot have variadic formals, but ending with :REST"
	     (get_field :named_name symb))
	    (return)
	    )
      (setq curpair (pair_tail curpair))
      ;; parse the type keyword
      (let ( (typkw  (pair_head curpair)) )
	(when (is_not_a typkw class_keyword)
	    (error_at loc "missing type keyword for (DEFPRIMITIVE $1 <args> <type> [:doc documentation] expansion...)"_ (get_field :named_name symb))
	    (return))
	(let ( (cty (unsafe_get_field :symb_data typkw)) 
	       (typknam (unsafe_get_field :named_name typkw))
	       )
	  (when (is_not_a cty class_ctype)
		(debug "mexpand_defprimitive bad cty" typkw)
		(error_at loc "bad type keyword $1 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 "prefered ctype is" (get_field :named_name (get_field :ctype_keyword cty)))
		  )
		(:else
		 (debug "mexpand_defprimitive strange typkw" typkw)
		 (error_at loc "invalid type keyword $1 for DEFPRIMITIVE"_
			     typknam)
		 (return ())   
		 ))
	  ;; parse the rest as to be expanded
	  (setq curpair (pair_tail curpair))
	  (when (== (pair_head curpair) ':doc)
	    (setq curpair (pair_tail curpair))
	    (if docv (error_at loc "duplicate :doc in DEFPRIMITIVE"))
	    (setq docv (pair_head curpair))
	    (setq curpair (pair_tail curpair))
	    )
	  (let (
		(curhead (pair_head curpair))
		(exploc (or (get_field :loca_location curhead) loc))
		(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
			   :sprim_exploc exploc))
		(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) curbind)
	     (mapobject_put substmap (get_field :binder curbind) curbind)
	     )
	    (debug "defprimitive primit" primit)
	    (check_c_expansion etuple loc substmap)
	    ;;
	    (warn_if_redefined symb env loc)
	    (put_env env pbind)
	    (debug "mexpand_defprimitive registering device sdefpri=" sdefpri " primit=" primit)
	    (register_generator_device sdefpri primit modctx)
	    (debug "mexpand_defprimitive result sdefpri" 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 modctx)
  (debug "mexpand_defciterator sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (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))
	 (symbname (get_field :named_name symb))
	 ;; 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
	 (befloc ())		     ;location of before chunk
	 (aftloc ())		     ;location of after chunk
	 )
    (when (is_not_a symb class_symbol)
      (error_at 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) () env mexpander modctx))
    (setq curpair (pair_tail curpair))
    (setq statsymb (pair_head curpair))
    (when (is_not_a statsymb class_symbol)
      (error_at loc 
		"missing statsymb for (DEFCITERATOR $1 startformals statesymb locformals expbefore expafter)"_ symbname)
      (return))
    (when (is_a bstartup discr_variadic_formal_sequence)
	  (error_at loc
		    "(DEFCITERATOR $1 startformals...) cannot have variadic start formals"_ symbname)
	  (return))
    ;; parse the formal local arguments
    (setq curpair (pair_tail curpair))
    (setq blocvtup  (lambda_arg_bindings (pair_head curpair) () env mexpander modctx))
    (when (is_a blocvtup  discr_variadic_formal_sequence)
      (error_at loc
		"(DEFCITERATOR $1 startformals state localformals...) cannot have variadic local formals" symbname)
      (return))
    (setq curpair (pair_tail curpair))
    ;; parse the documentation, if any
    (when (== (pair_head curpair) ':doc)
      (setq curpair (pair_tail curpair))
      (if docv (error_at loc
			 "duplicate documentation in DEFCITERATOR $1" symbname))
      (setq docv (pair_head curpair))
      (setq curpair (pair_tail curpair)))
    ;; parse the before expansion
    (let ( (sexpbef (pair_head curpair)) )
      (when (is_not_a sexpbef class_sexpr)
	    (error_at loc
		      "missing before expansion for  (DEFCITERATOR $1 startformals statesymb locformals expbefore expafter)"_ 
		      symbname)
	    (return))
      (setq befloc (get_field :loca_location sexpbef))
      (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)) )
      (when (is_not_a sexpaft class_sexpr)
	    (error_at loc 
		      "missing after expansion for  (DEFCITERATOR $1 startformals statesymb locformals expbefore expafter)"_ 
		      symbname)
	    (return))
      (setq aftloc (get_field :loca_location sexpaft))
      (setq expaft  (parse_pairlist_c_code_expansion loc (list_first (unsafe_get_field :sexp_contents sexpaft))))
      )
    ;; parse the documentation, if any
    (if (== (pair_head curpair) ':doc)
	(progn
	  (setq curpair (pair_tail curpair))
	  (if docv (error_at loc
			     "duplicate documentation in DEFCITERATOR $1"_ symbname))
	  (setq docv (pair_head curpair))
	  (setq curpair (pair_tail curpair))))
    ;; 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
			    :sciterdef_beforeloc befloc
			    :sciterdef_afterloc aftloc
			    ))
	   (substmap (make_mapobject 
		      discr_map_objects
		      (+i 7 (+i (*i 2 (multiple_length bstartup))
				(*i 2 (multiple_length blocvtup))))))
	   ) ;; fill the substmap
      (debug "srcit citer" srcit)
      (mapobject_put substmap statsymb statsymb)
      (debug "bstartup citer" bstartup)
      (foreach_in_multiple
       (bstartup)
       (cursbind :long bsix)
       (assert_msg "check start cursbind" (is_a cursbind class_formal_binding) cursbind)
       (mapobject_put substmap (get_field :binder cursbind) cursbind))
      (debug "blocvtup citer" blocvtup)
      (foreach_in_multiple
       (blocvtup)
       (curlbind :long blix)
       (debug "curlbind local citer" curlbind)
       (assert_msg "check local curlbind" (is_a curlbind class_any_binding) curlbind)
       (mapobject_put substmap (get_field :binder curlbind) curlbind))
;;; check the expansions
      (check_c_expansion expbef loc substmap "DEFCITERATOR before")
      (check_c_expansion expaft loc substmap "DEFCITERATOR after")
      ;; fill the citerator binding
      (unsafe_put_fields citbind :cbind_citerdef srcit)
      (put_env env citbind)
      (debug "mexpand_defciterator registering device srcit=" srcit " citer=" citer)
      (register_generator_device srcit citer modctx)
      (debug "mexpand_defciterator parsed citerator citer" 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 modctx)
  (debug "mexpand_defcmatcher sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (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))
	 (symbname (get_field :named_name symb))
	 ;; 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 ())			;documentation
	 (loctest ())			;location of test
	 (locfill ()) 			;location of fill
	 (locoper ())			;location of oper
	 )
    ;; check the symb
    (debug "mexpand_defcmatcher symb" symb)
    (when (is_not_a symb class_symbol)
      (error_at
       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) () env mexpander modctx))
	   (:long nbmatinformals (multiple_length matinformals)) 
	   )
      (when (<i nbmatinformals 1)
	(error_at loc 
		  "empty ins for (DEFCMATCHER $1 <ins> <outs> <statesym> <test> <fill> <oper>)"_ symbname)
	(return))
      (when (is_a matinformals discr_variadic_formal_sequence)
	(error_at loc 
		  "(DEFCMATCHER $1 <ins> ...) cannot have variadic input formals"_ symbname)
	(return)
	)
      (setq sformals matinformals)
      (setq matchformal (multiple_nth matinformals 0))
      (debug "mexpand_defcmatcher matchformal" matchformal)
      (assert_msg "check matchformal" (is_a matchformal class_formal_binding) matchformal)
      (setq informals (make_multiple discr_multiple (-i nbmatinformals 1)))
      (foreach_in_multiple 
       (matinformals)
       (comp :long ix) (if (>i ix 0) (multiple_put_nth informals (-i ix 1) comp)))
      (debug "mexpand_defcmatcher informals" informals)
      )
    ;; parse the out formals
    (setq curpair (pair_tail curpair))
    (setq outformals (lambda_arg_bindings (pair_head curpair) () env mexpander modctx))
    (debug "mexpand_defcmatcher outformals" outformals)
    (when (not (is_multiple outformals))
      (error_at loc "bad outs for (DEFCMATCHER $1 <ins> <outs> <statesym> <test> <fill> <oper>)"_ symbname)
      (return))
    (when (is_a outformals discr_variadic_formal_sequence)
      (error_at loc "out formals for  (DEFCMATCHER $1 <ins> <outs> ...) cannot be variadic" symbname)
      (return))
    ;; parse the state symbol
    (setq curpair (pair_tail curpair))
    (setq statesym (pair_head curpair))
    (when (is_not_a statesym class_symbol)
      (debug "mexpand_defcmatcher bad statesym" statesym)
      (error_at loc "bad statesym for (DEFCMATCHER $1 <ins> <outs> <statesym> <test> <fill> <oper>)"_ symbname)
      (return))
    (debug "mexpand_defcmatcher statesym" statesym)
    (setq curpair (pair_tail curpair))
    ;; parse the documentation if any
    (when (== (pair_head curpair) ':doc)
      (setq curpair (pair_tail curpair))
      (if docv (error_at  loc "duplicate documentation in DEFCMATCHER $1" symbname))
      (setq docv (pair_head curpair))
      (setq curpair (pair_tail curpair))
      )
    ;; parse the test expansion
    (let ( (sexptest (pair_head curpair)) )
      (when (and sexptest (is_not_a sexptest class_sexpr))
	(debug "mexpand_defcmatcher bad sexptest" sexptest)
	(error_at loc "bad test expansion in (DEFCMATCHER $1 <ins> <outs> <statesym> <test> <fill> <oper>)"_ symbname)
	(return))
      (setq loctest (or (get_field :loca_location sexptest) loc))
      (if sexptest
	  (setq exptest 
		(parse_pairlist_c_code_expansion 
		 loc
		 (list_first (unsafe_get_field :sexp_contents sexptest)))))
      )
    (debug "mexpand_defcmatcher exptest" exptest)
    ;; parse the fill expansion
    (setq curpair (pair_tail curpair))
    (let ( (sexpfill (pair_head curpair)) )
      (when (and sexpfill (is_not_a sexpfill class_sexpr))
	(error_at loc "bad fill expansion in (DEFCMATCHER $1 <ins> <outs> <statesym> <test> <fill> <oper>)"_ symbname)
	(return))
      (setq locfill (or (get_field :loca_location sexpfill) loc))
      (if sexpfill
	  (setq expfill
		(parse_pairlist_c_code_expansion 
		 loc (list_first (unsafe_get_field :sexp_contents sexpfill)))))
      )
    (debug "mexpand_defcmatcher expfill" expfill)
    ;; parse the operate expansion
    (setq curpair (pair_tail curpair))
    (let ( (sexpoper (pair_head curpair)) )
      (when (and sexpoper (is_not_a sexpoper class_sexpr))
	(error_at loc "bad oper expansion in (DEFCMATCHER $1 <ins> <outs> <statesym> <test> <fill> <oper>)"_ symbname)
	(return))
      (setq locoper (or (get_field :loca_location sexpoper) loc))
      (setq expoper
	    (if sexpoper
		(parse_pairlist_c_code_expansion loc (list_first (unsafe_get_field :sexp_contents sexpoper)))))
      )
    (debug "mexpand_defcmatcher expfill" expoper)
    ;; 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) matchformal)
    ;; 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
				 :scmatdef_testloc loctest
				 :scmatdef_fillloc locfill
				 :scmatdef_operloc locoper)) 
	  (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) curibind)
       (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) curobind)
       (mapobject_put substmap (get_field :binder curobind) curobind))
      ;; check the expansions
      (check_c_expansion exptest loc substmap "DEFCMATCHER test")
      (check_c_expansion expfill loc substmap "DEFCMATCHER fill")
      (check_c_expansion expoper loc substmap "DEFCMATCHER operation")
      (debug "mexpand_defcmatcher sdefcmatch" sdefcmatch)
      (put_env env cmbind)
      (debug "mexpand_defcmatcher registering device sdefcmatch=" sdefcmatch " cmatch=" cmatch)
      (register_generator_device sdefcmatch cmatch modctx)
      (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 modctx)
  (debug "mexpand_defunmatcher sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (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))
	 (symbname (get_field :named_name symb))
	 ;; 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 "mexpand_defunmatcher symb" symb)
    (when (is_not_a symb class_symbol)
      (error_at
       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) () env mexpander modctx))
	   (:long nbmatinformals (multiple_length matinformals)) 
	   )
      (when (<i nbmatinformals 1)
	(error_at loc "empty ins for (DEFUNMATCHER $1 <ins> <outs> [:doc docum] <matchfun> <applyfun> [<data>])"_ symbname)
	(return))
      (when (is_a matinformals discr_variadic_formal_sequence)
	(error_at loc "(DEFUNMATCHER $1  <ins> ...) inputs cannot be variadic with last :rest formal"
		  symbname)
	(return)
	)
      (setq sformals matinformals)
      (setq matchformal (multiple_nth matinformals 0))
      (debug "mexpand_defunmatcher matchformal" matchformal)
      (setq informals (make_multiple discr_multiple (-i nbmatinformals 1)))
      (foreach_in_multiple 
       (matinformals)
       (comp :long ix) (if (>i ix 0) (multiple_put_nth informals (-i ix 1) comp)))
      (debug "mexpand_defunmatcher informals" informals)
      )
    ;; parse the out formals
    (setq curpair (pair_tail curpair))
    (setq outformals (lambda_arg_bindings (pair_head curpair) () env mexpander modctx))
    (when (not (is_multiple outformals))
      (error_at loc "bad outs for (DEFUNMATCHER $1 <ins> <outs>[:doc docum]  <matchfun> <applyfun> [<data>])"_ symbname)
      (return))
    (when (is_a outformals discr_variadic_formal_sequence)
      (error_at loc "(DEFUNMATCHER $1  <ins> <outs> ...) outputs cannot be variadic with last :rest formal"
		symbname)
      (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 (mexpander mfa env mexpander modctx))
	(error_at loc "bad matchfun for (DEFUNMATCHER $1 <ins> <outs> <matchfun> <applyfun> [<data>])"_ symbname))
      )
    (debug "mexpand_defunmatcher matchfunx" matchfunx)
    ;; parse & macroexpand the applyfun expr if given
    (setq curpair (pair_tail curpair))
    (let ( (afa (pair_head curpair)) )
      (if afa
	  (setq applyfunx (mexpander afa env mexpander modctx))
	;; apply function is optional, can be missing.
	)
      )
    (debug "mexpand_defunmatcher applyfunx" applyfunx)
    ;; parse & macroexpand the data expr
    (setq curpair (pair_tail curpair))
    (let ( (dta (pair_head curpair)) )
      (if dta
	  (setq datax (mexpander dta env mexpander modctx))
	;; data is optional, so no error if missing
	))
    (debug "mexpand_defunmatcher datax" datax)
    ;; check for no extra stuff
    (setq curpair (pair_tail curpair))
    (if curpair 
	(error_at loc "extra for (DEFUNMATCHER $1 <ins> <outs> <matchfun> [<applyfun> [<data>]])"_ symbname))
    (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 "mexpand_defunmatcher made fuma" fuma)
      (debug "mexpand_defunmatcher fmbind" fmbind)
      (debug "mexpand_defunmatcher return sdfum" 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 modctx)
  (debug "mexp.defun sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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))
	 (symbname (get_field :named_name symb))
	 (newenv (fresh_env env))
	 (docv ())
	 (fbind 
	  (instance class_function_binding
		    :binder symb
		    :fubind_defun ()	;to be filled later
		    ))
	 )
    (if (is_not_a symb class_symbol)
	(error_plain loc "missing symbol for DEFUN"_))
    (warn_if_redefined symb env loc)
    (put_env env fbind)
    (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) :checkarg env mexpander modctx))
		  (:else
		   (debug "mexpand_defun strange arglist curpairhead" curpairhead)
		   (error_at loc "missing or invalid arglist for DEFUN $1"_ symbname)
		   ()
		   )))
	   )
      (when (not (is_multiple btup))
	    (debug "mexpand_defun strange btup" btup)
	    (error_at loc "missing formal arguments for DEFUN $1"_ symbname))
      (foreach_in_multiple (btup) (fb :long bix) (put_env newenv fb))
      (setq curpair (pair_tail curpair))
      ;; handle the optional :doc documentationvalue
      (when (== (pair_head curpair) ':doc)
	    (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 modctx)) 
	     (sdefun
	      (instance class_source_defun
			:loca_location loc
			:sdef_name symb
			:sdef_doc docv
			:sformal_args btup
			:sfun_body bodytup
			))
	     )
	(put_fields fbind :fubind_defun sdefun)
	(unless (multiple_length bodytup)
	  (error_at loc "missing or empty body for DEFUN $1" symbname))
	(return 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.}#)


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

;; this magic function should expand and compile all the macro definitions of maclist

(defun melt_delayed_macro_expander (mbind maclist env mexpander modctx)
  (debug "melt_delayed_macro_expander mbind=" mbind "\n.. maclist=" maclist
	 "\n.. env=" env
	 "\n.. mexpander=" mexpander
	 "\n.. old-mocx_macrolist=" (get_field :mocx_macrolist modctx) 
	 "\n.. modctx=" debug_less modctx)
  (shortbacktrace_dbg "melt_delayed_macro_expander" 12)
  (assert_msg "check maclist" (is_list maclist) maclist)
  (block_signals 
   () ()
   (put_fields modctx :mocx_macrolist (make_list discr_list)))
  ;;
  (let ( (macroenv (get_field :mocx_macroenv modctx))
	 )
  (debug "melt_delayed_macro_expander maclist=" maclist "\n.. env=" debug_more env
	 "\n.. macroenv=" debug_more macroenv 
	 "\n.. modctx=" debug_less modctx
	 "\n.. mbind=" debug_less mbind "\n")
  (assert_msg "check macroenv" (is_a macroenv class_environment) macroenv)
  (let ( (res (melt_invoke_translator_runner_macroexpansions maclist macroenv modctx))
	 )
    (debug "melt_delayed_macro_expander final res=" res
	   "\n mbind=" mbind)
    )))

;;;;;;;;;;;;;;;;;; the defmacro expander
;;;(DEFMACRO macroname formals [:doc documentation] body...)
(defun mexpand_defmacro (sexpr env mexpander modctx)
  (debug "mexpand_defmacro sexpr=" sexpr "\n.. modctx=" modctx
	 "\n.. env=" env "\n")
  (shortbacktrace_dbg "mexpand_defmacro" 15)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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))
	 (symbname (get_field :named_name symb))
	 (modinienv (get_field :mocx_initialenv modctx))
	 (modmacroenv (get_field :mocx_macroenv modctx))
	 (maclist (get_field :mocx_macrolist modctx))
	 (newenv (fresh_env modmacroenv))
	 (docv ())
	 (mbind 
	  (instance class_defined_macro_binding
		    :binder symb
		    :mbind_expanser ()	;to be filled later
		    ))
	 (fbind 
	  (instance class_function_binding
		    :binder symb
		    :fubind_defun ()	;to be filled later
		    ))
	 )
    (debug "mexpand_defmacro loc=" debug_less loc "; modmacroenv=" modmacroenv "\n.. newenv=" newenv
	   "\n.. mbind=" mbind)
    (when (is_not_a symb class_symbol)
      (debug "mexpand_defmacro bad symb=" symb " in sexpr=" sexpr)
      (error_at loc "missing symbol for DEFMACRO"_)
      (return))
    (when (null modinienv)
      (error_at loc "DEFMACRO $1 prohibited in cold bootstrap of warmelt-first file"
		symbname)
      (assert_msg "unexpected DEFMACRO in code bootstrap of warmelt-first file" ())
      (return))
    (when (not (is_list maclist))
      (error_at loc "DEFMACRO $1 requires a module context with macro list" symbname)
      (assert_msg "bad maclist in DEFMACRO" () maclist)
      (return))
    (warn_if_redefined symb env loc)
    (put_env env mbind)
    (warn_if_redefined symb newenv loc)
    (put_env modmacroenv fbind)
    (debug "mexpand_defmacro loc=" debug_less loc "; updated env=" debug_more env)
    (debug "mexpand_defmacro loc=" debug_less loc "; updated modmacroenv=" debug_more modmacroenv)
    (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) :checkarg env mexpander modctx))
		  (:else
		   (debug "mexpand_defmacro strange arglist curpairhead" curpairhead)
		   (error_at loc "missing or invalid arglist for DEFMACRO $1"_ symbname)
		   ()
		   )))
	   )
      (debug "mexpand_defmacro loc=" loc "; btup=" btup)
      (when (not (is_multiple btup))
	(error_at loc "missing formal arguments for DEFMACRO $1"_ symbname)
	(return))
      (foreach_in_multiple 
       (btup) 
       (fb :long bix) 
       (put_env newenv fb))
      (debug "mexpand_defmacro loc=" loc "; updated newenv=" debug_more newenv)
      (setq curpair (pair_tail curpair))
      ;; handle the optional :doc documentationvalue
      (when (== (pair_head curpair) ':doc)
	(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
	)
      (debug "mexpand_defmacro initial mbind=" mbind "\n.. modctx=" modctx "\n")
      ;; should put a :mbind_expanser closure into mbind
      ;; handle the body
      (let ( (bodytup (expand_pairlist_as_tuple curpair newenv mexpander modctx))
	     (sdefmacro
	      (instance class_source_defmacro
			:loca_location loc
			:sdef_name symb
			:sdef_doc docv
			:sformal_args btup
			:sfun_body bodytup
			:smacro_binding mbind
			))
	     (sinstmacro
	      (instance class_source_macro_installation
			:loca_location loc
			:smacinst_defmacro sdefmacro
			:smacinst_env modmacroenv
			))
	     )
	(debug "mexpand_defmacro loc=" loc "; bodytup=" bodytup "\n.. newenv=" newenv)
	(debug "mexpand_defmacro loc=" loc "; sdefmacro=" sdefmacro "\n.. sinstmacro=" sinstmacro)
	(when (not (is_list maclist))
	  (error_at loc "macros, i.e. DEFMACRO, are forbidden in this module $1" 
		    (get_field :mocx_modulename modctx))
	  (return))
	(put_fields mbind :mbind_defmacro sdefmacro)
	(debug "mexpand_defmacro loc=" loc "; sdefmacro=" sdefmacro "\n old maclist=" maclist 
	       "\n.. modulname=" (get_field :mocx_modulename modctx))
	(debug "mexpand_defmacro loc=" loc "; sinstmacro=" sinstmacro)
	(assert_msg "check maclist" (is_list maclist) maclist)
	(list_append maclist sinstmacro)
	(debug "mexpand_defmacro loc=" loc "; updated maclist=" maclist)
	(put_fields fbind :fubind_defun sdefmacro)
	(debug "mexpand_defmacro loc=" loc "; updated fbind=" fbind
	       "\n.. mbind=" mbind)
	;; we should put a :mbind_expanser closure into mbind
	(put_fields mbind 
		    :mbind_expanser 
		    (lambda (sexprm envm mexpanderm modctxm)
		      (debug "mexpand_defmacro/lambdambind loc=" loc "; sexprm=" sexprm
			     "\n.. envm=" envm
			     "\n.. modctxm=" modctxm "\n")
		      (shortbacktrace_dbg "mexpand_defmacro/lambdambind" 15)
		      (assert_msg "check modctxm" (== modctxm modctx) modctxm modctx)
		      (debug "mexpand_defmacro/lambdambind loc=" loc "; env=" debug_less env 
			     "\n.. envm=" debug_less envm
			     "\n.. newenv=" debug_less newenv
			     "\n.. modinienv=" debug_less modinienv)
		      (let ( (oldmclos (get_field :mbind_expanser mbind))
			     (locm (get_field :loca_location sexprm))
			     )
			(debug "mexpand_defmacro/lambdambind before melt_delayed_macro_expander mbind=" mbind)
			(melt_delayed_macro_expander mbind maclist envm mexpanderm modctx)
			(debug "mexpand_defmacro/lambdambind after melt_delayed_macro_expander mbind=" mbind)
			(assert_msg "check mbind" (is_a mbind class_defined_macro_binding) mbind)
			(let ( (mclos (get_field :mbind_expanser mbind))
			       )
			  (debug "mexpand_defmacro/lambdambind mclos=" mclos "\n.. sexprm=" sexprm)
			  (assert_msg "check mclos" (is_closure mclos) mclos)
			  (when (== oldmclos mclos)
			    (error_at locm "failed to macro-expand macro $1" symbname)
			    (warning_at loc "failed to expand macro $1 defined here" symbname)
			    (return)
			    )
			  (multicall 
			   (expmac othermac)
			   (mclos sexprm envm mexpanderm modctxm)
			   (debug "mexpand_defmacro/lambdambind expmac=" expmac " othermac=" othermac)
			   (return expmac othermac)
			   )
			  ))))
	(debug "mexpand_defmacro loc=" loc "; final mbind=" mbind "\n.. final fbind=" fbind
	       "\n.. sdefmacro=" sdefmacro)
	(return sdefmacro)
	))))

(install_initial_macro 'defmacro mexpand_defmacro)
(export_macro defmacro mexpand_defmacro
	      :doc #{The $DEFMACRO macro defines a macro. Syntax
is ($DEFMACRO @var{funame} @var{formals} [:doc @var{documentation}]
@var{body}...). At most four @var{formals} are permitted of ctype
@code{:value}, for the @var{s-expression} invoking the macro, the
@var{environment} at macro-expansion time, the current
@var{macro-expander} closure and at last the @var{module context}.}#)


;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;; the hook to install a macro
(defhook hook_macro_installer (mbind mexpclos)
  ()
  :void
  :predef HOOK_MACRO_INSTALLER
  :doc #{The internal $HOOK_MACRO_INSTALLER is installing macro, during a translation}#
  (debug "hook_macro_installer" " mbind=" mbind " mexpclos=" mexpclos)
  (shortbacktrace_dbg "hook_macro_installer" 16)
  (assert_msg "check mbind" (is_a mbind class_defined_macro_binding) mbind)
  (assert_msg "check mexpclos" (is_closure mexpclos) mexpclos mbind)
  (put_fields mbind :mbind_expanser mexpclos)
  (debug "hook_macro_installer updated mbind=" mbind)
  )

;;;;;;;;;;;;;;;;;; the at_macro_expansion expander
;;;(AT_MACRO_EXPANSION  body...)
(defun mexpand_at_macro_expansion (sexpr env mexpander modctx)
  (debug "mexpand_at_macro_expansion sexpr=" sexpr "\n.. modctx" debug_less modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (modinienv (get_field :mocx_initialenv modctx))
	 (modmacroenv (get_field :mocx_macroenv modctx))
	 (maclist (get_field :mocx_macrolist modctx))
	 (curpair (pair_tail (list_first cont)))
	 (bodytup (expand_pairlist_as_tuple curpair modmacroenv mexpander modctx))
	 )
    (debug "mexpand_at_macro_expansion bodytup=" bodytup "\n.. modinienv=" modinienv "\n.. maclist=" maclist)
    (when (not (is_list maclist))
      (error_at loc "macros, i.e. AT_MACRO_EXPANSION, are forbidden in this module $1" 
		(get_field :mocx_modulename modctx))
      (return))
    (assert_msg "check bodytup" (is_multiple bodytup) bodytup)
    (foreach_in_multiple 
     (bodytup)
     (curbody :long bodix)
     (debug "mexpand_at_macro_expansion bodix#" bodix " curbody=" curbody)
     (list_append maclist curbody))
    (debug "mexpand_at_macro_expansion updated maclist=" maclist)
    (return ())
    ))
(install_initial_macro 'at_macro_expansion mexpand_at_macro_expansion)
(export_macro at_macro_expansion mexpand_at_macro_expansion
	      :doc #{The $AT_MACRO_EXPANSION macro will evaluate its
 body, e.g. containing @code{defun} or @code{definstance}
 at macro-expansion time. In particular, functions used
 inside a $DEFMACRO should be defined inside
 $AT_MACRO_EXPANSION and are not available in ordinary
 code.}#)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;; the defvar expander
;;;(DEFVAR varname [:doc documentation])
(defun mexpand_defvar (sexpr env mexpander modctx)
  (debug "mexpand_defvar sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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))
	 (symbname (get_field :named_name symb))
	 (newenv (fresh_env env))
	 (docv ())
	 (vbind 
	  (instance class_variable_binding
		    :binder symb
		    ))
	 )
    (when (is_not_a symb class_symbol)
	(error_at loc "missing symbol for DEFVAR"_)
	(return))
    (warn_if_redefined symb env loc)
    (put_env env vbind)
    (setq curpair (pair_tail curpair))
      ;; handle the optional :doc documentationvalue
    (when (== (pair_head curpair) ':doc)
	    (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
	    )
    ;; check that no body is given
    (when curpair
      (error_at loc "DEFVAR too long - expecting (DEFVAR $1 [:doc <doc>])"
		  symbname)
      (return))
    (let ( (sdefvar (instance class_source_defvar
			      :loca_location loc 
			      :sdef_name symb
			      :sdef_doc docv
			      ))
	   )
      (debug "mexpand_defvar sdefvar=" sdefvar)
      (return sdefvar)
    )))
(install_initial_macro 'defvar mexpand_defvar)
(export_macro defvar mexpand_defvar
	      :doc #{The $DEFVAR macro defines a module variable,
initialized to the nil value. Syntax 
is ($DEFVAR @var{varame} [:doc @var{documentation}]).}#)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; the defhook expander
(defun mexpand_defhook (sexpr env mexpander modctx)
  (debug "mexpand_defhook sexpr=" sexpr " modctx=" modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (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))
	 (symbname (get_field :named_name symb))
	 (sycname (symbol_cname symb))
	 (intup ())			;formal input tuple
	 (outup ())			;formal output tuple
	 (restypkw ())			;the ctype keyword of result
	 (resctyp ())			;the ctype of result
	 (predefv ())			;optional :predef
	 (modvar ())			;optional :var
	 (docv ())			;optional :doc
	 (hbind (instance class_hook_binding
			  :binder symb
			  :hookbind_defhook ()
			  :hookbind_descr ())) ;to be filled later
	 (newenv (fresh_env env))
	 )
    (when (is_not_a symb class_symbol)
      (error_plain loc 
		   "missing symbol for (DEFHOOK <symb> <informals> <outformals> <ctype-key> [:predef <predef>] [:doc <doc>] <body....>)")
      (return))
    (when (>=i (string_length sycname)
	      (expr_chunk maxlen_chk :long #{/*mexpand_defhook $MAXLEN_CHK*/MELT_HOOKNAME_LEN}#))
      (error_at loc
		  "too long cname '$1' for symbol of DEFHOOK $2" sycname symbname)
      (return))
    (setq curpair (pair_tail curpair))
    (warn_if_redefined symb env loc)
    ;; parse the formal input arguments
    (setq intup 
	  (let ( (insexp (pair_head curpair))
		 )
	    (debug "mexpand_defhook insexp=" insexp)
	    (cond ( (is_a insexp class_sexpr)
		    (lambda_arg_bindings insexp :checkarg env mexpander modctx))
		  ( (null insexp)
		    (make_multiple discr_multiple 0))
		  (:else
		    (error_at 
		     loc
		     "bad input formals for  (DEFHOOK $1 <informals> <outformals> <ctype-key> ...)"
		     symbname)
		    (return)))))
    (debug "mexpand_defhook intup=" intup)
    (when (is_a intup  discr_variadic_formal_sequence)
      (error_at loc "DEFHOOK $1 cannot have variadic input formals" symbname)
      (return))
    (setq curpair (pair_tail curpair))
    ;; parse the formal output arguments
    (setq outup 
	  (let ( (outsexp (pair_head curpair))
		 )
	    (debug "mexpand_defhook outsexp=" outsexp)
	    (cond ( (is_a outsexp class_sexpr)
		    (lambda_arg_bindings outsexp :checkarg env mexpander modctx))
		  ( (null outsexp)
		    (make_multiple discr_multiple 0))
		  (:else
		    (error_at 
		     loc
		     "bad output formals for  (DEFHOOK $1 <informals> <outformals> <ctype-key> ...)"
		     symbname)
		    (return)))))
    (debug "mexpand_defhook outup=" outup)
    (when (is_a outup  discr_variadic_formal_sequence)
      (error_at loc "DEFHOOK $1 cannot have variadic output formals" symbname)
      (return))
    (setq curpair (pair_tail curpair))
    ;; parse the type keyword
    (setq restypkw (pair_head curpair))
    (when (is_not_a restypkw class_keyword)
      (error_at loc "DEFHOOK $1 needs a ctype keyword after output formals" symbname)
      (return))
    (let ( (cty (unsafe_get_field :symb_data restypkw))
	   )
      (when (is_not_a cty class_ctype)
      (error_at loc "DEFHOOK $1 with bad ctype keyword after output formals" symbname)
      (return))
      (setq resctyp cty))
    (setq curpair (pair_tail curpair))
    ;; handle :predef
    (when (== (pair_head curpair) ':predef)
      (setq curpair (pair_tail curpair))
      (if predefv (error_at loc "duplicate :predef in DEFHOOK $1" symbname))
      (setq predefv (pair_head curpair))
      (setq curpair (pair_tail curpair))
      )
    ;; handle :var
    (when (== (pair_head curpair) ':var)
      (setq curpair (pair_tail curpair))
      (if modvar (error_at loc "duplicate :VAR in DEFHOOK $1" symbname))
      (setq modvar (pair_head curpair))
      (setq curpair (pair_tail curpair))
      (when (is_not_a modvar class_symbol)
	(error_at loc "DEFHOOK $1 should have a symbol :VAR" symbname)
	(return))
      )
    ;; handle :doc
    (when (== (pair_head curpair) ':doc)
      (setq curpair (pair_tail curpair))
      (if docv (error_at loc "duplicate :doc in DEFHOOK $1" symbname))
      (setq docv (pair_head curpair))
      (setq curpair (pair_tail curpair))
      )
    ;; update the env & newenv
    (put_env env hbind)
    (foreach_in_multiple
     (intup)
     (inbnd :long inix)
     (warn_if_redefined (get_field :binder inbnd) env loc)
     (put_env newenv inbnd))
    (foreach_in_multiple
     (outup)
     (outbnd :long outix)
     (warn_if_redefined (get_field :binder outbnd) env loc)
     (put_env newenv outbnd))
    ;; parse the rest as to be expanded 
    (let ( (bodytup (expand_pairlist_as_tuple curpair newenv mexpander modctx)) 
	   (sdefhook
	    (instance class_source_defhook
		      :loca_location loc
		      :sdef_name symb
		      :sdef_doc docv
		      :sformal_args intup
		      :shook_out_formals outup
		      :shook_ctype resctyp
		      :shook_predef predefv
		      :shook_variable modvar
		      :shook_body bodytup
		      ))
	   )
      (put_fields hbind :hookbind_defhook sdefhook)
      (debug "mexpand_defhook result sdefhook=" sdefhook "\n hbind=" hbind)
      (return sdefhook)
      )))
(install_initial_macro 'defhook mexpand_defhook)
(export_macro defhook mexpand_defhook
 :doc #{The $DEFHOOK macro defines hooks, that is arbitrary C/C++
 routines coded in MELT.. Syntax is @code{(DEFHOOK @var{hook-name}
 @var{input-formals} @var{output-formals} @var{ctype} [:var
 @var{hook-var}] [:predef @var{hook-predef}] [:doc
 @var{documentation}] @var{body...})}. This binds @var{hook-name} to a
 generated hook value of $DISCR_HOOK discriminant, containing a
 pointer to the generated C/C++ routine and closed values, like
 functions and instances mentionned inside the @var{body}, etc... This
 generates an @code{extern "C"} C/C++ routine named
 @code{melthook_@var{hook-name}}, return a result of given @var{ctype},
 and with formal arguments: the hook value itself, the input formals,
 the pointers to output formals (which can be modified in the body
 with $SETQ).  If @var{hook-var} is given with a @code{:var}
 annotation, it should be a module variable defined with $DEFVAR, and
 that module variable is assigned to the hook value. Then, a C/C++
 routine named @code{melthookproc_@var{hook-name}} is emitted, taking
 only the input and output formals, and passing that module variable
 as the hook. And similarily for predefined hooks with their
 @var{hook-predef}.}#)







;;;;;;;;;;;;;;;;;; the define expander
;;;(DEFINE name [:doc documentation] expr ...)
 ;; same as defun, Scheme syntax sugar:
;;;(DEFINE (name formals...) [:doc documentation] expr ...)
(defun mexpand_define (sexpr env mexpander modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (curelem (pair_head curpair))
	 )
    (debug "mexpand_define start sexpr" sexpr)
    (cond 
     ;;
     ;; case (DEFINE name ...)
     ((is_a curelem class_symbol)
      (let ( 
	    (defname curelem)
	    (defdoc ())
	    (defvalbind (instance class_defined_value_binding
				  :binder defname
				  :defvalbind_define () ;filled below
				  ))
	    )
	(warn_if_redefined defname env loc)
	(put_env env defvalbind)
	(setq curpair (pair_tail curpair))
	;; consume the doc
	(if (== (pair_head curpair) ':doc)
	    (progn
	      (setq curpair (pair_tail curpair))
	      (setq defdoc (pair_head curpair))
	      (setq curpair (pair_tail curpair))))
	;;
	(let ( 
	      (bodytup (expand_pairlist_as_tuple curpair env mexpander modctx))
	      (sdefine (instance class_source_define
				 :loca_location loc
				 :sdef_name defname
				 :sdef_doc defdoc
				 :sdefine_body bodytup
				 ))
	      )
	  (put_fields defvalbind  :defvalbind_define sdefine)
	  (setq curpair (pair_tail curpair))
	  (debug "mexpand_define simple value bodytup=" bodytup " sdefine=" sdefine)
	  (return sdefine)
	  )))
     ;;
     ;; case (DEFINE (name formals ...) [:doc <docstr>] ...)
     ((is_a curelem class_sexpr)
      (let ( (floc (unsafe_get_field :loca_location curelem))
	     (fcont (unsafe_get_field :sexp_contents curelem))
	     (funame (pair_head (list_first fcont)))
	     (cursubpair (pair_tail (list_first fcont)))
	     (formaltup (lambda_arg_bindings cursubpair :checkarg env mexpander modctx))
	     (defdoc ())
	     (fbind (instance class_function_binding
			      :binder funame
			      :fubind_defun () ;to be filled later
			      ))
	     )
	;; check the funame
	(when (is_not_a funame class_symbol)
	  (error_at loc 
		    "Bad function name, expecting (DEFINE (name formals...) ...")
	  (return))
	(warn_if_redefined funame env loc)
	(put_env env fbind)
	;; consume the doc
	(when (== (pair_head curpair) ':doc)
	  (setq curpair (pair_tail curpair))
	  (setq defdoc (pair_head curpair))
	  (setq curpair (pair_tail curpair)))
	;;
	(let ( 
	      (newenv (fresh_env env))
	      (sdefun
	       (instance class_source_defun
			 :loca_location loc
			 :sdef_name funame
			 :sdef_doc defdoc
			 :sformal_args formaltup
			 :sfun_body ()	;filled later
			 ))
	      (formal0bind (multiple_nth formaltup 0))
	      )
	  ;; check that the first formal, if given, is a :value
	  (if formal0bind
	      (if (!= (get_field :fbind_type formal0bind) ctype_value)
		  (progn
		    (debug "mexpand_define function bad formal0bind=" formal0bind)
		    (error_at floc "invalid first formal argument in DEFINE-d function $1, expecting a :value"
			      (get_field :named_name funame))
		    (return))))
	  ;; bind the formals and expand the body
	  (foreach_in_multiple (formaltup) (fb :long fbix) (put_env newenv fb))
	  (let ( (bodytup (expand_pairlist_as_tuple curpair newenv mexpander modctx)) 
		 )
	    (put_fields sdefun :sfun_body bodytup)
	    (debug "mexpand_define function return sdefun" sdefun)
	    (return sdefun)
	    ))))
     ;;
     ;; bad DEFINE
     (:else
      (error_at loc "Expects <name> or (<name> <formals) after DEFINE")
      (return)
      ))
    ))

(install_initial_macro 'define mexpand_define)
(export_macro define mexpand_define
	      :doc #{The $DEFINE macro defines a named non-recursive
value.  Syntax (like in Scheme) is 
($DEFINE @var{name} [:doc @var{documentation}] @var{expr} ...) to define a value, and
($DEFINE (@var{funame} @var{formals}...) [:doc @var{documentation}]  @var{expr} ...) 
to define a function like $DEFUN does. Use $EXPORT_VALUES to make that name visible outside its module.}#)

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

;; internal routine with multiple results to scan the defclass
(defun scan_defclass (sexpr env mexpander modctx)
  (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))
	 (claname (get_field :named_name symb))
	 )
    (debug "scan_defclass sexpr" sexpr)
    (if (is_not_a symb class_symbol)
	(error_at 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_at loc "expecting keyword in DEFCLASS $1"_ claname))
	       (setq curpair (pair_tail curpair))
	       (let ( (curval (pair_head curpair)) )
		 (setq curpair (pair_tail curpair))
		 (cond 
		  ( (== curkw ':super)
		    (if supernam (error_at loc "duplicate super in DEFCLASS $1"_ claname))
		    (if (not (is_a curval class_symbol))
			(error_at loc "bad super in DEFCLASS $1"_ claname))
		    (setq supernam curval)
		    (debug "scan_defclass supernam" 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_at loc "super $1 is not a class in DEFCLASS $2"_ 
					      (get_field :named_name supernam) claname)))
			      )
			    (:else 
			     (debug "scan_defclass superb=" superb " env" env)
			     (error_at loc "invalid super in DEFCLASS $1"_
					 (unsafe_get_field :named_name supernam))
			     )
			    )
		      ))
		  ( (== curkw ':fields)
		    (if fieldnams (error_at loc "duplicate fields in DEFCLASS $1"_ claname))
		    (if curval
			(if (is_not_a curval class_sexpr)
			    (error_at loc "bad fields in DEFCLASS $1"_ claname)))
		    (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_at namloc "non name field #$1 in DEFCLASS $2"_ (+i ix 1) claname))
				 (multiple_put_nth namtupl ix curnam)
				 )
			       (setq nampair (pair_tail nampair))
			       (setq ix (+i ix 1))
			       )
		      (setq fieldnams namtupl)
		      ))
		  ( (== curkw ':predef)
		    (if predef (error_at loc "duplicate predef in DEFCLASS $1"_ claname))
		    (setq predef (mexpander curval env mexpander modctx))
		    (cond
		     ( (is_integerbox predef) 
		       ()
		       )
		     ( (is_a predef class_symbol)
		       ()
		       )
		     (:else
		      (error_at loc "bad predef in DEFCLASS $1"_ claname)
		      )
		     )
		    )
		  ( (== curkw ':doc)
		    (if docv (error_at loc "duplicate doc in DEFCLASS $1"_ claname))
		    ;; the documentation is NOT macro-expanded!
		    (setq docv curval)
		    )
		  (:else
		   (error_at loc "invalid keyword $1 in DEFCLASS $2"_ 
			       (unsafe_get_field :named_name curkw) claname)
		   )
		  ))))
    (debug "scan_defclass returns symb=" symb " loc=" loc)
    (debug "scan_defclass returns supernam=" supernam " superbinds=" superbind " superclass=" superclass)
    (debug "scan_defclass returns predef=" predef " fieldnams=" fieldnams " fieldsloc=" fieldsloc)
    (debug "scan_defclass returns docv" docv)
    (warn_if_redefined symb env loc)
    (return symb loc supernam superbind superclass predef fieldnams fieldsloc docv)
    ))


(defun mexpand_defclass (sexpr env mexpander modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (debug "mexp.defclass sexpr" sexpr)
  (multicall 
   (symb loc supernam superbind superclass predef fieldnams fieldsloc docv)
   (scan_defclass sexpr env mexpander modctx)
   (debug "mexp.defclass scanned symb=" symb" loc=" loc)
   (debug "mexp.defclass scanned supernam=" supernam " superbind=" superbind " superclass=" superclass)
   (debug "mexp.defclass scanned predef=" predef)
   (debug "mexp.defclass scanned fieldnams=" fieldnams " fieldsloc=" fieldsloc)
   (debug "mexp.defclass scanned docv=" docv)
   (assert_msg "check symb" (is_a symb class_symbol) symb)
   (let ( (claname (get_field :named_name symb))
	  )
     (and (null predef)
	  (null superclass)
	  (error_at loc 
		    "DEFCLASS $1 of a non-predefined class without superclass"
		    claname)
	  )
     (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) superclass)
			    (assert_msg "check superancestors" (is_multiple superancestors) 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 "expdefclas superfields" superfields)
       (foreach_in_multiple 
	(superfields)
	(sfld :long ix)
	(assert_msg "check superfield" (is_a sfld class_field) sfld)
	(multiple_put_nth fieldtup ix sfld)
	(mapstring_putstr fieldstrmap (unsafe_get_field :named_name sfld) sfld)
	)
;;;
       (foreach_in_multiple
	(fieldnams)
	(fldnam :long 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_at fieldsloc "duplicate field $1 in DEFCLASS $2"_ fldstr claname))
	  (cond
	   ( (null fldprevbind)
	     (void)
	     )
	   ( (is_a fldprevbind class_field_binding)
	     (debug "mexpand_defclass fldprevbind !field" fldprevbind)
	     (error_at fieldsloc "field name $1 already defined in DEFCLASS $2"_ fldstr claname)
	     )
	   ( (is_a fldprevbind class_value_binding)
	     (debug "mexpand_defclass fldprevbind !value" fldprevbind)
	     (debug "mexpand_defclass symb !value" symb)
	     (let ( (prevalue (get_field :vbind_value fldprevbind))
		    )
	       ;; this test avoids warnings when recompiling
	       ;; warmelt-*.melt files
	       (if (or (is_not_a prevalue class_field)
		       (!=s (get_field :named_name (get_field :fld_ownclass prevalue))
			    (get_field :named_name symb)))
		   (warning_at fieldsloc "field name $1 already bound to a value in DEFCLASS $2"_ fldstr claname)
		 )))
	   (:else
	    (debug "mexpand_defclass fldprevbind !other" fldprevbind)
	    (warning_at  fieldsloc "field name $1 previously bound in DEFCLASS $2"_ fldstr claname))
	   )
	  (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 "mexp.defclass newclass=" 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 modctx)
  (debug "start parse_field_assignment cla" cla)
  (debug "start parse_field_assignment loc" loc)
  (debug "start parse_field_assignment fldkw" fldkw)
  (when (is_not_a fldkw class_keyword)
	(error_plain loc "expecting :fieldname in field assignment"_)
	(return)
	)
  (assert_msg "check fldkw" (is_a fldkw class_keyword) fldkw)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  ;; expr is an sexpr or a symbol or a string or ...
  (let ( (fld ()) 
	 (fldkwnam (get_field :named_name fldkw))
	 )
    ;; if we have a class, find the field inside
    (if (is_a cla class_class)
	(let ( (clafields (unsafe_get_field :class_fields cla)) 
	       )
	  (debug "parse_field_assignment clafields" clafields)
	  (multicall 
	   (foundfld :long ix :value foundname)
	   (multiple_iterate_test
	    clafields
	    (lambda (curfld :long ix)
	      (assert_msg "check fld" (is_a curfld class_field) fld)
	      (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 "parse_field_assignment found curfld" curfld)
		   (debug "parse_field_assignment found curfldnam" curfldnam)
		   (return () curfldnam))
		 (:else
		  ;; did not found the field, so return true
		  (return :true ()))))))
	   (if foundfld
	       (progn
		 (debug "parse_field_assignment return foundfld" foundfld)
		 (setq fld foundfld))))))
    (debug "parse_field_assignment after class scanning fld" fld)
    (if (null fld)
	;; othewise, find the field by its bound name
	(let ( 
	       (fldnam (create_symbolstr fldkwnam)) 
	       )
	  (debug "parse_field_assignment fldnam" fldnam)
	  (assert_msg "check fldnam symb" (is_a fldnam class_symbol) fldnam)
	  (let ( (fldbind (find_env env fldnam)) )
	    (debug "parse_field_assignment fldbind" fldbind)
	    (cond 
	     ( (null fldbind)
	       (error_at loc "unknown field name $1 in field assignment"_ 
			   fldkwnam)
	       (return)
	       )
	     ( (is_a fldbind class_field_binding)
	       (setq fld (unsafe_get_field :flbind_field fldbind) )
	       (debug "parse_field_assignment found fld in field binding" fld)
	       )
	     ( (is_a fldbind class_value_binding)
	       (let ( (vfld (unsafe_get_field :vbind_value fldbind)) )
		 (debug "parse_field_assignment has vfld" 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)
		       (when (!=s vfldnam kwnam)
			 ;; this happen when a field is used by its synonym
			 (warning_at loc "obsolete use of synonym field $1, better use $2 " kwnam vfldnam))
			 (debug "parse_field_assignment gives vfld" vfld)
		       vfld)) ))
	     (:else
	      (error_at loc "bad field name $1 in field assignment"_
			  fldkwnam)
	      (return)
	      ))
	    (debug "parse_field_assignment fld from environment" fld)
	    )))			  
    ;;end when fld has to be found in the environment
    (assert_msg "check fld" (is_a fld class_field) fld)
    (let ( (xex (mexpander expr env mexpander modctx)) 
	   (fa (instance class_source_fieldassign 
			 :loca_location loc
			 :sfla_field fld
			 :sfla_expr xex
			 ))
	   )
      (debug "parse_field_assignment return fa" fa)
      (return fa))
    ))

;; the definstance expanser
(defun mexpand_definstance (sexpr env mexpander modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (debug "mexp.definstance sexpr" 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_at loc "missing symbol for DEFINSTANCE"_))
    (setq curpair (pair_tail curpair))
    (let ( 
	  (symbname (get_field :named_name symb))
	  (nam (pair_head curpair)) 
	  (ibind 
	   (instance class_instance_binding
		     :binder symb
		     :ibind_iclass (); filled later
		     ))
	  )
      (warn_if_redefined symb env loc)
      (put_env env ibind)
      (if (is_not_a nam class_symbol)
	  (error_at loc "missing class name for DEFINSTANCE $1"_ symbname))
      (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_at loc "invalid class name $1 for DEFINSTANCE $2"_
		      (unsafe_get_field :named_name nam) symbname)
	  (return ())
	  ))
	(setq claname nam)
	(assert_msg "check cla" (is_a cla class_class) cla)
	(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_at loc "expecting keyword in DEFINSTANCE $1"_ symbname))
		   (setq curpair (pair_tail curpair))
		   (let ( (curexp (pair_head curpair)) )
		     (cond  ( (== curfkw ':obj_num)
			      (if objnum (error_at loc "duplicate :obj_num in DEFINSTANCE $1"_ symbname))
			      (setq objnum 
				    (if (is_a curexp class_sexpr)
					(mexpander curexp env mexpander modctx)
				      curexp))
			      )
			    ( (== curfkw ':predef)
			      (if predef (error_at loc "duplicate :predef in DEFINSTANCE $1"_ symbname))
			      (setq predef 
				    (if (is_a curexp class_sexpr)
					(mexpander curexp env mexpander modctx)
				      curexp))
			      )
			    ( (== curfkw ':doc)
			      (if docv (error_at loc "duplicate :doc in DEFINSTANCE $1"_ symbname))
			      (setq docv curexp)
			      )
			    (:else 
			     (let  ( (flda 
				      (parse_field_assignment cla loc curfkw curexp env mexpander modctx)) )
			       (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
			  ))
	       )
	  (put_fields ibind :ibind_iclass cla)
	  (debug "mexp.definstance sinst" 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 modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (debug "mexp.definstance sexpr" 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 ())
	 )
    (when (is_not_a symb class_symbol)
	  (error_at loc "missing symbol for (DEFSELECTOR <name> <class> ...)"_)
	  (return))
    (setq curpair (pair_tail curpair))
    (let (
	  (symbname (get_field :named_name symb))
	  (nam (pair_head curpair)) 
	  (selbind (instance class_selector_binding
			      :binder symb
			      :sbind_selectordef (); filled later
			      ))
	   )
      (when (is_not_a nam class_symbol)
	(error_at loc "missing class name for (DEFSELECTOR $1 <class> ...)"_ symbname)
	(return))
      (warn_if_redefined symb env loc)
      (put_env env selbind)
      ;;
      (setq claname nam)
      (debug "mexpand_defselector claname" claname)
      (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)))
	 ((notnull bnd)
	  (debug "mexpand_defselector faulty bnd" bnd)
	  (error_at loc "invalid class name $1 for (DEFSELECTOR $2 <class> ...)"_
		      (unsafe_get_field :named_name claname) symbname)
	  (return))
	 (:else
	  (error_at loc "unknown class name $1 for (DEFSELECTOR $2 <class> ...)"_
		      (unsafe_get_field :named_name claname) symbname)
	  (return)
	  ))
	;;
	(debug "mexpand_defselector cla" cla)
	(when (not (subclass_or_eq cla class_selector))
	  (debug "mexpand_defselector class_selector=" class_selector)
	  (error_at loc "invalid class $1 in (DEFSELECTOR $2 <class>); expecting CLASS_SELECTOR or its subclass"_
		    (unsafe_get_field :named_name claname) symbname)
	  (return))
	;;
	(assert_msg "check cla" (is_a cla class_class) cla)
	(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_at loc "expecting keyword in DEFSELECTOR $1"_ symbname))
		   (setq curpair (pair_tail curpair))
		   (let ( (curexp (pair_head curpair)) )
		     (cond  ( (== curfkw ':obj_num)
			      (if curexp (error_at loc "duplicate :obj_num in DEFSELECTOR $1"_ symbname))
			      (setq objnum 
				    (if (is_a curexp class_sexpr)
					(mexpander curexp env mexpander modctx)
				      curexp))
			      )
			    ( (== curfkw ':predef)
			      (if curexp (error_at loc "duplicate :predef in DEFSELECTOR $1"_ symbname))
			      (setq predef 
				    (if (is_a curexp class_sexpr)
					(mexpander curexp env mexpander modctx)
				      curexp))
			      )
			    ( (== curfkw ':doc)
			      (if docv (error_at loc "duplicate :doc in DEFSELECTOR $1"_ symbname))
			      (setq docv curexp)
			      )
			    ( (== curfkw ':formals)
			      (if formals (error_at loc "duplicate :formals in DEFSELECTOR $1"_ symbname))
			      ;; curfkw is non-null so we ask the
			      ;; arguments to be checked by
			      ;; lambda_arg_bindings
			      (setq formals (lambda_arg_bindings curexp :checkarg env mexpander modctx))
			      (let ( (firstf (multiple_nth formals 0)) )
				(cond
				 ( (null firstf)
				   (error_at loc 
					     ":formals of DEFSELECTOR $1 should have at least one value argument for the receiver"_ 
					     symbname))
				 ( (!= (get_field :fbind_type firstf) ctype_value)
				   (error_at loc "first :formals of DEFSELECTOR $1 should be a :value"_ symbname))
			      )))
			    (:else 
			     (let  ( (flda (parse_field_assignment cla loc curfkw curexp env mexpander modctx)) )
			       (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
			      ))
	       )
	  (put_fields selbind :sbind_selectordef res)
	  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 modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (let ( (fields ())
	 (fieldnams ())
	 (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (clasymb (pair_head curpair))
	 (cla ())
	 (clabind ())
	 )
    (debug "mexpand_instance start sexpr" sexpr)
    (if (is_not_a clasymb class_symbol)
	(error_plain loc "missing class symbol for INSTANCE"_))
    (let ( (bnd (find_env env clasymb)) 
	   (fldlist (make_list discr_list))
	   (claname (get_field :named_name clasymb))
	   )
      (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_at loc "invalid class name for INSTANCE $1"_
		    claname)
	(return ())
	))
      (debug "mexpand_instance cla" cla)
      (assert_msg "check cla" (is_a cla class_class) cla)
      (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_at loc "expecting keyword in INSTANCE $1"_ claname))
		 (setq curpair (pair_tail curpair))
		 (let ( (curexp (pair_head curpair)) )
		   (let  ( (flda 
			    (parse_field_assignment cla loc curfkw curexp env mexpander modctx)) )
		     (debug "mexpand_instance flda" flda)
		     (if flda 
			 (list_append fldlist flda)
		       (error_at loc "bad field name $1 in INSTANCE $2"_
				   (unsafe_get_field :named_name curfkw) claname)
		       ))))
	       (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 modctx)
  (debug "mexpand_load start sexpr=" sexpr "\n.. env=" env)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (shortbacktrace_dbg "mexpand_load" 25)
  (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 (mexpander filnam env mexpander modctx)))
    (if (is_a filnam class_named)
	(setq filnam (unsafe_get_field :named_name filnam)))
    (debug "mexpand_load" " loc=" loc "; filnam=" filnam)
    (cond 
     ( (is_string filnam)
       (inform_strv loc "MELT loading file " filnam)
       (let ( (curead (read_file filnam)) )
	 (debug "mexpand_load"" curead=" curead)
	 (let ( (explist (macroexpand_toplevel_list curead env mexpander modctx)) 
		(exptuple (list_to_multiple explist discr_multiple))
		)
	   (debug "mexpand_load" " explist=" explist)	   
	   (shortbacktrace_dbg "mexpand_load" 10)
	   (debug "mexpand_load" " return exptuple=" exptuple)
	   (return exptuple)
	   )
	 )
       )
     (:else
      (debug "mexpand_load strange filnam" 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>).}#)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mexpand_skip_nil (sexpr env mexpander modctx)
  (debug "mexpand_skip_nil" " start sexpr=" sexpr "\n.. env=" env)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (reslist (make_list discr_list))
	 (explist (expand_restlist_as_tuple cont env mexpander modctx))
	 )
    (each_component_in_list
     explist
     curcomp
     (debug "mexpand_skip_nil" " curcomp=" curcomp)
     (if curcomp (list_append reslist curcomp))
     )
    (let (
	  (restup (list_to_multiple reslist discr_multiple))
	  )
      (debug "mexpand_skip_nil" " restup=" restup)
      (return restup)
      )
    )
  )
(install_initial_macro 'skip_nil mexpand_skip_nil)
(export_macro skip_nil mexpand_skip_nil
	      :doc #{The $SKIP_NIL macro is macro-expanding its arguments, and skipping those who are macro-expanded to nil.}#
	      )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; parse a field pattern
(defun parse_field_pattern (fkeyw cla flpsexp env pctx psloc)
  (debug "parse_field_pattern keyw" fkeyw)
  (assert_msg "check fkeyw" (is_a fkeyw class_keyword) fkeyw)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check pctc" (is_a pctx class_pattern_expansion_context) pctx)
  (assert_msg "check cla" (is_a cla class_class) cla)
  (let (
	(clafields (unsafe_get_field :class_fields cla))
	(fldcont (instance class_reference :referenced_value ())) 
	(flpat (patternexpand_1 flpsexp env pctx psloc)) 
	)
    (debug "parse_field_pattern clafields" clafields)
    ;; find the field inside the class
    (multiple_iterate_test
     clafields
     (lambda (cfld :long ix)
       (assert_msg "check fld" (is_a cfld class_field) cfld)
       (if (==s (unsafe_get_field :named_name cfld) 
		(unsafe_get_field :named_name fkeyw))
	   (progn 
	     (put_fields fldcont :referenced_value cfld)
	     (return ()	())			; nil to exit to iteration 
	     )
	 (return cfld ())))
     )
    (let ( (fld (get_field :referenced_value fldcont))
	   )
      (when (is_not_a fld class_field)
	    (debug "parse_field_pattern bad fld" fld)
	    (error_at psloc "invalid :field $1 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 "parse_field_pattern return patf" patf)
	(return patf)
	))))

(defun patexpand_instance (sexpr env pctx)
  (debug "patexpand_instance sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context) pctx)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(fields ())
	(fieldnams ())
	(curpair (pair_tail (list_first cont)))
	(clasymb (pair_head curpair))
	(cla ())
	(clabind ())
	)
    (if (is_not_a clasymb class_symbol)
	(error_plain loc "missing class symbol for INSTANCE pattern"_))
    (let ( (bnd (find_env env clasymb)) 
	   (fldlist (make_list discr_list))
	   (claname (get_field :named_name clasymb))
	   )
      (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_at loc "invalid class name for INSTANCE $1"_
		    claname)
	(return ())
	))
      (assert_msg "check cla" (is_a cla class_class) cla)
      (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 "patexpand_instance fldp" fldp)
	     (if fldp
		 (list_append fldlist fldp)
	       (error_at loc "bad field name $1 in INSTANCE $2"_
			 (unsafe_get_field :named_name curfkw) claname)
	       ))))
       (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 "patexpand_instance return spati" 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)
  (debug "patexpand_object sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context) pctx)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(fields ())
	(fieldnams ())
	(curpair (pair_tail (list_first cont)))
	(clasymb (pair_head curpair))
	(cla ())
	(clabind ())
	)
    (if (is_not_a clasymb class_symbol)
	(error_plain loc "missing class symbol for  OBJECT pattern"_))
    (let ( (bnd (find_env env clasymb)) 
	   (fldlist (make_list discr_list))
	   (claname (get_field :named_name clasymb))
	   )
      (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 $1 pattern"_
		    claname)
	(return ())
	))
      (assert_msg "check cla" (is_a cla class_class) cla)
      (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_at loc "expecting keyword in OBJECT $1 pattern"_ claname))
	 (setq curpair (pair_tail curpair))
	 (let ( (curexp (pair_head curpair)) )
	   (let  ( (fldp (parse_field_pattern curfkw cla curexp env pctx loc)) )
	     (debug "patexpand_object fldp" fldp)
	     (if fldp
		 (list_append fldlist fldp)
	       (error_at loc "bad field name $1 in OBJECT $2 pattern"_
			   (unsafe_get_field :named_name curfkw) claname)
	       ))))
       (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 "patexpand_object return spati" spati)
	(return spati)
	)))
    ))

(defun mexpand_object (sexpr env mexpander modctx)
  (debug "mexpand_object sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (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.}# )



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun expand_macrostring_pairs (pairs sloc env mexpander modctx)
  (debug "expand_macrostring_pairs pairs=" pairs)
  (assert_msg "check pairs" (is_pair pairs) pairs)
  (assert_msg "check env" (is_a env class_environment) env)
  (let ( (chklist (make_list discr_list))
	 )
    (letrec ( 
	     (mexp_macrostring 
	      (lambda (comp loc)
		(debug "expand_macrostring_pairs/mexp_macrostring comp=" comp "\n loc=" loc)
		(cond
		 ( (is_string comp)
		   (list_append chklist (make_string discr_verbatim_string comp)))
		 ( (is_a comp class_sexpr_macrostring)
		   (let ( 
			 (cloc (get_field :loca_location comp))
			 (compcont (get_field :sexp_contents comp))
			 )
		     (debug "expand_macrostring_pairs/mexp_macrostring compcont=" compcont)
		     (foreach_pair_component_in_list
		      (compcont)
		      (compair subcomp)
		      (mexp_macrostring subcomp cloc))
		     (debug "expand_macrostring_pairs/mexp_macrostring updated chklist=" chklist)
		     ))
		 ( (is_a comp class_sexpr)
		   (let ( (mcomp (mexpander comp env mexpander modctx))
			  )
		     (debug "expand_macrostring_pairs//mexp_macrostring mcomp=" mcomp)
		     (list_append chklist mcomp)))
		 (:else
		  (list_append chklist comp)))
		(debug "expand_macrostring_pairs/mexp_macrostring comp=" comp
		       "\n updated chklist=" chklist)))
	     )
      (foreach_pair
       (pairs)
       (thispair thiscomp)
       (debug "expand_macrostring_pairs thiscomp=" thiscomp)
       (mexp_macrostring thiscomp sloc)
       )
      (debug "expand_macrostring_pairs final chklist=" chklist)
      (let ( (tup (list_to_multiple chklist discr_multiple))
	     )
	(debug "expand_macrostring_pairs return tup=" tup)
	(return tup)
	))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; the code_chunk expander
(defun mexpand_code_chunk (sexpr env mexpander modctx)
  (debug "mexpand_code_chunk sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (sloc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (curchk ())
	 (gsym ())
	 (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))
    (let (
	  (tup (expand_macrostring_pairs curpair sloc env mexpander modctx))
	  (mres (instance class_source_codechunk
			  :loca_location sloc
			  :sch_gensym gsym
			  :sch_chunks tup
			  )) 
	  )
      (debug "mexpand_code_chunk return mres=" mres)
      (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}-s may be macro-strings or nested s-expressions. It
generates a C block. Nested expressions should be :void and are
expanded at place of occurence, as blocks. Since it does not make any
type verification, it should be used with parcimony. See $DEFPRIMITIVE
and $EXPR_CHUNK etc.}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; the expr_chunk expander
(defun mexpand_expr_chunk (sexpr env mexpander modctx)
  (debug "mexpand_expr_chunk sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (sloc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (curchk ())
	 (gsym ())
	 (kcty ())
	 (curel ())
	 )
    (setq curel (pair_head curpair))
    (if (is_a curel class_symbol)
	(setq gsym curel)
      (error_plain sloc "missing symbol in (EXPR_CHUNK <state-symbol> <ctype> <chunk>...)"))
    (setq curpair (pair_tail curpair))
    (setq kcty (pair_head curpair))
    (when (is_not_a kcty class_keyword)
      (error_plain sloc "missing type keyword in (EXPR_CHUNK <state-symbol> <ctype> <chunk>...)")
      (return))
    (setq curpair (pair_tail curpair))
    (let ( (cty (unsafe_get_field :symb_data kcty)) 
	   (typknam (unsafe_get_field :named_name kcty))
	   )
      (when (is_not_a cty class_ctype)
	(debug "mexpand_expr_chunk bad kcty=" kcty)
	(error_at sloc "bad type keyword for EXPR_CHUNK"_  typknam)
	(return ())
	)
      (cond ( (== (unsafe_get_field :ctype_keyword cty) kcty)
	      ()
	      )
	    ( (== (unsafe_get_field :ctype_altkeyword cty) kcty)
	      (warning_at sloc "using obsolete ctype keyword $1 in EXPR_CHUNK, preferring $2" 
			    typknam (get_field :named_name (get_field :ctype_keyword cty)))
	      )
	    (:else
	     (debug "mexpand_expr_chunk strange kcty=" kcty)
	     (error_at sloc "invalid type keyword $1 for EXPR_CHUNK"_
			 typknam)
	     (return ())   
	     ))
      (let (
	    (tup (expand_macrostring_pairs curpair sloc env mexpander modctx))
	    (mres (instance class_source_exprchunk
			    :loca_location sloc
			    :sch_gensym gsym
			    :sch_chunks tup
			    :sxch_ctype cty
			    )) 
	    )
	(debug "mexpand_expr_chunk return mres=" mres)
	(return mres)
	))))
(install_initial_macro 'expr_chunk mexpand_expr_chunk)
(export_macro expr_chunk mexpand_expr_chunk
	      :doc #{The $EXPR_CHUNK macro is for low-level C
@b{expression} chunks, e.g. anonymous primitive-like expressions. The
syntax is ($EXPR_CHUNK @var{state-symbol} @var{ctype} @var{chunk}...)  where
@var{chunk}-s may be macro-strings or sub-expressions. It generates a
C expressions, with all the sub-expressions strictly normalized before
the expansion of the @code{expr_chunk}. Since it does not make any
type verification, it should be usually avoided. See $DEFPRIMITIVE and
$EXPR_CHUNK etc.}#)

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

;;;; the unsafe_put_fields expander
(defun mexpand_unsafe_put_fields (sexpr env mexpander modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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)
	      (mexpander objsrc env mexpander modctx)
	    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 modctx)) )
		     (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 modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (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)
	      (mexpander objsrc env mexpander modctx)
	    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 modctx)) )
		     (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 modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (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 modctx)) )
	(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 modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (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 modctx)) )
	(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.}#)


;; internal routine to make a progn from a pairlist at a location
(defun pairlist_to_progn (pair loc env mexpander modctx)
  (debug "pairlist_to_progn pair=" pair)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check_pair" (is_pair pair) pair)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (bodytup (expand_pairlist_as_tuple pair env mexpander modctx))
	 (sprogn
	  (instance class_source_progn
		    :loca_location loc
		    :sprogn_body bodytup
		    )) )
    (debug "pairlist_to_progn sprogn" sprogn)
    (return sprogn)
    ))

;;;; the setq expander
(defun mexpand_setq (sexpr env mexpander modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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  (mexpander curexp env mexpander modctx)
		)
      )))
(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 modctx)
  (debug "mexpand_if sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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 (mexpander curif env mexpander modctx)) )
      (debug "mexpand_if xcond" xcond)
      (let ( (curthen (pair_head curpair)) )
	(setq curpair (pair_tail curpair))
	(let ( (xthen (mexpander curthen env mexpander modctx)) 
	       )
	  (debug "mexpand_if xthen" xthen)
	  (if (is_pair curpair)
	      (let ( (curelse (pair_head curpair)) 
		     (xelse (mexpander curelse env mexpander modctx)) )
		(debug "mexpand_if xelse" 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 "mexpand_if with else return rese" rese)
		  (return rese)))
	    (let ( (resp (instance class_source_if
				   :loca_location loc
				   :sif_test xcond
				   :sif_then xthen)) )
	      (debug "mexpand_if plain return resp" resp)
	      (return resp))
	    ))))))
(install_initial_macro 'if mexpand_if)
(export_macro if mexpand_if
 :doc #{The $IF syntax is for simple conditional expressions. See also $WHEN and $UNLESS and $COND. Syntax
 is (IF <test-expression> <then-expression> [<else-expression>]).}#)


;;;;;;;;;;;;;;;;
;;;; WHEN macro = syntactic sugar (WHEN <test> <body...>) === (IF <test> (PROGN <body...>))
(defun mexpand_when (sexpr env mexpander modctx)
  (debug "mexpand_when sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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 WHEN"_))
    (setq curpair (pair_tail curpair))
    (if (not (is_pair curpair))
	(error_plain loc "missing body in WHEN"_))
    (let ( (xcond (mexpander curif env mexpander modctx))
	   (xprogn (pairlist_to_progn curpair loc env mexpander modctx))
	   (xwhen (instance class_source_if
			    :loca_location loc
			    :sif_test xcond
			    :sif_then xprogn))
	   )
      (debug "mexpand_when return xwhen=" xwhen)
      (return xwhen)
      )))

(install_initial_macro 'when mexpand_when)
(export_macro  when mexpand_when
 :doc #{The $WHEN syntax sugar is for conditional expressions with body. Syntax
 is (WHEN <test> <body>...) syntactic sugar for (IF <test> (PROGN <body>...)).}#)


;;;;;;;;;;;;;;;;
;;;; UNLESS macro = syntactic sugar (UNLESS <test> <body...>) === (IF <test> () (PROGN <body...>))
(defun mexpand_unless (sexpr env mexpander modctx)
  (debug "mexpand_unless sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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 UNLESS"_))
    (setq curpair (pair_tail curpair))
    (if (not (is_pair curpair))
	(error_plain loc "missing body in UNLESS"_))
    (let ( (xcond (mexpander curif env mexpander modctx))
	   (xprogn (pairlist_to_progn curpair loc env mexpander modctx))
	   (xunless (instance class_source_ifelse
			    :loca_location loc
			    :sif_test xcond
			    :sif_then ()
			    :sif_else xprogn))
	   )
      (debug "mexpand_unless return xunless=" xunless)
      (return xunless)
      )))

(install_initial_macro 'unless mexpand_unless)
(export_macro  unless mexpand_unless
 :doc #{The $UNLESS syntax sugar is for negated conditional expressions with body. Syntax
 is @code{(UNLESS @var{<test>} @var{<body>...})} = syntactic sugar for @code{(IF @var{<test>} () (PROGN @var{<body>...}))}.}#)


;;;;;;;;;;;;;;;;
;;;; WITH_CLONED_SYMB macro = 
;;; syntactic sugar (WITH_CLONED_SYMB (<symb1>...) <body...>) 
;;;     == (LET ((<symb1> (CLONE_SYMBOL <symb1>)) ....) <body...>)
(defun mexpand_with_cloned_symb (sexpr env mexpander modctx)
  (debug "mexpand_with_cloned_symb sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(symbs (pair_head curpair))
	(newenv (fresh_env env))
	(bindlist (make_list discr_list))
	(bodyl ())
	(processlist 
	 (lambda (bloc blist)
	   (debug "mexpand_with_cloned_symb/processlist bloc=" bloc " blist=" blist)
	   (assert_msg "check blist" (is_list_or_null blist) blist)
	   (foreach_pair_component_in_list
	    (blist)
	    (curpair cursymb)
	    (when (is_not_a cursymb class_symbol)
	      (error_plain bloc "non-symbol in symbol list for (WITH_CLONED_SYMB <symbol-list> <body...>)")
	      (return))
	    (if (is_a cursymb class_keyword)
		(warning_strv bloc "keyword in WITH_CLONED_SYMB is discouraged"
			      (get_field :named_name cursymb)))
	    (if (find_env newenv cursymb)
		(warning_strv bloc "symbol in WITH_CLONED_SYMB hides previous definition"
			      (get_field :named_name cursymb)))
	    (let ( (appclonesymb (instance class_source_apply 
					   :loca_location bloc
					   :sapp_fun 'clone_symbol
					   :sargop_args (tuple (instance class_source_quote
									 :loca_location bloc
									 :squoted cursymb))))
		   ;; notice that class_source_let_binding is not a binding, but an AST construct...
		   (bindsymb (instance class_source_let_binding
				       :loca_location bloc
				       :sletb_type ctype_value
				       :sletb_binder cursymb
				       :sletb_expr appclonesymb
				       ))
		   ;; this is the binding to extend the environment...
		   (bind (instance class_let_binding
				   :binder cursymb
				   :letbind_type ctype_value
				   :letbind_expr appclonesymb
				   :letbind_loc bloc))
		   )
	      (put_env newenv bind)
	      (list_append bindlist bindsymb)
	      (debug "mexpand_with_cloned_symb/processlist end bindsymb=" bindsymb)
	      )
	    )))
	)
    (setq curpair (pair_tail curpair))
    ;; parse the symbol list and build bindlist
    (debug "mexpand_with_cloned_symb symbs=" symbs)
    (cond ( (null symbs)
	    (void)
	    )
	  ( (is_a symbs class_sexpr)
	    (let ( (syloc (or (unsafe_get_field :loca_location symbs) loc))
		   (sylist (unsafe_get_field :sexp_contents symbs))
		   )
	      (processlist syloc sylist)
	      (void)
	      ))
	  ( (is_list symbs)
	    (processlist loc symbs)
	    (void))
	  ( (is_multiple symbs)
	    (processlist loc (multiple_to_list symbs discr_list))
	    (void))
	  (:else
	   (error_plain loc "WITH_CLONED_SYMB wants a list of symbols as first argument")
	   (return () ())))
    (debug "mexpand_with_cloned_symb bindlist=" bindlist)
    ;; expand the body
    (let ( (mbody (expand_pairlist_as_tuple curpair newenv mexpander modctx))
	   (mlet (instance class_source_let
			   :loca_location loc
			   :slet_bindings (list_to_multiple bindlist discr_multiple)
			   :slet_body mbody
			   ))
	   )
      (debug "mexpand_with_cloned_symb mbody=" mbody "\n.. result mlet=" mlet)
      (return mlet)
      )))
(install_initial_macro 'with_cloned_symb mexpand_with_cloned_symb)
(export_macro with_cloned_symb mexpand_with_cloned_symb
 :doc #{The $WITH_CLONED_SYMB syntax sugar is for easily cloning symbols, notably useful in macros. 
Syntax is @code{(WITH_CLONED_SYMB (@var{<symb>...}) @var{<body>...})} same as
@code{(LET ( (@var{<symb>} (CLONE_SYMBOL (QUOTE @var{<symb>}))) @var{...})  @var{<body>...})} etc...}#)


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

;;;;;;;;;;;;;;;;
;;;;; the CPPIF expander
(defun mexpand_cppif (sexpr env mexpander modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check modctx" (is_object modctx) modctx)
  (debug "mexpand_cppif sexpr" 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 (mexpander curif env mexpander modctx)) )
      (debug "mexpand_cppif xcond" 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 (mexpander curthen env mexpander modctx)) 
	       (xelse ())
	       )
	  (debug "mexpand_cppif xthen" xthen)
	  (if (is_pair curpair)
	      (let ( (curelse (pair_head curpair)) 
		     (gotxelse (mexpander curelse env mexpander modctx)) )
		(debug "mexpand_cppif gotxelse" 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 "mexpand_cppif return resp" 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>]).}#)

;;;;; the cond expanser
(defun mexpand_cond (sexpr env mexpander modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (debug "mexpand_cond sexpr" 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 "mexpand_cond lastcexp lx" lx)
		    lx))
	(:long ix (-i nbcond 1))
	(res ())
	)
    (debug "mexpand_cond cexptuple" cexptuple)
    (forever condloop
	     (if (<i ix 0) (exit condloop))
	     (let ( (curcond (multiple_nth cexptuple ix)) )
	       (debug "mexpand_cond curcond" 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
						     modctx)))
		    (debug "mexpand_cond res for :else" res)
		    ))
		( (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
					     (mexpander curcondtest env mexpander modctx)
					     res)))
			    (debug "mexpand_cond res for monoexp cond" res)
			    )
			  ( (null (pair_tail curcondrestpairs))
			    (setq res
				  (instance class_source_ifelse
					    :loca_location curcondloc
					    :sif_test (mexpander curcondtest env mexpander modctx)
					    :sif_then (mexpander (pair_head curcondrestpairs) env mexpander modctx)
					    :sif_else res
						))
			    (debug "mexpand_cond res for biexp cond" res)
			    )
			  (:else 
			   (setq res
				 (instance class_source_ifelse
					   :loca_location curcondloc
					   :sif_test (mexpander curcondtest env mexpander modctx)
					   :sif_then (pairlist_to_progn curcondrestpairs curcondloc env mexpander modctx)
					       :sif_else res))
			   (debug "mexpand_cond res for manyexp cond" res)
			   ))
		    ))
		(:else ;curcond is not a sexpr 
		 (setq res (instance class_source_or
				     :loca_location loc
				     :sor_disj (tuple curcond res)))
		 (debug "mexpand_cond res for nonsexp cond" res)
		 )
		)
	       )
	     (setq ix (-i ix 1))
	     )
    (debug "mexpand_cond final res" res)
    (return res)
    ))
(install_initial_macro 'cond mexpand_cond)
(export_macro cond mexpand_cond
 :doc #{The usual lisp $COND conditional. Syntax is @code{(COND
 @var{<conditions>...})}. Each condition is a list of the form
 @code{(@var{<test>} @var{<expr>...})}. The last catch-all condition
 can be @code{(:else @var{<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 modctx)
  (debug  "mexpand_and sexpr:" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(cxtup (expand_pairlist_as_tuple curpair env mexpander modctx))
	(:long nbcomp (multiple_length cxtup))
	)
    (debug "mexpand_and cxtup" 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 "mexpand_and res:" res)
	(return res)))))


;;;; the AS pattern expander
(defun patexpand_as (sexpr env pctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context) pctx)
  (debug "patexpand_as sexpr" 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 "patexpand_as returns res" res)
	(return res)
	))))

(defun mexpand_as (sexpr env mexpander modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (debug "mexpand_as sexpr=" 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)
  (debug "patexpand_when sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context) pctx)
  (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" () sexpr)
    (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) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context) pctx)
  (debug "patexpand_and sexpr" 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 "patexpand_and res" res)
    (return res)
    ))

(install_initial_patmacro 'and patexpand_and mexpand_and)
(export_patmacro and patexpand_and mexpand_and
 :doc #{The lispy $AND conjunction syntax is a short-circuit "and
 then" conjunction. 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 modctx)
  (debug "mexpand_or sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(cxtup (expand_pairlist_as_tuple (pair_tail (list_first cont)) env mexpander modctx))
	(: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 "mexpand_or res" res)
	 (return res)
	 ))))

;;;; the OR pattern expander
(defun patexpand_or (sexpr env pctx)
  (debug "patexpand_or sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context) pctx)
  (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 "patexpand_or res" 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.}# )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; CONTENT & REFERENCE

;; (reference x) is a shorthand for 
;; (instance class_reference :referenced_value x)
(defun mexpand_reference (sexpr env mexpander modctx)
  (debug "mexpand_reference sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check modctx" (is_object modctx) modctx)
  (assert_msg "check class_reference has one field"
	      (==i 1 (multiple_length
		     (get_field :class_fields class_reference)))
	      class_fields
	      )
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(xargtup (expand_restlist_as_tuple cont env mexpander modctx))
	(:long nbarg (multiple_length xargtup))
	(arg1 (multiple_nth xargtup 0))
	(spredclasscont (instance class_source_fetch_predefined
				  :loca_location loc
				  :sfepd_predef 'CLASS_REFERENCE))
	(clabind (find_env env 'class_reference))
	(flda (parse_field_assignment 
	       class_reference loc :referenced_value arg1 env mexpander modctx))
	(sinst (instance 
		class_source_instance
		:loca_location loc
		:smins_class class_reference
		:smins_clabind clabind
		:smins_fields (tuple flda)))
	)
    (if (!=i nbarg 1)
	(progn
	  (error_plain loc "(REFERENCE <value>) needs exactly one argument")
	  (return)))
    ;; testing that clabind binds exactly the same class_reference
    ;; don't work well for makedoc mode.
    (if (null clabind)
	(warning_plain loc  "(REFERENCE <value>) where CLASS_REFERENCE is not visible"))
    ;;
    (debug "mexpand_reference returns sinst" sinst)
    (return sinst)
))


(defun patexpand_reference (sexpr env pctx)
  (debug "patexpand_reference sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context) pctx)
  (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))
	(arg1 (multiple_nth argsp 0))
	(fldp (parse_field_pattern :referenced_value class_reference arg1 env pctx loc))
	(res (instance class_source_pattern_instance
		       :loca_location loc
		       :pat_weight '1
		       :spat_class class_reference
		       :spat_fields (tuple fldp)))
	)
    (if (!=i (multiple_length argsp) 1)
	(progn
	  (error_plain loc "(REFERENCE <subpattern>) pattern needs one argument")
	  (return)))
    (debug "patexpand_reference res" res)
    (return res)
))
(install_initial_patmacro 'reference patexpand_reference mexpand_reference)
(export_patmacro reference patexpand_reference mexpand_reference
 :doc #{The $REFERENCE syntax is a short-hand for making or matching
 instances of $CLASS_REFERENCE. Expression syntax (REFERENCE
 <subexpression>) is a short-hand for (INSTANCE
 CLASS_REFERENCE :REFERENCED_VALUE <subexpression>) to make an instance
 of $CLASS_REFERENCE with the given value as $REFERENCED_VALUE. Pattern
 syntax is ?(REFERENCE <subpattern>) to match an instance of
 $CLASS_REFERENCE with its $REFERENCED_VALUE matching
 <subpattern>. $REFERENCE expressions are constructive, so can appear
 in $LETREC bindings.}#)


;; (deref x) is a shorthand for 
;; (get_field :referenced_value x)
(defun mexpand_deref (sexpr env mexpander modctx)
  (debug "mexpand_deref sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (assert_msg "check class_reference has one field"
	      (==i 1 (multiple_length
		     (get_field :class_fields class_reference)))
	      class_reference)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(xargtup (expand_restlist_as_tuple cont env mexpander modctx))
	(:long nbarg (multiple_length xargtup))
	(arg1 (multiple_nth xargtup 0))
	(spredclasscont (instance class_source_fetch_predefined
				  :loca_location loc
				  :sfepd_predef 'CLASS_REFERENCE))
	(clabind (find_env env 'class_reference))
	(sget (instance 
		class_source_get_field
		:loca_location loc
		:suget_obj arg1
		:suget_field referenced_value))
	)
    (assert_msg "check referenced_value" (is_a referenced_value class_field) referenced_value)
    (if (!=i nbarg 1)
	(progn
	  (error_plain loc "(DEREF <value>) needs exactly one argument")
	  (return)))
    ;; testing that clabind binds exactly the same class_reference
    ;; don't work well for makedoc mode.
    (if (null clabind)
	(warning_plain loc  "(DEREF <value>) where CLASS_REFERENCE is not visible"))
    (debug "mexpand_deref returns sget" sget)
    (return sget)))

(install_initial_macro 'deref mexpand_deref)
(export_macro deref mexpand_deref
 :doc #{The $DEREF macro is a short-hand to retrieve values inside
 instances of $CLASS_REFERENCE. So @code{(DEREF @var{<value>})}
 means @code{(GET_FIELD :REFERENCED_VALUE @var{<value>})}, hence test that @var{<value>}
 is indeed an instance of $CLASS_REFERENCE, or else gives null. The special syntax @code{!@var{<expr>}} is a syntactic sugar for @code{(DEREF @var{<expr>})}.}#)


(defun mexpandobsolete_content (sexpr env mexpander modctx)
  (debug "mexpandobsolete_content sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (warning_plain (get_field :loca_location sexpr)
		 "obsolete use of CONTENT in expression; use DEREF instead")
  (mexpand_deref sexpr env mexpander modctx))
(install_initial_macro 'content mexpandobsolete_content)
(export_macro content mexpandobsolete_content
 :doc #{The $CONTENT macro is obsolete. Use $DEREF instead.}#)


;;; exclaim is the same as deref, but export_synonym don't work for macros
(install_initial_macro 'exclaim mexpand_deref)
(export_macro exclaim mexpand_deref 
 :doc #{$EXCLAIM [usually given thru the ! syntactic sugar] is a
 synonym for $DEREF, e.g. @code{!(IF p c)} means @code{(DEREF (IF P C))}
 hence @code{(GET_FIELD :REFERENCED_VALUE (IF P C))}}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SET_REF

;; (set_ref r x) is a shorthand for 
;; (put_fields r :referenced_value x)
(defun mexpand_set_ref (sexpr env mexpander modctx)
  (debug "mexpand_set_ref sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (assert_msg "check class_reference has one field"
	      (==i 1 (multiple_length
		     (get_field :class_fields class_reference)))
	      class_reference)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(xargtup (expand_restlist_as_tuple cont env mexpander modctx))
	(:long nbarg (multiple_length xargtup))
	(arg1 (multiple_nth xargtup 0))
	(arg2 (multiple_nth xargtup 1))
	(spredclasscont (instance class_source_fetch_predefined
				  :loca_location loc
				  :sfepd_predef 'CLASS_REFERENCE))
	(clabind (find_env env 'class_reference))
	(putup (tuple (instance class_source_fieldassign 
			 :loca_location loc
			 :sfla_field referenced_value
			 :sfla_expr arg2
			 )
		))
	(sput (instance 
		class_source_put_fields
		:loca_location loc
		:suput_obj arg1
		:suput_fields putup))
	)
    (assert_msg "check referenced_value" (is_a referenced_value class_field) referenced_value)
    (if (!=i nbarg 2)
	(progn
	  (error_plain loc "(SET_REF <ref> <value>) needs exactly two arguments")
	  (return)))
    ;; testing that clabind binds exactly the same class_reference
    ;; don't work well for makedoc mode.
    (if (null clabind)
	(warning_plain loc  "(SET_REF <ref> <value>) where CLASS_REFERENCE is not visible"))
    (debug "mexpand_set_ref returns sput" sput)
    (return sput)))

(install_initial_macro 'set_ref mexpand_set_ref)
(export_macro set_ref mexpand_set_ref
 :doc #{The $SET_REF macro is a short-hand to put a value inside
 instances of $CLASS_REFERENCE. So @code{(SET_REF @var{<ref>} @var{<value>})}
 means @code{(PUT_FIELDS @var{<ref>} :REFERENCED_VALUE @var{<value>})}, hence test that @var{<ref>}
 is indeed an instance of $CLASS_REFERENCE before updating it.}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + 
;;;; the + macro expander
(defun mexpand_plus  (sexpr env mexpander modctx)
  (debug "mexpand_plus sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(xargtup (expand_restlist_as_tuple cont env mexpander modctx))
	(res (instance class_source_arithmetic_variadic_operation
	      :loca_location loc
	      :sargop_args xargtup
	      :sarithvar_neutral '0
	      :sarithvar_primitive +i
	      ))
	)
    (when (==i 0 (multiple_length xargtup))
      (error_plain loc "+ operator needs at least one argument")
      (return))
    (debug "mexpand_plus result" res)
    (return res)
    ))
(install_initial_macro '+ mexpand_plus)
(export_macro + mexpand_plus
 :doc #{The addition @code{+} operator is variadic, and understood as successive 
applications of @code{+i} primitives.}#
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - 
;;;; the - macro expander
(defun mexpand_minus  (sexpr env mexpander modctx)
  (debug "mexpand_minus sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(xargtup (expand_restlist_as_tuple cont env mexpander modctx))
	(res (instance class_source_arithmetic_variadic_operation
	      :loca_location loc
	      :sargop_args xargtup
	      :sarithvar_neutral '0
	      :sarithvar_primitive -i
	      ))
	)
    (when (==i 0 (multiple_length xargtup))
      (error_plain loc "- operator needs at least one argument")
      (return))
    (debug "mexpand_minus result" res)
    (return res)
    ))
(install_initial_macro '- mexpand_minus)
(export_macro - mexpand_minus
 :doc #{The substraction @code{-} operator is variadic, and understood as successive 
applications of @code{-i} primitives.}#
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - 
;;;; the * macro expander
(defun mexpand_times  (sexpr env mexpander modctx)
  (debug "mexpand_times sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(xargtup (expand_restlist_as_tuple cont env mexpander modctx))
	(res (instance class_source_arithmetic_variadic_operation
	      :loca_location loc
	      :sargop_args xargtup
	      :sarithvar_neutral '1
	      :sarithvar_primitive *i
	      ))
	)
    (when (==i 0 (multiple_length xargtup))
      (error_plain loc "* operator needs at least one argument")
      (return))
    (debug "mexpand_times result" res)
    (return res)
    ))
(install_initial_macro '* mexpand_times)
(export_macro * mexpand_times
 :doc #{The product @code{*} operator is variadic, and understood as successive 
applications of @code{*i} primitives.}#
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - 
;;;; the / macro expander
(defun mexpand_div  (sexpr env mexpander modctx)
  (debug "mexpand_div sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(xargtup (expand_restlist_as_tuple cont env mexpander modctx))
	(res (instance class_source_arithmetic_variadic_operation
	      :loca_location loc
	      :sargop_args xargtup
	      :sarithvar_neutral '1
	      :sarithvar_primitive /i
	      ))
	)
    (when (==i 0 (multiple_length xargtup))
      (error_plain loc "/ operator needs at least one argument")
      (return))
    (debug "mexpand_div result" res)
    (return res)
    ))
(install_initial_macro '/ mexpand_div)
(export_macro / mexpand_div
 :doc #{The division @code{/} operator is variadic, and understood as successive 
applications of @code{/i} primitives.}#
)

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

;;;; the TUPLE pattern expander
(defun patexpand_tuple (sexpr env pctx)
  (debug "patexpand_tuple sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context) pctx)
  (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 "patexpand_tuple res" 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 modctx)
  (debug "mexpand_list sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(xargtup (expand_restlist_as_tuple cont env mexpander modctx))
	(res  (instance class_source_list
	      :loca_location loc
	      :sargop_args xargtup))
	)
    (debug "mexpand_list result" res)
    (return res)
    ))

;;;; the LIST pattern expander
(defun patexpand_list (sexpr env pctx)
  (debug "patexpand_list sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check pctx" (is_a pctx class_pattern_expansion_context) pctx)
  (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 "patexpand_list res" 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 modctx)
  (debug "mexpand_match sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(msexp (pair_head (pair_tail (list_first cont))))
	(matsx (mexpander msexp env mexpander modctx))
	(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 "mexpand_match lastmexp lx" lx)
		    lx))
	(:long ix (-i nbmatch 1))
	(caselist (make_list discr_list))
	)
    (debug "mexpand_match mexptuple" mexptuple)
    (forever matchloop
	     (if (<i ix 0) (exit matchloop))
	     (let ( (curmatch (multiple_nth mexptuple ix)) )
	       (debug "mexpand_match curmatch" 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 17)
					      :pctx_modctx modctx
					      ))
			 (curpat (let ( (cp (patternexpand_1 curmatchpatx env curpatctx curmatchloc)) )
					(debug "mexpand_match curpat" cp)
					(assert_msg "check curpat" cp)
					cp))
			 (curbody (expand_pairlist_as_tuple curmatchrestpairs env mexpander modctx))
			 (curcase (instance class_source_match_case
					    :loca_location curmatchloc
					    :scam_patt curpat
					    :scam_body curbody))
			 )
		    (debug "mexpand_match curcase" 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 "mexpand_match caselist" caselist)
    (let (
	  (casetupl  (list_to_multiple caselist discr_multiple))
	  (lastcase (multiple_nth casetupl -1))
	  (smat (instance class_source_match
			   :loca_location loc
			   :smat_matchedx matsx
			   :smat_cases casetupl) 
		 )
	  )
      ;; inform the user if the last match clause is not a joker
      (if (is_not_a 
	   (get_field :scam_patt lastcase) 
	   class_source_pattern_joker_variable)
	  (inform_plain loc "last (MATCH ...) clause is not a joker"))
      ;;;
      (debug "mexpand_match result smat" 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
 @code{?_} should appear in the last match-case if any. Pattern variables
 like @code{?x} are bound by the matching in their match-case.}#)


;;; matchalt is like match 

;;;; the matchalt expander
(defun mexpand_matchalt (sexpr env mexpander modctx)
  (debug "mexpand_matchalt sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(msexp (pair_head (pair_tail (list_first cont))))
	(matsx (mexpander msexp env mexpander modctx))
	(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 "MATCHALT with non-sexpr"_))
		      c
		      ))) 
	(:long nbmatch (multiple_length mexptuple))
	(lastmexp (let ( (lx (multiple_nth mexptuple -1)) )
		    (debug "mexpand_matchalt lastmexp lx" lx)
		    lx))
	(:long ix (-i nbmatch 1))
	(caselist (make_list discr_list))
	)
    (debug "mexpand_matchalt mexptuple" mexptuple)
    (forever matchloop
	     (if (<i ix 0) (exit matchloop))
	     (let ( (curmatch (multiple_nth mexptuple ix)) )
	       (debug "mexpand_matchalt curmatch" 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 17)
					      :pctx_modctx modctx
					      ))
			 (curpat (let ( (cp (patternexpand_1 curmatchpatx env curpatctx curmatchloc)) )
					(debug "mexpand_matchalt curpat" cp)
					(assert_msg "check curpat" cp)
					cp))
			 (curbody (expand_pairlist_as_tuple curmatchrestpairs env mexpander modctx))
			 (curcase (instance class_source_match_case
					    :loca_location curmatchloc
					    :scam_patt curpat
					    :scam_body curbody))
			 )
		    (debug "mexpand_matchalt curcase" curcase)
		    (list_prepend caselist curcase)
		    ))
		;; detect non-sexp clauses
		(:else
		 (error_plain loc "(MATCHALT <expr> <match-case>...) with non sexpr matchcase") 
		 )))
	     (setq ix (-i ix 1)))
    (debug "mexpand_matchalt caselist" caselist)
    (let (
	  (casetupl  (list_to_multiple caselist discr_multiple))
	  (lastcase (multiple_nth casetupl -1))
	  (smat (instance class_source_matchalt
			   :loca_location loc
			   :smat_matchedx matsx
			   :smat_cases casetupl) 
		 )
	  )
      ;; inform the user if the last matchalt clause is not a joker
      (if (is_not_a 
	   (get_field :scam_patt lastcase) 
	   class_source_pattern_joker_variable)
	  (inform_plain loc "last (MATCHALT ...) clause is not a joker"))
      ;;;
      (debug "mexpand_matchalt result smat" smat)
      (return smat)
      )))

(install_initial_macro 'matchalt mexpand_matchalt)
(export_macro matchalt mexpand_matchalt
 :doc #{The temporary $MATCHALT syntax is for pattern-matching
 expressions. It is sama as $MATCH but uses an alternative
 implementation. @b{Don't use it} (except for test cases), it will disappear when that better
 implemenation will be fully debugged.}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;; for LET
;; internal routine to make a letbinding, called from mexpand_let
(defun mexpand_letbinding (sexpr env mexpander modctx)
  (debug "mexpand_letbinding" " sexpr=" sexpr "\n.. env=" debug_less env)
  (shortbacktrace_dbg "mexpand_letbinding" 7)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(ctyp quasi_ctype_auto)		
	(var ())
	(expr ())
	(curpair (list_first cont))
	(curarg ())
	)
    (setq curarg (pair_head curpair))
    ;; parse the ctype keyword
    (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_quasi_ctype)
	     (error_at loc "letbinding with invalid type keyword $1"_ tynam))
	   ( (== (get_field :ctype_keyword cty) curarg)
	     (setq ctyp cty))
	   ( (== (get_field :ctype_altkeyword cty) curarg)
	     (setq ctyp cty)
	     (warning_at loc "obsolete alternate ctype $1 keyword in let binding, wanting $2"
			   tynam (get_field :named_name (get_field :ctype_keyword ctyp)))
	     )
	   (:else
	    (error_at loc "let-binding with invalid type keyword $1"_
			tynam)))
	  (setq curpair (pair_tail curpair))
	  (setq curarg (pair_head curpair))
	  ))
    ;; parse the variable
    (cond ( (is_a curarg class_keyword)
	    (error_at loc "let-binding cannot bind keyword $1"_  
			(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_at loc "missing variable in letbinding"_))
    ;; special case for :macro i.e. quasi_ctype_macro
    ;; syntax of the macro binding (:macro <name> <formals> <body>...)
    (if (== ctyp quasi_ctype_macro)
	(let ( (macformals (lambda_arg_bindings curarg :checkarg env mexpander modctx))
	       (varname (unsafe_get_field :named_name var))
	       (macbody ())
	       (newenv (fresh_env env))
	       )
	  (debug "mexpand_letbinding macformals=" macformals "\n.. newenv=" debug_less newenv)
	  (setq curpair (pair_tail curpair))
	  (if (is_a macformals discr_variadic_formal_sequence)
	      (error_at loc ":macro let-binding $1 cannot be variadic" varname))
	  (if (>i (multiple_length macformals) 4)
	      (error_at loc ":macro $1 let-binding should have at most 4 formals" varname))
	  (foreach_in_multiple
	   (macformals)
	   (curmacformal :long ix)
	   (debug "mexpand_letbinding curmacformal=" curmacformal)
	   (assert_msg "check curmacformal" (is_a curmacformal class_formal_binding) curmacformal)
	   (let ( (curformalname (get_field :named_name (get_field :binder curmacformal))) 
		  )
	     (if (!= (get_field :fbind_type curmacformal) ctype_value)
		 (error_at loc ":macro $1 let-binding should be :value" curformalname))
	     (if (find_env newenv (get_field :binder curmacformal))
		 (error_at loc ":macro $1 formal already bound" curformalname))
	     (put_env newenv curmacformal)
	     ))
	  (setq macbody (expand_pairlist_as_tuple curpair newenv mexpander modctx))
	  (debug "mexpand_letbinding macbody=" macbody)
	  (let ( (smacbind
		  (instance class_source_macro_let_binding
			    :loca_location loc
			    :sletb_binder var 
			    :sletm_macro_formals macformals
			    :sletm_macro_body macbody
			    ))
		 )
	    (debug "mexpand_letbinding smacbind=" smacbind)
	    (return smacbind)
	    )))
    ;;
    (when curarg
      (setq expr (mexpander curarg env mexpander modctx))
      (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_at loc
			 "local let binding $1 hides upper one"
			 (get_field :named_name var))
	   (if prevloc
	       (warning_at prevloc
			     "here is the hidden binding of $1" 
			     (get_field :named_name var)))
				  
	   ))
       ( (is_a prevbind class_fixed_binding)
	 (warning_at loc
		       "local let binding $1 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 modctx)
  (debug "mexpand_let" " start sexpr=" sexpr " env=" debug_less env
	 "\n.. modctx=" modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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))
	(sbindlist (cond
		    ( (is_a bindexpr class_sexpr)
		      (get_field :sexp_contents bindexpr))
		    ( (null bindexpr)
		      ())
		    ( (is_list bindexpr)
		      bindexpr)
		    (:else
		     (error_at loc "invalid bindings in LET")
		     ())))
	(letbindlist (make_list discr_list))
	(newenv (fresh_env env))
	(maclist (get_field :mocx_macrolist modctx))
	)
    (debug "mexpand_let" " loc=" loc " cont=" cont "\n.. newenv=" debug_less newenv
	   "\n..sbindlist=" sbindlist "\n.. maclist=" maclist)
    (assert_msg "check sbindlist" (is_list_or_null sbindlist) sbindlist sexpr)
    (each_component_in_list
     sbindlist
     curbindsrc
     (debug "mexpand_let" " curbindsrc=" curbindsrc)
     (let ( (cursbind
	     (cond
	      ( (is_a curbindsrc class_source_any_let_binding)
		;;can happen only if the LET expression comes from some macro
		curbindsrc)
	      ( (is_a curbindsrc class_sexpr)
		(mexpand_letbinding curbindsrc newenv mexpander modctx))
	      (:else
	       (error_at loc "inexpected binding $1 in LET" curbindsrc)
	       ())))
	    )
       (debug "mexpand_let" " cursbind=" cursbind
	      "\n..for curbindsrc=" debug_less curbindsrc)
       (assert_msg "check cursbind" (is_a cursbind class_source_any_let_binding)
		   cursbind curbindsrc sexpr)
       (cond ( (is_a cursbind class_source_let_binding)
	       (let (
		     (sx (unsafe_get_field :sletb_expr cursbind))
		     (letbind (instance class_let_binding
					:binder (unsafe_get_field :sletb_binder cursbind)
					:letbind_type (unsafe_get_field :sletb_type cursbind)
					:letbind_expr sx
					:letbind_loc (or (get_field :loca_location cursbind) loc)))
		     )
		 (debug "mexpand_let" " letbind=" letbind)
		 (put_env newenv letbind)
		 (list_append letbindlist cursbind)
		 (debug "mexpand_let" " letbind-updated newenv=" newenv
			"\n.. for cursbind=" cursbind)
		 )
	       )
	     ( (is_a cursbind class_source_macro_let_binding)
	       (debug "mexpand_let:macro" " loc=" loc "; cursbind=" cursbind)
	       (shortbacktrace_dbg "mexpand_let:macro" 15)
	       (assert_msg "check maclist" (is_list maclist) maclist modctx)
	       (let ( 
		     (macsymb (get_field :sletb_binder cursbind))
		     (macloc (or (get_field :loca_location cursbind) loc))
		     (macformals (get_field :sletm_macro_formals cursbind))
		     (macbody (get_field :sletm_macro_body cursbind))
		     (macbind (instance class_defined_macro_binding
					:binder macsymb
					:mbind_expanser ()
					:mbind_defmacro cursbind
					:mbind_data ()
					))
		     (defmaclet (instance class_source_defmacro_in_let
					  :loca_location loc
					  :sdef_name macsymb
					  :sdef_doc ()
					  :sformal_args macformals
					  :sfun_body macbody
					  :smacro_binding macbind
					  :smacro_sourceletbinding cursbind))
		     (sinstmac (instance class_source_macro_installation
					 :loca_location loc
					 :smacinst_defmacro defmaclet
					 :smacinst_env newenv))
		     )
		 (list_append maclist sinstmac)
		 (debug "mexpand_let:macro"
			" loc=" loc
			"\n.. macbind=" macbind
			"\n.. defmaclet=" defmaclet
			"\n.. updated maclist=" maclist
			"\n.. sinstmac=" sinstmac)
		 (letrec ( (mexpanser
			    (lambda (sexprm envm mexpanderm modctxm)
			      (debug "mexpand_let:mexpanser sexprm=" sexprm
				     "\n.. envm=" debug_more envm
				     "\n.. modctxm=" debug_less modctxm
				     "\n.. mexpanderm=" debug_less mexpanderm
				     "\n.. macbind=" macbind)
			      (shortbacktrace_dbg "mexpand_let:mexpanser" 25)
			      (debug "mexpand_let:mexpanser before melt_delayed_macro_expander"
				     " maclist=" maclist "\n.. macbind=" macbind)
			      (melt_delayed_macro_expander macbind maclist envm mexpanderm modctx)
			      (debug "mexpand_let:mexpanser after melt_delayed_macro_expander"
				     " maclist=" maclist "\n.. macbind=" macbind)
			      (let ( (mclos (get_field :mbind_expanser macbind))
				     (locm (get_field :loca_location sexprm))
				     )
				(debug "mexpand_let:mexpanser"
				       " loc=" loc " locm=" locm
				       "\n.. mclos=" mclos
				       "\n.. mexpanser=" mexpanser
				       "\n.. sexprm=" sexprm)
				;; @@@ NOT SURE
				;; (when (== mclos mexpanser)
				;;  (error_at locm "failed to macro-expand LET :macro $1" macsymb)
				;;  (warning_at loc "failed to expand LET :macro $1 defined here" macsymb)
				;;  (return))
				(multicall 
				 (expmac othermac)
				 (mclos sexprm envm mexpanderm modctxm)
				 (debug "mexpand_let:mexpanser expmac=" expmac " othermac=" othermac)
				 (return expmac othermac)
				 )
				)
			      ))
			   )
		   (debug "mexpand_let:macro" " loc=" loc " mexpanser=" mexpanser "\n.. macbind=" macbind)
		   (put_fields macbind :mbind_expanser mexpanser)
		   (debug "mexpand_let:macro" " loc=" loc " update macbind=" macbind)
		   (put_env newenv macbind)
		   (list_append letbindlist cursbind)
		   (debug "mexpand_let:macro" " letbind-updated newenv=" debug_more newenv
			  "\n.. for cursbind=" cursbind
			  "\n.. macbind=" macbind)
		   (shortbacktrace_dbg "mexpand_let:macro-endletrec-mexpanser" 32)
		   )
		 ))
	     (:else
	      (assert_msg "impossible cursbind" () cursbind curbindsrc)))
       )
     )					; end each_component_in_list
    (debug "mexpand_let" " loc=" loc " final newenv=" debug_more newenv
	   "\n.. restpair=" restpair)
    (let ( (bodytup (expand_pairlist_as_tuple restpair newenv mexpander modctx))
	   (bindtup (list_to_multiple letbindlist discr_multiple))
	   (letr 
	    (instance class_source_let
		      :loca_location loc
		      :slet_bindings bindtup
		      :slet_body bodytup))
	   )
      (debug "mexpand_let" " loc=" loc " result letr=" letr "\n.. modctx=" modctx)
      (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
 or :auto (which is the default), followed by a local variable name,
 followed by a single expression. With an :auto type annotation, the
 bound variable takes the type provided by the binding 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 "yes_recursively_constructible recv" 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 modctx)
  (debug "mexpand_letrec sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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 "mexpand_letrec firstloop curbindexpr" 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 "mexpand_letrec recsexprtup after firstloop" recsexprtup)
	      (debug "mexpand_letrec vartup after firstloop" vartup)
;;;
	      ;; 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 "mexpand_letrec second loop curvar" curvar)
		 (if (mapobject_get envmap curvar)
		     (error_at loc "repeated variable $1 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 "mexpand_letrec bindtup after secondloop" bindtup)
;;;
	      ;; 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 (mexpander cursexpr newenv mexpander modctx))
		     (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 "mexpand_letrec exprtup after thirdloop" exprtup)
	      )		;end let recbindtup when bindexpr is an s-expr
	  (error_plain loc "missing letbinding-s in LETREC"_))
      )
    (debug "mexpand_letrec srcbindtup" srcbindtup)
    (setq bodytup (expand_pairlist_as_tuple restpair newenv mexpander modctx))
    (if (<=i (multiple_length bodytup) 0)
	(error_plain loc "empty body in LETREC"))
    (let ( (letr
	    (instance class_source_letrec
		      :loca_location loc
		      :slet_bindings srcbindtup
		      :slet_body bodytup)) )
      (debug "mexpand_letrec result" letr)
      (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 modctx)
  (debug "mexpand_lambda sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (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 :checkarg env mexpander modctx)) )
      (setq curpair (pair_tail curpair))
      (foreach_in_multiple 
       (argtup)
       (lb :long ix) 
       (assert_msg "check lb" (is_a lb class_formal_binding) lb)
       (put_env newenv lb))
      (let ( (bodytup (expand_pairlist_as_tuple curpair newenv mexpander modctx))
	     (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 @code{(LAMBDA ( @var{<formals> ...} ) @var{<body>...})}. The
 formal argument list should have its first formal be a :value. Other
 arguments can be c-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{constructive} so can
 appear in $LETREC bindings.}# )


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

;;;;;;;; for VARIADIC
(defun mexpand_variadic (sexpr env mexpander modctx)
  (debug "mexpand_variadic sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (firstpair (pair_tail (list_first cont))) 
	 (rescont (reference ()))
	 (varbindmap (make_mapobject discr_map_objects (+i 7 (*i 3 (list_length cont)))))
	 (hookfun (lambda (x) 
		    (debug "mexpand_variadic/hookfun rescont set to x" x "; loc=" loc)
		    (set_ref rescont x)))
	 )
    (foreach_pair
     (firstpair)
     (curpaircase curcase)
     (debug "mexpand_variadic curcase=" curcase " loc=" loc)
     (when (is_not_a curcase class_sexpr)
	   (error_plain loc "(VARIADIC variadic-case...) expects a list, so cannot have non-list components.")
	   (return))
     (let (
	   (curcaseloc (unsafe_get_field :loca_location curcase))
	   (curcasecont (unsafe_get_field :sexp_contents curcase))
	   (curcasepair (list_first curcasecont))
	   (casefirst (pair_head curcasepair))
	   (caserest (pair_tail curcasepair))
	   )
       (debug "mexpand_variadic casefirst=" casefirst " curcase=" curcase)
       (cond
	((== casefirst :else)
	 ;; warn if not last
	 (when (pair_tail curpaircase)
	       (error_plain curcaseloc "case (:ELSE ...) should be last in (VARIADIC ...)")
	       (warning_plain loc "This (VARIADIC ...) should have (:ELSE ...) case at last")
	       (return))
	 ;; expand the body
	 (debug "mexpand_variadic caserest=" caserest
		"; curcaseloc=" curcaseloc "; loc=" loc)
	 (let ( (bodytup (expand_pairlist_as_tuple caserest env mexpander modctx))
		 )
	   (debug "mexpand_variadic else bodytup before hookfun " bodytup)
	   (debug "mexpand_variadic hookfun before" hookfun)
	   (shortbacktrace_dbg "mexpand_variadic before calling hookfun for else" 15)
	   (hookfun bodytup)
	   )
	 )
	((or (null casefirst)
	     (is_a casefirst class_sexpr))
	 (debug "mexpand_variadic casefirst=" casefirst)
	 (let ( (args (lambda_arg_bindings casefirst :checkarg env mexpander modctx))
		(newenv (fresh_env env))
		)
	   (debug "mexpand_variadic args" args)
	   (foreach_in_multiple 
	    (args)
	    (fbi :long fix)
	    (assert_msg "check fbi" (is_a fbi class_formal_binding) fbi)
	    (let ( ( fbisymb (get_field :binder fbi)) 
		   )
	      (warn_if_redefined fbisymb newenv loc)
	      (if (mapobject_get varbindmap
				 fbisymb)
		  (error_at curcaseloc "formals should all be distinct in (VARIADIC ...) but $1 is repeated" 
			    (get_field :named_name fbisymb))
		)
	      (mapobject_put varbindmap fbisymb fbi)
	      (put_env newenv fbi)
	      ))
	   (let ( (bodytup (expand_pairlist_as_tuple caserest newenv mexpander modctx))
		  (sifvariadic (instance class_source_ifvariadic
					 :loca_location (or curcaseloc loc)
					 :sifvariadic_argbind args
					 :sifvariadic_then bodytup
					 :sifvariadic_else ()))
		  )
	     (debug "mexpand_variadic bodytup" bodytup " sifvariadic=" sifvariadic " loc=" loc)
	     (shortbacktrace_dbg "mexpand_variadic before calling hookfun for casefirst" 15)
	     (hookfun sifvariadic)
	     (setq hookfun
		   (lambda (xtup) 
		     (debug "mexpand_variadic/hookfun xtup" xtup)
		     (put_fields sifvariadic :sifvariadic_else 
				 (if (is_multiple_or_null xtup) 
				     xtup
				   (tuple xtup)))
		     (debug "mexpand_variadic/hookfun updated sifvariadic" sifvariadic)
		     ))
	     )))
	(:else
	 (debug "mexpand_variadic invalid casefirst" casefirst)
	 (error_plain curcaseloc "invalid case in (VARIADIC ...), should start with formals")
	 (return)
	 )
	)
       )
     (debug "mexpand_variadic done curcase=" curcase)
     )
    (debug "mexpand_variadic final rescont=" rescont " loc=" loc)
    (let ( (res !rescont) 
	   )
      (debug "mexpand_variadic result=" res " loc=" loc)
      (return res)
      )))
(install_initial_macro 'variadic mexpand_variadic)
(export_macro variadic mexpand_variadic
 :doc #{The $VARIADIC syntax is for getting variable arguments inside
variadic functions -using :REST-.  Syntax is 
@code{(VARIADIC @var{variadic-case ...})} where each @var{variadic-case} is
@code{( (@var{formal ...}) @var{body ...})} and the last
@var{variadic-case} can also be @code{(:ELSE @var{body ...})}. When
the actual variable arguments's signature match the given formals in a
@var{variadic-case}, they are bound, and the body of that case is
evaluated. If no @var{formals} match in type and number and if the last
@var{variadic-case} starts with @code{:ELSE} it is exacuted. As an
expression, @code{(VARIADIC @var{...})} gives no result, so is
@code{:void}. In a @var{variadic-case}, if no @var{<formals} are
given, the body is executed when no more actual variable arguments
remain.}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;; for MULTICALL
(defun mexpand_multicall (sexpr env mexpander modctx)
  (debug "mexpand_multicall sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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) :checkarg env mexpander modctx)) 
	   )
      (if (is_a restup discr_variadic_formal_sequence)
	  (progn
	    (error_plain loc "MULTICALL cannot have variadic result")
	    (return)))
      (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 (mexpander curcallexp env mexpander modctx)) )
	  ;; check the called subexpression
	  (cond 
	   ((or (is_a curcall class_source_apply)
		(is_a curcall class_source_msend)) 
	    ())
	   (:else 
	    (debug "mexpand_multicall bad curcall" 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 (expand_pairlist_as_tuple curpair newenv mexpander modctx))
		 (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 @code{(MULTICALL ( @var{<formals>} ) @var{<application-or-message-send>}
 @var{<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 BOX
(defun mexpand_box (sexpr env mexpander modctx)
  (debug "mexpand_box start sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (boxedexp (pair_head curpair))
	 )
    (if (pair_tail curpair)
	(error_plain loc "BOX should have only one argument"_))
    (let (
	  (boxed (mexpander boxedexp env mexpander modctx))
	  (src (instance class_source_box
			 :loca_location loc
			 :sboxed boxed))
	  )
      (debug "mexpand_box src=" src)
      (return src)
      )))
(install_initial_macro 'box mexpand_box)
(export_macro
 box mexpand_box
 :doc #{The $BOX syntax is boxing stuff into mutable values. So
 @code{(box 2)} gives the same as @code{(make_integerbox discr_integer
 2)} and if @var{g} is some @i{gimple} stuff, @code{(box g)} gives the
 same as @code{(make_gimple discr_gimple g)} etc... If the argument is
 some value, it makes some reference, instance of $CLASS_REFERENCE,
 from that value.}#)

;;;;;;; for CONSTANT_BOX
(defun mexpand_constant_box (sexpr env mexpander modctx)
  (debug "mexpand_constant_box start sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (boxedexp (pair_head curpair))
	 )
    (if (pair_tail curpair)
	(error_plain loc "CONSTANT_BOX should have only one argument"_))
    (let (
	  (boxed (mexpander boxedexp env mexpander modctx))
	  (src (instance class_source_constant_box
			 :loca_location loc
			 :sboxed boxed))
	  )
      (debug "mexpand_constant_box src=" src)
      (return src)
      )))
(install_initial_macro 'constant_box mexpand_constant_box)
(export_macro
 constant_box mexpand_constant_box
 :doc #{The $CONSTANT_BOX syntax is boxing stuff into constant
 values. So @code{(constant_box 2)} gives the same as
 @code{(make_integerbox discr_constant_integer 2)} and if @var{g} is
 some @i{gimple} stuff, @code{(box g)} gives the same as
 @code{(make_gimple discr_constant_gimple g)} etc...}#)


;;;;;;; for UNBOX
(defun mexpand_unbox (sexpr env mexpander modctx)
  (debug "mexpand_unbox start sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (ubctypk (pair_head curpair))
	 (ubexpr (progn
		   (setq curpair (pair_tail curpair))
		   (pair_head curpair)))
	 )
    (setq curpair (pair_tail curpair))
    (when curpair
      (error_plain loc "UNBOX expects two arguments: (UNBOX <ctype> <expr>)")
      (return))
    (debug "mexpand_unbox ubctypk=" ubctypk " ubexpr=" ubexpr)
    (when (is_not_a ubctypk class_keyword)
      (error_plain loc "first argument to UNBOX should be a ctype keyword like :tree ....")
      (return))
    (let ( (ctyp (get_field :symb_data ubctypk))
	   )
      (when (is_not_a ctyp class_ctype)
	(error_plain loc "first argument to UNBOX should be a ctype")
	(return))
      (debug "mexpand_unbox ctyp=" ctyp)
      (let ( (mexp (mexpander ubexpr env mexpander modctx))
	     (sunbox (instance class_source_unbox
			       :loca_location loc
			       :sunbox_ctype ctyp
			       :sunbox_expr mexp
			       ))
	     )
	(debug "mexpand_unbox mexp=" mexp " sunbox=" sunbox)
	(return sunbox)
	))))
(install_initial_macro 'unbox mexpand_unbox)
(export_macro
 unbox mexpand_unbox
 :doc #{The $UNBOX syntax is unboxing some value into some raw
 stuff. It is given a ctype and an expression: @code{(UNBOX
 @var{ctype} @var{expr})}.}#)


;;;;;;;; for COMMENT (only of strings)
(defun mexpand_comment  (sexpr env mexpander modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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 CHEADER
(defun mexpand_cheader  (sexpr env mexpander modctx)
  (debug "mexpand_cheader sexpr=" sexpr "\n.. modctx=" debug_less modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (chead (pair_head curpair))
	 )
    (if (pair_tail curpair)
	(warning_plain loc "CHEADER should have only one argument"))
    (debug "mexpand_cheader chead=" chead "\n.. loc=" loc)
    (cond
     ((is_string chead)
      (void)
      )
     ((is_a chead class_sexpr_macrostring)
      (let ( (sbuf (make_strbuf discr_strbuf))
	     (scont (get_field :sexp_contents chead))
	     (sloc (get_field :loca_location chead))
	     )
	(if sloc (setq loc sloc))
	(foreach_pair_component_in_list
	 (scont)
	 (curpair curarg)
	 (add2out sbuf curarg)
	 )
	(setq chead (strbuf2string discr_verbatim_string sbuf))
	))
     (:else
      (error_plain loc "CHEADER without string or macrostring"_)
      (return)
      )
     )
    (shortbacktrace_dbg "mexpand_cheader" 8)
    (let ( (sch (instance class_source_cheader
			  :loca_location loc
			  :sc_codestring chead)) )
      (debug "mexpand_cheader gives sch=" sch)
      (return sch ())
      )))
(install_initial_macro 'cheader mexpand_cheader)
(export_macro cheader mexpand_cheader
 :doc #{The $CHEADER syntax inserts C code in the header part of the generated code.}#)


;;;;;;;;;;;;;;;;
;;;;;;;; for CIMPLEMENT
(defun mexpand_cimplement  (sexpr env mexpander modctx)
  (debug "mexpand_cimplement sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (chead (pair_head curpair))
	 )
    (if (pair_tail curpair)
	(warning_plain loc "CIMPLEMENT should have only one argument"))
    (debug "mexpand_cimplement chead=" chead)
    (cond
     ((is_string chead)
      (void)
      )
     ((is_a chead class_sexpr_macrostring)
      (let ( (sbuf (make_strbuf discr_strbuf))
	     (scont (get_field :sexp_contents chead))
	     (sloc (get_field :loca_location chead))
	     )
	(if sloc (setq loc sloc))
	(foreach_pair_component_in_list
	 (scont)
	 (curpair curarg)
	 (add2out sbuf curarg)
	 )
	(setq chead (strbuf2string discr_verbatim_string sbuf))
	))
     (:else
      (error_plain loc "CIMPLEMENT without string or macrostring"_)
      (return)
      )
     )
    (let ( (sch (instance class_source_cimplement
			  :loca_location loc
			  :sc_codestring chead)) )
      (debug "mexpand_cimplement gives sch=" sch)
      (return sch)
      )))
(install_initial_macro 'cimplement mexpand_cimplement)
(export_macro cimplement mexpand_cimplement
 :doc #{The $CIMPLEMENT syntax inserts C code in the implementation part of the generated code.}#)


;;;;;;;;;;;;;;;;
;;;;;;;; for MODULE_IS_GPL_COMPATIBLE
(defun mexpand_module_is_gpl_compatible  (sexpr env mexpander modctx)
  (debug "mexpand_module_is_gpl_compatible sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (chead (pair_head curpair))
	 )
    (if (pair_tail curpair)
	(warning_plain loc "MODULE_IS_GPL_COMPATIBLE should have only one argument"))
    (debug "mexpand_module_is_gpl_compatible chead=" chead)
    (cond
     ((is_string chead)
      (void)
      )
     ((is_a chead class_sexpr_macrostring)
      (let ( (sbuf (make_strbuf discr_strbuf))
	     (scont (get_field :sexp_contents chead))
	     (sloc (get_field :loca_location chead))
	     )
	(if sloc (setq loc sloc))
	(foreach_pair_component_in_list
	 (scont)
	 (curpair curarg)
	 (add2out sbuf curarg)
	 )
	(setq chead (strbuf2string discr_verbatim_string sbuf))
	))
     ((is_a chead class_symbol)
      (setq chead (get_field :named_name chead))
      (assert_msg "check symbol name" (is_string chead) chead))
     (:else
      (error_plain loc "MODULE_IS_GPL_COMPATIBLE without string or macrostring"_)
      (return)
      )
     )
    (let ( (sch (instance class_source_module_is_gpl_compatible
			  :loca_location loc
			  :sc_codestring chead)) )
      (debug "mexpand_module_is_gpl_compatible gives sch=" sch)
      (return sch)
      )))
(install_initial_macro 'module_is_gpl_compatible mexpand_module_is_gpl_compatible)
(export_macro module_is_gpl_compatible mexpand_module_is_gpl_compatible
 :doc #{The $MODULE_IS_GPL_COMPATIBLE syntax reminds that MELT modules
 should be GPL compatible. Argument is a comment-like string or
 symbol. This has a role analogue to the
 @code{plugin_is_GPL_compatible} symbol in GCC plugins.}#)


;;;;;;;;;;;;;;;;
;;; for USE_PACKAGE_FROM_PKG_CONFIG

(defun mexpand_use_package_from_pkg_config  (sexpr env mexpander modctx)
  (debug "mexpand_use_package_from_pkg_config sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (xargtup (expand_restlist_as_tuple cont env mexpander modctx))
	 (cmdbuf (make_strbuf discr_strbuf))
	 )
    (debug "mexpand_use_package_from_pkg_config xargtup=" xargtup)
    (add2out cmdbuf "pkg-config --exists")
    (foreach_in_multiple
     (xargtup)
     (curpkgname :long pkgix)
     (unless 
	 (is_string curpkgname)
       (error_plain loc "invalid argument to (USE_PACKAGE_FROM_PKG_CONFIG <pkg-name>...), expecting string")
       (return)
       )
     (let ( (:long goodpkgname 1)
	    )
       (code_chunk checkpkgname_chk #{/* mexpand_use_package_from_pkg_config $CHECKPKGNAME_CHK */ {
		   const char* pkgs_$CHECKPKGNAME_CHK
                      = melt_string_str ((melt_ptr_t) $CURPKGNAME) ;
		   if (!pkgs_$CHECKPKGNAME_CHK) 
                      $GOODPKGNAME = 0 ;
		     else {
		   const char* pc = NULL;
		   for (pc = pkgs_$CHECKPKGNAME_CHK   ; 
			   *pc && $GOODPKGNAME   ; 
			   pc++)
		   {
		   if (ISALNUM(*pc) || *pc == '+' || *pc == '-' || *pc == '_' || *pc == '.' || *pc == '@')
		   continue ;
		   else $GOODPKGNAME = 0L ;
		   }
		   } ;
		   } /* end mexpand_use_package_from_pkg_config $CHECKPKGNAME_CHK */ }#)
       (unless goodpkgname
	 (error_at loc "invalid package name $1 for (USE_PACKAGE_FROM_PKG_CONFIG ...)" curpkgname)
	 (return))
       (add2out cmdbuf " " curpkgname)
       )
     ) ;; end foreach_in_multiple
    ;; check by running pkg-config --exists that the package are existing
    (let ( (cmdstr (strbuf2string discr_string cmdbuf))
	   (:long failcmd 0)
	   )
      (debug "mexpand_use_package_from_pkg_config cmdstr=" cmdstr)
      (code_chunk testpkgconfig_chk #{ /* mexpand_use_package_from_pkg_config $TESTPKGCONFIG_CHK */ {
		  const char* cmd_$TESTPKGCONFIG_CHK = 
		    melt_string_str ((melt_ptr_t) $CMDSTR) ;
		  fflush (NULL)	;
		  $FAILCMD = (cmd_$TESTPKGCONFIG_CHK 
			      ? system (cmd_$TESTPKGCONFIG_CHK) 
			      : 1000) ;
		  } /* end mexpand_use_package_from_pkg_config $TESTPKGCONFIG_CHK */
		  }#)
      (debug "mexpand_use_package_from_pkg_config failcmd=" failcmd)
      (when failcmd
	(error_at loc "unexistent package names for USE_PACKAGE_FROM_PKG_CONFIG $1" cmdstr)
	(return))
      )
    ;; return the source 
    (let ( (sup (instance class_source_use_package_from_pkg_config
			  :loca_location loc
			  :susepackage_pkgtuple xargtup)) )
      (debug "mexpand_use_package_from_pkg_config gives sup=" sup)
      (return sup)
    )))

(install_initial_macro 'use_package_from_pkg_config mexpand_use_package_from_pkg_config)
(export_macro use_package_from_pkg_config mexpand_use_package_from_pkg_config
 :doc #{The @code{$USE_PACKAGE_FROM_PKG_CONFIG} or
 @code{$USE-PACKAGE-FROM-PKG-CONFIG} syntax enables usage of
 @code{pkg-config}-ured packages. Arguments are strings naming
 packages. This modifies the compilation and linking of generated C
 code. Probably using some $CHEADER for some @code{#include} is useful.}#)
(export_macro use-package-from-pkg-config mexpand_use_package_from_pkg_config
 :doc #{The $USE-PACKAGE-FROM-PKG-CONFIG or
 $USE_PACKAGE_FROM_PKG_CONFIG syntax enables usage of
 @code{pkg-config}-ured packages. Arguments are strings naming
 packages. This modifies the compilation and linking of generated C
 code. Probably using some $CHEADER for some @code{#include} is useful.}#)

;;;;;;;;;;;;;;;;
;;;;;;;; for PROGN

;; internal routine to make a return from a pairlist at a location
(defun pairlist_to_return (pair loc env mexpander modctx)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (bodytup (expand_pairlist_as_tuple pair env mexpander modctx))
	 )
    (instance class_source_return
	      :loca_location loc
	      :sargop_args bodytup
	      )
    ))

;;;; the progn expanser
(defun mexpand_progn (sexpr env mexpander modctx)
  (debug "mexpand_progn sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) 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
			       modctx)) )
      (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 modctx)
  (debug "mexpand_return sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (retr
	  (pairlist_to_return (pair_tail (list_first (unsafe_get_field :sexp_contents sexpr)))
			      (unsafe_get_field :loca_location sexpr)
			      env
			      mexpander
			      modctx)) 
	 )
    (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. Hooks cannot return secondary results.}#)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; the forever expanser
(defun mexpand_forever (sexpr env mexpander modctx)
  (debug "mexpand_forever sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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 (mexpander slabnam env mexpander modctx))
	 (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 (expand_pairlist_as_tuple curpair newenv mexpander modctx))
	     (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 modctx)
  (debug "mexpand_exit sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (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 (mexpander slabnam env mexpander modctx))
	 (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)) )
      (when (is_not_a labind class_label_binding)
	    (error_at loc "bad label in EXIT $1"_
			(unsafe_get_field :named_name xlabnam))
	    (return ()))
      (let ( (bodytup (expand_pairlist_as_tuple curpair newenv mexpander modctx))
	     (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 exiting a local $FOREVER loop in the
 same function. Syntax is @code{(EXIT @var{<loop-name>} @var{<expression>...})}.}#)

;;;;;;;;;;;;;;;; 
;;;; the again expander
(defun mexpand_again (sexpr env mexpander modctx)
  (debug "mexpand_again sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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))
	 (xlabsymb (mexpander slabnam env mexpander modctx))
	 )
    (setq curpair (pair_tail curpair))
    (when (is_not_a xlabsymb class_symbol)
	    (error_plain loc "bad label in (AGAIN <label>)"_)
	    (return))
    (when curpair
	  (error_plain loc "extra operands to (AGAIN <label>)")
	  (return))
    (let ( (labind (find_env env xlabsymb)) )
      (when (is_not_a labind class_label_binding)
	    (error_at loc "bad label in AGAIN $1"_
			(unsafe_get_field :named_name xlabsymb))
	    (return))
    (let ( (magain (instance class_source_again
			:loca_location loc
			:slabel_bind labind
			     ))
		 )
      (debug "mexpand_again result" magain)
      (return magain)
))))

(install_initial_macro 'again mexpand_again)
(export_macro
 again mexpand_again
 :doc #{The $AGAIN syntax is for restarting a local $FOREVER loop in the
 same function. Syntax is @code{(AGAIN @var{<loop-label>})}.}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 modctx)
  (debug "mexpand_compile_warning sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (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 (mexpander smsg env mexpander modctx))
	 )
    (if (not (is_string xmsg))
	(progn
	  (error_at loc "missing message string in (COMPILE_WARNING <msg> <exp>)"_)
	  (return ())))
    (setq curpair (pair_tail curpair))
    (let ( (sexp (pair_head curpair))
	   (xexp (mexpander sexp env mexpander modctx))
	   )
      (setq curpair (pair_tail curpair))
      (if (notnull curpair)
	  (error_at loc "too many arguments in (COMPILE_WARNING <msg> [<exp>])"_))
      (let ( (res (instance  class_source_compile_warning
			     :loca_location loc
			     :scdiag_msg xmsg
			     :scdiag_expr xexp
			     ))
	     )
	(debug "mexpand_compile_warning result" res)
	(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>]).}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; compile time error (compile_error msg expr)
;; we don't issue the error at expansion phase, but at normalization phase.
(defun mexpand_compile_error (sexpr env mexpander modctx)
  (debug "mexpand_compile_error sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (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 (mexpander smsg env mexpander modctx))
	 )
    (if (not (is_string xmsg))
	(progn
	  (error_at loc "missing message string in (COMPILE_ERROR <msg> <exp>)"_)
	  (return ())))
    (setq curpair (pair_tail curpair))
    (let ( (sexp (pair_head curpair))
	   (xexp (mexpander sexp env mexpander modctx))
	   )
      (setq curpair (pair_tail curpair))
      (if (notnull curpair)
	  (error_at loc "too many arguments in (COMPILE_ERROR <msg> [<exp>])"_))
      (let ( (res (instance  class_source_compile_error
			     :loca_location loc
			     :scdiag_msg xmsg
			     :scdiag_expr xexp
			     ))
	     )
	(debug "mexpand_compile_error result" res)
	(return res)
	))))
(install_initial_macro 'compile_error mexpand_compile_error)
(export_macro compile_error mexpand_compile_error
 :doc #{The $COMPILE_ERROR syntax issues an error, inspired by GCC
 #error. Syntax is (COMPILE_ERROR <string> [<expression>]). May be
 useful in macros or with $GCCIF.}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; assert_msg macro is expanded into other src..
;;;;;; (assert_msg msg check ...)
;;; becomes
;;;;;; (cppif MELT_HAVE_DEBUG (if check (melt_assert_failure_fun () msg filename lineno ...)) ())
;;; where melt_assert_failure_fun is a function.

(defun mexpand_assert_msg (sexpr env mexpander modctx)
  (debug "mexpand_assert_msg sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(xmsg (mexpander (pair_head curpair)  env mexpander modctx))
	(xtest ())
	(xarglist ())
	(assfail_binding (find_env env 'melt_assert_failure_fun))
	)
    (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)
	    (setq xtest (mexpander (pair_head curpair) env mexpander modctx))
	    (setq xarglist (expand_pairlist_as_list (pair_tail curpair) env mexpander modctx))
	    )
	  (:else
	   (warning_strv loc "empty ASSERT_MSG" xmsg)
	   ))
    (let (
	  (assfailfun 
	   (cond 
	    ( (null assfail_binding)
	      (error_plain loc "unbound MELT_ASSERT_FAILURE in (ASSERT_MSG <msg> <test>)"_)
	      (debug "mexpand_assert_msg  without MELT_ASSERT_FAILURE env=" env
		     " env's class" (discrim env)
		     "find_env giving:" (find_env_debug env 'melt_assert_failure_fun)
		     "'melt_assert_failure_fun=" 'melt_assert_failure_fun)
	      (assert_msg "assfail_binding nul! @@" ())
	      (return))
	    ( (is_a assfail_binding class_function_binding)
	      (or 
	       (unsafe_get_field :fixbind_data assfail_binding)
	       (unsafe_get_field :fubind_defun assfail_binding))
	       )
	    ( (and (is_a assfail_binding class_value_binding)
		   (is_closure (unsafe_get_field :vbind_value assfail_binding)))
	      (unsafe_get_field :vbind_value assfail_binding))
	    (:else
	     (debug "mexpand_assert_msg bad assfail_binding=" assfail_binding)
	     (error_plain loc "MELT_ASSERT_FAILURE badly bound in  (ASSERT_MSG <msg> <test>)"_)
	     (return)
	     )))
	  (filnam (cond
		   ((is_mixint loc) (mixint_val loc))
		   ((is_mixloc loc) (mixloc_val loc))))
	  (afapply (instance 
		  class_source_apply
		  :loca_location loc
		  :sapp_fun 'melt_assert_failure_fun
		  :sargop_args (list_to_multiple 
				(list_append2list
				 (list
				  ()
				  xmsg
				  filnam
				  (make_integerbox discr_integer (get_int loc)))
				 xarglist
				))
		  )
		  )
	  (atest (instance
		  class_source_ifelse
		  :loca_location loc
		  :sif_test xtest
		  :sif_then ()
		  :sif_else afapply))
	  (acppif (instance class_source_cppif
			    :loca_location loc
			    :sifp_cond 'MELT_HAVE_DEBUG
			    :sifp_then atest
			    :sifp_else ()
			    )) 
	  )
      (debug "mexpand_assert_msg result acppif" 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
	      MELT_HAVE_DEBUG enabled- and also issues a compile
	      warning if condition is missing so false.}#)



;;;;;; (this_line)  is expand to the literal integer corresponding to the line number;
;;;;; inspired by C++ __LINE__
(defun mexpand_this_line (sexpr env mexpander modctx)
  (debug "mexpand_this_line sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(:long dline (get_int loc))
	)
    (debug "mexpand_this_line dline=" dline)
    (return (if (>i dline 0)
		(constant_box dline))
	    ())))

(install_initial_macro 'this_line mexpand_this_line)
(export_macro this_line mexpand_this_line
	      :doc #{$THIS_LINE, inspired by the @code{__LINE__} macro
	      of C or C++, is a macro expanding to the line number in
	      the source file of its occurrence, or NIL if no line.}#)


;;;;;; (this_file)  is expand to the literal integer corresponding to the line number;
;;;;; inspired by C++ __FILE__
(defun mexpand_this_file (sexpr env mexpander modctx)
  (debug "mexpand_this_file sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(dfilnam (cond
		  ((is_mixint loc) (mixint_val loc))
		  ((is_mixloc loc) (mixloc_val loc))))
	)
    (debug "mexpand_this_file dfilnam=" dfilnam)
    (return dfilnam)))
(install_initial_macro 'this_file mexpand_this_file)
(export_macro this_file mexpand_this_file
	      :doc #{$THIS_FILE, inspired by the @code{__FILE__} macro
	      of C or C++, is a macro expanding to the string naming
	      the source file of its occurrence, or NIL if no source location is available.}#)


;;;;;; (debug ...) 
;;; becomes
;;;;;; (cppif MELT_HAVE_DEBUG (if (melt_need_dbg 0) (melt_debug_fun () count filename lineno ...)))
;;; where count is (melt_callcount) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mexpand_debug  (sexpr env mexpander modctx)
  (debug "mexpand_debug sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(dfilnam (cond
		  ((is_mixint loc) (mixint_val loc))
		  ((is_mixloc loc) (mixloc_val loc))))
	(:long dline (get_int loc))
	(debugfunbind (find_env env 'melt_debug_fun))
	(thecountbind (find_env env 'melt_callcount))
	(theneeddbgbind (find_env env 'melt_need_dbg))
	(theincrdbgbind (find_env env 'melt_increment_dbgcounter))
	(curpair (pair_tail (list_first cont)))
	(xarglist (expand_pairlist_as_list curpair env mexpander modctx))
	(dbgarglist (list ()))
	)
    ;;; warn if the debug expr is really heavy
    (let ( (sexpw (s_expr_weight sexpr)) 
	   (:long nbsepw (get_int sexpw))
	   )
      (if (or
	   (>i nbsepw 26)
	   (null sexpw))
	  (warning_strv loc
			"suspicious very heavy (DEBUG ....)"
			(string4out discr_string "weight:" sexpw))))
    ;;;
    (if (not (is_string dfilnam))
	(progn
	  (error_plain loc "(DEBUG ...) used without file location")
	  (return)))
    (if (not (or (is_a debugfunbind class_function_binding)
		 (is_a debugfunbind class_value_binding)))
	(progn
	(error_plain loc "(DEBUG ...) used in context with bad MELT_DEBUG_FUN")
	(return)))
    (let (
	  (thecountprim 
	   (cond 
	    ( (is_a thecountbind class_primitive_binding)
	      (get_field :pbind_primitive thecountbind))
	    ( (is_a thecountbind class_value_binding)
	      (get_field :vbind_value thecountbind))
	    (:else
	     (error_plain loc "(DEBUG ...) used in context with bad THE_MELTCALLCOUNT")
	     (return))))
	  (dcount (instance class_source_primitive
			    :loca_location loc
			    :sprim_oper thecountprim
			    :sargop_args (tuple)))
	  )
      (list_append dbgarglist dcount)
      )
    (list_append dbgarglist dfilnam)
    (list_append dbgarglist (make_integerbox discr_constant_integer dline))
    (list_append2list dbgarglist xarglist)
    (debug "mexpand_debug dbgarglist" dbgarglist)
    (let (
	  (:long nbdbgarg (list_length dbgarglist))
	  (theneeddbg
	   (cond 
	    ( (is_a theneeddbgbind class_primitive_binding)
	      (get_field :pbind_primitive theneeddbgbind))
	    ( (is_a theneeddbgbind class_value_binding)
	      (get_field :vbind_value theneeddbgbind))
	    (:else
	     (error_plain loc "(DEBUG ...) used in context with bad MELT_NEED_DBG")
	     (return))))
	  (dneedbg (instance class_source_primitive
			     :loca_location  loc
			     :sprim_oper theneeddbg
			     :sargop_args (tuple '0)))
	  (dcall (instance 
		  class_source_apply
		  :loca_location loc
		  :sapp_fun 'melt_debug_fun
		  :sargop_args (list_to_multiple dbgarglist discr_multiple)))
	  (theincrdbg
	   (cond 
	    ( (is_a theincrdbgbind class_primitive_binding)
	      (get_field :pbind_primitive theincrdbgbind))
	    ( (is_a theincrdbgbind class_value_binding)
	      (get_field :vbind_value theincrdbgbind))
	    (:else
	     (error_plain 
	      loc 
	      "(DEBUG ...) used in context with bad MELT_INCREMENT_DBGCOUNTER")
	     (return))))
	  (dincrdbg (instance
		     class_source_primitive
		     :loca_location loc
		     :sprim_oper theincrdbg
		     :sargop_args (tuple)))
	  (difdbg (instance
		   class_source_if
		   :loca_location loc
		   :sif_test dneedbg
		   :sif_then dcall))
	  (dvoid (instance
		  class_source_primitive
		  :loca_location loc
		  :sprim_oper void
		  :sargop_args (tuple)))
	  (dprogn (instance 
		   class_source_progn
		   :loca_location loc
		   :sprogn_body (tuple dincrdbg difdbg dvoid)
		   ))
	  (dcppif (instance class_source_cppif
			    :loca_location loc
			    :sifp_cond 'MELT_HAVE_DEBUG
			    :sifp_then dprogn
			    :sifp_else dvoid
			    )) 
	  )
      ;;
      ;;
      (debug "mexpand_debug dcall=" dcall " return dcppif=" dcppif)
      (return dcppif)
      )))
(install_initial_macro 'debug mexpand_debug)

(export_macro debug mexpand_debug
   :doc #{$DEBUG is a variadic and polytypic macro for debugging
   prints. You can give it arbitrary arguments -either
   stuff or values-. Debugging prints should be enabled at
   compilation time of the generated C code with the
   @code{quicklybuilt} or @code{debugnoline} module
   flavors, and at run time with the
   @code{-f[plugin-arg-]melt-debugging=} option. Internally
   @code{(DEBUG @var{arg...})} is macro expanded to something similar to
   @code{(cppif MELT_HAVE_DEBUG (if (melt_need_dbg 0) (melt_debug_fun ()
   @var{count} @var{filename} @var{lineno} ...)))}}#)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; export_values macro (export_values <symbol> ...)
(defun mexpand_export_values (sexpr env mexpander modctx)
  (debug "mexpand_export_values sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(symbtup (expand_pairlist_as_tuple curpair env mexpander modctx))
	(res (instance class_source_export_values
		       :loca_location loc
		       :sexport_names symbtup))
	)
    (foreach_in_multiple
     (symbtup)
     (cursymb :long six)
     (if (is_not_a cursymb class_symbol)
       (error_at loc "(EXPORT_VALUES <symbol> ...) with non-symbol argument of rank $1" six)))
    (debug "mexpand_export_values result res" res)
    (return res)
    ))
(install_initial_macro 'export_values mexpand_export_values)
(export_macro export_values mexpand_export_values
	      :doc #{$EXPORT_VALUES is a macro to export values
	      defined by names. Give it a sequence of names bound to
	      values using $DEFINE, $DEFUN, $DEFINSTANCE,
	      $DEFSELECTOR, $DEFCITERATOR, $DEFCMATCHER,
	      $DEFFUNMATCHER etc. Use $EXPORT_CLASS for exporting
	      classes and their fields.}#)

;;;;
;;; export_macro macro (export_macro <symbol> <expander> [:doc <documentation>])
;;; or (export_macro <symbol>) for a DEFMACRO-ed symbol
(defun mexpand_export_macro (sexpr env mexpander modctx)
  (debug "mexpand_export_macro sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(symb (mexpander (pair_head curpair) env mexpander modctx))
	(doc ())
	)
    (if (is_not_a symb class_symbol)
	(error_plain loc "(EXPORT_MACRO <sym> [<expander>]) expecting symbol"_))
    (setq curpair (pair_tail curpair))
    (let (
	  (symbname (get_field :named_name symb))
	  (sexpv (let ( (se (pair_head curpair)) 
			)
		   (debug "mexpand_export_macro sexpv=" se)
		   se))
	  (cbind (let ( (cb (find_env env symb))
			)
		   (debug "mexpand_export_macro cbind=" cb)
		   cb))
	  (:long isdefmacro (is_a cbind class_defined_macro_binding))
	  (expv (cond ( (null sexpv)
			(when (not isdefmacro)
			  (error_at loc "(EXPORT_MACRO $1 <expander>) needs an expander for non-defmacro symbol"
				      symbname)
			  (return))
			symb
			)
		      (:else 
		       (mexpander sexpv env mexpander modctx))))
	  )
      (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_at loc  "(EXPORT_MACRO $1 <expander> [:doc <docum>]) expecting expander"_ symbname))
      (let ( (res (if (and isdefmacro (null sexpv))
		      (instance class_source_export_defmacro
				:loca_location loc
				:sexpmac_mname symb
				:sexpmac_doc doc)
		      (instance class_source_export_macro
			    :loca_location loc
			    :sexpmac_mname symb
			    :sexpmac_doc doc
			    :sexpmac_mval expv
			    )))
	     )
	(debug "mexpand_export_macro result res=" res)
	(return res)
	))))
(install_initial_macro 'export_macro mexpand_export_macro)
(export_macro export_macro mexpand_export_macro
	      :doc #{@code{($EXPORT_MACRO @var{name} @var{macro-expander} [@code{:doc} @var{documentation}])} is used to define an exported macro.}#)




;;;;
;;; export_patmacro macro (export_patmacro <symbol> <patexpander> <macexpander> [:doc <docum>])
(defun mexpand_export_patmacro (sexpr env mexpander modctx)
  (debug "mexpand_export_patmacro sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check mexpander" (is_closure mexpander) mexpander)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(symb (mexpander (pair_head curpair) env mexpander modctx))
	(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 (mexpander (pair_head curpair) env mexpander modctx))
    (if (null patexpv)
	(error_plain loc  "(EXPORT_PATMACRO <sym> <patexpander> <macexpander> [:doc <docum>]) expecting patexpander"_))
    (setq curpair (pair_tail curpair))
    (setq macexpv (mexpander (pair_head curpair) env mexpander modctx))
    (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 "mexpand_export_patmacro result res" res)
      (return res)
      )))
(install_initial_macro 'export_patmacro mexpand_export_patmacro)
(export_macro export_patmacro mexpand_export_patmacro
	      :doc #{@code{($EXPORT_PATMACRO @var{name} @var{pattern-expander} [@var{macro-expander}] [:doc @var{documentation}])} 
is used to define patmacros.}#)

;;;;
;;; export_class macro (export_class <symbol> ...)
(defun mexpand_export_class (sexpr env mexpander modctx)
  (debug "mexpand_export_class sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(symbtup (expand_pairlist_as_tuple curpair env mexpander modctx))
	(res (instance class_source_export_class
		       :loca_location loc
		       :sexport_names symbtup))
	)
    (foreach_in_multiple
     (symbtup)
     (cursymb :long six)
     (if (is_not_a cursymb class_symbol)
       (error_at loc "(EXPORT_CLASS <symbol> ...) with non-symbol argument of rank $1" six)))
    (debug "mexpand_export_class result res" res)
    (return res)
    ))
(install_initial_macro 'export_class mexpand_export_class)
(export_macro export_class mexpand_export_class
	      :doc #{@code{($EXPORT_CLASS @var{names...})} is used to export class and their field names.}#)



;;; export_synonym macro (export_synonym <newname> <oldname>  [:doc <documentation>])
(defun mexpand_export_synonym (sexpr env mexpander modctx)
  (debug "mexpand_export_synonym sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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 (mexpander (pair_head curpair) env mexpander modctx))
    (debug "mexpander_export_synonym newsymb" 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 (mexpander (pair_head curpair) env mexpander modctx))
    (debug "mexpander_export_synonym oldsymb" 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 "mexpander_export_synonym doc" doc)
    (let ( 
	  (res (instance class_source_export_synonym
			 :loca_location loc
			 :sexpsyn_newname newsymb
			 :sexpsyn_oldname oldsymb
			 :sexpsyn_doc doc))
	  )
      (debug "mexpander_export_synonym result" res)
      (return res)
      )))
(install_initial_macro 'export_synonym mexpand_export_synonym)
(export_macro export_synonym mexpand_export_synonym
	      :doc #{@code{($EXPORT_SYNONYM @var{new-name} @var{old-name}
					    [:doc @var{documentation}])}
		     is used to define a synonym.
					    }#)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; current_module_environment_reference macro 
(defun mexpand_current_module_environment_reference (sexpr env mexpander modctx)
  (debug "mexpand_current_module_environment_reference sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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_reference
		       :loca_location loc))
	)
    (if (notnull curpair)
	(error_plain loc "(CURRENT_MODULE_ENVIRONMENT_REFERENCE) should not have any argument"_))
    (debug "mexpand_current_module_environment_reference return res" res)
    (return res)
    ))

(install_initial_macro 'current_module_environment_reference mexpand_current_module_environment_reference)
(export_macro current_module_environment_reference mexpand_current_module_environment_reference
	      :doc #{@code{($CURRENT_MODULE_ENVIRONMENT_REFERENCE)}
returns a container, i.e. a reference thru @code{$CLASS_REFERENCE},
for the current environment. See also $PARENT_MODULE_ENVIRONMENT and
$CLASS_ENVIRONMENT. @code{($CURRENT_MODULE_ENVIRONMENT_REFERENCE)}
cannot be used inside hooks. Was previously called inccorrectly
@code{CURRENT_MODULE_ENVIRONMENT_CONTAINER}.}#)

(install_initial_macro 'current_module_environment_container mexpand_current_module_environment_reference)
(export_macro current_module_environment_container mexpand_current_module_environment_reference
	      :doc #{@code{($CURRENT_MODULE_ENVIRONMENT_CONTAINER)} is
	      obsolete. Use $CURRENT_MODULE_ENVIRONMENT_REFERENCE.}#)

;;;;;;;;;;;;;;;;
;;;; parent_module_environment macro 
(defun mexpand_parent_module_environment (sexpr env mexpander modctx)
  (debug "mexpand_parent_module_environment sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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 "mexpand_parent_module_environment return res" res)
    (return res)
    ))
(install_initial_macro 'parent_module_environment mexpand_parent_module_environment)
(export_macro parent_module_environment mexpand_parent_module_environment
	      :doc #{@code{($PARENT_MODULE_ENVIRONMENT)} gives the
	      parent environnment of this module. See also
	      $CLASS_ENVIRONMENT and
	      $CURRENT_MODULE_ENVIRONMENT_REFERENCE. @code{($PARENT_MODULE_ENVIRONMENT)}
	      cannot be used inside hooks.}#)



;;;;;;;;;;;;;;;;
;;;; update_current_module_environment_reference macro 
(defun mexpand_update_current_module_environment_reference  (sexpr env mexpander modctx)
  (debug "mexpand_update_current_module_environment_reference sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (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_reference
		       :loca_location loc))
	)
    (if (notnull curpair)
	(error_plain loc "(UPDATE_CURRENT_MODULE_ENVIRONMENT_REFERENCE) should not have any argument"_))
    (if (not (melt_is_bootstrapping))
	(error_plain loc "(UPDATE_CURRENT_MODULE_ENVIRONMENT_REFERENCE) can only be used while bootstrapping MELT."))
    (debug "mexpand_update_current_module_environment_reference return res" res)
    (return res)
    ))

(install_initial_macro 'update_current_module_environment_reference mexpand_update_current_module_environment_reference)
(export_macro update_current_module_environment_reference mexpand_update_current_module_environment_reference
	      :doc
#{@code{($UPDATE_CURRENT_MODULE_ENVIRONMENT_REFERENCE)} is a guru
macro to update the current module environment reference.  You
probably should never use it, but it is necessary inside MELT. See
$CURRENT_MODULE_ENVIRONMENT_REFERENCE. Was previously called incorrectly
@code{UPDATE_CURRENT_MODULE_ENVIRONMENT_CONTAINER}.}#)

;; compatibility
(install_initial_macro 'update_current_module_environment_container mexpand_update_current_module_environment_reference)
(export_macro update_current_module_environment_container mexpand_update_current_module_environment_reference)

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

(defun mexpand_fetch_predefined (sexpr env mexpander modctx)
  (debug "mexpand_fetch_predefined sexpr" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(spredef (mexpander (pair_head curpair) env mexpander modctx))
	)
    (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 "mexpand_fetch_predefined result" res)
      (return res)
      )))
(install_initial_macro 'fetch_predefined mexpand_fetch_predefined)
(export_macro fetch_predefined mexpand_fetch_predefined
	      :doc #{@code{($FETCH_PREDEFINED @var{predefined-name})} is accessing a predefined value without using environments. You probably don't need that.}#)

;;;;;;;;;;;;;;;;
(defun mexpand_store_predefined (sexpr env mexpander modctx)
  (debug "mexpand_store_predefined sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (if (null mexpander) (setq mexpander macroexpand_1))
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(spredef (mexpander (pair_head curpair) env mexpander modctx))
	(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 (mexpander (pair_head curpair) env mexpander modctx))
    (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 "mexpand_store_predefined result" res)
      (return res)
      )))
(install_initial_macro 'store_predefined mexpand_store_predefined)
(export_macro store_predefined mexpand_store_predefined 
	      :doc #{@code{($STORE_PREDEFINED @var{predefined-name} @var{value})} is storing a predefined value. You probably never need that.}#)

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

(export_class  ;classes for source representations, alphabetical order
 class_defined_macro_binding
 class_pattern_expansion_context
 class_source_again
 class_source_any_let_binding
 class_source_apply
 class_source_arithmetic_variadic_operation
 class_source_argumented_operator
 class_source_box
 class_source_cheader
 class_source_cimplement
 class_source_citeration
 class_source_cmatchexpr
 class_source_code_string
 class_source_codechunk
 class_source_comment
 class_source_compile_diagnostic
 class_source_compile_error
 class_source_compile_warning
 class_source_constant_box
 class_source_cppif
 class_source_current_module_environment_reference
 class_source_defciterator
 class_source_defclass
 class_source_defcmatcher
 class_source_defhook
 class_source_define
 class_source_definition
 class_source_definition_formal
 class_source_definstance
 class_source_defobjcommon
 class_source_defprimitive
 class_source_defmacro
 class_source_defmacro_in_let
 class_source_defselector
 class_source_defun
 class_source_defunmatcher
 class_source_defvar
 class_source_exit
 class_source_export_any_macro
 class_source_export_class
 class_source_export_defmacro
 class_source_export_macro
 class_source_export_patmacro
 class_source_export_synonym
 class_source_export_values
 class_source_exportcommon
 class_source_exprchunk
 class_source_fetch_predefined
 class_source_field_pattern
 class_source_fieldassign
 class_source_forever
 class_source_funmatchexpr
 class_source_generator_device
 class_source_get_field
 class_source_hook_call
 class_source_if
 class_source_ifelse
 class_source_ifvariadic
 class_source_instance
 class_source_labelled
 class_source_lambda
 class_source_lambda_for_macro
 class_source_lazy_macro_expansion
 class_source_let
 class_source_let_binding
 class_source_let_binding_for_macro
 class_source_letrec
 class_source_letrec_binding
 class_source_list
 class_source_macro_let_binding
 class_source_macro_installation
 class_source_match
 class_source_match_case
 class_source_matchalt
 class_source_module_is_gpl_compatible
 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_protochunk
 class_source_put_fields
 class_source_quasi_box
 class_source_quote
 class_source_return
 class_source_setq
 class_source_store_predefined
 class_source_tuple
 class_source_unbox
 class_source_unsafe_get_field
 class_source_unsafe_put_fields
 class_source_update_current_module_environment_reference
 class_source_use_package_from_pkg_config
 )			       ;end classes for source representations

(export_synonym
 class_source_update_current_module_environment_container class_source_update_current_module_environment_reference
)

(export_synonym
 class_source_current_module_environment_container class_source_current_module_environment_reference
)

(export_values			 ;values for source representations
 expand_apply
 expand_msend  
 expand_pairlist_as_tuple
 expand_pairlist_as_list
 expand_restlist_as_list
 expand_restlist_as_tuple
 expand_tuple_slice_as_tuple 
 expand_primitive
 hook_macro_installer
 install_initial_macro
 install_initial_patmacro
 is_recursively_constructible
 lambda_arg_bindings
 macroexpand_1
 macroexpand_toplevel_list
 melt_register_translator_runner_macroexpansions
 patternexpand_1
 patternexpand_expr
 patternexpand_pairlist_as_tuple
 pattern_weight_tuple
 register_generator_device
 s_expr_weight
 mexpand_reference
 patexpand_reference
 )			  ;end of values for source representations


;; eof warmelt-macro.melt