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

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

    This file is part of GCC.

    GCC is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 3, or (at your option)
    any later version.

    GCC is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with GCC; see the file COPYING3.  If not see
    <http://www.gnu.org/licenses/>.
")

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

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




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


;;; source application 
(defclass class_src_apply
  :super class_src
  :fields (sapp_fun			;the function to apply
	   sapp_args			;the arguments tuple
	   ))


;;; source message sending 
(defclass class_src_msend
  :super class_src
  :fields ( 
	   msend_selsymb		;the selector symbol
	   msend_recv			;the reciever
	   msend_args 			;the tuple of arguments
	   ))

;;; source primitive call
(defclass class_src_primitive
  :super class_src
  :fields (sprim_oper			;the primitive operation
	   sprim_args			;the arguments tuple
	   ))

;;; source citerator invocation
(defclass class_src_citeration
  :super class_src
  :fields (sciter_oper			;the citerator operation
	   sciter_args			;the citerator input tuple
	   sciter_varbind		;tuple of formal local var bindings
	   sciter_body			;tuple for body
	   ))

;;; source cmatcher expression
(defclass class_src_cmatchexpr
  :super class_src
  :fields (scmatx_cmatcher		;the cmatcher
	   scmatx_args			;the arguments
	   ))

;; source funmatcher expression
(defclass class_src_funmatchexpr
  :super class_src
  :fields (sfmatx_fmatcher		;the funmatcher
	   sfmatx_fmatbind		;the funmatcher binding
	   sfmatx_args			;the arguments
))

;;; source progn
(defclass class_src_progn
  :super class_src
  :fields (sprogn_body			;the body tuple
	   ))

;;; source return
(defclass class_src_return
  :super class_src
  :fields (sreturn_body			;the body tuple
	   ))

;;;; source setq
(defclass class_src_setq
  :super class_src
  :fields (sstq_var
	   sstq_expr))

;;;; source comment
(defclass class_src_comment
  :super class_src
  :fields (scomm_str
	   ))

;;;; source quote
(defclass class_src_quote
  :super class_src
  :fields (squoted
	   ))

;; source export 
(defclass class_src_exportcommon
  :super class_src
  :fields (sexport_names
	   ))
;; export value
(defclass class_src_export_values
  :super class_src_exportcommon
  :fields (
	   ))

;; export classes
(defclass class_src_export_class
  :super class_src_exportcommon
  :fields (
	   ))

;; export one macro - (export_macro <macroname> <value>)
;; beware that the evaluation of the value is done near end of initial routine!
(defclass class_src_export_macro
  :super class_src
  :fields (sexpmac_mname
	   sexpmac_mval
	   ))

;; export one pattern - (export_patmacro <macroname> <patexpvalue> <macexpvalue>)
;; beware that the evaluation of the value is done near end of initial routine!
(defclass class_src_export_patmacro
  :super class_src_export_macro
  :fields (
	   sexppat_pval			;value of patternexpander
	   ))

;;; superclass for all source definitions
(defclass class_srcdef
  :super class_src
  :fields (sdef_name			;defined name
	   ))

;;; superclass for all definitions with formal arglist
(defclass class_srcdeformal
  :super class_srcdef
  :fields (sformal_args			;formal arguments binding tuple
	   ))

;;;; define a function
(defclass class_src_defun
  :super class_srcdeformal
  :fields (sfun_body			;body sequence
	   ))

;;; define a primitive
(defclass class_src_defprimitive
  :super class_srcdeformal
  :fields (sprim_type			;result type of primitive
	   sprim_expansion		;primitive expansion
	   ))

;;; define a citerator
(defclass class_src_defciterator
  :super class_srcdeformal		;the sformal_args is the start arguments
  :fields (sciterdef_citerator		;the citerator
	   ))

;;; define a cmatcher
(defclass class_src_defcmatcher
  :super class_srcdeformal
  :fields (;;src_loc is the location
	   ;;sdef_name is the new cmatcher name
	   ;;sformal_args is for the matched formal & input arguments
	   ;;;;the first formal is for the matched stuff. The rest is for input
	   scmatdef_cmatcher		;the cmatcher
	   ))

;;; define a funmatcher
(defclass class_src_defunmatcher
  :super class_srcdeformal
  :fields (;;src_loc 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_src_defobjcommon
  :super class_srcdef
  :fields (sobj_predef			;the predefined rank
	   sobj_docstr			;documentation string
	   ))

;; define a class 
;;;; the class has been built (at compile time), but we need a
;;;; srcdefclass to actually generate code
(defclass class_src_defclass
  :super class_src_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_src_definstance
  :super class_src_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_src_defselector
  :super class_src_definstance
  )

;; a field assignment
(defclass class_src_fieldassign
  :super class_src
  :fields (sfla_field			;the field 
	   sfla_expr			;the expression
	   ))


;; make an instance
(defclass class_src_make_instance
  :super class_src
  :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_src_get_field
  :super class_src
  :fields (suget_obj	     ;the object expression
	   suget_field	     ;the field keyword
	   ))


;;; source unsafe get field
(defclass class_src_unsafe_get_field
  :super class_src_get_field
  :fields (
	   ))

;;; source get field

;; source put fields
(defclass class_src_put_fields
  :super class_src
  :fields (suput_obj	     ;the object expression
	   suput_fields			;the sequence of field assignment
	   ))

;; source unsafe put fields
(defclass class_src_unsafe_put_fields
  :super class_src_put_fields
  :fields (
	   ))


;; a conditional (if, and, cond)
(defclass class_src_if
  :super class_src
  :fields (sif_test
	   sif_then
	   ))

(defclass class_src_ifelse
  :super class_src_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_src_or
  :super class_src
  :fields (sor_disj			;tuple of disjuncts
	   ))


;; preprocessor conditional
(defclass class_src_cppif
  :super class_src
  :fields (sifp_cond			;C preprocessor symbol or verbatim string to test
	   sifp_then			;then clause
	   sifp_else			;else clause
	   ))

;;;;;;;;;;;;;;;;
;; match 
(defclass class_src_match
  :super class_src
  :fields (smat_matchedx		;matched expression
	   smat_cases			;match case tuple
	   ))

;; match case
(defclass class_src_casematch
  :super class_src
  :fields (scam_patt			;pattern
	   scam_body			;body
	   ))
;; match case with when
(defclass class_src_casewhenmatch
  :super class_src_casematch
  :fields (scwm_when			;when 
	   ))
;;;;;;;;;;;;;;;;

;;; letbinding source
(defclass class_src_letbinding
  :super class_src
  :fields (sletb_type			;the type of the binding
	   sletb_binder			;the binder (variable)
	   sletb_expr			;the expression
	   ))

;; let source
(defclass class_src_let
  :super class_src
  :fields (slet_bindings		;the tuple of letbinding-s
	   slet_body			;the body tuple 
	   ))

;; lambda
(defclass class_src_lambda
  :super class_src 
  :fields (slam_argbind			;tuple of argument bindings
	   slam_body			;tuple for body
	   ))


;; multicall
(defclass class_src_multicall
  :super class_src
  :fields (smulc_resbind		;tuple of argument bindings for multiple results
	   smulc_call			;called stuff
	   smulc_body			;tuple for body
	   ))

;;; forever & exit share a common label
(defclass class_src_labelled
  :super class_src
  :fields (slabel_bind			;the label binding
	   ))

;; forever
(defclass class_src_forever
  :super class_src_labelled
  :fields (sfrv_body			;tuple for body
	   ))

;; exit
(defclass class_src_exit
  :super class_src_labelled
  :fields ( sexi_body			;tuple for body
	    ))

;; compile time warning
(defclass class_src_compilewarning
  :super class_src
  :fields (scwarn_msg
	   scwarn_expr))

;; the fresh current module environment box, returning the newly build
;; module environment result of the generated start_module_basilys
(defclass class_src_current_module_environment_container
  :super class_src
  :fields (
	   cmec_comment		;extra comment
	   ))

;; the fres previous module environment, returning the argument passed
;; to the generated start_module_basilys
(defclass class_src_parent_module_environment
  :super class_src
  :fields (
	   ))


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


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

;; store into a predefined
(defclass class_src_store_predefined
  :super class_src
  :fields (sstpd_predef
	   sstpd_value
	   ))


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

;;;;;;;;;;;;;;;;
;;; source patterns
(defclass class_srcpattern_any
  :super class_src
  :fields (
	   ))

;;; or patterns
(defclass class_srcpattern_or
  :super class_srcpattern_any
  :fields (orpat_disj		    ;tuple of pattern disjuncts
))

;;; and patterns
(defclass class_srcpattern_and
  :super class_srcpattern_any
  :fields (andpat_conj			;tuple of pattern conjoncts
))


;;; as pattern
(defclass class_srcpattern_as
  :super class_srcpattern_any
  :fields (aspat_varpat		    ;the pattern variable
	   aspat_subpat		    ;the sub-pattern
))

;;; simple source pattern variable
(defclass class_srcpattern_variable
  :super class_srcpattern_any
  :fields (spat_var
	   ))

;;; the joker source pattern variable
(defclass class_srcpattern_jokervar
  :super class_srcpattern_variable
  :fields (
	   ))

;;; simple source pattern constant
(defclass class_srcpattern_constant
  :super class_srcpattern_any
  :fields (spat_constx			;expression giving the constant
	   ))

;; 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_srcpattern_object
  :super class_srcpattern_any
  :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_srcpattern_instance
  :super class_srcpattern_object
  :fields (
	   ))

;; simple field pattern
(defclass class_srcfieldpattern
  :super class_src
  :fields (spaf_field			;the required field
	   spaf_pattern			;the pattern matching the field
	   ))

;; abstract composite source pattern
(defclass class_srcpattern_composite
  :super class_srcpattern_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_srcpattern_anymatch
  :super class_srcpattern_composite
  :fields (
	   ))

;; cmatcher composite source pattern
(defclass class_srcpattern_cmatch
  :super class_srcpattern_anymatch
  :fields (
	   ))

;; funmatcher composite source pattern
(defclass class_srcpattern_funmatch
  :super class_srcpattern_anymatch
  :fields (
	   ))

;;;;;;;;;;;;;;;;;;;; first pass, macro expansion

;;get the n-th son of a sexpr
(defun sexpr_nth_son (sexp :long n)
  (if (is_a sexp class_sexpr)
      (let ( (:long ix 0)
	     (curpair (list_first (unsafe_get_field :sexp_contents sexp)))
	     )
	(forever nthloop
		 (if (not (is_pair curpair)) (exit nthloop))
		 (if (==i ix n) (exit nthloop (pair_head curpair)))
		 (setq ix (+i ix 1))
		 (setq curpair (pair_tail curpair))
		 ))))

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

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


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


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


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


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


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


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

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

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


;;; class for pattern expansion context
(defclass class_pattexpcontext
  :super class_root
  :fields (pctx_mexpander      	;macroexpander
	   pctx_pexpander      	;pattern expander
	   pctx_varmap	        ;objmap for pattern variables [symbols => srcpattern_variable]
	   ))


(defun patternexpand_pairlist_as_tuple (pairlist env pctx psloc)
  (pairlist_to_multiple pairlist discr_multiple
			(lambda (x) (patternexpand_1 x env pctx psloc)))
  )


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

;; pattern expansion of a pattern expression like (question SEXPR)
(defun patternexpand_expr (sexpr env pctx psloc)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattexpcontext))
  (debug_msg sexpr "patternexpand_expr sexpr")
  (let ( (scont (unsafe_get_field :sexp_contents sexpr))
	 (sloc (unsafe_get_field :loca_location sexpr))
	 (curpair (list_first scont))
	 (soper (pair_head curpair)) )
    (if (is_not_a soper class_symbol)
	(progn
	  (debug_msg soper "patternexpand_expr bad soper")
	  (error_plain sloc "pattern expression requires symbol operator")
	  (return)))
    (let ( (opbind (find_env env soper))
	   (opnam (unsafe_get_field :named_name soper))
	   )
      (debug_msg opbind "patternexpand_expr opbind")
      (cond 
       ( (null opbind)
	 (error_strv sloc "unbound pattern operator" opnam)
	 )
       ( (is_a opbind class_patmacro_binding)
	 (let ( (patexp (unsafe_get_field :patbind_expanser opbind)) )
	   (assert_msg "check patexp" (is_closure patexp))
	   (let ( (resp (patexp sexpr env pctx)) )
	     (debug_msg resp "patternexpand_expr patmacro so return resp")
	     (return resp)
	     )))
       ( (is_a opbind class_cmatcher_binding)
	 (let ( (cmat (unsafe_get_field :cmbind_matcher opbind)) )
	   (debug_msg cmat "patternexpand_expr cmat")
	   (assert_msg "check cmat-cher" (is_a cmat class_cmatcher))
	   (multicall
	    (args pats)
	    (patmacexpand_for_matcher (pair_tail curpair) cmat env sloc pctx)
	    (debug_msg args "patternexpand_expr cmatcher args")
	    (debug_msg pats "patternexpand_expr cmatcher pats")
	    (let ( (pcomp (instance class_srcpattern_cmatch
				    :src_loc sloc
				    :spac_operator cmat
				    :spac_operbind opbind
				    :spac_inargs args
				    :spac_outargs pats
				    ))
		   )
	      (debug_msg pcomp "patternexpand_expr cmatcher return pcomp")
	      (return pcomp)
	      ))))
       ;; funmatcher binding
       ( (is_a opbind class_funmatcher_binding)
	 (let ( (fmat (unsafe_get_field :fmbind_funmatcher opbind)) 
		(defm (unsafe_get_field :fmbind_defunmatcher opbind))
		)
	   (debug_msg fmat "patternexpand_expr funmatcher fmat")
	   (debug_msg defm "patternexpand_expr funmatcher defm")
	   (debug_msg opbind "patternexpand_expr funmatcher opbind")
	   (assert_msg "check fmat-cher" (is_a fmat class_funmatcher))
	   (multicall
	    (args pats)
	    (patmacexpand_for_matcher (pair_tail curpair) fmat env sloc pctx)
	    (debug_msg args "patternexpand_expr funmatcher args")
	    (debug_msg pats "patternexpand_expr funmatcher pats")
	    (let ( (pcomp (instance class_srcpattern_funmatch
				    :src_loc sloc
				    :spac_operator fmat
				    :spac_operbind opbind
				    :spac_inargs args
				    :spac_outargs pats
				    )) )
	      (debug_msg pcomp "patternexpand_expr funmatcher return pcomp")
	      (return pcomp)
	      ))))
       ;; imported values 
       ( (is_a opbind class_value_binding)
	 (let ( (opval (unsafe_get_field :vbind_value opbind)) )
	   (cond 
	    ( (is_a opval class_cmatcher) 
	      (multicall
	       (args pats)
	       (patmacexpand_for_matcher (pair_tail curpair) opval env sloc pctx)
	       (debug_msg args "patternexpand_expr imported cmatcher args")
	       (debug_msg pats "patternexpand_expr imported cmatcher pats")
	       (let ( (pcomp (instance class_srcpattern_cmatch
				       :src_loc sloc
				       :spac_operator opval
				       :spac_operbind opbind
				       :spac_inargs args
				       :spac_outargs pats
				       ))
		      )
		 (debug_msg pcomp "patternexpand_expr cmatcher value pcomp")
		 (return pcomp)
		 )))
	    ( (is_a opval class_funmatcher) 
	      (debug_msg opval "patternexpand_expr funmatcher value opval")
	      (multicall
	       (args pats)
	       (patmacexpand_for_matcher (pair_tail curpair) opval env sloc pctx)
	       (debug_msg args "patternexpand_expr imported funmatcher args")
	       (debug_msg pats "patternexpand_expr imported funmatcher pats")
	       (let ( (pcomp (instance class_srcpattern_funmatch
				       :src_loc sloc
				       :spac_operator opval
				       :spac_operbind opbind
				       :spac_inargs args
				       :spac_outargs pats
				       ))
		      )
		 (debug_msg pcomp "patternexpand_expr funmatcher value pcomp")
		 (return pcomp)
		 ))
	      )
	    (:else
	     (error_strv sloc "invalid pattern operator value" opnam)
	     (return)))))
       (:else
	(error_strv sloc
		    "pattern operator badly bound - patternmacro expected"
		    opnam)
	)
       )
      ))
  )

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


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun macroexpand_toplevel_list (slist env)
  ;; (messageval_dbg "macroexpand_toplevel_list Env" env)
  ;;  (debug_msg  env "macroexpand_toplevel_list env"(the_callcount)) 
  (debug_msg slist "macroexpand_toplevel_list slist") 
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check slist" (is_list slist))
  (let ( (xlist (list_map slist 
			  (lambda (sexp) 
			    (debug_msg sexp "macroexpand_toplevel_list sexp")
			    (let ( (mex (macroexpand_1 sexp env macroexpand_1)) 
				   )
			      (debug_msg mex "macroexpand_toplevel_list mex")
			      mex
			      )))) 
	 )
    (debug_msg xlist "macroexpand_toplevel_list res xlist")
    xlist
    ))

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




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

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



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

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

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

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

;; utility to check that a C expansion has good symbols; every symbol
;; should be in the substitution map
(defun check_c_expansion (etuple loc substmap)
  (debug_msg etuple "check_c_expansion etuple")
  (debug_msg loc "check_c_expansion loc")
  (foreach_in_multiple
   (etuple)
   (ecomp :long ix)
   (cond 
   ( (null ecomp)
     (error_plain loc "null component in C expansion"))  
    ( (is_a ecomp class_symbol)
      (if (null (mapobject_get substmap ecomp))
	  (error_strv loc "unexpected symbol in C expansion"
		      (get_field :named_name ecomp)))
      ()
      )
    ( (is_string ecomp)
      ()
      )
    (:else 
     (warning_strv loc "unexpected C expansion component of " 
		   (get_field :named_name (discrim ecomp)))
     ()
     ))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;; macro expansers
;; the defprimitive expander
(defun mexpand_defprimitive (sexpr env mexpander)
  (debug_msg sexpr "mexpand_defprimitive sexpr")
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (symb (pair_head curpair))
	 )
    (if (is_not_a symb class_symbol)
	(error_plain loc "missing symbol for (DEFPRIMITIVE symb args type expansion...)"_))
    (setq curpair (pair_tail curpair))
    ;; parse the formal arguments
    (let ( (btup (lambda_arg_bindings (pair_head curpair) (the_null))) )
      (setq curpair (pair_tail curpair))
      ;; parse the type keyword
      (let ( (typkw  (pair_head curpair)) )
	(if (is_not_a typkw class_keyword)
	    (error_plain loc "missing type keyword for (DEFPRIMITIVE symb args type expansion...)"_))
	(let ( (cty (unsafe_get_field :symb_data typkw)) )
	  (if (is_not_a cty class_ctype)
	      (progn
		(debug_msg typkw "mexpand_defprimitive bad cty")
		(error_strv loc "bad type keyword for "_
			    (unsafe_get_field :named_name typkw))
		(return (the_null))
		))
	  (if (!= (unsafe_get_field :ctype_keyword cty) typkw)
	      (progn
		(debug_msg typkw "mexpand_defprimitive strange typkw")
		(error_strv loc "invalid type keyword for defprimitive"_
			    (unsafe_get_field :named_name typkw)) 
		(return (the_null))   
		))
	  ;; parse the rest as to be expanded
	  (setq curpair (pair_tail curpair))
	  (let (
		(etuple (parse_pairlist_c_code_expansion loc curpair))
		(substmap (make_mapobject discr_mapobjects
					  (+i 5 (*i 2 (multiple_length btup)))))
		(sdefpri
		 (instance class_src_defprimitive
			   :src_loc loc
			   :sdef_name symb
			   :sformal_args btup
			   :sprim_type cty
			   :sprim_expansion etuple))
		(primit
		 (instance class_primitive
			   :named_name (unsafe_get_field :named_name symb)
			   :prim_formals btup
			   :prim_type cty
			   :prim_expansion etuple))
		(pbind
		 (instance class_primitive_binding
			   :binder symb
			   :pbind_primdef sdefpri
			   :pbind_primitive primit
			   ))
		)
	    ;; fill the substmap according to btup to check the C expansion
	    (foreach_in_multiple
	     (btup)
	     (curbind :long bix)
	     (assert_msg "check curbind" (is_a curbind class_formal_binding))
	     (mapobject_put substmap (get_field :binder curbind) curbind)
	     )
	    (debug_msg primit "defprimitive primit")
	    (check_c_expansion etuple loc substmap)
	    ;;
	    (warn_if_redefined symb env loc)
	    (put_env env pbind)
	    (debug_msg sdefpri "mexpand_defprimitive result sdefpri")
	    (return sdefpri)
	    ))))))
(install_initial_macro 'defprimitive mexpand_defprimitive)
(export_macro defprimitive mexpand_defprimitive)



;; the defciterator expander
;;(DEFCITERATOR symb startformals statesymb varformals expbefore expafter)
(defun mexpand_defciterator (sexpr env mexpander)
  (debug_msg sexpr "mexpand_defciterator sexpr")
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (symb (pair_head curpair))
	 ;; the following variables are set later by setq
	 (bstartup ())		     ;the start formals tuple
	 (statsymb ())		     ;the state symbol
	 (blocvtup ())		     ;the local var formals tuple
	 (expbef ())		     ;the tuple expansion before tuple
	 (expaft ())		     ;the tuple expansion after tuple
	 )
    (if (is_not_a symb class_symbol)
	(progn
	  (error_plain loc 
		       "missing symbol for (DEFCITERATOR symb startformals statesymb locformals expbefore expafter)"_)
	  (return)
	  ))
    (setq curpair (pair_tail curpair))
    ;; parse the formal start arguments
    (setq bstartup (lambda_arg_bindings (pair_head curpair)))
    (setq curpair (pair_tail curpair))
    (setq statsymb (pair_head curpair))
    (if (is_not_a statsymb class_symbol)
	(progn
	  (error_plain loc 
		       "missing statsymb for (DEFCITERATOR symb startformals statesymb locformals expbefore expafter)"_)
	  (return)))
    (setq curpair (pair_tail curpair))
    (setq blocvtup  (lambda_arg_bindings (pair_head curpair)))
    (setq curpair (pair_tail curpair))
    ;; parse the before expansion
    (let ( (sexpbef (pair_head curpair)) )
      (if (is_not_a sexpbef class_sexpr)
	  (progn
	    (error_plain loc "missing before expansion for  (DEFCITERATOR symb startformals statesymb locformals expbefore expafter)"_)
	    (return)))
      (setq expbef (parse_pairlist_c_code_expansion loc (list_first (unsafe_get_field :sexp_contents sexpbef))))
      )
    (setq curpair (pair_tail curpair))
    ;; parse the after expansion
    (let ( (sexpaft (pair_head curpair)) )
      (if (is_not_a sexpaft class_sexpr)
	  (progn
	    (error_plain loc "missing after expansion for  (DEFCITERATOR symb startformals statesymb locformals expbefore expafter)"_)
	    (return)))
      (setq expaft  (parse_pairlist_c_code_expansion loc (list_first (unsafe_get_field :sexp_contents sexpaft))))
      )
    ;; make the citerator and binding
    (let ( (citer (instance class_citerator
			    :named_name (unsafe_get_field :named_name symb)
			    :citer_start_formals bstartup
			    :citer_state statsymb
			    :citer_body_formals blocvtup
			    :citer_expbefore expbef
			    :citer_expafter expaft
			    ))
	   (citbind (instance class_citerator_binding
			      :binder symb
			      ;; :cbind_citerdef bound later
			      :cbind_citerator citer
			      ))
	   (srcit (instance class_src_defciterator
			    :src_loc loc
			    :sdef_name symb
			    :sformal_args bstartup
			    :sciterdef_citerator citer))
	   (substmap (make_mapobject 
		      discr_mapobjects
		      (+i 7 (+i (*i 2 (multiple_length bstartup))
				(*i 2 (multiple_length blocvtup))))))
	   )
      ;; fill the substmap
      (debug_msg srcit "srcit citer")
      (mapobject_put substmap statsymb statsymb)
      (debug_msg bstartup "bstartup citer")
      (foreach_in_multiple
       (bstartup)
       (cursbind :long bsix)
       (assert_msg "check start cursbind" (is_a cursbind class_formal_binding))
       (mapobject_put substmap (get_field :binder cursbind) cursbind))
      (debug_msg blocvtup "blocvtup citer")
      (foreach_in_multiple
       (blocvtup)
       (curlbind :long blix)
       (debug_msg curlbind "curlbind local citer")
       (assert_msg "check local curlbind" (is_a curlbind class_any_binding))
       (mapobject_put substmap (get_field :binder curlbind) curlbind))
      ;;; check the expansions
      (check_c_expansion expbef loc substmap)
      (check_c_expansion expaft loc substmap)
      ;; fill the citerator binding
      (unsafe_put_fields citbind :cbind_citerdef srcit)
      (put_env env citbind)
      (debug_msg citer "parsed citerator citer")
      (return srcit)
      )))
(install_initial_macro 'defciterator mexpand_defciterator)
(export_macro defciterator mexpand_defciterator)

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

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

;;;;;;;;;;;;;;;;;; the defun expander
;;;(DEFUN funame formals body...)
(defun mexpand_defun (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexp.defun sexpr")
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (symb (pair_head curpair))
	 (newenv (fresh_env env))
	 )
    (if (is_not_a symb class_symbol)
	(error_plain loc "missing symbol for DEFUN"_))
    (setq curpair (pair_tail curpair))
    ;; parse the formal arguments
    (let ( (curpairhead (pair_head curpair)) 
	   (btup 
	    (cond ( (null curpairhead) 
		    (make_multiple discr_multiple 0) )
		  ( (is_a curpairhead class_sexpr)
		    (lambda_arg_bindings (pair_head curpair) sexpr))
		  (:else
		   (debug_msg curpairhead "mexpand_defun strange arglist curpairhead")
		   (error_plain loc "missing or invalid arglist for DEFUN"_)
		   (the_null)
		   )))
	   )
      (if (not (is_multiple btup))
	  (progn
	    (debug_msg btup "mexpand_defun strange btup")
	    (error_plain loc "missing formal arguments for DEFUN"_)))
      (multiple_every btup (lambda (fb) (put_env newenv fb)))
      (setq curpair (pair_tail curpair))
      (let ( (bodytup (expand_pairlist_as_tuple curpair newenv mexpander)) 
	     (sdefun
	      (instance class_src_defun
			:src_loc loc
			:sdef_name symb
			:sformal_args btup
			:sfun_body bodytup
			))
	     (fbind 
	      (instance class_function_binding
			:binder symb
			:fubind_defun sdefun
			))
	     )
	(warn_if_redefined symb env loc)
	(put_env env fbind)
	sdefun
	))))
(install_initial_macro 'defun mexpand_defun)
(export_macro defun mexpand_defun)


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

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


(defun mexpand_defclass (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg  sexpr "mexp.defclass sexpr")
  (multicall 
   (symb loc supernam superbind superclass predef fieldnams fieldsloc docstr)
   (scan_defclass sexpr env mexpander)
   (debug_msg symb "mexp.defclass scanned symb")
   (debug_msg loc "mexp.defclass scanned loc")
   (debug_msg supernam "mexp.defclass scanned supernam")
   (debug_msg superbind "mexp.defclass scanned superbind")
   (debug_msg superclass "mexp.defclass scanned superclass")
   (debug_msg predef "mexp.defclass scanned predef")
   (debug_msg fieldnams "mexp.defclass scanned fieldnams")
   (debug_msg fieldsloc "mexp.defclass scanned fieldsloc")
   (debug_msg docstr "mexp.defclass scanned docstr")
   (assert_msg "check symb" (is_a symb class_symbol))
   (let ( 
	 (ancestors (if (is_object superclass)
			(let ( (superancestors (unsafe_get_field :class_ancestors superclass))
			       (:long nbsuperanc (multiple_length superancestors))
			       (anctuple (make_multiple discr_seqclass (+i 1 nbsuperanc)))
			       (:long ix 0)
			       )
			  (assert_msg "check superclass" (is_a superclass class_class))
			  (assert_msg "check superancestors" (is_multiple superancestors))
			  (forever ancloop
				   (if (>=i ix nbsuperanc) (exit ancloop))
				   (multiple_put_nth anctuple ix (multiple_nth superancestors ix))
				   (setq ix (+i ix 1))
				   )
			  (multiple_put_nth anctuple nbsuperanc superclass)
			  anctuple
			  )
		      (make_multiple discr_seqclass 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_mapstrings (+i 3 (*i 2 (+i nbsuperfields nbfieldnames)))))
	 (fieldtup (make_multiple discr_seqfield (+i nbsuperfields nbfieldnames)))
	 (ownfieldbindings (make_multiple discr_multiple nbfieldnames))
	 (newclass (instance class_class
			     :named_name (unsafe_get_field :named_name symb)
			     :class_ancestors ancestors
			     ;; other fields to be set later
			     ))
	 (clabind (instance class_class_binding
			    :binder symb
			    :cbind_class newclass))
	 )
     (put_env env clabind)
     (debug_msg superfields "expdefclas superfields")
     (multiple_every 
      superfields 
      (lambda (sfld :long ix)
	(messagenum_dbg "expdefclasupflds ix" ix)
	(messageval_dbg "expdefclasupfldsval sfld" sfld)
	(assert_msg "check superfield" (is_a sfld class_field))
	(multiple_put_nth fieldtup ix sfld)
	(mapstring_putstr fieldstrmap (unsafe_get_field :named_name sfld) sfld)
	))
     (multiple_every
      fieldnams
      (lambda (fldnam :long ix)
	(messagenum_dbg "expdefclafldnam ix" ix)
	(assert_msg "check fldnam" (is_a fldnam class_symbol))
	(let ( (fldstr (unsafe_get_field :named_name fldnam)) 
	       )
	  (if (mapstring_getstr fieldstrmap fldstr)
	      (error_strv fieldsloc "duplicate field in DEFLCLASS"_ fldstr))
	  (let ( (:long fldoff (+i ix (get_int boxnbsuperfields))) 
		 (newfld (instance class_field
				   :named_name fldstr
				   :fld_ownclass newclass
				   )) )
	    (put_int newfld fldoff)
	    (messagenum_dbg "expdefclafldnam fldoff" fldoff)
	    (multiple_put_nth fieldtup fldoff newfld)
	    (mapstring_putstr fieldstrmap fldstr newfld)
	    (let ( (newfldbind (instance class_field_binding
					 :binder fldnam
					 :flbind_clabind clabind
					 :flbind_field newfld)) )
	      (warn_if_redefined fldnam env loc)
	      (put_env env newfldbind)
	      (multiple_put_nth ownfieldbindings ix newfldbind)
	      )
	    ))))
     (unsafe_put_fields newclass
			:class_fields fieldtup)
     ;; we need to put the object magic to OBJMAG_OBJECT now
     (put_int newclass (object_magic_object))
     (debug_msg newclass "mexp.defclass newclass" )
     (instance class_src_defclass
	       :src_loc loc
	       :sdef_name symb
	       :sobj_predef predef
	       :sobj_docstr docstr
	       :sclass_clabind clabind
	       :sclass_superbind superbind
	       :sclass_fldbinds ownfieldbindings
	       ))))
(install_initial_macro 'defclass mexpand_defclass)
(export_macro defclass mexpand_defclass)

;;;;;;;;;;;;;;;; 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)
  (if (not (is_a fldkw class_keyword))
      (error_plain loc "expecting :fieldname"_))
  (assert_msg "check fldkw" (is_a fldkw class_keyword))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check mexpander" (is_closure mexpander))
  ;; expr is an sexpr or a symbol or a string or ...
  (let ( (fldbox (make_box discr_box ())) )
    ;; if we have a class, find the field inside
    (if (is_a cla class_class)
	(multiple_iterate_test
	 (unsafe_get_field :class_fields cla)
	 (lambda (cfld :long ix)
	   (assert_msg "check fld" (is_a cfld class_field))
	   (if (==s (unsafe_get_field :named_name cfld) 
		    (unsafe_get_field :named_name fldkw))
	       (progn 
		 (box_put fldbox cfld)
		 ()			; nil to exit to iteration
		 )
	     cfld))
	 )
      ;; othewise, find the field by its bound name
      (let ( (fldnam (create_symbolstr (unsafe_get_field :named_name fldkw))) 
	     (fldbind (find_env env fldnam)) 
	     (fld  (cond 
		    ( (is_a fldbind class_field_binding)
		      (unsafe_get_field :flbind_field fldbind) )
		    ( (is_a fldbind class_value_binding)
		      (let ( (vfld (unsafe_get_field :vbind_value fldbind)) )
			(if (is_a vfld class_field)
			    vfld)) )
		    )) )
	(if (is_a fld class_field)
	    (box_put fldbox fld)
	  (error_strv loc "invalid field name in field assignment"_ 
		      (unsafe_get_field :named_name fldkw)))
	()
	))
    ;; at last make the field assignment
    (let ( (fld (box_content fldbox)) )
      (if (is_a fld class_field)
	  (let ( (xex (macroexpand_1 expr env mexpander)) )
	    (instance class_src_fieldassign 
		      :src_loc loc
		      :sfla_field fld
		      :sfla_expr xex
		      ))
	(error_strv loc "unknown field name in field assignment"_
		    (unsafe_get_field :named_name fldkw))
	))))

;; the definstance expanser
(defun mexpand_definstance (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexp.definstance sexpr")
  (let ( (predef ())
	 (objnum ())
	 (fields ())
	 (fieldnams ())
	 (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (symb (pair_head curpair))
	 (claname ())
	 (cla ())
	 (clabind ())
	 )
    (if (is_not_a symb class_symbol)
	(error_plain loc "missing symbol for DEFINSTANCE"_))
    (setq curpair (pair_tail curpair))
    (let ( (nam (pair_head curpair)) )
      (if (is_not_a nam class_symbol)
	  (error_plain loc "missing class name for DEFINSTANCE"_))
      (let ( (bnd (find_env env nam)) 
	     (fldlist (make_list discr_list))
	     )
	(cond 
	 ( (is_a bnd class_class_binding)
	   (setq clabind bnd)
	   (setq cla (unsafe_get_field :cbind_class bnd)) )
	 ( (and (is_a bnd class_value_binding)
		(is_a (unsafe_get_field :vbind_value bnd) class_class))
	   (setq clabind bnd)
	   (setq cla (unsafe_get_field :vbind_value bnd)))
	 (:else
	  (error_strv loc "invalid class name for DEFINSTANCE"_
		      (unsafe_get_field :named_name nam))
	  (return (the_null))
	  ))
	(setq claname nam)
	(assert_msg "check cla" (is_a cla class_class))
	(setq curpair (pair_tail curpair))
	(forever insloop
		 (if (not (is_pair curpair)) (exit insloop))
		 (let ( (curfkw (pair_head curpair)) )
		   (if (is_not_a curfkw class_keyword)
		       (error_plain loc "expecting keyword in DEFINSTANCE"_))
		   (setq curpair (pair_tail curpair))
		   (let ( (curexp (pair_head curpair)) )
		     (cond  ( (== curfkw ':obj_num)
			      (if objnum (error_plain loc "duplicate :obj_num in DEFINSTANCE"_))
			      (setq objnum 
				    (if (is_a curexp class_sexpr)
					(macroexpand_1 curexp env mexpander)
				      curexp))
			      )
			    ( (== curfkw ':predef)
			      (if predef (error_plain loc "duplicate :predef in DEFINSTANCE"_))
			      (setq predef 
				    (if (is_a curexp class_sexpr)
					(macroexpand_1 curexp env mexpander)
				      curexp))
			      )
			    (:else 
			     (let  ( (flda (parse_field_assignment cla loc curfkw curexp env mexpander)) )
			       (if flda 
				   (list_append fldlist flda)
				 )
			       ))))
		   (setq curpair (pair_tail curpair))
		   ))
	(let ( (fastup (list_to_multiple fldlist discr_multiple)) 
	       (sinst 
		(instance class_src_definstance
			  :src_loc loc
			  :sdef_name symb
			  :sobj_predef predef
			  :sinst_class cla
			  :sinst_clabind clabind
			  :sinst_objnum objnum
			  :sinst_fields fastup
			  ))
	       (ibind 
		(instance class_instance_binding
			  :binder symb
			  :ibind_iclass cla
			  ))
	       )
	  (warn_if_redefined symb env loc)
	  (put_env env ibind)
	  (debug_msg sinst "mexp.definstance sinst")
	  (return sinst)
	  )))))
(install_initial_macro 'definstance mexpand_definstance)
(export_macro definstance mexpand_definstance)


;; the definstance expanser
(defun mexpand_defselector (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexp.definstance sexpr")
  (let ( (predef ())
	 (objnum ())
	 (fields ())
	 (fieldnams ())
	 (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (symb (pair_head curpair))
	 (claname ())
	 (cla ())
	 (clabind ())
	 )
    (if (is_not_a symb class_symbol)
	(error_plain loc "missing symbol for DEFINSTANCE"_))
    (setq curpair (pair_tail curpair))
    (let ( (nam (pair_head curpair)) )
      (if (is_not_a nam class_symbol)
	  (error_plain loc "missing class name for DEFINSTANCE"_))
      (let ( (bnd (find_env env nam)) 
	     (fldlist (make_list discr_list))
	     )
	(cond 
	 ( (is_a bnd class_class_binding)
	   (setq clabind bnd)
	   (setq cla (unsafe_get_field :cbind_class bnd)) )
	 ( (and (is_a bnd class_value_binding)
		(is_a (unsafe_get_field :vbind_value bnd) class_class))
	   (setq clabind bnd)
	   (setq cla (unsafe_get_field :vbind_value bnd)))
	 (:else
	  (error_strv loc "invalid class name for DEFINSTANCE"_
		      (unsafe_get_field :named_name nam))
	  (return (the_null))
	  ))
	(setq claname nam)
	(assert_msg "check cla" (is_a cla class_class))
	(setq curpair (pair_tail curpair))
	(forever insloop
		 (if (not (is_pair curpair)) (exit insloop))
		 (let ( (curfkw (pair_head curpair)) )
		   (if (is_not_a curfkw class_keyword)
		       (error_plain loc "expecting keyword in DEFINSTANCE"_))
		   (setq curpair (pair_tail curpair))
		   (let ( (curexp (pair_head curpair)) )
		     (cond  ( (== curfkw ':obj_num)
			      (if curexp (error_plain loc "duplicate :obj_num in DEFINSTANCE"_))
			      (setq objnum 
				    (if (is_a curexp class_sexpr)
					(macroexpand_1 curexp env mexpander)
				      curexp))
			      )
			    ( (== curfkw ':predef)
			      (if curexp (error_plain loc "duplicate :predef in DEFINSTANCE"_))
			      (setq predef 
				    (if (is_a curexp class_sexpr)
					(macroexpand_1 curexp env mexpander)
				      curexp))
			      )
			    (:else 
			     (let  ( (flda (parse_field_assignment cla loc curfkw curexp env mexpander)) )
			       (if flda 
				   (list_append fldlist flda)
				 )
			       ))))
		   (setq curpair (pair_tail curpair))
		   ))
	(let ( ( fastup (list_to_multiple fldlist discr_multiple)) 
	       (res (instance class_src_defselector
			      :src_loc loc
			      :sdef_name symb
			      :sobj_predef predef
			      :sinst_class cla
			      :sinst_clabind clabind
			      :sinst_objnum objnum
			      :sinst_fields fastup
			      ))
	       (selbind (instance class_selector_binding
				  :binder symb
				  :sbind_selectordef res
				  ))
	       )
	  (warn_if_redefined symb env loc)
	  (put_env env selbind)
	  res
	  )))))
(install_initial_macro 'defselector mexpand_defselector)
(export_macro defselector mexpand_defselector)


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


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

(defun patexpand_instance (sexpr env pctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattexpcontext))
  (debug_msg sexpr "patexpand_instance sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(fields ())
	(fieldnams ())
	(curpair (pair_tail (list_first cont)))
	(claname (pair_head curpair))
	(cla ())
	(clabind ())
	)
    (if (is_not_a claname class_symbol)
	(error_plain loc "missing class symbol for INSTANCE pattern"_))
    (let ( (bnd (find_env env claname)) 
	   (fldlist (make_list discr_list))
	   )
      (cond 
       ( (is_a bnd class_class_binding)
	 (setq clabind bnd)
	 (setq cla (unsafe_get_field :cbind_class bnd)) 
	 )
       ( (and (is_a bnd class_value_binding)
	      (is_a (unsafe_get_field :vbind_value bnd) class_class))
	 (setq clabind bnd)
	 (setq cla (unsafe_get_field :vbind_value bnd))
	 )
       (:else
	(error_strv loc "invalid class name for INSTANCE"_
		    (unsafe_get_field :named_name claname))
	(return (the_null))
	))
      (assert_msg "check cla" (is_a cla class_class))
      (setq curpair (pair_tail curpair))
      ;; build the list of field patterns
      (forever 
       insloop
       (if (not (is_pair curpair)) (exit insloop))
       (let ( (curfkw (pair_head curpair)) )
	 (if (is_not_a curfkw class_keyword)
	     (error_plain loc "expecting keyword in INSTANCE"_))
	 (setq curpair (pair_tail curpair))
	 (let ( (curexp (pair_head curpair)) )
	   (let  ( (fldp (parse_field_pattern curfkw cla curexp env pctx loc)) )
	     (debug_msg fldp "patexpand_instance fldp")
	     (if fldp
		 (list_append fldlist fldp)
	       (error_strv loc "bad field name in INSTANCE"_
			   (unsafe_get_field :named_name curfkw))
	       ))))
       (setq curpair (pair_tail curpair))
       )
      (let ( (spati (instance class_srcpattern_instance
			      :src_loc loc
			      :spat_class cla
			      :spat_fields (list_to_multiple fldlist discr_multiple)))
	     )
	(debug_msg spati "patexpand_instance return spati")
	(return spati)
	))
    ))
(install_initial_patmacro 'instance patexpand_instance mexpand_instance)
(export_patmacro instance patexpand_instance mexpand_instance)

(defun patexpand_object (sexpr env pctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattexpcontext))
  (debug_msg sexpr "patexpand_object sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(fields ())
	(fieldnams ())
	(curpair (pair_tail (list_first cont)))
	(claname (pair_head curpair))
	(cla ())
	(clabind ())
	)
    (if (is_not_a claname class_symbol)
	(error_plain loc "missing class symbol for  OBJECT pattern"_))
    (let ( (bnd (find_env env claname)) 
	   (fldlist (make_list discr_list))
	   )
      (cond 
       ( (is_a bnd class_class_binding)
	 (setq clabind bnd)
	 (setq cla (unsafe_get_field :cbind_class bnd)) 
	 )
       ( (and (is_a bnd class_value_binding)
	      (is_a (unsafe_get_field :vbind_value bnd) class_class))
	 (setq clabind bnd)
	 (setq cla (unsafe_get_field :vbind_value bnd))
	 )
       (:else
	(error_strv loc "invalid class name for OBJECT pattern"_
		    (unsafe_get_field :named_name claname))
	(return (the_null))
	))
      (assert_msg "check cla" (is_a cla class_class))
      (setq curpair (pair_tail curpair))
      ;; build the list of field patterns
      (forever 
       insloop
       (if (not (is_pair curpair)) (exit insloop))
       (let ( (curfkw (pair_head curpair)) )
	 (if (is_not_a curfkw class_keyword)
	     (error_plain loc "expecting keyword in OBJECT pattern"_))
	 (setq curpair (pair_tail curpair))
	 (let ( (curexp (pair_head curpair)) )
	   (let  ( (fldp (parse_field_pattern curfkw cla curexp env pctx loc)) )
	     (debug_msg fldp "patexpand_object fldp")
	     (if fldp
		 (list_append fldlist fldp)
	       (error_strv loc "bad field name in OBJECT pattern"_
			   (unsafe_get_field :named_name curfkw))
	       ))))
       (setq curpair (pair_tail curpair))
       )
      (let ( (spati (instance class_srcpattern_object
			      :src_loc loc
			      :spat_class cla
			      :spat_fields (list_to_multiple fldlist discr_multiple)))
	     )
	(debug_msg spati "patexpand_object return spati")
	(return spati)
	))
    ))

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

(install_initial_patmacro 'object patexpand_object mexpand_object)
(export_patmacro object patexpand_object mexpand_object)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; the codechunk expander
(defun mexpand_code_chunk (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (sloc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (curchk ())
	 (gsym ())
	 (chklist (make_list discr_list))
	 (curel ())
	 )
    (setq curel (pair_head curpair))
    (if (is_a curel class_symbol)
	(setq gsym curel)
      (error_plain sloc "missing symbol in (CODE_CHUNK <gensymbol> <chunk>)"))
    (setq curpair (pair_tail curpair))
    (setq curchk (pair_head curpair))
    (if  (pair_tail curpair)
	(error_plain sloc "CODE_CHUNK expects one single chunk sexpr"))
    (if (is_not_a curchk class_sexpr)
	(error_plain sloc "CODE_CHUNK expects a chunk sexpr"))
    (let ( (loc (get_field :loca_location curchk)) 
	   (chkcont (get_field :sexp_contents curchk))
	   )
      (foreach_in_list
       (chkcont)
       (curpair curcomp)
       (cond ( (is_string curcomp)
	       (list_append chklist (make_string discr_verbatimstring curcomp))
	       )
	     ( (is_a curcomp class_symbol)
	       (list_append chklist curcomp))
	     (:else
	      (error_plain loc "bad content in CODE_CHUNK - expecting string or symbol")))
       )
      (let ( (mres (instance class_src_codechunk
			     :src_loc (or loc sloc)
			     :sch_gensym gsym
			     :sch_chunks (list_to_multiple chklist discr_multiple)
			     )) )
	(debug_msg mres "mexpand_code_chunk result")
	(return mres)
	))))

(install_initial_macro 'code_chunk mexpand_code_chunk)
(export_macro code_chunk mexpand_code_chunk)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; the unsafe_put_fields expander
(defun mexpand_unsafe_put_fields (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (fields ())
	 (fieldnams ())
	 (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (objsrc (pair_head curpair))
	 (objexp 
	  (if (is_a objsrc class_sexpr)
	      (macroexpand_1 objsrc env mexpander)
	    objsrc))
	 )
    (setq curpair (pair_tail curpair))
    (let ( (fldlist (make_list discr_list))
	   )
      (forever insloop
	       (if (not (is_pair curpair)) (exit insloop))
	       (let ( (curfkw (pair_head curpair)) )
		 (if (is_not_a curfkw class_keyword)
		     (error_plain loc "expecting heyword in UNSAFE_PUT_FIELDS"_))
		 (setq curpair (pair_tail curpair))
		 (let ( (curexp (pair_head curpair)) )
		   (let  ( (flda (parse_field_assignment () loc curfkw curexp env mexpander)) )
		     (if flda 
			 (list_append fldlist flda)
		       ))))
	       (setq curpair (pair_tail curpair))
	       )
      (let ( ( fastup (list_to_multiple fldlist discr_multiple)) )
	(instance class_src_unsafe_put_fields
		  :src_loc 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)

;;;; the put_fields expander
(defun mexpand_put_fields (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (fields ())
	 (fieldnams ())
	 (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (objsrc (pair_head curpair))
	 (objexp 
	  (if (is_a objsrc class_sexpr)
	      (macroexpand_1 objsrc env mexpander)
	    objsrc))
	 )
    (setq curpair (pair_tail curpair))
    (let ( (fldlist (make_list discr_list))
	   )
      (forever insloop
	       (if (not (is_pair curpair)) (exit insloop))
	       (let ( (curfkw (pair_head curpair)) )
		 (if (is_not_a curfkw class_keyword)
		     (error_plain loc "expecting heyword in PUT_FIELDS"_))
		 (setq curpair (pair_tail curpair))
		 (let ( (curexp (pair_head curpair)) )
		   (let  ( (flda (parse_field_assignment () loc curfkw curexp env mexpander)) )
		     (if flda 
			 (list_append fldlist flda)
		       ))))
	       (setq curpair (pair_tail curpair))
	       )
      (let ( ( fastup (list_to_multiple fldlist discr_multiple)) )
	(instance class_src_put_fields
		  :src_loc loc
		  :suput_obj objexp
		  :suput_fields fastup)
	))))
(install_initial_macro 'put_fields mexpand_put_fields)
(export_macro put_fields mexpand_put_fields)

;;;; the UNSAFE_GET_FIELD macro expander
(defun mexpand_unsafe_get_field (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (curfkw (pair_head curpair)) 
	 )
    (if (is_not_a curfkw class_keyword)
	(progn
	  (error_plain loc "field keyword expected in UNSAFE_GET_FIELD"_)
	  (return (the_null))))
    (setq curpair (pair_tail curpair))
    (let ( (curexp (pair_head curpair)) )
      (setq curpair (pair_tail curpair))
      (if curpair (error_plain loc "UNSAFE_GET_FIELD with more than two sons"_))
      ;; it is not a field assignment but we use the parse_field_assignment
      ;; routine to get the field and the expression
      (let  ( (flda (parse_field_assignment () loc curfkw curexp env mexpander)) )
	(if (not (is_a flda class_src_fieldassign))
	    (progn 
	      (error_plain loc "bad field and expression in UNSAFE_GET_FIELD"_)
	      (return (the_null))))
	(let ( (fld (unsafe_get_field :sfla_field flda))
	       (exp (unsafe_get_field :sfla_expr flda)) )
	  (instance class_src_unsafe_get_field
		    :src_loc 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)

;;;; the GET_FIELD expander
(defun mexpand_get_field (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (curfkw (pair_head curpair)) 
	 )
    (if (is_not_a curfkw class_keyword)
	(progn
	  (error_plain loc "field keyword expected in GET_FIELD"_)
	  (return (the_null))))
    (setq curpair (pair_tail curpair))
    (let ( (curexp (pair_head curpair)) )
      (setq curpair (pair_tail curpair))
      (if curpair (error_plain loc "UNSAFE_GET_FIELD with more than two sons"_))
      ;; it is not a field assignment but we use the parse_field_assignment
      ;; routine to get the field and the expression
      (let  ( (flda (parse_field_assignment () loc curfkw curexp env mexpander)) )
	(if (not (is_a flda class_src_fieldassign))
	    (progn 
	      (error_plain loc "bad field and expression in GET_FIELD"_)
	      (return (the_null))))
	(let ( (fld (unsafe_get_field :sfla_field flda))
	       (exp (unsafe_get_field :sfla_expr flda)) )
	  (instance class_src_get_field
		    :src_loc loc
		    :suget_obj exp
		    :suget_field fld
		    ))))))
(install_initial_macro 'get_field mexpand_get_field)
(export_macro get_field mexpand_get_field)


;;;; the setq expander
(defun mexpand_setq (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont)))
	 (cursym (pair_head curpair)) 
	 )
    (if (is_not_a cursym class_symbol)
	(progn
	  (error_plain loc "var symbol name expected in SETQ"_)
	  (return (the_null))))
    (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_src_setq 
		:src_loc loc
		:sstq_var cursym
		:sstq_expr  (macroexpand_1 curexp env mexpander)
		)
      )))
(install_initial_macro 'setq mexpand_setq)
(export_macro setq mexpand_setq)

;;;;; the if expanser
(defun mexpand_if (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_if sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(curif (pair_head curpair)) )
    (if (not (is_pair curpair))
	(error_plain loc "missing condition in IF"_))
    (setq curpair (pair_tail curpair))
    (if (not (is_pair curpair))
	(error_plain loc "missing then in IF"_))
    (let ( (xcond (macroexpand_1 curif env mexpander)) )
      (debug_msg xcond "mexpand_if xcond")
      (let ( (curthen (pair_head curpair)) )
	(setq curpair (pair_tail curpair))
	(let ( (xthen (macroexpand_1 curthen env mexpander)) )
	  (debug_msg xthen "mexpand_if xthen")
	  (if (is_pair curpair)
	      (let ( (curelse (pair_head curpair)) 
		     (xelse (macroexpand_1 curelse env mexpander)) )
		(debug_msg xelse "mexpand_if xelse")
		(setq curpair (pair_tail curpair))
		(if (is_pair curpair)
		    (error_plain loc "IF with more than three sons"_))
		(let ( (rese
			(instance class_src_ifelse
				  :src_loc loc
				  :sif_test xcond
				  :sif_then xthen
				  :sif_else xelse
				  )) )
		  (debug_msg rese "mexpand_if with else return rese")
		  (return rese)))
	    (let ( (resp (instance class_src_if
				   :src_loc loc
				   :sif_test xcond
				   :sif_then xthen)) )
	      (debug_msg resp "mexpand_if plain return resp")
	      (return resp))
	    ))))))
(install_initial_macro 'if mexpand_if)
(export_macro if mexpand_if)

;;;;; the cppif expander
(defun mexpand_cppif (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_cppif sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(curif (pair_head curpair)) )
    (if (not (is_pair curpair))
	(error_plain loc "missing condition in CPPIF"_))
    (setq curpair (pair_tail curpair))
    (if (not (is_pair curpair))
	(error_plain loc "missing then in CPPIF"_))
    (let ( (xcond (macroexpand_1 curif env mexpander)) )
      (debug_msg xcond "mexpand_cppif xcond")
      (cond 
       ( (is_string xcond) ())
       ( (is_a xcond class_symbol) ())
       (:else
	(error_plain loc "invalid cpp-condition in CPPIF - string or symbol expected"_)
	(return ())))
      (let ( (curthen (pair_head curpair)) )
	(setq curpair (pair_tail curpair))
	(let ( (xthen (macroexpand_1 curthen env mexpander)) 
	       (xelse ())
	       )
	  (debug_msg xthen "mexpand_cppif xthen")
	  (if (is_pair curpair)
	      (let ( (curelse (pair_head curpair)) 
		     (gotxelse (macroexpand_1 curelse env mexpander)) )
		(debug_msg gotxelse "mexpand_cppif gotxelse")
		(setq curpair (pair_tail curpair))
		(setq xelse gotxelse)
		(if (is_pair curpair)
		    (error_plain loc "CPPIF with more than three sons"_))))
	  (let ( (resp (instance class_src_cppif
				 :src_loc loc
				 :sifp_cond xcond
				 :sifp_then xthen
				 :sifp_else xelse
				 ))
		 )
	    (debug_msg resp "mexpand_cppif return resp")
	    (return resp)
	    ))))))
(install_initial_macro 'cppif mexpand_cppif)
(export_macro cppif mexpand_cppif)



;;;;; the cond expanser
(defun mexpand_cond (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_cond sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(cexptuple (pairlist_to_multiple 
		    (pair_tail (list_first cont))
		    discr_multiple
		    (lambda (c)
		      (if (is_not_a c class_sexpr)
			  (error_plain loc "COND with non-sexpr"_))
		      c
		      ))) 
	(:long nbcond (multiple_length cexptuple))
	(lastcexp (let ( (lx (multiple_nth cexptuple -1)) )
		    (debug_msg lx "mexpand_cond lastcexp lx")
		    lx))
	(:long ix (-i nbcond 1))
	(res ())
	)
    (debug_msg cexptuple "mexpand_cond cexptuple")
    (forever condloop
	     (if (<i ix 0) (exit condloop))
	     (let ( (curcond (multiple_nth cexptuple ix)) )
	       (debug_msg curcond "mexpand_cond curcond")
	       (cond  
		( (and (null res)
		       (is_a curcond class_sexpr)
		       (== ':else (pair_head (list_first 
					      (unsafe_get_field :sexp_contents curcond)))))
		  (let ( (restpairs 
			  (pair_tail (list_first (unsafe_get_field :sexp_contents curcond)))) 
			 )
		    (if restpairs 
			(setq res (pairlist_to_progn restpairs 
						     (unsafe_get_field :loca_location curcond) 
						     env mexpander)))
		    (debug_msg res "mexpand_cond res for :else")
		    ))
		( (is_a curcond class_sexpr)
		  (let ( (curcondcont (unsafe_get_field :sexp_contents curcond))
			 (curcondloc (unsafe_get_field :loca_location curcond)) 
			 (curcondtest (pair_head (list_first curcondcont)))
			 (curcondrestpairs (pair_tail (list_first curcondcont))) 
			 )
		    (cond ( (null curcondrestpairs)
			    (setq res (instance class_src_or
						:src_loc curcondloc
						:sor_disj (make_tuple2 discr_multiple 
								       (macroexpand_1 curcondtest env mexpander)
								       res)))
			    (debug_msg res "mexpand_cond res for monoexp cond")
			    )
			  ( (null (pair_tail curcondrestpairs))
			    (setq res (instance class_src_ifelse
						:src_loc curcondloc
						:sif_test (macroexpand_1 curcondtest env mexpander)
						:sif_then (macroexpand_1 (pair_head curcondrestpairs) env mexpander)
						:sif_else res
						))
			    (debug_msg res "mexpand_cond res for biexp cond")
			    )
			  (:else 
			   (setq res (instance class_src_ifelse
					       :src_loc curcondloc
					       :sif_test (macroexpand_1 curcondtest env mexpander)
					       :sif_then (pairlist_to_progn curcondrestpairs curcondloc env mexpander)
					       :sif_else res))
			   (debug_msg res "mexpand_cond res for manyexp cond")
			   ))
		    ))
		(:else ;curcond is not a sexpr 
		 (setq res (instance class_src_or
				     :src_loc loc
				     :sor_disj (make_tuple2 discr_multiple curcond res)))
		 (debug_msg res "mexpand_cond res for nonsexp cond")
		 )
		)
	       )
	     (setq ix (-i ix 1))
	     )
    (debug_msg res "mexpand_cond final res")
    (return res)
    ))
(install_initial_macro 'cond mexpand_cond)
(export_macro cond mexpand_cond)

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


;;;; the AS pattern expander
(defun patexpand_as (sexpr env pctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattexpcontext))
  (debug_msg sexpr "patexpand_as sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(argsp (patternexpand_pairlist_as_tuple curpair env pctx loc))
	)
    (if (!=i (multiple_length argsp) 2)
	(progn
	  (error_plain loc "AS pattern expects two arguments: ?patvar subpattern")
	  (return)))
    (let ( (argvar (multiple_nth argsp 0))
	   (argsub (multiple_nth argsp 1))
	   )
      (if (is_a argvar class_srcpattern_jokervar)
	  (progn
	    (warning_plain loc "AS pattern with useless joker")
	    (return argsub)))
      (if (is_not_a argvar class_srcpattern_variable)
	  (progn
	    (error_plain loc "AS pattern needs a pattern variable as first argument")
	    (return)))
      (let (
	    (res (instance class_srcpattern_as
			   :src_loc loc
			   :aspat_varpat argvar
			   :aspat_subpat argsub))
	    )
	(debug_msg res "patexpand_as returns res")
	(return res)
	))))

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


;;;; the AND pattern expanser
(defun patexpand_and (sexpr env pctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattexpcontext))
  (debug_msg sexpr "patexpand_and sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(argsp (patternexpand_pairlist_as_tuple curpair env pctx loc))
	(res (instance class_srcpattern_and
		       :src_loc loc
		       :andpat_conj argsp))
	)
    (debug_msg res "patexpand_and res")
    (return res)
    )
  )
(install_initial_patmacro 'and patexpand_and mexpand_and)
(export_patmacro and patexpand_and mexpand_and)

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

;;;; the OR pattern expander
(defun patexpand_or (sexpr env pctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (assert_msg "check pctx" (is_a pctx class_pattexpcontext))
  (debug_msg sexpr "patexpand_or sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(argsp (patternexpand_pairlist_as_tuple curpair env pctx loc))
	(res (instance class_srcpattern_or
		       :src_loc loc
		       :orpat_disj argsp))
	)
    (debug_msg res "patexpand_or res")
    (return res)
    )
  )
(install_initial_patmacro 'or patexpand_or mexpand_or)
(export_patmacro or patexpand_or mexpand_or)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; the match expander
(defun mexpand_match (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_match sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(msexp (pair_head (pair_tail (list_first cont))))
	(matsx (macroexpand_1 msexp env mexpander))
	(mexptuple (pairlist_to_multiple 
		    (pair_tail (pair_tail (list_first cont)))
		    discr_multiple
		    (lambda (c)
		      (if (is_not_a c class_sexpr)
			  (error_plain loc "MATCH with non-sexpr"_))
		      c
		      ))) 
	(:long nbmatch (multiple_length mexptuple))
	(lastmexp (let ( (lx (multiple_nth mexptuple -1)) )
		    (debug_msg lx "mexpand_match lastmexp lx")
		    lx))
	(:long ix (-i nbmatch 1))
	(caselist (make_list discr_list))
	)
    (debug_msg mexptuple "mexpand_match mexptuple")
    (forever matchloop
	     (if (<i ix 0) (exit matchloop))
	     (let ( (curmatch (multiple_nth mexptuple ix)) )
	       (debug_msg curmatch "mexpand_match curmatch")
	       (cond  
		;; handle (:when pattern condexpr ...) clause
		( (and 
		   (is_a curmatch class_sexpr)
		   (== ':when (pair_head (list_first 
					  (unsafe_get_field :sexp_contents curmatch)))))
		  (let ( (curpair (pair_tail (list_first 
					      (unsafe_get_field :sexp_contents curmatch))))
			 (curmatchloc (unsafe_get_field :loca_location curmatch)) 
			 (swhenpat (let ( (sw (pair_head curpair)) ) (setq curpair (pair_tail curpair)) sw))
			 (swhencond (let ( (sc (pair_head curpair)) ) (setq curpair (pair_tail curpair)) sc))
			 (whencondx (macroexpand_1 swhencond env mexpander))
			 (whenbody (expand_pairlist_as_tuple curpair 
							     (unsafe_get_field :loca_location curmatch) 
							     env mexpander))
			 (curpatctx (instance class_pattexpcontext
					      :pctx_mexpander mexpander
					      :pctx_pexpander patternexpand_1
					      :pctx_varmap (make_mapobject discr_mapobjects 13)))
			 (curpat (patternexpand_1 swhenpat env curpatctx curmatch))
			 (curcase (instance class_src_casewhenmatch
					    :src_loc curmatchloc
					    :scam_patt curpat
					    :scwm_when whencondx
					    :scam_body whenbody))
			 )
		    (debug_msg curcase "mexpand_match when curcase")
		    (list_append caselist curcase)
		    )
		  )
		;; 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_pattexpcontext
					      :pctx_mexpander mexpander
					      :pctx_pexpander patternexpand_1
					      :pctx_varmap (make_mapobject discr_mapobjects 13)))
			 (curpat (patternexpand_1 curmatchpatx env curpatctx curmatchloc))
			 (curbody (expand_pairlist_as_tuple curmatchrestpairs env mexpander))
			 (curcase (instance class_src_casematch
					    :src_loc curmatchloc
					    :scam_patt curpat
					    :scam_body curbody))
			 )
		    (debug_msg curcase "mexpand_match curcase")
		    (list_prepend caselist curcase)
		    ))
		;; detect non-sexp clauses
		(:else
		 (error_plain loc "(MATCH <expr> <match-case>...) with non sexpr matchcase") 
		 )))
	     (setq ix (-i ix 1)))
    (debug_msg caselist "mexpand_match caselist")
    (let ( (smat (instance class_src_match
			   :src_loc loc
			   :smat_matchedx matsx
			   :smat_cases (list_to_multiple caselist discr_multiple)) 
		 ))
      (debug_msg smat "mexpand_match result smat")
      (return smat)
      )))

(install_initial_macro 'match mexpand_match)
(export_macro match mexpand_match)

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

;;; the LET expander itself
(defun mexpand_let (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(secpair (pair_tail (list_first cont)))
	(restpair (pair_tail secpair))
	(bindexpr (pair_head secpair))
	(newenv (fresh_env env))
	(bindtup ())
	(bodytup ())
	)
    (if bindexpr 
	(if (is_a bindexpr class_sexpr) 
	    (setq bindtup 
		  (pairlist_to_multiple 
		   (list_first (unsafe_get_field :sexp_contents bindexpr))
		   discr_multiple
		   (lambda (b) 
		     (if (is_not_a b class_sexpr)
			 (error_plain loc "sexpr expected in LET binding"))
		     (mexpand_letbinding b env mexpander))))
	  (error_plain loc "missing letbinding-s in LET"_))
      )
    (multiple_every
     bindtup
     (lambda (slb)
       (assert_msg "mexp.let. check slb" (is_a slb class_src_letbinding))
       (let (
	     (sx (unsafe_get_field :sletb_expr slb))
	     (lb (instance class_let_binding
			   :binder (unsafe_get_field :sletb_binder slb)
			   :letbind_type (unsafe_get_field :sletb_type slb)
			   :letbind_expr sx)) )
	 (assert_msg "mexp.let not list lb" (not (is_list lb)))
	 (put_env newenv lb)
	 )))
    (setq bodytup (pairlist_to_multiple restpair discr_multiple 
					(lambda (e) (macroexpand_1 e newenv mexpander))))
    (let ( (letr
	    (instance class_src_let
		      :src_loc loc
		      :slet_bindings bindtup
		      :slet_body bodytup)) )
      (return letr)
      )))
(install_initial_macro 'let mexpand_let)
(export_macro let mexpand_let)

;;;;;;;; for LAMBDA
(defun mexpand_lambda (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (newenv (fresh_env env))
	 (formals (pair_head curpair))
	 )
    ;; parse the formal arguments
    (if (and (notnull formals) (is_not_a formals class_sexpr))
	(error_plain loc "missing formal argument list in (LAMBDA (arglist...) body...)"_))
    (let ( (argtup (lambda_arg_bindings formals sexpr)) )
      (setq curpair (pair_tail curpair))
      (multiple_every argtup 
		      (lambda (lb) (put_env newenv lb)))
      (let ( (bodytup (pairlist_to_multiple curpair discr_multiple 
					    (lambda (e) (macroexpand_1 e newenv mexpander)))) 
	     (lambr 
	      (instance class_src_lambda
			:src_loc loc
			:slam_argbind argtup
			:slam_body bodytup))
	     ) 
	(return lambr)
	))))
(install_initial_macro 'lambda mexpand_lambda)
(export_macro lambda mexpand_lambda)

;;;;;;;; for MULTICALL
(defun mexpand_multicall (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (newenv (fresh_env env))
	 )
    ;; parse the formal results
    (let ( (restup (lambda_arg_bindings (pair_head curpair) sexpr)) )
      (setq curpair (pair_tail curpair))
      (let ( (curcallexp (pair_head curpair)) )
	(if (not (is_a curcallexp class_sexpr))
	    (error_plain loc "missing called expression in multicall"_))
	(setq curpair (pair_tail curpair))
	(let ( (curcall (macroexpand_1 curcallexp env mexpander)) )
	  (multiple_every restup 
			  (lambda (lb) (put_env newenv lb)
			    ))
	  (let ( (bodytup (pairlist_to_multiple curpair discr_multiple 
						(lambda (e) (macroexpand_1 e newenv mexpander)))) 
		 (mulcr
		  (instance class_src_multicall
			    :src_loc loc
			    :smulc_resbind restup
			    :smulc_call curcall
			    :smulc_body bodytup
			    )) 
		 )
	    (return mulcr)
	    ))))))
(install_initial_macro 'multicall mexpand_multicall)
(export_macro multicall mexpand_multicall)


;;;;;;;; for QUOTE (only of symbols or keywords)
(defun mexpand_quote (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (quoted (pair_head curpair))
	 )
    (if (pair_tail curpair)
	(error_plain loc "QUOTE should have only one symbol argument"_))
    (if (not (is_a quoted class_symbol))
	(error_plain loc "QUOTE should have a symbol argument - composite quotations unsupported"_))
    (if (is_a quoted class_keyword)
	(return quoted))
    (let ( (squ (instance class_src_quote
			  :src_loc loc
			  :squoted quoted)) )
      (return squ)
      )))
(install_initial_macro 'quote mexpand_quote)
(export_macro quote mexpand_quote)

;;;;;;;; for COMMENT (only of strings)
(defun mexpand_comment  (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (comstr (pair_head curpair))
	 )
    (if (pair_tail curpair)
	(error_plain loc "COMMENT should have only one string argument"_))
    (if (not (is_string comstr))
	(progn
	  (error_plain loc "COMMENT should have a string"_)
	  (setq comstr ()))
      )
    (let ( (scom (instance class_src_comment
			   :src_loc loc
			   :scomm_str comstr)) )
      (return scom)
      )))
(install_initial_macro 'comment mexpand_comment)
(export_macro comment mexpand_comment)

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

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

;;;; the progn expanser
(defun mexpand_progn (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (let ( (sloc (unsafe_get_field :loca_location sexpr))
	 (pairs  (pair_tail
		  (list_first (unsafe_get_field :sexp_contents sexpr)))) 
	 )
    (if (not (is_pair pairs))
	(progn
	  (error_plain sloc "empty PROGN"_)
	  (return)))
    (let ( (progr
	    (pairlist_to_progn pairs
			       sloc
			       env
			       mexpander)) )
      (return progr)
      )))
(install_initial_macro 'progn mexpand_progn)
(export_macro progn mexpand_progn)

;;;; the return expanser
(defun mexpand_return (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (let ( (retr
	  (pairlist_to_return (pair_tail (list_first (unsafe_get_field :sexp_contents sexpr)))
			      (unsafe_get_field :loca_location sexpr)
			      env
			      mexpander)) 
	 )
    (return retr)
    ))
(install_initial_macro 'return mexpand_return)
(export_macro return mexpand_return)


;;;; the forever expanser
(defun mexpand_forever (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (slabnam (pair_head curpair))
	 (xlabnam (macroexpand_1 slabnam env mexpander))
	 (newenv (fresh_env env))
	 )
    (if (is_not_a xlabnam class_symbol)
	(progn
	  (error_plain loc "missing label in FOREVER"_)
	  (return (the_null))))
    (setq curpair (pair_tail curpair))
    (let ( (labind (instance class_label_binding
			     :binder xlabnam
			     :labind_loc loc)) )
      (put_env newenv labind)
      (let ( (bodytup (pairlist_to_multiple
		       curpair
		       discr_multiple
		       (lambda (e) (macroexpand_1 e newenv mexpander)))) 
	     (forr
	      (instance class_src_forever
			:src_loc loc
			:slabel_bind labind
			:sfrv_body bodytup)) 
	     )
	(return forr)
	))))
(install_initial_macro 'forever mexpand_forever)
(export_macro forever mexpand_forever)

;;;; the exit expanser
(defun mexpand_exit (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (slabnam (pair_head curpair))
	 (xlabnam (macroexpand_1 slabnam env mexpander))
	 (newenv (fresh_env env))
	 )
    (if (is_not_a xlabnam class_symbol)
	(progn
	  (error_plain loc "missing label in EXIT"_)
	  (return (the_null))))
    (setq curpair (pair_tail curpair))
    (let ( (labind (find_env env xlabnam)) )
      (if (is_not_a labind class_label_binding)
	  (progn 
	    (error_strv loc "bad label in EXIT"_
			(unsafe_get_field :named_name xlabnam))
	    (return (the_null))))
      (let ( (bodytup (pairlist_to_multiple
		       curpair
		       discr_multiple
		       (lambda (e) (macroexpand_1 e newenv mexpander)))) 
	     (exr
	      (instance class_src_exit
			:src_loc loc
			:slabel_bind labind
			:sexi_body bodytup)) 
	     )
	(return exr)
	))))
(install_initial_macro 'exit mexpand_exit)
(export_macro exit mexpand_exit)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; compile time warning (compile_warning msg expr)
;; we don't issue the warning at expansion phase, but at normalization phase.
(defun  mexpand_compile_warning (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (debug_msg sexpr "mexpand_compile_warning sexpr")
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (smsg (pair_head curpair))
	 (xmsg (macroexpand_1 smsg env mexpander))
	 )
    (if (not (is_string xmsg))
	(progn
	  (error_plain loc "missing message string in (COMPILE_WARNING <msg> <exp>)"_)
	  (return (the_null))))
    (setq curpair (pair_tail curpair))
    (let ( (sexp (pair_head curpair))
	   (xexp (macroexpand_1 sexp env mexpander))
	   )
      (setq curpair (pair_tail curpair))
      (if (notnull curpair)
	  (error_plain loc "too many arguments in (COMPILE_WARNING <msg> <exp>)"_))
      (let ( (res (instance  class_src_compilewarning
			     :src_loc loc
			     :scwarn_msg xmsg
			     :scwarn_expr xexp
			     ))
	     )
	(debug_msg res "mexpand_compile_warning result")
	(return res)
	))))
(install_initial_macro 'compile_warning mexpand_compile_warning)
(export_macro compile_warning mexpand_compile_warning)

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

(defun mexpand_assert_msg (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_assert_msg sexpr")
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(loc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(xmsg (macroexpand_1 (pair_head curpair)  env mexpander))
	(xtest ())
	(assfail_symb 'assert_failed)
	(assfail_binding (find_env env assfail_symb))
	)
    (if (not (is_string xmsg))
	(error_plain loc "non string message in (ASSERT_MSG <msg> <test>)"_))
    (setq curpair (pair_tail curpair))
    (if (not (is_pair curpair))
	(error_plain loc "missing test in (ASSERT_MSG <msg> <test>)"_))
    (setq xtest (macroexpand_1 (pair_head curpair) env mexpander))
    (if (pair_tail curpair)
	(error_plain loc "extra arg for (ASSERT_MSG <msg> <test>)"_))
    (let (
	  (afprim 
	   (cond 
	    ( (null assfail_binding)
	      (error_plain loc "unbound ASSERT_FAILED in (ASSERT_MSG <msg> <test>)"_)
	      (debug_msg env "mexpand_assert_msg env without assert_failed")
	      (debug_msg (discrim env) "mexpand_assert_msg env's class without assert_failed")
	      (debug_msg  (find_env_debug env assfail_symb) "mexpand_assert_msg findenvdbg give")
	      (debug_msg assfail_symb "mexpand_assert_msg ASSERT_FAILED symbol")
	      (assert_msg "assfail_binding nul! @@" ())
	      (return))
	    ( (is_a assfail_binding class_primitive_binding)
	      (unsafe_get_field :pbind_primitive assfail_binding))
	    ( (and (is_a assfail_binding class_value_binding)
		   (is_a (unsafe_get_field :vbind_value assfail_binding) 
			 class_primitive))
	      (unsafe_get_field :vbind_value assfail_binding))
	    (:else
	     (debug_msg assfail_binding "bad assfail_binding")
	     (error_plain loc "ASSERT_FAILED not bound to a primitive in  (ASSERT_MSG <msg> <test>)"_)
	     (return)
	     )))
	  (filnam (cond
		   ((is_mixint loc) (mixint_val loc))
		   ((is_mixloc loc) (mixloc_val loc))))
	  (aprim (instance 
		  class_src_primitive
		  :src_loc loc
		  :sprim_oper afprim
		  :sprim_args (make_tuple3 discr_multiple
					   xmsg
					   filnam
					   (make_integerbox discr_integer (get_int loc)))))
	  (atest (instance
		  class_src_ifelse
		  :src_loc loc
		  :sif_test xtest
		  :sif_then ()
		  :sif_else aprim))
	  (acppif (instance class_src_cppif
			    :src_loc loc
			    :sifp_cond 'ENABLE_CHECKING
			    :sifp_then atest
			    :sifp_else ()
			    )) 
	  )
      (debug_msg acppif "mexpand_assert_msg result acppif")
      (return acppif)
      )))
(install_initial_macro 'assert_msg mexpand_assert_msg)
(export_macro assert_msg mexpand_assert_msg)

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

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

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

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

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

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

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

(install_initial_macro 'current_module_environment_container mexpand_current_module_environment_container)
(export_macro current_module_environment_container mexpand_current_module_environment_container)


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



;;;;;;;;;;;;;;;;
;;;; update_current_module_environment_container macro 
(defun mexpand_update_current_module_environment_container  (sexpr env mexpander)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr))
  (assert_msg "check env" (is_a env class_environment))
  (debug_msg sexpr "mexpand_update_current_module_environment_container sexpr")
  (let (
	(loc  (unsafe_get_field :loca_location sexpr))
	(cont (unsafe_get_field :sexp_contents sexpr))
	(curpair (pair_tail (list_first cont)))
	(res (instance class_src_update_current_module_environment_container
		       :src_loc loc))
	)
    (if (notnull curpair)
	(error_plain loc "(UPDATE_CURRENT_MODULE_ENVIRONMENT_CONTAINER) should not have any argument"_))
    (debug_msg res "mexpand_update_current_module_environment_container return res")
    (return res)
    ))
					;(install_initial_macro 'update_current_module_environment_box mexpand_update_current_module_environment_container)
					;(export_macro update_current_module_environment_box mexpand_update_current_module_environment_container)
;;; to prepare the renaming

(install_initial_macro 'update_current_module_environment_container mexpand_update_current_module_environment_container)
(export_macro update_current_module_environment_container mexpand_update_current_module_environment_container)



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

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

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

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

(export_class  ;classes for source representations, alphabetical order
 class_pattexpcontext
 class_src_apply
 class_src_casematch
 class_src_casewhenmatch
 class_src_citeration
 class_src_cmatchexpr
 class_src_codechunk
 class_src_comment
 class_src_compilewarning
 class_src_cppif
 class_src_current_module_environment_container
 class_src_defciterator
 class_src_defclass
 class_src_defcmatcher
 class_src_definstance
 class_src_defobjcommon
 class_src_defprimitive
 class_src_defselector
 class_src_defun
 class_src_defunmatcher
 class_src_exit
 class_src_export_class
 class_src_export_macro
 class_src_export_patmacro
 class_src_export_values
 class_src_exportcommon
 class_src_fetch_predefined
 class_src_fieldassign
 class_src_forever
 class_src_funmatchexpr
 class_src_get_field
 class_src_if
 class_src_ifelse
 class_src_labelled
 class_src_lambda
 class_src_let
 class_src_letbinding
 class_src_make_instance
 class_src_match
 class_src_msend
 class_src_multicall
 class_src_or
 class_src_parent_module_environment
 class_src_primitive
 class_src_progn
 class_src_put_fields
 class_src_quote
 class_src_return
 class_src_setq
 class_src_store_predefined
 class_src_unsafe_get_field
 class_src_unsafe_put_fields
 class_src_update_current_module_environment_container
 class_srcdef
 class_srcdeformal
 class_srcfieldpattern
 class_srcpattern_and
 class_srcpattern_any
 class_srcpattern_anymatch
 class_srcpattern_as
 class_srcpattern_cmatch
 class_srcpattern_composite
 class_srcpattern_constant
 class_srcpattern_instance
 class_srcpattern_jokervar
 class_srcpattern_object
 class_srcpattern_or
 class_srcpattern_variable
 )			       ;end classes for source representations

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

;; eof warmelt-macro.melt