;; file warmelt-normal.melt -*- Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (comment "*** Copyright 2008 - 2014 Free Software Foundation, Inc. Contributed by Basile Starynkevitch 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 . ***") ;; the copyright notice above apply both to warmelt-normal.melt and ;; to the generated file warmelt-normal*.c ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; This file is part of a bootstrapping compiler for the MELT lisp ;; dialect, compiler which should be able to compile itself (into ;; generated C file[s]) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ================ normalized representations ;; basically, the normalized representation of (f a (g x)) ;; is let y=(g x) in (f a y) ;; etc... where y is a cloned symbol ;;; common superclass for normalized representations (defclass class_nrep :super class_root :doc #{The $CLASS_NREP is the common super class of normalized representations. Its $NREP_LOC field gives the location in source, if any.}# :fields (nrep_loc ;location in source )) ;;; the discriminant for normalizing closures (definstance discr_normalizing_closure class_discriminant :doc #{The $DISCR_NORMALIZING_CLOSURE is the discriminant of MELT debug functions. Use $CLONE_WITH_DISCRIMINANT on a closure, e.g. with $LAMBDA, to make it a normalizing function. For gurus.}# :obj_num MELTOBMAG_CLOSURE :disc_super discr_closure :named_name '"DISCR_NORMALIZING_CLOSURE") (defclass class_normal_magic_binding :doc #{The $CLASS_NORMAL_MAGIC_BINDING is tricky, rarely used (e.g. for @code{code_chunk} tags): the $NMAGIC_VALUE is the returned value of its $BINDER. If it is a closure of DICR_NORMALIZING_CLOSURE, that closure is applied to normalize.}# :super class_any_binding :fields (nmagic_value) ) ;; a simple stuff is a non-object, a symbol (or keyword or clonedsym), ;; ... (defclass class_nrep_simple :doc #{The $CLASS_NREP_SIMPLE is for simple normal things -e.g. normal symbols.}# :super class_nrep :fields ( )) ;; a normalized expression should never be the result of normal_exp; ;; it should only appear in bindings! (defclass class_nrep_expression :doc #{Common superclass $CLASS_NREP_EXPRESSION of normalized expressions which can only appear in normal bindings.}# :super class_nrep :fields ( )) ;; normalized typed expressions also have a ctype (defclass class_nrep_typed_expression :doc #{Common super-class $CLASS_NREP_TYPED_EXPRESSION of typed normalized expressions. $NEXPR_CTYP gives its c-type.}# :super class_nrep_expression :fields (nexpr_ctyp ;the ctype )) ;; normalized typed expressions with arguments (defclass class_nrep_typed_expression_with_arguments :doc #{Common super-class $CLASS_NREP_TYPED_EXPRESSION_WITH_ARGUMENTS of typed normalized expressions with normalized arguments. $NEXPR_ARGS is the tuple of normalized arguments.}# :super class_nrep_typed_expression :fields (nexpr_args)) ;; normal applications have simple functions & arguments (defclass class_nrep_apply :super class_nrep_typed_expression_with_arguments :doc #{The $CLASS_NREP_APPLY class is for normal applications. $NAPP_FUN is the simple function to apply to $NEXPR_ARGS.}# :fields (napp_fun ;simple function to apply )) ;; normal hook calls (defclass class_nrep_hook_call :super class_nrep_typed_expression_with_arguments :doc #{The $CLASS_NREP_HOOK_CALL is for normal hook calls. $NHOOK_CALLED is the called hook. $NHOOK_OUTS it the actual output arguments to the hook. $NHOOK_DESCR is the descriptor.}# :fields (nhook_name nhook_called nhook_outs nhook_descr )) ;; normalized multiresult apply (defclass class_nrep_multiapply :doc #{The $CLASS_NREP_MULTIAPPLY is for normal applications of functions with several results within $MULTICALL. $NMULAPP_BINDINGS is the tuple of formal result bindings. $NMULAPP_BODY is the normal body.}# :super class_nrep_apply :fields (nmulapp_bindings ;a tuple of formal result bindings nmulapp_body ;body normexp )) ;;; normal message sending (defclass class_nrep_msend :doc #{The $CLASS_NREP_SEND is for normal message send (or message passing), with a single result. $NSEND_SEL is the normalized selector, $NSEND_RECV the normalized receiver, with $NEXPR_ARGS giving the normalized arguments.}# :super class_nrep_typed_expression_with_arguments :fields (nsend_sel ;the normalized selector occurrence nsend_recv ;the receiver )) ;; normalized multiresult message send (defclass class_nrep_multimsend :doc #{The $CLASS_NREP_MULTIMSEND is for normal message sends with multiple results thru $MULTICALL. $NMULSEND_BINDINGS is the tuple of formal result bindings, and $NMULSEND_BODY is the normalized body.}# :super class_nrep_msend :fields (nmulsend_bindings ;tuple of formal bindings nmulsend_body ;body normexp )) ;; normal chunk is a normalized expansion of primitive (defclass class_nrep_chunk :doc #{The $CLASS_NREP_CHUNK is for normalized expansion of primitive or cmatcher expressions. Field $NCHUNK_EXPANSION is the expansion - where strings of $DISCR_VERBATIM_STRING are handled specifically. Field $NCHUNK_OPER is the operator.}# :super class_nrep_typed_expression :fields (nchunk_expansion ;the expansion nchunk_oper ;the operator (primitive or cmatcher) )) ;; normal comment is a normalized comment (defclass class_nrep_comment :doc #{The $CLASS_NREP_COMMENT if for normalized comments in the generated C code. The field $NCOMM_STRING gives the comment.}# :super class_nrep_expression :fields (ncomm_string ;the comment )) ;; normal lets have simple binding & body subexpressions (defclass class_nrep_let :doc #{The $CLASS_NREP_LET is for normalized lets. The $NLET_BINDINGS field is a tuple of $CLASS_NORMAL_LET_BINDING instances. The $NLET_BODY field is the normal body. The normalization process introduce many such normal lets.}# :super class_nrep_expression :fields (nlet_bindings ;a tuple of class_normal_let_binding-s nlet_body )) ;; normal letrec (defclass class_nrep_letrec :doc #{The $CLASS_NREP_LETREC is for normalized letrec. The field $NLETREC_FILL_BINDINGS is the list of internal normal bindings to fill the letrec-ed constructions. The field $NLETREC_BODY_BINDINGS is the tuple of internal normal bindings for the body. The field $NLETREC_LOCSYMS is the tuple of local symbol occurrences.}# :super class_nrep_let :fields ( ;; the nlet_bindings is a tuple of constructive bindings nletrec_fill_bindings nletrec_body_bindings nletrec_locsyms )) ;; normal return have a main & supplementary subexpressions (defclass class_nrep_return :doc #{The $CLASS_NREP_RETURN is for normalized returns. The primary returned value is given thru $NRET_MAIN field. The secondary returned things are thru $NRET_REST tuple.}# :super class_nrep_expression :fields (nret_main ;main normal expression to return nret_rest ;tuple of normal expr... )) ;; common normal for if, ifisa ... (defclass class_nrep_ifcommon :doc #{The $CLASS_NREP_IFCOMMON is the common superclass for normalized if-like tests. $NIF_THEN gives the then branch, and $NIF_ELSE gives the else branch.}# :super class_nrep_typed_expression :fields (nif_then nif_else )) ;;; common normal for testing some value (defclass class_nrep_iftestvalue :doc #{The $CLASS_NREP_IFTESTVALUE is a common superclass for testing about some given value $NIF_TESTVAL}# :super class_nrep_ifcommon :fields (nif_testval )) ;; normal if is_a(value,class) then else (defclass class_nrep_ifisa :doc #{The $CLASS_NREP_IFISA is for normalized $IS_A tests. Inherited $NIF_TESTVAL gives the value to be tested, and $NIFA_CLASS gives the normalized class data in which the value is tested for membership.}# :super class_nrep_iftestvalue :fields (nifa_class ;normal class )) (defclass class_nrep_iftuplesized :doc #{The $CLASS_NREP_IFTUPLESIZED is for normalized tests of multiple of given size. Inherited $NIF_TESTVAL gives the value to be tested (if it is multiple), and $NIF_TUPSIZ gives the size to be tested (if it has that size).}# :super class_nrep_iftestvalue :fields (nif_tupsiz)) ;; normal if_variadic(variadic,typetuple) then .. (defclass class_nrep_ifvariadic :doc #{The $CLASS_NREP_IFVARIADIC is for normalized $VARIADIC tests. $NIFV_VARIADIC gives the variadic name, and $NIFV_CTYPES gives the tuple of ctypes.}# :super class_nrep_ifcommon :fields (nifv_variadic nifv_ctypes)) ;; normal consume_variadic (defclass class_nrep_consume_variadic :super class_nrep_expression :doc #{The $CLASS_NREP_CONSUME_VARIADIC is for $VARIADIC argument consumption. Field $NCONSVA_VARIADIC gives the variadic, and $NCONSVA_CTYPES the consumed types of arguments. }# :fields ( nconsva_variadic nconsva_ctypes )) ;; normal if same (t1,t2) then else (defclass class_nrep_ifsame :doc #{The $CLASS_NREP_IFSAME is for normalized identity tests for matching. $NIFS_LEFT and $NIFS_RIGHT are the simple stuff to compare for identity.}# :super class_nrep_ifcommon :fields (nifs_left nifs_right)) ;; normal if have simple test, then, else clauses & a ctype (defclass class_nrep_if :doc #{The $CLASS_NREP_IF is for usual normalized if-test. $NIF_TEST gives the tested thing.}# :super class_nrep_ifcommon :fields (nif_test )) ;; normal ifcpp have a symbol and a ctyp. Perhaps it should be ;; refactored using class_nrep_ifcommon? (defclass class_nrep_cppif :doc #{The $CLASS_NREP_CPPIF is for cppif compile-time tests. $NIFP_COND is the tested cpp symbol. $NIFP_THEN the then part, $NIFP_ELSE the else part, $NIFP_CTYP the ctype.}# :super class_nrep_expression :fields (nifp_cond nifp_then nifp_else nifp_ctyp )) ;; normal progn has a distingished last (defclass class_nrep_progn :doc #{The $CLASS_NREP_PROGN is for normalized $PROGN sequences. The $NPROGN_SEQ field is the tuple of all-but-last subexpressions, and the last one is given in $NPROGN_LAST.}# :super class_nrep_expression :fields (nprogn_seq ;tuple of all but last nprogn_last )) (defclass class_nrep_checksignal :doc #{The $CLASS_NREP_CHECKSIGNAL is an internal expression to check interrupts, corresponding to emission of the melt_check_interrupt() C macro. It is emitted at safe places.}# :super class_nrep_expression :fields () ) (defclass class_nrep_putmodulevar :super class_nrep_expression :fields (nputmod_destvar nputmod_value)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (compile_warning ":doc missing below") ;; normalized unsafe get field (defclass class_nrep_unsafe_get_field :super class_nrep_expression :fields (nuget_obj nuget_field)) ;; normalized unsafe_put_field (defclass class_nrep_unsafe_put_fields :super class_nrep_expression :fields (nuput_obj nuput_fields)) ;; normalized unsafe nth_component (defclass class_nrep_unsafe_nth_component :super class_nrep_expression :fields (nunth_tuple nunth_index)) ;; normalized setq (defclass class_nrep_setq :super class_nrep_expression :fields (nstq_var nstq_exp )) ;; normalized forever (defclass class_nrep_forever :super class_nrep_expression :fields (nforever_bind ;the label binding nforever_body ;a tuple nforever_result ;cloned symbol for result )) ;; normalized exit (defclass class_nrep_exit :super class_nrep_expression :fields (nexit_bind ;the label binding nexit_val ;the exited value )) ;; normalized again (defclass class_nrep_again :super class_nrep_expression :fields (nagain_bind ;the label binding )) ;; normalized field assign (in make instance) (defclass class_nrep_fieldassign :super class_nrep :fields (nfla_field ;the field nfla_val ;its normalized value )) ;; normalized make instance (defclass class_nrep_instance :super class_nrep_expression :fields (nmins_class ;the instanciated class nmins_cladata ;its data nmins_fields ;the tuple of field assignments )) ;; normalized variadic argument retrieval (defclass class_nrep_variadic_argument :super class_nrep_expression :fields (nvarg_variadic ;variadic symbol for index nvarg_ctyp ;ctype of argument nvarg_offset ;boxed integer offset )) ;; normalized lambda (defclass class_nrep_lambda :super class_nrep_expression :fields (nlambda_proc ;the procedure nlambda_constrout ;the constant routine nlambda_closedv ;the tuple of closed normal values )) ;; normalized citeration (defclass class_nrep_citeration :super class_nrep_expression :fields (nciter_citerator ;the citerator nciter_chunkbefore ;the expansed chunk before nciter_chunkafter ;the expansed chunk after nciter_body ;the normalized body nciter_statocc ;the state local occurrence nciter_locbindings ;the local bindings nciter_bodbindings ;normalized body bindings )) ;; normalized tests sequence, used for matches (defclass class_nrep_tests :super class_nrep_expression :fields (ntests_testseq ;the tuples of normal tests ;;;; see file warmelt-normatch.melt )) ;;;;;;;;;;;;;;;; (defclass class_normal_constructor_binding :doc #{The internal $CLASS_NORMAL_CONSTRUCTOR_BINDING is the common super-class of constructor bindings in LETREC... Field $NCONSB_LOC gives the optional location, field $NCONSB_DISCR gives the normalized discriminant, and field $NCONSB_NLETREC gives the normal letrec containing it..}# :super class_any_binding :fields (nconsb_loc nconsb_discr nconsb_nletrec) ) (defclass class_normal_constructed_tuple_binding :doc #{The internal $CLASS_NORMAL_CONSTRUCTED_TUPLE_BINDING is the class of tuple constructor bindings. Field $NTUPB_COMP gives the tuple of initial normalized components.}# :super class_normal_constructor_binding :fields (ntupb_comp)) (defclass class_normal_constructed_pair_binding :doc #{The internal $CLASS_NORMAL_CONSTRUCTED_PAIR_BINDING is the class of pair constructor bindings. Field $NPAIRB_HEAD gives the normalized head, and $NPAIRB_TAIL gives the normalized tail.}# :super class_normal_constructor_binding :fields (npairb_head npairb_tail)) (defclass class_normal_constructed_list_binding :doc #{The internal $CLASS_NORMAL_CONSTRUCTED_LIST_BINDING is the class of list constructor bindings. Field $NLISTB_FIRST gives the initial normalized first pair, and field $NLISTB_LAST gives the last one. Field $NLISTB_PAIRSB gives the tuple of constructed pair bindings}# :super class_normal_constructor_binding :fields (nlistb_first nlistb_last nlistb_pairsb)) (defclass class_normal_constructed_lambda_binding :doc #{The internal $CLASS_NORMAL_CONSTRUCTED_LAMBDA_BINDING is the class of lambda constructor bindings. Field $NLAMBDAB_NCLOSED gives the normalized closed values, and $NLAMBDAB_DATAROUT gives the normalized routine data, and $NLAMBDAB_CONSTROUT its constant.}# :super class_normal_constructor_binding :fields (nlambdab_nclosed nlambdab_constrout nlambdab_datarout)) (defclass class_normal_constructed_instance_binding :doc #{The internal $CLASS_NORMAL_CONSTRUCTED_INSTANCE_BINDING is the class of instance constructor bindings. Field $NINSTB_SLOTS is the tuple of the normalized slots, and $NINSTB_CLABIND is the class binding.}# :super class_normal_constructor_binding :fields (ninstb_slots ninstb_clabind)) (defclass class_normal_module_variable_binding :doc #{The internal $CLASS_NORMAL_MODULE_VARIABLE_BINDING is the class of module variable bindings. }# :super class_variable_binding :fields (nvarb_num)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; procedures (defclass class_nrep_anyproc :doc #{The $CLASS_NREP_ANYPROC is the common super-class for procedures. Field $NPROC_BODY is the normalized body.}# :super class_nrep :fields ( nproc_body )) ;; the class of the initial procedure (defclass class_nrep_initproc :super class_nrep_anyproc :doc #{The $CLASS_NREP_INITPROC is the class for the initial procedure in a module. Field $NINIT_TOPL is the list of top-level normalized expressions. Field $NINIT_DEFBINDS is the list of $DEFINE-d bindings. Field $NINIT_IMPORTS is the list of imports.}# :fields (ninit_topl ;list of toplevel nrep ninit_defbinds ;list of define-d bindings ninit_imports ;list of imports ninit_importexprs ;tuple of import assignments )) ;; the class of the initial procedure when extending a module (defclass class_nrep_initextendproc :super class_nrep_initproc :doc #{The $CLASS_NREP_INITEXTENDPROC is the class for the initial extending procedure for an existing module. Field ninitextend_modenv is the extended environment.}# :fields (ninitextend_modenv )) (defclass class_nrep_closproc :super class_nrep_anyproc :doc #{The internal $CLASS_NREP_CLOSPROC is the super-class for closing procedures with optional name $NRCLOP_NAME, [input] arguments bindings tuplz $NRCLOP_ARGBINDTUPLE, closed bindings list $NRCLOP_CLOBINDLIST, constant list $NRCLOP_CONSTLIST, and object const cache map $NRCLOP_OBJCONSTCACHEMAP}# :fields (nrclop_name nrclop_argbindtuple nrclop_clobindlist nrclop_constlist nrclop_objconstcachemap )) ;; the class of the normalized hook procedure (defclass class_nrep_hookproc :super class_nrep_closproc :doc #{The $CLASS_NREP_HOOKPROC is the class for a hook procedure in a module, defined with $DEFHOOK. }# :fields (nrhook_outb ;output arguments binding tuple nrhook_ctype ;ctype of result nrhook_datahook ;hook data object )) ;; normal routine procedure (defclass class_nrep_routproc :super class_nrep_closproc :doc #{The $CLASS_NREP_ROUTPROC is the class for normal routine procedures, representing $DEFUN or $LAMBDA code. Field $NRPRO_DATAROUT is the routine data object. Field $NRPRO_DATACLOS is the closure data object. Field $NRPRO_THUNKLIST is the list of thunks to be called when compiling it. Field $NRPRO_VARIADIC is non-null if the routine is variadic.}# :fields ( nrpro_datarout ;routine data object nrpro_dataclos ;closure data object nrpro_thunklist ;list of thunks to be called when compiling it nrpro_variadic ;non null iff variadic )) (defclass class_nrep_lambdaroutproc :super class_nrep_routproc :doc #{The $CLASS_NREP_LAMBDAROUTPROC is the class for $LAMBDA related routine procedures.}# :fields ()) (defclass class_nrep_defunroutproc :super class_nrep_routproc :doc #{The $CLASS_NREP_DEFUNROUTPROC is the class for $DEFUN related routine procedures.}# :fields ()) ;;; static normalized predef (defclass class_nrep_predef :doc #{The $CLASS_NREP_PREDEF is for normalized predefined values. $NRPREDEF gives the symbolic or integer number.}# :super class_nrep_simple :fields ( nrpredef ;the predef is a symbol or a boxed integer )) ;; normalized nil (defclass class_nrep_nil :doc #{The $CLASS_NREP_NIL is for normalized nil occurrences.}# :super class_nrep_simple :fields ( )) ;; give the normal import of some imported value or literal named value (defun normal_import (nimpval env ncx psloc) (debug "normal_import nimpval=" nimpval "\n.. ncx=" ncx) (let ( (nsymb ()) (nsymbname ()) ) (cond ( (is_a nimpval class_nrep_importedval) (setq nsymb (get_field :nimport_symb nimpval)) (setq nsymbname (get_field :named_name nsymb)) (debug "normal_import importedval nsymb=" nsymb "\n.. nsymbname=" nsymbname) ) ( (is_a nimpval class_nrep_literalvalue) (setq nsymb (get_field :nlitval_symbol nimpval)) (setq nsymbname (get_field :named_name nsymb)) (debug "normal_import literalvalue nsymb=" nsymb "\n.. nsymbname=" nsymbname) ) (:else (debug "normal_import bad nimpval=" nimpval) (assert_msg "normal_import with unepxected nimpval" () nimpval) (return) ) ) (assert_msg "check nsymb" (is_a nsymb class_symbol) nsymb) (let ( (modctx (get_field :nctx_modulcontext ncx)) (curproc (get_field :nctx_curproc ncx)) (ndataparenv (get_field :nctx_qdatparmodenv ncx)) (modname (get_field :mocx_modulename modctx)) (sloc (or (get_field :nrep_loc nimpval) psloc)) (nimphc (instance class_nrep_hook_call :nrep_loc sloc :nexpr_ctyp ctype_value :nhook_name '"HOOK_SYMBOL_IMPORTER" :nexpr_args (tuple nsymbname modname ndataparenv) :nhook_called (normal_predef hook_symbol_importer ncx sloc "hook_symbol_importer") :nhook_outs (tuple) :nhook_descr (hook_data hook_symbol_importer) ) ) (nsetimp (instance class_nrep_setq :nrep_loc sloc :nstq_var nimpval :nstq_exp nimphc )) ) (debug "normal_import nimphc=" nimphc "\n.. nimpval=" nimpval "\n.. nsetimp=" nsetimp) (return nsetimp) ))) ;;; quasidata are stuff to be computed inside the initial routine; ;;; most of them are plain data, but current_module_environment_reference & ;;; parent_module_environment need specific stuff (defclass class_nrep_quasidata :doc #{The $CLASS_NREP_QUASIDATA is an abstract super-class for data computed during initialization.}# :super class_nrep :fields ( )) (defclass class_nrep_bound_data :super class_nrep_quasidata :doc #{The internal $CLASS_NREP_BOUND_DATA is for normalized defined and bound data. The objnum of its instance is the predefined rank if any.}# ;; the objnum is the predefined rank if any :fields (ndata_name ;name if any of the data ndata_rank ;boxed integer rank of the data ;;; we box the integer and don't use the objnum bzcause we ;;; might have a lot (>30000) of data ndata_locbind ;local binding tuple to fill the data ) ) (defclass class_nrep_discriminated_data :doc #{The internal $CLASS_NREP_DISCRIMINATED_DATA is for defined data with a static disciminant.}# :super class_nrep_bound_data :fields ( ndata_discrx ;discriminant normal expression )) ;; normal "static" instance - built at modules initialization (defclass class_nrep_datainstance :super class_nrep_discriminated_data :fields (ninst_objnum ;object number (a number or a symbol) ninst_predef ;predefined rank (number or symbol) ninst_hash ;integer hash ninst_slots ;tuple of normalized slots expressions )) ;; normal "static" string (defclass class_nrep_datastring :super class_nrep_discriminated_data :fields ( nstr_string ;the string )) ;; normal "static" boxed integer (defclass class_nrep_databoxedinteger :super class_nrep_discriminated_data :fields ( nboxint_num ;the numerical integer )) ;; normal "static" tuple (defclass class_nrep_datatuple :super class_nrep_discriminated_data :fields ( ntup_comp ;the tuple of component values expressions )) ;; normal interned static symbol (defclass class_nrep_datasymbol :super class_nrep_datainstance :fields ( ndsy_namestr )) ;; normal interned static keyword (defclass class_nrep_datakeyword :super class_nrep_datasymbol :fields ( )) ;; normal static routine data (defclass class_nrep_dataroutine :super class_nrep_discriminated_data :fields (ndrou_proc ;associated procedure )) ;; normal static hook data (defclass class_nrep_datahook :super class_nrep_discriminated_data :fields (ndhook_proc ;associated procedure ndhook_data ;the data ndhook_closv ;tuple of closed values ndhook_predef ;the predefined, if any ndhook_modvarbind ;the module variable binding if any )) ;; normal static closure data (defclass class_nrep_dataclosure :super class_nrep_discriminated_data :fields (ndclo_proc ;associated procedure ndclo_closv ;tuple of closed values )) ;; normal static start value ;; obtained from an initial binding, imported from parent environment (defclass class_nrep_importedval :super class_nrep_simple :fields (nimport_symb ;the symbol nimport_sydata ;the symbol data )) ;; normal literal value (defclass class_nrep_literalvalue :super class_nrep_simple :fields (nlitval_regval )) ;; normal literal named values (defclass class_nrep_literalnamedvalue :super class_nrep_literalvalue :fields (nlitval_symbol )) ;; normal static variable occurrence (defclass class_nrep_modulevarocc :super class_nrep_simple :fields (nmodvar_bind ;the normal variable binding, containing the index )) ;; normal occurrence of a symbol (defclass class_nrep_symocc :super class_nrep_simple :fields (nocc_symb nocc_ctyp ;the ctype of the symbol, eg ctype_value nocc_bind ;the binding of the symbol )) ;; normal local occurrence of a symbol (defclass class_nrep_locsymocc :super class_nrep_symocc :fields ( )) ;; normal closed occurrence of a symbol (defclass class_nrep_closedocc :super class_nrep_symocc :fields (ncloc_procs ;list of enclosing procedures )) ;; normal constant occurrence of a symbol (defclass class_nrep_constocc :super class_nrep_closedocc ) ;;; normal quasi constants for current_module_environment_reference & ;;; parent_module_environment & constants (defclass class_nrep_quasiconstant :super class_nrep_simple :fields (nconst_sval ;source value nconst_proc ;containing proc nconst_data ;normalized data or stuff inside iniproc )) ;; normal constant (.e.g a quoted symbol, a keyword, a define-d value ...) (defclass class_nrep_constant :super class_nrep_quasiconstant :fields ( )) (defclass class_nrep_defined_constant :super class_nrep_quasiconstant :fields (nconst_defbind ) ) ;; noormal current_module_environment_reference quasiconst (defclass class_nrep_quasiconst_current_module_environment_reference :super class_nrep_quasiconstant :fields ( nqcmec_comment )) ;; normal current_module_environment_reference quasidata (defclass class_nrep_quasidata_current_module_environment_reference :super class_nrep_quasidata :fields ( )) ;; noormal parent_module_environment quasiconst (defclass class_nrep_quasiconst_parent_module_environment :super class_nrep_quasiconstant :fields ( )) ;; normal parent_module_environment quasidata (defclass class_nrep_quasidata_parent_module_environment :super class_nrep_quasidata :fields ( )) ;; data field accessor (mostly used for defclass initialization) this ;; translates into melt_field_object(,) of obj is not a ;; datainstance and directly to the field if it is a datainstance (defclass class_nrep_fieldacc :super class_nrep_expression :fields (naccf_obj ;data for the object to be accessed naccf_fld ;rank or field to be accessoed )) ;;; data multiple accessor (mostly used for defclass initialization) ;; this translates into melt_multiple_nth(,) if mul is not ;; a datatuple and directly to the component if it is a datatuple (defclass class_nrep_multacc :super class_nrep_expression :fields (naccm_mul ;data for the multiple to be accessed naccm_ix ;index to be accessed (a boxed integer) )) ;; normalized store predefined (defclass class_nrep_store_predefined :super class_nrep_expression :fields (nstpd_predef nstpd_value )) ;; normalized update current module environment box (defclass class_nrep_update_current_module_environment_reference :super class_nrep_expression :fields ( nucmeb_expr ;the normalized expression ;computing the box ncumeb_comment ;optional comment )) ;; normalized check of current running module environment box (defclass class_nrep_check_running_module_environment_container :super class_nrep_expression :fields (nchrumod_comment ;optional comment )) ;;; export all the normalized representations classes (export_class ;; normal representations classes in alphabetical order class_normal_constructed_instance_binding class_normal_constructed_lambda_binding class_normal_constructed_list_binding class_normal_constructed_pair_binding class_normal_constructed_tuple_binding class_normal_constructor_binding class_normal_magic_binding class_normal_module_variable_binding class_nrep class_nrep_again class_nrep_anyproc class_nrep_apply class_nrep_bound_data class_nrep_check_running_module_environment_container class_nrep_checksignal class_nrep_chunk class_nrep_citeration class_nrep_closedocc class_nrep_closproc class_nrep_comment class_nrep_constant class_nrep_constocc class_nrep_consume_variadic class_nrep_cppif class_nrep_databoxedinteger class_nrep_dataclosure class_nrep_datahook class_nrep_datainstance class_nrep_datakeyword class_nrep_dataroutine class_nrep_datastring class_nrep_datasymbol class_nrep_datatuple class_nrep_defined_constant class_nrep_defunroutproc class_nrep_discriminated_data class_nrep_exit class_nrep_expression class_nrep_fieldacc class_nrep_fieldassign class_nrep_forever class_nrep_hookproc class_nrep_hook_call class_nrep_if class_nrep_ifcommon class_nrep_ifisa class_nrep_ifsame class_nrep_iftestvalue class_nrep_iftuplesized class_nrep_ifvariadic class_nrep_importedval class_nrep_initextendproc class_nrep_initproc class_nrep_instance class_nrep_lambda class_nrep_lambdaroutproc class_nrep_let class_nrep_letrec class_nrep_literalnamedvalue class_nrep_literalvalue class_nrep_locsymocc class_nrep_msend class_nrep_multacc class_nrep_multiapply class_nrep_multimsend class_nrep_nil class_nrep_predef class_nrep_progn class_nrep_putmodulevar class_nrep_quasiconst_current_module_environment_reference class_nrep_quasiconst_parent_module_environment class_nrep_quasiconstant class_nrep_quasidata class_nrep_quasidata_current_module_environment_reference class_nrep_quasidata_parent_module_environment class_nrep_return class_nrep_routproc class_nrep_setq class_nrep_simple class_nrep_modulevarocc class_nrep_store_predefined class_nrep_symocc class_nrep_typed_expression class_nrep_typed_expression_with_arguments class_nrep_unsafe_get_field class_nrep_unsafe_nth_component class_nrep_unsafe_put_fields class_nrep_update_current_module_environment_reference class_nrep_variadic_argument ) ;end of export normal classes ;;;;;;; primitive for extra warnings (defprimitive has_extra_warnings () :long "(extra_warnings)") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; add some data to a normalization context and return it (defun add_nctx_data (nctx ndata) (debug "add_nctx_data nctx=" nctx) (debug "add_nctx_data ndata=" ndata "\n") (shortbacktrace_dbg "add_nctx_data" 16) (assert_msg "check nctx" (is_a nctx class_normalization_context) nctx) (assert_msg "check ndata" (is_a ndata class_nrep_bound_data) ndata) (assert_msg "fresh ndata" (null (unsafe_get_field :ndata_rank ndata)) ndata) (let ( (datlis (unsafe_get_field :nctx_datalist nctx)) (ncurproc (unsafe_get_field :nctx_curproc nctx)) ) (debug "add_nctx_data ncurproc=" ncurproc) (debug "add_nctx_data datlis=" datlis) (assert_msg "check datlis" (is_list datlis) datlis) (let ( (lastdat (pair_head (list_last datlis))) ) (if (is_a lastdat class_nrep_bound_data) (let ( (:long lastrk (get_int (unsafe_get_field :ndata_rank lastdat))) ) (assert_msg "check lastrk" (>i lastrk 0) lastrk) (let ( (rkbox (make_integerbox discr_integer (+i 1 lastrk))) ) (unsafe_put_fields ndata :ndata_rank rkbox) )) (let ( (rkbox1 (make_integerbox discr_integer 1)) ) (unsafe_put_fields ndata :ndata_rank rkbox1) ))) (list_append datlis ndata) (debug "add_nctx_data updated datlis=" datlis "\n result ndata=" ndata) ndata )) ;; the automatically generated warmelt-predef.melt file defines a fill_initial_predefmap function (load "warmelt-predef.melt") ;; internal primitive to return the last predefined index (defprimitive last_globpredef_index () :long "BGLOB__LASTGLOB") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass class_literal_value :super class_proped :fields (litv_value litv_rank litv_loc) :doc #{$CLASS_LITERAL_VALUE is the class managing literal values in runtime extension modules. $LITV_VALUE is the literal value itself $LITV_RANK is its unique rank in the extension module $LITV_LOC may contain its stack location}# ) (export_class class_literal_value) (defun register_literal_value (val modctx) (debug "register_literal_value val=" val "\n in modctx=" modctx) (assert_msg "check modctx" (is_a modctx class_running_extension_module_context) modctx) (let ( (litvalist (get_field :morcx_litervalist modctx)) (litobjmap (get_field :morcx_literobjmap modctx)) (countlit (get_field :morcx_countlitval modctx)) (:long count (get_int countlit)) ) (assert_msg "check litvalist" (is_list litvalist) litvalist) (assert_msg "check litobjmap" (is_mapobject litobjmap) litobjmap) (assert_msg "check countlit" (is_integerbox countlit) countlit) ;; check once in a while that the counter is the list length (assert_msg "check count" (or (%iraw count 8) (==i count (list_length litvalist))) count) (cond ( (null val) (assert_msg "null literal value" ()) (return)) ( (is_integerbox val) (assert_msg "integer literal value" () val) (return)) ( (is_string val) (assert_msg "string literal value" () val) (return)) ( (is_object val) (let ( (litv (mapobject_get litobjmap val)) ) (cond (litv (debug "register_literal_value found litv=" litv) (assert_msg "check litv" (is_a litv class_literal_value) litv) (assert_msg "check old found value" (== (get_field :litv_value litv) val) litv val) ) (:else (setq litv (instance class_literal_value :litv_value val :litv_rank (make_integerbox discr_constant_integer count) :litv_loc () )) (list_append litvalist litv) (put_int countlit (+i count 1)) (mapobject_put litobjmap val litv) (debug "register_literal_value new litv=" litv "\n updated litobjmap=" litobjmap) ) ) (return litv) )) (:else ;; non-object value (let ( (litv (instance class_literal_value :litv_value val :litv_rank (make_integerbox discr_constant_integer count) :litv_loc () )) ) (list_append litvalist litv) (put_int countlit (+i count 1)) (debug "register_literal_value nonobject value litv=" litv) (return litv) )) ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; create a normalization context (defun create_normcontext (modctx) :doc #{Internal routine to reate a normalization context for module context $MODCTX, used to compile modules.}# (debug "create_normcontext modctx=" modctx) (shortbacktrace_dbg "create_normcontext" 12) (let ( (:long maxpredefix (last_globpredef_index)) (:long ix 1) (predefmap (make_mapobject discr_map_objects (+i 19 (*i 2 maxpredefix)))) (valmap (make_mapobject discr_map_objects 350)) ) (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx) (forever predefloop (if (>=i ix maxpredefix) (exit predefloop)) (let ( (curpredef (get_globpredef ix)) ) (if (is_object curpredef) (mapobject_put predefmap curpredef (make_integerbox discr_integer ix))) ) (setq ix (+i ix 1))) (fill_initial_predefmap predefmap) (let ( (inipro (instance class_nrep_initproc :ninit_topl (make_list discr_list) :ninit_defbinds (make_list discr_list) :nrep_loc () )) (ncx (instance class_normalization_context :nctx_initproc inipro :nctx_proclist (make_list discr_list) :nctx_datalist (make_list discr_list) :nctx_valuelist (make_list discr_list) :nctx_symbmap (make_mapstring discr_map_strings 50) :nctx_keywmap (make_mapstring discr_map_strings 40) :nctx_predefmap predefmap :nctx_valmap valmap :nctx_valbindmap (make_mapobject discr_map_objects 20) ;; we need a symbcachemap for the toplevel expressions :nctx_symbcachemap (make_mapobject discr_map_objects 30) :nctx_curproc inipro :nctx_modulcontext modctx :nctx_qdatcurmodenvbox (instance class_nrep_quasidata_current_module_environment_reference ) :nctx_qdatparmodenv (instance class_nrep_quasidata_parent_module_environment ) :nctx_procurmodenvlist (make_list discr_list) )) ) (debug "create_normcontext make ncx=" ncx) (return ncx) ))) ;;;;;;;;;;;;;;;; (defun create_normal_extending_context (modctx modenv) :doc #{Internal routine to create a normalization context for module context $MODCTX, used to compile, e.g. for running, the extension of a module environment $MODENV.}# (debug "create_normal_extending_context start modctx=" modctx "\n* modenv=" modenv "\n") (shortbacktrace_dbg "create_normal_extending_context" 12) (let ( (:long maxpredefix (last_globpredef_index)) (:long ix 1) (predefmap (make_mapobject discr_map_objects (+i 11 (*i 2 maxpredefix)))) (valmap (make_mapobject discr_map_objects 91)) ) (assert_msg "check modctx" (is_a modctx class_running_extension_module_context) modctx) (assert_msg "check modenv" (is_a modenv class_environment) modenv) (forever predefloop (if (>=i ix maxpredefix) (exit predefloop)) (let ( (curpredef (get_globpredef ix)) ) (if (is_object curpredef) (mapobject_put predefmap curpredef (make_integerbox discr_integer ix))) ) (setq ix (+i ix 1))) (fill_initial_predefmap predefmap) (let ( (inipro (instance class_nrep_initextendproc :ninit_topl (make_list discr_list) :ninit_defbinds (make_list discr_list) :nrep_loc () :ninitextend_modenv modenv )) (ncx (instance class_normalization_context :nctx_initproc inipro :nctx_proclist (make_list discr_list) :nctx_datalist (make_list discr_list) :nctx_valuelist (make_list discr_list) :nctx_symbmap (make_mapstring discr_map_strings 30) :nctx_keywmap (make_mapstring discr_map_strings 20) :nctx_predefmap predefmap :nctx_valmap valmap :nctx_valbindmap (make_mapobject discr_map_objects 20) ;; we need a symbcachemap for the toplevel expressions :nctx_symbcachemap (make_mapobject discr_map_objects 10) :nctx_curproc inipro :nctx_modulcontext modctx :nctx_qdatcurmodenvbox (instance class_nrep_quasidata_current_module_environment_reference ) :nctx_qdatparmodenv (instance class_nrep_quasidata_parent_module_environment ) :nctx_procurmodenvlist (make_list discr_list) )) ) (debug "create_normal_extending_context make inipro=" inipro "\n.. result ncx=" ncx "\n") (return ncx) ))) ;;; the normal_exp selector ;;;;; expected arguments: ;;; recv = the receiver, eg a sexpr ;;; env = the environment ;;; ncx = the normalization context ;;; psloc = (parent) source location ;;;;; expected results: normalized + binding list ;;; IMPORTANT NOTICE: even for simple expressions [like side-effecting ;;; expressions returning void, e.g. RETURN, EXIT, ... other simple ;;; side-effecting expressions like SETQ], the normalized should ;;; always be a simple occurrence, and the work being done in the ;;; bindings list. (defselector normal_exp class_selector :doc #{Normalize an expression, often an S-expr or a literal constant. $RECV is the reciever, $ENV the environment of $CLASS_ENVIRONMENT, $NCX the normalization context of $CLASS_NORMALIZATION_CONTEXT and $PSLOC the parent source location. Should return a normalized thing, often an instance of $CLASS_NREP_LOCSYMOCC, and as a secondary result a list of bindings.)}# :formals (recv env ncx psloc) ; :named_name (stringconst2val discr_namestring "NORMAL_EXP") ) ;; many stuff, e.g. constant literal strings or numbers, are already normalized (defun normexp_identical (recv env ncx psloc) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) ;; is a no-op (debug "normexp_identical recv" recv) (return recv ())) (install_method discr_string normal_exp normexp_identical) (install_method discr_integer normal_exp normexp_identical) (defun normexp_null (recv env ncx psloc) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check nctxt" (is_a ncx class_normalization_context) ncx) (let ( (normnull (instance class_nrep_nil :nrep_loc psloc)) ) (debug "normexp_null normnull" normnull) (return normnull ()) )) (install_method discr_null_receiver normal_exp normexp_null) ;;; an object or a value may have to be normalized only when inside a ;;; constructed s-expression. The reader is not able to give such ;;; values. So it practically happens only when running an ;;; evaluation. ;;;;;;;;;;;;;;;; (defun normexp_any_object (recv env ncx psloc) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) ;; we should normalize arbitrary objects into themselves. However, ;; we should collect all these objects, so that the runtime ;; evaluator gets them all, so the normalized expression would be an ;; access to some constant offset inside a tuple (let ( (cla (discrim recv)) (claname (get_field :named_name cla)) (recname (get_field :named_name recv)) ) (if (is_string recname) (error_at psloc "unimplemented normalization for literal object named $1"_ recname)) (error_at psloc "unimplemented normalization for literal object of $1"_ claname) (assert_msg "@$@ unimplemented normexp_any_object" () recv))) (install_method class_root normal_exp normexp_any_object) (defun normexp_any_value (recv env ncx psloc) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) ;; we should normalize arbitrary values into themselves, unless when ;; they are containers for stuff like DISCR_TREE etc..., then we ;; should unbox that stuff. so the normalized expression would be ;; an access to some constant offset inside a tuple or its unboxing (debug "normexp_any_value recv=" recv) (let ( (cla (discrim recv)) (claname (get_field :named_name cla)) ) (error_at psloc "unimplemented normalization for literal value of $1"_ claname) (warning_at psloc "unnormalizable literal value is $1" recv) (assert_msg "@$@ unimplemented normexp_any_value" () recv))) (install_method discr_any_receiver normal_exp normexp_any_value) ;;; catchall for src (defun normexp_src_catchall (recv env ncx psloc) (debug "normexp_src_catchall recv=" recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (myclass (discrim recv)) (myclassname (unsafe_get_field :named_name myclass)) ) (error_at (unsafe_get_field :loca_location recv) "unimplemented normalization for value of $1" myclassname) (assert_msg "normexp_src_catchall unimplemented normexp for src" () recv) )) (install_method class_source normal_exp normexp_src_catchall) ;; normalization of lazy macro expansion (defun normexp_lazymacroexp (recv env ncx psloc) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (get_field :loca_location recv)) (lazymacfun (get_field :slazymacro_fun recv)) (lazymacoper (get_field :slazymacro_oper recv)) ) (multicall (mexp mresexp) (lazymacfun) (debug "normexp_lazymacroexp mexp" mexp) (if mresexp ;;; this happens in the pathological case when the lazy macro ;;; macro-expands to more than one result (error_at sloc "delayed lazy macro expansion cannot macro expand multiply"_)) (if (is_a mexp class_source_lazy_macro_expansion) ;;; this happens in the pathological case when a macro ;;; operator is not defined (progn (if (is_a lazymacoper class_symbol) (error_at sloc "undefined operator; unknown name $1" (get_field :named_name lazymacoper)) (error_at sloc "undefined macro; delayed lazy macro expansion too lazy")) (return) )) (multicall (nrep nbind) (normal_exp mexp env ncx psloc) (debug "normexp_lazymacroexp nrep=" nrep " nbind=" nbind) (return nrep nbind) ) ))) (install_method class_source_lazy_macro_expansion normal_exp normexp_lazymacroexp) ;; the selector to compute the ctype of a value in an environment ;;; argument: environment ;;;; sometimes this selector is used with a null environment, for ;;;; instance in the code generation phase (defselector get_ctype class_selector ) ;;; selector to compile a normalized stuff into an object ;;; receiver: the normalized stuff ;;; arguments: ;;;; * GCX the code generation context ;;; result = the obj instruction or value (defselector compile_obj class_selector ) ;;; most stuff are really ctype_value (defun gectyp_anyrecv (recv env) ctype_value) (install_method discr_any_receiver get_ctype gectyp_anyrecv) (defun gectyp_root (recv env) ctype_value) (install_method class_root get_ctype gectyp_root) ;; integers are ctype_long (defun gectyp_integer (recv env) (debug "gectyp_integer recv" recv) ctype_long) (install_method discr_integer get_ctype gectyp_integer) ;; strings are ctype_cstring (defun gectyp_string (recv env) ctype_cstring) (install_method discr_string get_ctype gectyp_string) ;;; normalize a tuple - returning a tuple & a bindinglist (defun normalize_tuple (tup env ncx psloc) (debug "normalize_tuple start tup=" tup " psloc=" psloc) (shortbacktrace_dbg "normalize_tuple" 12) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (if (null tup) (return () ())) (assert_msg "check tup" (is_multiple tup) tup) (let ( (bindlist (make_list discr_list)) (:long tuplen (multiple_length tup)) (res (make_multiple discr_multiple tuplen)) ) (foreach_in_multiple (tup) (comp :long ix) (debug "normalize_tuple comp=" comp "\n ix=" ix) (multicall (norcomp nbinds) (normal_exp comp env ncx psloc) (debug "normalize_tuple norcomp=" norcomp "\n of discrim=" (discrim norcomp) "\n* nbinds=" nbinds "\n* for comp=" comp "\n ix=" ix) (assert_msg "check nbinds" (is_list_or_null nbinds) nbinds) ;; Shameful dirty hack for module variables; notably for ;; application, we need to put them into a local ;; binding, because meltgc_apply is passing argument ;; by references, and melt_module_var_fetch returns ;; a pointer value, not a reference. (if (is_a norcomp class_nrep_modulevarocc) (let ( (nvarbind (unsafe_get_field :nmodvar_bind norcomp)) ) (debug "normalize_tuple modulevarocc norcomp=" norcomp " ix#" ix) (if (null nbinds) (setq nbinds (make_list discr_list))) (assert_msg "check nvarbind" (is_a nvarbind class_normal_module_variable_binding) nvarbind) (let ( (nvbinder (get_field :binder nvarbind)) (clonsym (clone_symbol nvbinder)) (clonbind (instance class_normal_let_binding :letbind_loc () :binder clonsym :letbind_type ctype_value :letbind_expr norcomp)) (clonocc (instance class_nrep_locsymocc :nrep_loc () :nocc_ctyp ctype_value :nocc_symb clonsym :nocc_bind clonbind)) ) (list_append nbinds clonbind) (setq norcomp clonocc) ))) ;; (assert_msg "check norcomp not class_nrep_expression" (is_not_a norcomp class_nrep_expression) norcomp) (if (is_list nbinds) (foreach_pair_component_in_list (nbinds) (curpair bnd) (assert_msg "check bnd" (is_a bnd class_any_binding) bnd) (assert_msg "check bindlist" (is_list bindlist) bindlist) (list_append bindlist bnd) ) ) (debug "normalize_tuple ix#" ix " norcomp=" norcomp) (multiple_put_nth res ix norcomp) )) (if (not (is_pair (list_first bindlist))) (setq bindlist ())) (debug "normalize_tuple final res=" res "\n.. bindlist=" bindlist) (return res bindlist) )) ;; wrap a normal let around a single normalized expression & a bindinglist (defun wrap_normal_let1 (nexp bindlist loc) (debug "wrap_normal_let1 nexp=" nexp " bindlist=" bindlist) (assert_msg "check bindlist" (is_list_or_null bindlist) bindlist) (list_every bindlist (lambda (cbind) (if (not (is_a cbind class_normal_let_binding)) (debug "wrap_normal_let1 nexp=" nexp " bindlist=" bindlist " cbind" cbind)) (assert_msg "check cbind wrapnormlet1" (is_a cbind class_normal_let_binding) cbind))) (if (and (is_list bindlist) (is_pair (list_first bindlist))) (let ( (wnlet (instance class_nrep_let :nrep_loc loc :nlet_bindings (list_to_multiple bindlist) :nlet_body (tuple nexp))) ) wnlet) nexp )) ;; wrap a normal let around a tuple of normalized expressions and a bindinglist ;; add an interrupt check (defun wrap_normal_letseq (tupnexp bindlist loc) (debug "wrap_normal_letseq tupnexp=" tupnexp " bindlist=" bindlist " loc=" loc) (shortbacktrace_dbg "wrap_normal_letseq" 6) (assert_msg "check tupnexp" (is_multiple_or_null tupnexp) tupnexp) (assert_msg "check bindlist" (is_list_or_null bindlist) bindlist) (let ( (:long nbnexp (multiple_length tupnexp)) ) (cond ( (not (is_multiple tupnexp)) (let ( (wnletn (wrap_normal_let1 tupnexp bindlist loc)) ) (debug "wrap_normal_letseq non-tuple tupnexp=" tupnexp "\n return wnletn=" wnletn) (return wnletn))) ( (==i nbnexp 0) (assert_msg "check impossible nbnexp" () tupnexp)) ( (==i nbnexp 1) (let ( (subnexp (multiple_nth tupnexp 0)) (wnlet1 (wrap_normal_let1 subnexp bindlist loc)) ) ;; single subexpression (debug "wrap_normal_letseq return wnlet1=" wnlet1) (return wnlet1) )) ( :else ;more than one sub-expression (let ( (ncheckint (instance class_nrep_checksignal :nrep_loc loc)) (growntup (make_multiple discr_multiple (+i nbnexp 1))) ) (multiple_put_nth growntup 0 ncheckint) (foreach_in_multiple (tupnexp) (curnexp :long nix) (assert_msg "check curnexp" (or (is_not_object curnexp) (is_a curnexp class_nrep)) curnexp) (multiple_put_nth growntup (+i nix 1) curnexp)) (list_every bindlist (lambda (cbind) (if (not (is_a cbind class_normal_let_binding)) (debug "wrap_normal_letseq tuplexp=" tupnexp " bindlist=" bindlist " cbind=" cbind)) (assert_msg "check cbind wrapnormletseq" (is_a cbind class_normal_let_binding) cbind))) (let ( (wnlet (instance class_nrep_let :nrep_loc loc :nlet_bindings (list_to_multiple bindlist) :nlet_body growntup)) ) (debug "wrap_normal_letseq return wnlet=" wnlet) (return wnlet))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; utility to check that every normalized argument has a passable ctype (defun check_ctype_nargs (nargs env sloc) (multiple_every nargs (lambda (cnarg :long ix) (let ( (ctyp (get_ctype cnarg env)) ) (assert_msg "check_ctype_nargs ctyp" (is_a ctyp class_ctype) ctyp) (if (not (is_string (unsafe_get_field :ctype_parstring ctyp))) (error_at sloc "argument has invalid type $1"_ (unsafe_get_field :named_name ctyp)) )) ))) (defselector normalize_binding class_selector :doc #{Normalize a locally bound symbol. $RECV is the binding, $ENV is the environment, $NCX is the normal context, $PSLOC the parent source location.}# :formals (recv env ncx procs psloc)) (defun normbind_failany (recv env ncx procs psloc) (debug "normbind_failany recv" recv) (let ( (dis (discrim recv)) ) (debug "normbind_failany dis" dis) (error_at psloc "unexpected binding normalization of instance of $1" (get_field :named_name dis)) (assert_msg "@$@unexpected normalize binding" () recv) )) (install_method discr_any_receiver normalize_binding normbind_failany) (defun normbind_anybind (bind env ncx procs psloc) (debug "normbind_anybind bind=" bind) (let ( (dis (discrim bind)) (symb (unsafe_get_field :binder bind)) (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) ) (warning_strv psloc "bizarre?? constant reference to" (unsafe_get_field :named_name symb)) (debug "normbind_anybind bind=" bind "\n of dis=" dis) (warning_strv psloc "bizarre binding normalization for " (get_field :named_name dis)) (let ( (kocc (instance class_nrep_constocc :nrep_loc psloc :nocc_ctyp ctype_value :nocc_symb symb :nocc_bind bind) ) ) (debug "normbind_anybind kocc=" kocc) ;; cache the result & return it (mapobject_put sycmap symb kocc) (debug "normbind_anybind updated sycmap=" sycmap) ;; put the const occurrence if needed in the const list of each proc (foreach_pair_component_in_list (procs) (curpair curproc) (debug "normbind_anybind const curproc=" curproc) (assert_msg "check curproc" (is_a curproc class_nrep_anyproc) curproc) (let ( (clcont (instance class_reference :referenced_value kocc)) (constlist (get_field :nrclop_constlist curproc)) ) (debug "normbind_anybind constlist=" constlist) (foreach_pair_component_in_list (constlist) (curpaircl curcl) (if (== curcl kocc) (put_fields clcont :referenced_value ()))) (let ( (newcl (get_field :referenced_value clcont)) ) (when newcl (debug "normbind_anybind newcl=" newcl) (list_append constlist newcl))) )) (return kocc) ))) (install_method class_any_binding normalize_binding normbind_anybind) ;; normalize local formal bindings (defun normbind_formalbind (bind env ncx procs psloc) (assert_msg "check bind" (is_a bind class_formal_binding) bind) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) (symb (unsafe_get_field :binder bind)) (syocc (instance class_nrep_locsymocc :nrep_loc psloc :nocc_ctyp (unsafe_get_field :fbind_type bind) :nocc_symb symb :nocc_bind bind) ) ) ;; cache the result & return it (mapobject_put sycmap symb syocc) (debug "normbind_formalbind updated sycmap=" sycmap " syocc=" syocc) syocc )) (install_method class_formal_binding normalize_binding normbind_formalbind) ;; normalize local let binding (defun normbind_letbind (bind env ncx procs psloc) (assert_msg "check bind" (is_a bind class_let_binding) bind) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) (symb (unsafe_get_field :binder bind)) (syocc (instance class_nrep_locsymocc :nrep_loc psloc :nocc_ctyp (unsafe_get_field :fbind_type bind) :nocc_symb symb :nocc_bind bind) ) ) ;; cache the result & return it (mapobject_put sycmap symb syocc) (debug "normbind_letbind updated sycmap=" sycmap " syocc=" syocc) syocc )) (install_method class_let_binding normalize_binding normbind_letbind) ;;; normalize local fixed binding (defun normbind_fixbind (bind env ncx procs psloc) (debug "normbind_fixbind bind=" bind) (assert_msg "check bind" (is_a bind class_fixed_binding) bind) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) (symb (unsafe_get_field :binder bind)) (fixdat (unsafe_get_field :fixbind_data bind)) ) (debug "normbind_fixbind fixdat=" fixdat) (when (null fixdat) (debug "normbind_fixbind strange bind=" bind) (error_at psloc "unresolved forward fixed reference to $1" (unsafe_get_field :named_name symb) ) ) (assert_msg "normbind_fixbind check fixdat" (is_a fixdat class_nrep_bound_data) fixdat) ;; cache the result & return it (mapobject_put sycmap symb fixdat) (debug "normbind_fixbind updated sycmap=" sycmap " symb=" symb " fixdat=" fixdat) fixdat)) (install_method class_fixed_binding normalize_binding normbind_fixbind) ;; normalize a define-d binding (defun normbind_definedvalbind (bind env ncx procs psloc) (debug "normbind_definedvalbind bind=" bind " psloc=" psloc) (assert_msg "check bind" (is_a bind class_defined_value_binding) bind) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) (symb (unsafe_get_field :binder bind)) (curproc (get_field :nctx_curproc ncx)) (syconst (instance class_nrep_defined_constant :nrep_loc psloc :nconst_sval symb :nconst_data () :nconst_proc curproc :nconst_defbind bind )) ) (debug "normbind_definedvalbind ncx=" ncx "\n env=" env " procs=" procs) ;; cache the result & return it (mapobject_put sycmap symb syconst) (put_fields bind :fixbind_data syconst) (debug "normbind_definedvalbind updated sycmap=" sycmap " syconst=" syconst " bind=" bind) (if (is_non_empty_list procs) (assert_msg "normbind_definedvalbind check no procs" () procs) (return syconst) ))) (install_method class_defined_value_binding normalize_binding normbind_definedvalbind) ;; normalize defined macro binding (defun normbind_defmacrobind (bind env ncx procs psloc) (debug "normbind_defmacrobind bind=" bind "\n.. env=" env "\n.. ncx=" debug_less ncx "\n.. procs=" debug_less procs "\n.. psloc=" psloc) (shortbacktrace_dbg "normbind_defmacrobind" 12) (assert_msg "check bind" (is_a bind class_defined_macro_binding) bind) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) (symb (unsafe_get_field :binder bind)) (curproc (get_field :nctx_curproc ncx)) (modctx (get_field :nctx_modulcontext ncx)) (mdata (get_field :mbind_data bind)) ) (debug "normbind_defmacrobind mdata=" mdata) (when (is_non_empty_list procs) (assert_msg "normbind_defmacrobind bad procs" () procs)) (when (is_not_a mdata class_nrep_dataclosure) (error_at psloc "insane use of undefined or ill-defined macro $1; macro uses should be operator-like." (get_field :named_name symb)) (assert_msg "normbind_defmacrobind bad macro data while bootstrapping" (not (melt_is_bootstrapping)) mdata bind (discrim bind)) (return) ) (mapobject_put sycmap symb mdata) (return mdata) )) (install_method class_defined_macro_binding normalize_binding normbind_defmacrobind) ;; normalize local constructed binding (defun normbind_constructbind (bind env ncx procs psloc) (assert_msg "check bind" (is_a bind class_normal_constructor_binding) bind) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) (symb (unsafe_get_field :binder bind)) (nletrec (get_field :nconsb_nletrec bind)) ) (debug "normbind_constructbind nletrec" nletrec) (assert_msg "normbind_constructbind check nletrec" (is_a nletrec class_nrep_letrec) nletrec) (let ( (nlocsyms (get_field :nletrec_locsyms nletrec)) (ourlocsym ()) ) (debug "normbind_constructbind nlocsyms" nlocsyms) ;; find the right locsym in nlocsyms and cache it (foreach_in_multiple (nlocsyms) (curlocsym :long syix) (when (== (get_field :nocc_bind curlocsym) bind) (setq syix -9999) ;to exit the loop [-1 don't work!] (setq ourlocsym curlocsym)) ) (debug "normbind_constructbind ourlocsym" ourlocsym) (assert_msg "normbind_constructbind should have ourlocsym" (is_a ourlocsym class_nrep_locsymocc) ourlocsym) ;; cache the result & return it (mapobject_put sycmap symb ourlocsym) (debug "normbind_constructbind updated sycmap=" sycmap " symb=" symb " ourlocsym=" ourlocsym) (return ourlocsym) ))) (install_method class_normal_constructor_binding normalize_binding normbind_constructbind) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; For symbols which are imported from a previous environment we ;; should detect them and generate some special data to fetch them, in ;; the start routine, from the given environment (which is the only ;; argument to the start routine). Detecting such symbols is easy: ;; their binding is a class_value_binding ;;;; normalize a symbol occurrence (defun normexp_symbol (recv env ncx psloc) (debug "normexp_symbol recv=" recv "\n.. env=" debug_less env "\n.. ncx=" debug_less ncx "\n.. psloc=" psloc ) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (assert_msg "check recv" (is_a recv class_symbol) recv) (multicall (bind procs gotenv) (find_enclosing_env env recv) (debug "normexp_symbol after find_enclosing_env bind=" debug_less bind "\n.. procs=" debug_less procs "\n.. gotenv=" debug_less gotenv) (assert_msg "normexp_symbol check recv" (is_a recv class_symbol) recv) (let ( (modctx (unsafe_get_field :nctx_modulcontext ncx)) (valbindmap (unsafe_get_field :nctx_valbindmap ncx)) (valuelist (unsafe_get_field :nctx_valuelist ncx)) (symbname (get_field :named_name recv)) ) (if (null psloc) (shortbacktrace_dbg "normex_symbol null psloc" 10) ) (when (null bind) (error_at psloc "unknown name $1; symbol is not bound" symbname) (shortbacktrace_dbg "normexp_symbol null bind" 15) (debug "normexp_symbol bad name recv=" recv "\n.. env=" env) (debug "normexp_symbol bad name envprev=" (get_field :env_prev env)) (debug "normexp_symbol bad name envprev2=" (get_field :env_prev (get_field :env_prev env))) (debug "normexp_symbol bad name envprev3=" (get_field :env_prev (get_field :env_prev (get_field :env_prev env)))) (if (melt_is_bootstrapping) (assert_msg "@$@normexp_symbol is failing while bootstrapping" () recv env)) (return () ())) ;; (if (is_a bind class_normal_magic_binding) (let ( (magval (get_field :nmagic_value bind)) ) (debug "normexp_symbol magicbind magval=" magval) (if (is_a magval discr_normalizing_closure) (multicall (nval nbind) (magval env ncx psloc) (debug "normexp_symbol magicbind nval=" nval " nbind=" nbind) (return nval nbind)) (progn (debug "normexp_symbol magicbind bind=" bind "\n gives magval=" magval) (return magval ()) )) )) ;; (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) (syca (mapobject_get sycmap recv)) ) (assert_msg "check sycmap" (is_mapobject sycmap) sycmap) (debug "normexp_symbol syca=" syca "\n.. for recv=" recv "\n.. bind=" bind) (cond ;; check if in the cache (syca (return syca ())) ;already cached ;; ;; value binding, get/put it into the map ( (is_a bind class_value_binding) (let ( (bvar (mapobject_get valbindmap bind)) (val (get_field :vbind_value bind)) ) (debug "normexp_symbol value bind=" bind "\n.. procs=" procs "\n.. bvar=" bvar "\n.. val=" val) (if (null bvar) (let ( (newbvar (cond ( (is_a modctx class_running_extension_module_context) (let ( (reglitval (register_literal_value val modctx)) (nlitval (instance class_nrep_literalnamedvalue :nlitval_regval reglitval :nlitval_symbol recv)) ) (debug "normexp_symbol nlitval=" nlitval) nlitval ) ) (:else (instance class_nrep_importedval :nrep_loc psloc :nimport_symb recv :nimport_sydata (normal_symbol_data recv ncx psloc))))) ) (mapobject_put valbindmap bind newbvar) (setq bvar newbvar) (list_append valuelist newbvar) (debug "normexp_symbol newbvar=" newbvar "\n.. valuelist=" valuelist) )) ;; if procs is a non-empty list, symbol is a "closed" ;; constant for the value (debug "normexp_symbol recv=" recv "\n.. procs=" procs) (if (and (is_list procs) (is_pair (list_first procs))) (let ( (fxocc (instance class_nrep_constocc :nrep_loc psloc :nocc_symb recv :nocc_bind bind :nocc_ctyp ctype_value :ncloc_procs procs)) ) ;; cache the result (mapobject_put sycmap recv fxocc) (debug "normexp_symbol const value fxocc=" fxocc " updated sycmap=" sycmap "\n.. procs=" debug_less procs "\n.. for symbname=" symbname) ;; put the const occurrence if needed in the const ;; list of each proc (foreach_pair_component_in_list (procs) (curpairpro pr) (debug "normexp_symbol const symbname=" debug_less symbname " pr=" debug_less pr) (assert_msg "check pr" (is_a pr class_nrep_anyproc) pr) (cond ( (is_a pr class_nrep_routproc) (let ( (clcont (instance class_reference :referenced_value fxocc)) (cnstlist (get_field :nrclop_constlist pr)) ) (debug "normexp_symbol cnstlist=" cnstlist "\n.. pr=" pr "\n.. recv=" recv) (foreach_pair_component_in_list (cnstlist) (curpaircx cx) (when (== cx fxocc) (put_fields clcont :referenced_value ()))) (let ( (newcl (get_field :referenced_value clcont)) ) (when newcl (debug "normexp_symbol newcl=" newcl) (list_append cnstlist newcl))) )) ( (is_a pr class_nrep_hookproc) (let ( (hkclobindlist (get_field :nrclop_clobindlist pr)) (foundbind ()) ) (debug "normexp_symbol hkclobindlist=" hkclobindlist) (assert_msg "check hkclobindlist" (is_list hkclobindlist) hkclobindlist) (foreach_pair_component_in_list (hkclobindlist) (curpairbndhc curbnd) (assert_msg "check curbnd" (is_a curbnd class_any_binding) curbnd) (if (== curbnd bind) (setq foundbind curbnd))) ;; append the new binding if not found (when (null foundbind) (list_append hkclobindlist bind) (debug "normexp_symbol recv=" recv "\n.. updated hkclobindlist=" hkclobindlist) ) )) (:else (debug "normexp_symbol unexpected pr=" pr "\n... of discrim: " (discrim pr)) (assert_msg "normexp_symbol unexpected closing procedure" () pr) ) ) ) ;end foreach in procs (return fxocc ()) ) ;; otherwise symbol is the direct value (progn ;; cache the result (mapobject_put sycmap recv bvar) (debug "normexp_symbol local value bvar=" bvar "\n.. updated sycmap=" sycmap "\n.. symbname=" symbname) (return bvar ()) ) ))) ;; ;; module variables ( (is_a bind class_normal_module_variable_binding) (debug "normexp_symbol variable binding bind=" bind) (let ( (nmodvar (instance class_nrep_modulevarocc :nmodvar_bind bind)) ) ;; cache the result (mapobject_put sycmap recv nmodvar) (debug "normexp_symbol module variable occurrence nmodvar=" nmodvar "\n.. updated sycmap=" sycmap) (return nmodvar ()) )) ;; ;; the procs is a non-empty list, so the symbol is closed ( (and (is_list procs) (is_pair (list_first procs))) (debug "normexp_symbol closed procs=" procs "\n.. bind=" bind) ;; check that a closed symbol is always a value (let ( (bty (cond ( (is_a bind class_formal_binding) (unsafe_get_field :fbind_type bind) ) ( (is_a bind class_let_binding) (unsafe_get_field :letbind_type bind)) (:else ()))) ) (if bty (if (!= bty ctype_value) (error_at psloc "closed variable $1 has non value ctype $2 (boxing required)" (unsafe_get_field :named_name recv) (get_field :named_name bty) ))) (setq bty ctype_value) (if (is_a bind class_fixed_binding) (let ( (fxocc (instance class_nrep_constocc :nrep_loc psloc :nocc_symb recv :nocc_bind bind :nocc_ctyp ctype_value :ncloc_procs procs)) ) ;; cache the result (mapobject_put sycmap recv fxocc) (debug "normexp_symbol fxocc=" fxocc " updated sycmap=" sycmap) ;; put the const occurrence if needed in the const list of each proc (foreach_pair_component_in_list (procs) (curpairproc curproc) (debug "normexp_symbol curproc=" curproc) (assert_msg "check curproc" (is_a curproc class_nrep_anyproc) curproc) (cond ( (is_a curproc class_nrep_routproc) (let ( (clcont (instance class_reference :referenced_value fxocc)) (cnstprocl (get_field :nrclop_constlist curproc)) ) (foreach_pair_component_in_list (cnstprocl) (curpairprocl cx) (when (== cx fxocc) (put_fields clcont :referenced_value ()) ())) (let ( (newcl (get_field :referenced_value clcont)) ) (when newcl (debug "normexp_symbol newcl=" newcl) (list_append cnstprocl newcl))) )) ( (is_a curproc class_nrep_hookproc) (debug "normexp_symbol curproc=" curproc "\n recv=" recv "\n bind=" bind "\n fxocc=" fxocc) (let ( (hkclobindlist (get_field :nrclop_clobindlist curproc)) (foundbind ()) ) (debug "normexp_symbol hkclobindlist=" hkclobindlist) (assert_msg "check hkclobindlist" (is_list hkclobindlist) hkclobindlist) (foreach_pair_component_in_list (hkclobindlist) (curpairbndhc curbnd) (assert_msg "check curbnd" (is_a curbnd class_any_binding) curbnd) (if (== curbnd bind) (setq foundbind curbnd))) (when (null foundbind) (list_append hkclobindlist bind) (debug "normexp_symbol updated hkclobindlist=" hkclobindlist)) )) ;; (:else (debug "normexp_symbol bad curproc=" curproc) (assert_msg "normexp_symbol unexpected curproc" () curproc) )) ) ;end foreach_pair_component_in_list (debug "normexp_symbol return fxocc=" fxocc) (return fxocc ()) ) ;; else bind is not a class_fixed_binding (let ( (clocc (instance class_nrep_closedocc :nrep_loc psloc :nocc_symb recv :nocc_ctyp ctype_value :nocc_bind bind :ncloc_procs procs)) ) ;; cache the result (mapobject_put sycmap recv clocc) (debug "normexp_symbol updated sycmap=" sycmap " clocc=" clocc) ;; put the closed occurrence if needed in the closed list of each proc (foreach_pair_component_in_list (procs) (curpair curproc) (assert_msg "check curproc" (is_a curproc class_nrep_anyproc) curproc) (let ( (clcont (instance class_reference :referenced_value clocc)) (clobindl (get_field :nrclop_clobindlist curproc)) ) (foreach_pair_component_in_list (clobindl) (curbndpair clbnd) (when (== clbnd bind) (put_fields clcont :referenced_value ()))) (let ( (newcl (get_field :referenced_value clcont)) ) (if newcl (list_append clobindl bind))) )) (return clocc ()) )))) ;; ;; dispatch the binding (:else (debug "normexp_symbol before normalize_binding bind=" bind " for recv=" recv " psloc=" psloc) (let ( (resnormbind (normalize_binding bind env ncx procs psloc)) ) (debug "normexp_symbol after normalize_binding resnormbind=" resnormbind " for bind=" bind " recv=" recv " psloc=" psloc) (return resnormbind ()) ))))))) (install_method class_symbol normal_exp normexp_symbol) ;;; (defun gectyp_symocc (recv env) (assert_msg "check recv" (is_a recv class_nrep_symocc) recv) (unsafe_get_field :nocc_ctyp recv) ) (install_method class_nrep_symocc get_ctype gectyp_symocc) ;;; (defun gectyp_modvarocc (recv env) (assert_msg "check recv" (is_a recv class_nrep_modulevarocc) recv) (return ctype_value) ) (install_method class_nrep_modulevarocc get_ctype gectyp_modvarocc) ;;; normalize a class - used in particular in normalization of get_field ;; this does not work well when the class's name is locally rebound, ;; which rarely happens in practice (defun normexp_class (recv env ncx psloc) (debug "normexp_class recv" recv) (assert_msg "check recv" (is_a recv class_class) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check nctxt" (is_a ncx class_normalization_context) ncx) (let ( (clasymb (get_symbolstr (unsafe_get_field :named_name recv))) (clabind (find_env env clasymb)) ) (debug "normexp_class clabind" clabind) (cond ( (is_a clabind class_class_binding) (let ( (normcla (normexp_symbol clasymb env ncx psloc)) ) (debug "normexp_class normcla class data inst" normcla) (assert_msg "check normcla" (or (is_a normcla class_nrep_datainstance) (is_a normcla class_nrep_constocc) ) normcla ) (return normcla) )) ( (is_a clabind class_value_binding) (assert_msg "check clabind value" (== recv (unsafe_get_field :vbind_value clabind)) clabind recv) (let ( (normcla (normexp_symbol clasymb env ncx psloc)) ) (debug "normexp_class normcla class value" normcla) ;; normcla can be a class_nrep_constocc or a class_nrep_importedval ... (assert_msg "check normcla" (is_a normcla class_nrep) normcla) (return normcla) )) (:else ;; this could happen if the class's name has been locally ;; rebound, But we don't really handle that. We might scan ;; the environment stack to find the real class binding and ;; normalize accordingly, but this won't happen often... (error_at psloc "class $1 incorrectly bound, perhaps locally rebound"_ (unsafe_get_field :named_name recv)) (debug "normexp_class failed") (return) )) )) (install_method class_class normal_exp normexp_class) ;;;;;;;;;;;;;;;; ;;; normalize a primitive invocation (defun normexp_primitive (recv env ncx psloc) (debug "normexp_primitive recv" recv) (assert_msg "check prim recv" (is_a recv class_source_primitive) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check nctxt" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (soper (unsafe_get_field :sprim_oper recv)) (sargs (unsafe_get_field :sargop_args recv)) ) (assert_msg "check soper" (is_a soper class_primitive) soper) (multicall (nargs nbind) (normalize_tuple sargs env ncx sloc) (let ( (sopnamstr (unsafe_get_field :named_name soper)) (sopformals (unsafe_get_field :prim_formals soper)) (soptype (unsafe_get_field :prim_type soper)) (sopexp (unsafe_get_field :prim_expansion soper)) (:long nbarg (multiple_length nargs)) (:long nbexp (multiple_length sopexp)) ) (assert_msg "check soptype" (is_a soptype class_ctype) soptype) (when (!=i nbarg (multiple_length sopformals)) (error_at sloc "length mismatch between formals & actuals in primitive $1, got $2 arguments for $3 formals"_ sopnamstr nbarg (multiple_length sopformals)) (return ())) (let ( (bmap (make_mapobject discr_map_objects (+i 5 (/iraw (*i 3 nbarg) 2)))) (expargs (make_multiple discr_multiple nbexp)) ) (foreach_in_multiple (sopformals) (forb :long ix) (assert_msg "check forb" (is_a forb class_formal_binding) forb) (debug "normexp_primitive forb" forb) (let ( (forarg (unsafe_get_field :binder forb)) (actarg (multiple_nth nargs ix)) (fortype (unsafe_get_field :fbind_type forb)) (actype (get_ctype actarg env)) ) (debug "normexp_primitive actarg=" actarg " actype=" actype) (when (and (is_a fortype class_ctype) (is_a actype class_ctype) (!= fortype actype)) (error_at sloc "type mismatch between formal $1 of ctype $2 and argument #$3 of ctype $4 in primitive $5"_ forarg (get_field :named_name fortype) ix (get_field :named_name actype) sopnamstr) ) (mapobject_put bmap forarg actarg) )) (debug "normexp_primitive bmap in sopexp" bmap) (foreach_in_multiple (sopexp) (excu :long jx) (let ( (exval (if (is_a excu class_symbol) (let ( (bval (mapobject_get bmap excu)) ) (if (null bval) (progn ;; we could perhaps handle symbols which are not primitive arguments ;; as some kind of closed constants, but this is rarely needed and ;; requires a lot of work: the excu should then be the constant ;; itself, and code should be generated to fill the primitive with ;; non-symbol values. (debug "normexp_primitive recv unexpected symbol in expansion recv=" recv "excu=" excu) (error_at sloc "unexpected symbol $1 in primitive $2 expansion"_ (unsafe_get_field :named_name excu) sopnamstr) )) bval) excu)) ) (if (null exval) (progn (warning_strv sloc "null expansion of primitive argument for" sopnamstr) (if (is_a excu class_named) (warning_strv sloc "null primitive original piece is" (unsafe_get_field :named_name excu))) )) (multiple_put_nth expargs jx exval)) ) (debug "normexp_primitive soper" soper) (assert_msg "check soper is named" (is_a soper class_named) soper) (let ( (csym (clone_symbol soper)) (nchunk (instance class_nrep_chunk :nrep_loc sloc :nchunk_expansion expargs :nchunk_oper soper :nexpr_ctyp soptype )) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type soptype :letbind_expr nchunk )) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp soptype :nocc_symb csym :nocc_bind cbind)) ) (debug "normexp_primitive nchunk=" nchunk) (if (is_list nbind) (list_append nbind cbind) (progn (setq nbind (make_list discr_list)) (list_append nbind cbind) )) (debug "normexp_primitive result clocc" clocc) (return clocc nbind ))))))) (install_method class_source_primitive normal_exp normexp_primitive) ;;;;;;;;;;;;;;;; ;;; normalize a hook call (defun normexp_hook_call (recv env ncx psloc) (debug "normexp_hook_call recv=" recv) (shortbacktrace_dbg "normexp_hook_call" 15) (assert_msg "check recv" (is_a recv class_source_hook_call) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check nctxt" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (shook (unsafe_get_field :shook_called recv)) (sargs (unsafe_get_field :sargop_args recv)) (hkname ()) (hksymb ()) (hkins ()) (hkouts ()) (hkctype ()) (hkdescr ()) (:long errorflag 0) (newenv (fresh_env env)) ) (debug "normexp_hook_call shook=" shook " sargs=" sargs) (match shook (?(instance class_source_defhook :sdef_name ?shksymb :sformal_args ?shkins :shook_ctype ?shctype :shook_out_formals ?shkouts) (setq hksymb shksymb) (assert_msg "check hksymb" (is_a hksymb class_symbol) hksymb) (setq hkname (get_field :named_name shksymb)) (setq hkins shkins) (setq hkouts shkouts) (setq hkctype shctype) (debug "normexp_hook_call sourcedefhook hkname=" hkname "\n hkins=" hkins "\n hkouts=" hkouts) ) (?(some_hook_with_data ?(and ?dhkdescr ?(instance class_hook_descriptor :named_name ?dhkname :hookdesc_in_formals ?dhkins :hookdesc_out_formals ?dhkouts :hookdesc_ctype ?dhkctype))) (assert_msg "check dhkname" (is_string dhkname) dhkname) (setq hksymb (get_symbolstr dhkname)) (setq hkname dhkname) (setq hkdescr dhkdescr) (setq hkins dhkins) (setq hkouts dhkouts) (setq hkctype dhkctype) (debug "normexp_hook_call valuehook hkname=" hkname "\n.. hkins=" hkins "\n.. hkouts=" hkouts "\n.. hkctype=" hkctype) ) (?_ (error_at sloc "invalid hook call") (setq errorflag 1) (assert_msg "@$@unexpected hook, unimplemented" () shook) )) (assert_msg "check hkname" (is_string hkname) hkname) (assert_msg "check hkins" (is_multiple hkins) hkins) (assert_msg "check hkouts" (is_multiple hkouts) hkouts) (assert_msg "check hkctype" (is_a hkctype class_ctype) hkctype) (debug "normexp_hook_call hkname=" hkname " hksymb=" hksymb "\n.. hkins=" hkins "\n.. hkouts=" hkouts "\n.. hkctype=" hkctype) (assert_msg "check hkctype" (is_a hkctype class_ctype) hkctype) (let ( (:long nbins (multiple_length hkins)) (:long nbouts (multiple_length hkouts)) (hnamestr (get_field :named_name hkname)) (sins (make_multiple discr_multiple nbins)) (souts (make_multiple discr_multiple nbouts)) (nouts (make_multiple discr_multiple nbouts)) (hkbind (find_env env hksymb)) ) (debug "normexp_hook_call hkbind=" hkbind "\n hksymb=" hksymb) (assert_msg "check hkbind" (is_object hkbind) hkbind) (when (!=i (multiple_length sargs) (+i nbins nbouts)) (error_at sloc "invalid operand arity $1 for hook call '$2' wanting #$3 inputs and #$4 outputs"_ (multiple_length sargs) hnamestr nbins nbouts) (return () ())) ;; extract and normalize the inputs (foreach_long_upto (0 (-i nbins 1)) (:long inix) (multiple_put_nth sins inix (multiple_nth sargs inix)) ) (debug "normexp_hook_call sins=" sins) (multicall (ninargs ninbinds) (normalize_tuple sins env ncx sloc) (debug "normexp_hook_call ninargs=" ninargs " ninbinds=" ninbinds) (if (null ninbinds) (setq ninbinds (make_list discr_list))) (foreach_pair_component_in_list (ninbinds) (curpair curinbind) (put_env newenv curinbind) ) ;; check type compatibility of inputs (foreach_in_multiple (ninargs) (curinarg :long inix) (let ( (curinbind (multiple_nth hkins inix)) (inbctyp (get_field :fbind_type curinbind)) (inbinder (get_field :binder curinbind)) (curinctyp (get_ctype curinarg newenv)) ) (debug "normexp_hook_call curinbind=" curinbind "\n curinarg=" curinarg "\n inix#" inix "\n inbctyp=" inbctyp "\n curinctyp=" curinctyp) (assert_msg "check inbctyp" (is_a inbctyp class_ctype) inbctyp) (assert_msg "check curinctyp" (is_a curinctyp class_ctype) curinctyp) (when (!= inbctyp curinctyp) (error_at sloc "type mismatch between input formal $1 of ctype $2 & argument #$3 of ctype $4 in hook call $5" (get_field :named_name inbinder) (get_field :named_name inbctyp) inix (get_field :named_name curinctyp) hnamestr) (setq errorflag 1) ) )) (debug "normexp_hook_call errorflag=" errorflag " after checking ninargs=" ninargs) ;; ;; extract and normalize the outputs (foreach_long_upto (0 (-i nbouts 1)) (:long outix) (let ( (curoutarg (multiple_nth sargs (+i outix nbins))) (curoutbind (multiple_nth hkouts outix)) (outbctyp (get_field :fbind_type curoutbind)) (outbinder (get_field :binder curoutbind)) ) (debug "normexp_hook_call curoutarg=" curoutarg "\n curoutbind=" curoutbind "\n outix#" outix) (multiple_put_nth souts outix curoutarg) (cond ( (is_a curoutarg class_symbol) (let ( (noutvar (normexp_symbol curoutarg env ncx sloc)) (varoutctyp (get_ctype noutvar env)) ) (debug "normexp_hook_call noutvar=" noutvar " varoutctyp=" varoutctyp) (when (is_not_a noutvar class_nrep_locsymocc) (error_at sloc "invalid output variable $1 for hook $2"_ (get_field :named_name curoutarg) hnamestr) (setq errorflag 1)) (assert_msg "check varoutctyp" (is_a varoutctyp class_ctype) varoutctyp) (when (!= varoutctyp outbctyp) (error_at sloc "incompatible output formal $1 ctype $2 expecting $3 for hook $4"_ (get_field :named_name outbinder) (get_field :named_name varoutctyp) (get_field :named_name outbctyp) hnamestr) (setq errorflag 1) ) (multiple_put_nth nouts outix noutvar) )) (:else (error_at sloc "hook output argument is not a symbol for formal output $1 of hook $2" (unsafe_get_field :named_name outbinder) hnamestr) (setq errorflag 1) )) )) (debug "normexp_hook_call errorflag=" errorflag " souts=" souts " nouts=" nouts) (if errorflag (return () ())) ;; (debug "normexp_hook_call hksymb=" hksymb "\n hkbind=" hkbind) (let ( (nhook (normexp_symbol hksymb env ncx sloc)) (nhkcall (instance class_nrep_hook_call :nrep_loc sloc :nexpr_ctyp hkctype :nhook_name hkname :nhook_called nhook :nexpr_args ninargs :nhook_outs nouts :nhook_descr hkdescr )) ) (debug "normexp_hook_call nhkcall=" nhkcall "\n.. nhook=" nhook "\n.. hksymb=" hksymb "\n .. hkdescr=" hkdescr) (let ( (csym (clone_symbol hksymb)) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type hkctype :letbind_expr nhkcall )) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp hkctype :nocc_symb csym :nocc_bind cbind)) ) (debug "normexp_hook_call cbind=" cbind " clocc=" clocc) (list_append ninbinds cbind) (debug "normexp_hook_call result clocc=" clocc " ninbinds=" ninbinds) (return clocc ninbinds) )))))) (install_method class_source_hook_call normal_exp normexp_hook_call) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; normalize boxes ;;; mutable boxes (defun normexp_box (recv env ncx psloc) (debug "normexp_box recv" recv) (assert_msg "check box recv" (is_a recv class_source_box) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (sboxed (get_field :sboxed recv)) ) (multicall (nboxed nbind) (normal_exp sboxed env ncx sloc) (debug "normexp_box nboxed=" nboxed " nbind=" nbind) (when (not (is_list nbind)) (setq nbind (list)) (debug "normexp_box set nbind=" nbind)) (let ( (nctyp (get_ctype nboxed env)) (autoboxdiscr (get_field :ctype_autoboxdiscr nctyp)) ) (assert_msg "normexp_box check nctyp" (is_a nctyp class_ctype) nctyp) (debug "normexp_box nctyp=" nctyp " autoboxdiscr=" autoboxdiscr) (when (is_not_a autoboxdiscr class_discriminant) (error_at sloc "non-BOX-able stuff of ctype $1" (get_field :named_name nctyp)) (return)) (let ( (boxer (cond ( (== nctyp ctype_value) (setq autoboxdiscr ()) '"/*boxvalue*/ meltgc_new_reference" ) ( (is_a nctyp class_ctype_plain) (let ( (boxing (get_field :ctypp_boxing nctyp)) ) boxing )) ( (is_a nctyp class_ctype_gty) (let ( (boxfun (get_field :ctypg_boxfun nctyp)) ) boxfun )) (:else (error_at sloc "unexpected ctype $1 for BOX" (get_field :named_name nctyp)))) ) ) (debug "normexp_box boxer=" boxer) (let ( (csym (clone_symbol 'box)) (nchunk (instance class_nrep_chunk :nrep_loc sloc :nchunk_oper 'box :nexpr_ctyp ctype_value :nchunk_expansion (if autoboxdiscr (let ( (predefdiscr (normal_predef autoboxdiscr ncx sloc "autoboxing discriminant")) ) (tuple (clone_with_discriminant '"/*full boxing*/ " discr_verbatim_string) (clone_with_discriminant boxer discr_verbatim_string) (clone_with_discriminant '"((meltobject_ptr_t) (" discr_verbatim_string) predefdiscr (clone_with_discriminant '"), (" discr_verbatim_string) nboxed (clone_with_discriminant '"))" discr_verbatim_string) )) (tuple (clone_with_discriminant '"/*short boxing*/ " discr_verbatim_string) (clone_with_discriminant boxer discr_verbatim_string) (clone_with_discriminant '"(" discr_verbatim_string) nboxed (clone_with_discriminant '")" discr_verbatim_string) ) ))) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type ctype_value :letbind_expr nchunk )) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_value :nocc_symb csym :nocc_bind cbind)) ) (debug "normexp_box nchunk=" nchunk " clocc=" clocc) (list_append nbind cbind) (debug "normexp_box return clocc=" clocc " nbind=" nbind) (return clocc nbind) )))))) (install_method class_source_box normal_exp normexp_box) ;;; constant boxes (defun normexp_constbox (recv env ncx psloc) (debug "normexp_box recv" recv) (assert_msg "check box recv" (is_a recv class_source_constant_box) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (sboxed (get_field :sboxed recv)) ) (multicall (nboxed nbind) (normal_exp sboxed env ncx sloc) (debug "normexp_constbox nboxed=" nboxed " nbind=" nbind) (when (not (is_list nbind)) (setq nbind (list)) (debug "normexp_constbox set nbind=" nbind)) (let ( (nctyp (get_ctype nboxed env)) (autoboxdiscr (get_field :ctype_autoconstboxdiscr nctyp)) ) (assert_msg "normexp_constbox check nctyp" (is_a nctyp class_ctype) nctyp) (debug "normexp_constbox nctyp=" nctyp " autoboxdiscr=" autoboxdiscr) (when (is_not_a autoboxdiscr class_discriminant) (error_at sloc "non-CONSTANT_BOX-able stuff of ctype $1" (get_field :named_name nctyp)) (return)) (let ( (boxer (cond ( (is_a nctyp class_ctype_plain) (let ( (boxing (get_field :ctypp_boxing nctyp)) ) boxing )) ( (is_a nctyp class_ctype_gty) (let ( (boxfun (get_field :ctypg_boxfun nctyp)) ) boxfun )) (:else (error_at sloc "unexpected ctype $1 for BOX"_ (get_field :named_name nctyp)))) ) ) (debug "normexp_box boxer=" boxer) (let ( (csym (clone_symbol 'box)) (nchunk (instance class_nrep_chunk :nrep_loc sloc :nchunk_oper 'box :nexpr_ctyp ctype_value :nchunk_expansion (if autoboxdiscr (let ( (predefdiscr (normal_predef autoboxdiscr ncx sloc "autoconstboxing discriminant")) ) (tuple (clone_with_discriminant '"/*full constboxing*/ " discr_verbatim_string) (clone_with_discriminant boxer discr_verbatim_string) (clone_with_discriminant '"((meltobject_ptr_t) (" discr_verbatim_string) predefdiscr (clone_with_discriminant '"), (" discr_verbatim_string) nboxed (clone_with_discriminant '"))" discr_verbatim_string) )) (tuple (clone_with_discriminant '"/*short constboxing*/ " discr_verbatim_string) (clone_with_discriminant boxer discr_verbatim_string) (clone_with_discriminant '"(" discr_verbatim_string) nboxed (clone_with_discriminant '")" discr_verbatim_string) ) ))) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type ctype_value :letbind_expr nchunk )) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_value :nocc_symb csym :nocc_bind cbind)) ) (debug "normexp_constbox nchunk=" nchunk " clocc=" clocc) (list_append nbind cbind) (debug "normexp_constbox return clocc=" clocc " nbind=" nbind) (return clocc nbind) )))))) (install_method class_source_constant_box normal_exp normexp_constbox) ;;; unboxing (defun normexp_unbox (recv env ncx psloc) (debug "normexp_unbox recv" recv) (assert_msg "check unbox recv" (is_a recv class_source_unbox) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (sexp (get_field :sunbox_expr recv)) (ctyp (get_field :sunbox_ctype recv)) (cname (get_field :ctype_cname ctyp)) ) (debug "normexp_unbox ctyp=" ctyp) (assert_msg "check ctyp" (is_a ctyp class_ctype) ctyp) (let ( (unboxer (cond ( (is_a ctyp class_ctype_plain) (get_field :ctypp_unboxing ctyp)) ( (is_a ctyp class_ctype_gty) (get_field :ctypg_unboxfun ctyp)) (:else (error_at sloc "unexpected ctype $1 for UNBOX" (get_field :named_name ctyp)) (return)))) ) (debug "normexp_unbox unboxer=" unboxer " cname=" cname) (multicall (nexp nbind) (normal_exp sexp env ncx sloc) (debug "normexp_unbox nexp=" nexp " nbind=" nbind) (when (not (is_list nbind)) (setq nbind (list)) (debug "normexp_unbox set nbind=" nbind)) (let ( (csym (clone_symbol 'unbox)) (nchunk (instance class_nrep_chunk :nrep_loc sloc :nchunk_oper 'unbox :nexpr_ctyp ctyp :nchunk_expansion (tuple (clone_with_discriminant '"/*unboxing*/ " discr_verbatim_string) (clone_with_discriminant unboxer discr_verbatim_string) (clone_with_discriminant '" ((melt_ptr_t)" discr_verbatim_string) nexp (clone_with_discriminant '")" discr_verbatim_string) ))) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type ctyp :letbind_expr nchunk )) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctyp :nocc_symb csym :nocc_bind cbind)) ) (debug "normexp_unbox nchunk=" nchunk " clocc=" clocc) (list_append nbind cbind) (debug "normexp_unbox return clocc=" clocc " nbind=" nbind) (return clocc nbind) ))))) (install_method class_source_unbox normal_exp normexp_unbox) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; normalize a code_chunk (defun normexp_code_chunk (recv env ncx psloc) (debug "normexp_code_chunk recv=" recv) (assert_msg "check code_chunk recv" (is_a recv class_source_codechunk) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check nctxt" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (schk (unsafe_get_field :sch_chunks recv)) (gsym (unsafe_get_field :sch_gensym recv)) (csym (clone_symbol gsym)) (bindlist (make_list discr_list)) (newenv (fresh_env env)) (csymstr (let ( (sbuf (make_strbuf discr_strbuf)) ) (add2sbuf_cident sbuf (get_field :named_name csym)) (add2sbuf_strconst sbuf "__") (add2sbuf_longdec sbuf (get_int (get_field :csym_urank csym))) (strbuf2string discr_verbatim_string sbuf) )) (magicbind (let ( (mb (instance class_normal_magic_binding :binder gsym :nmagic_value csymstr)) ) (put_env newenv mb) (debug "normexp_code_chunk magicbind=" mb) mb)) (nchk (let ( (nc (multiple_map schk (lambda (curcomp :long curix) (cond ( (is_string curcomp) (clone_with_discriminant curcomp discr_verbatim_string)) ( (is_a curcomp class_symbol) (normal_exp curcomp newenv ncx sloc)) (:else (debug "normexp_code_chunk curcomp=" curcomp " curix#" curix) (multicall (nexp nbind) (normal_exp curcomp newenv ncx sloc) (debug "normexp_code_chunk nexp=" nexp "\n.. nbind=" nbind) (assert_msg "check nbind" (is_list_or_null nbind) nbind) (let ( (compctyp (get_ctype nexp newenv)) (cloc (or (get_field :loca_location curcomp) sloc)) ) (debug "normexp_code_chunk compctyp=" compctyp) (when (!= compctyp ctype_void) (error_at cloc "composite CODE_CHUNK element should be :void, got $1" (get_field :named_name compctyp)) (return ()) ) (let ( (wl (wrap_normal_let1 nexp nbind sloc)) ) (debug "normexp_code_chunk wl=" wl " curix#" curix) wl))))))))) (debug "normexp_code_chunk nchk=" nc) nc)) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type ctype_void :letbind_expr (instance class_nrep_chunk :nrep_loc sloc :nchunk_expansion nchk :nchunk_oper csym :nexpr_ctyp ctype_void ))) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_void :nocc_symb csym :nocc_bind cbind)) ) (debug "normexp_code_chunk schk=" schk "\n.. nchk=" nchk) (debug "normexp_code_chunk clocc=" clocc) (assert_msg "check nchk" (is_multiple nchk) nchk) (debug "normexp_code_chunk return clocc=" clocc " cbind=" cbind) (return clocc (list cbind)) )) (install_method class_source_codechunk normal_exp normexp_code_chunk) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; normalize an expr_chunk (defun normexp_expr_chunk (recv env ncx psloc) (debug "normexp_expr_chunk recv=" recv) (assert_msg "check expr_chunk recv" (is_a recv class_source_exprchunk) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (schk (unsafe_get_field :sch_chunks recv)) (gsym (unsafe_get_field :sch_gensym recv)) (ctyp (unsafe_get_field :sxch_ctype recv)) (csym (clone_symbol gsym)) (bindlist (make_list discr_list)) (newenv (fresh_env env)) (csymstr (let ( (sbuf (make_strbuf discr_strbuf)) ) (add2sbuf_cident sbuf (get_field :named_name csym)) (add2sbuf_strconst sbuf "__") (add2sbuf_longdec sbuf (get_int (get_field :csym_urank csym))) (strbuf2string discr_verbatim_string sbuf) )) (magicbind (let ( (mb (instance class_normal_magic_binding :binder gsym :nmagic_value csymstr)) ) (put_env newenv mb) (debug "normexp_expr_chunk magicbind=" mb) mb)) (listbinds (make_list discr_list)) (listnchunks (make_list discr_list)) (nchk (make_multiple discr_multiple (multiple_length schk))) ) (debug "normexp_expr_chunk ctyp=" ctyp "\n schk=" schk) (assert_msg "check schk" (is_multiple schk) schk) (assert_msg "check ctyp" (is_a ctyp class_ctype) ctyp) (foreach_in_multiple (schk) (srcomp :long six) (debug "normexp_expr_chunk six#" six " srcomp=" srcomp) (cond ( (is_a srcomp class_source) (multicall (ncomp ncbind) (normal_exp srcomp newenv ncx sloc) (debug "normexp_expr_chunk six#" six " ncomp=" ncomp "\n.. ncbind=" ncbind) (assert_msg "check ncbind" (is_list_or_null ncbind) ncbind) (if ncbind (list_append2list listbinds ncbind)) (if (is_list ncomp) (list_append2list listnchunks ncomp) (list_append listnchunks ncomp)) )) ( (is_a srcomp class_symbol) (multicall (nsymb nsbind) (normal_exp srcomp newenv ncx sloc) (debug "normexp_expr_chunk nsymb=" nsymb " nsbind=" nsbind) (assert_msg "nsbind null" (null nsbind) nsbind) (list_append listnchunks nsymb) )) ( (is_string srcomp) (list_append listnchunks (make_string discr_verbatim_string srcomp)) ) (:else (list_append listnchunks srcomp) )) (debug "normexp_expr_chunk six#" six "\n updated listbinds=" listbinds "\n updated listnchunks=" listnchunks) ) ;; end foreach_in_multiple (let ( (tupnchunk (list_to_multiple listnchunks discr_multiple)) (nchunk (instance class_nrep_chunk :nrep_loc sloc :nchunk_expansion tupnchunk :nchunk_oper csym :nexpr_ctyp ctyp)) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type ctyp :letbind_expr nchunk)) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctyp :nocc_symb csym :nocc_bind cbind)) ) (list_append listbinds cbind) (debug "normexp_expr_chunk with nchunk=" nchunk " gives clocc=" clocc " listbinds=" listbinds) (return clocc listbinds) ))) (install_method class_source_exprchunk normal_exp normexp_expr_chunk) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; normalize a cmatchexpr (defun normexp_cmatchexpr (recv env ncx psloc) (debug "normexp_cmatchexpr recv" recv) (assert_msg "check recv" (is_a recv class_source_cmatchexpr) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (scmat (unsafe_get_field :scmatx_cmatcher recv)) (sargs (unsafe_get_field :sargop_args recv)) ) (assert_msg "check scmat" (is_a scmat class_cmatcher) scmat) (multicall (nargs nbind) (normalize_tuple sargs env ncx sloc) (let ( (cmanamstr (unsafe_get_field :named_name scmat)) ;; the outformals are really the "input" arguments for cmatchexpr (oformals (unsafe_get_field :amatch_out scmat)) ;; the matchbind gives the result of the cmatchexpr (mabind (let ( (mb (unsafe_get_field :amatch_matchbind scmat)) ) (assert_msg "check mabind" (is_a mb class_formal_binding) mb) mb)) ;; the type of the cmatchexpr (otype (unsafe_get_field :fbind_type mabind)) (sopexp (unsafe_get_field :cmatch_expoper scmat)) (:long nbarg (multiple_length nargs)) (:long nbexp (multiple_length sopexp)) ) (assert_msg "check otype" (is_a otype class_ctype) otype) (if (!=i nbarg (multiple_length oformals)) (progn (error_at sloc "length mismatch between formals & actuals in cmatch $1 expr" cmanamstr) (return)) ) (let ( (bmap (make_mapobject discr_map_objects (+i 5 (/iraw (*i 3 nbarg) 2)))) (expargs (make_multiple discr_multiple nbexp)) ) (multiple_every oformals (lambda (forb :long ix) (assert_msg "check forb" (is_a forb class_formal_binding) forb) (debug "normexp_cmatchexpr forb" forb) (let ( (forarg (unsafe_get_field :binder forb)) (actarg (multiple_nth nargs ix)) (fortype (unsafe_get_field :fbind_type forb)) (actype (get_ctype actarg env)) ) (debug "normexp_cmatchexpr actarg=" actarg " actype=" actype) (if (and (is_a fortype class_ctype) (is_a actype class_ctype) (!= fortype actype)) (progn (error_at sloc "type mismatch between formals & actuals in cmatch $1 operator formal $2 actual ctype $3 expected ctype $4"_ cmanamstr (unsafe_get_field :named_name forarg) (unsafe_get_field :named_name actype) (unsafe_get_field :named_name fortype)) )) (mapobject_put bmap forarg actarg) ))) (debug "normexp_cmatchexpr bmap in sopexp" bmap) (multiple_every sopexp (lambda (excu :long jx) ;;(debug "normexp_cmatchexpr excu in sopexp" excu) (let ( (exval (if (is_a excu class_symbol) (let ( (bval (mapobject_get bmap excu)) ) (if (null bval) (progn ;; we could perhaps handle symbols which are not primitive arguments ;; as some kind of closed constants, but this is rarely needed and ;; requires a lot of work: the excu should then be the constant ;; itself, and code should be generated to fill the primitive with ;; non-symbol values. (debug "normexp_cmatchexpr unexpected symbol in expansion recv=" recv " excu=" excu) (error_at sloc "unexpected symbol in cmatch expression expansion $1 for $2"_ (unsafe_get_field :named_name excu) cmanamstr) )) bval) excu)) ) (if (null exval) (progn (warning_strv sloc "null expansion of cmatch expression argument for" cmanamstr) (if (is_a excu class_named) (warning_strv sloc "null cmatch expression original piece is" (unsafe_get_field :named_name excu))) )) ;(debug "normexp_cmatchexpr exval in sopexp" exval) (multiple_put_nth expargs jx exval)) )) (let ( (csym (clone_symbol cmanamstr)) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type otype :letbind_expr (instance class_nrep_chunk :nrep_loc sloc :nchunk_expansion expargs :nchunk_oper scmat :nexpr_ctyp otype ))) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp otype :nocc_symb csym :nocc_bind cbind)) ) (if (is_list nbind) (list_append nbind cbind) (progn (setq nbind (make_list discr_list)) (list_append nbind cbind) )) (debug "normexp_cmatchexpr result clocc" clocc) (return clocc nbind ))))))) (install_method class_source_cmatchexpr normal_exp normexp_cmatchexpr) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; normalize a funmatchexpr (defun normexp_funmatchexpr (recv env ncx psloc) (debug "normexp_funmatchexpr recv" recv) (assert_msg "check recv" (is_a recv class_source_funmatchexpr) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (sfmat (unsafe_get_field :sfmatx_fmatcher recv)) (sfbind (unsafe_get_field :sfmatx_fmatbind recv)) (sargs (unsafe_get_field :sargop_args recv)) (nbind (make_list discr_list)) ) (assert_msg "check sfmat" (is_a sfmat class_funmatcher) sfmat) (assert_msg "check sfbind" (is_a sfbind class_any_binding) sfbind) (debug "normexp_funmatchexpr sfbind" sfbind) (let ( (fmatsym (unsafe_get_field :binder sfbind)) ) (assert_msg "check fmatsym" (is_a fmatsym class_symbol) fmatsym) (assert_msg "check good sfbind" (== sfbind (find_env env fmatsym)) sfbind fmatsym) (let ( (nfmat (normal_exp fmatsym env ncx psloc)) ) (debug "normexp_funmatchexpr nfmat" nfmat) ;; should create a normlet binding to hold the nfmat's ;; fmatch_applyf field (let ( (csym (clone_symbol fmatsym)) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type ctype_value :letbind_expr (instance class_nrep_unsafe_get_field :nrep_loc sloc :nuget_obj nfmat :nuget_field fmatch_applyf) )) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_value :nocc_symb csym :nocc_bind cbind)) ) (list_append nbind cbind) (multicall (nargs nargbind) (normalize_tuple sargs env ncx sloc) (debug "normexp_funmatchexpr nargs=" nargs " nargbind=" nargbind) (list_append2list nbind nargbind) (let ( (asym (clone_symbol fmatsym)) (abind (instance class_normal_let_binding :letbind_loc sloc :binder asym :letbind_type ctype_value :letbind_expr (instance class_nrep_apply :nexpr_ctyp ctype_value :nrep_loc sloc :napp_fun clocc :nexpr_args nargs ))) (calocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_value :nocc_symb asym :nocc_bind abind )) ) (list_append nbind abind) (debug "normexp_funmatchexpr final calocc=" calocc " nbind=" nbind) (return calocc nbind) ))))))) (install_method class_source_funmatchexpr normal_exp normexp_funmatchexpr) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; normalize an application (defun normexp_apply (recv env ncx psloc) (debug "normexp_apply recv=" recv "\n env=" env) (assert_msg "check apply recv" (is_a recv class_source_apply) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (sfun (unsafe_get_field :sapp_fun recv)) (sargs (unsafe_get_field :sargop_args recv)) (sfusymb (if (is_a sfun class_symbol) sfun '_fun_)) ) (debug "normexp_apply sloc=" sloc "; sfun=" sfun) (multicall (nfun nbindfun) (normal_exp sfun env ncx sloc) (debug "normexp_apply nfun=" nfun "\n nbindfun=" nbindfun) (assert_msg "check nbindfun" (is_list_or_null nbindfun) nbindfun) (let ( (nfunctyp (get_ctype nfun env)) ) (debug "normexp_apply nfunctyp" nfunctyp) (if (!= nfunctyp ctype_value) (progn (debug "normexp_apply bad nfun=" nfun " sfun=" sfun " nfunctyp=" nfunctyp " recv=" recv) (error_at sloc "applied function should be a value, but has bad ctype $1" (get_field :named_name nfunctyp)) (cond ( (is_string sfun) (error_at sloc "bad applied string '$1', not a function"_ sfun)) ( (is_a sfun class_named) (error_at sloc "bad applied function, named $1"_ (get_field :named_name sfun))) ( (is_a sfun class_located) (error_at (get_field :loca_location sfun) "here is the wrong applied function"))) ))) (debug "normexp_apply sloc=" sloc "; sargs=" sargs) (multicall (nargs nbindargs) (normalize_tuple sargs env ncx sloc) (assert_msg "check nbindargs" (is_list_or_null nbindargs) nbindargs) ;; if given the first argument should be a value (let ( (nargfirst (multiple_nth nargs 0)) ) (debug "normexp_apply nargfirst" nargfirst) (if nargfirst (let ( (nargfirstctype (get_ctype nargfirst env)) ) (debug "normexp_apply nargfirstctype" nargfirstctype) (if (!= nargfirstctype ctype_value) (error_at sloc "first argument of function application should be a value not a $1" (get_field :named_name nargfirstctype)) )) )) ;; (check_ctype_nargs nargs env sloc) (setq nbindargs (list_append2list nbindargs nbindfun)) ;; add a void binding to check interrupts (let ( (cintsym (clone_symbol sfusymb)) (nchint (instance class_nrep_checksignal :nrep_loc sloc)) (cintbind (instance class_normal_let_binding :letbind_loc sloc :binder cintsym :letbind_type ctype_void :letbind_expr nchint)) ) (if (null nbindargs) (setq nbindargs (list cintbind)) (list_append nbindargs cintbind)) ) (assert_msg "check nbindargs" (is_list nbindargs) nbindargs) ;; (let ( (csym (clone_symbol sfusymb)) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type ctype_value :letbind_expr (instance class_nrep_apply :nrep_loc sloc :nexpr_ctyp ctype_value :napp_fun nfun :nexpr_args nargs ))) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_value :nocc_symb csym :nocc_bind cbind )) ) (list_append nbindargs cbind) (return clocc nbindargs) ))))) (install_method class_source_apply normal_exp normexp_apply) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; normalize a message send (defun normexp_msend (msnd env ncx psloc) (debug "normexp_msend msnd=" msnd) (assert_msg "check msnd" (is_a msnd class_source_msend) msnd) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (msrecv (unsafe_get_field :msend_recv msnd)) (msargs (unsafe_get_field :sargop_args msnd)) (selnam (unsafe_get_field :msend_selsymb msnd)) (curproc (unsafe_get_field :nctx_curproc ncx)) (sloc (unsafe_get_field :loca_location msnd)) (nsel (normexp_symbol selnam env ncx sloc)) (selbind (find_env env selnam)) ) (debug "normexp_msend curproc=" curproc " selbind=" selbind) ;;;; we should add the constant selector into the current routine's constant pool (multicall (nrecv nbindrecv) (normal_exp msrecv env ncx sloc) (assert_msg "check nbindrecv" (is_list_or_null nbindrecv) nbindrecv) ;; check that receiver is a value (let ( (ctypr (get_ctype nrecv env)) ) (assert_msg "normexp_msend check ctypr " (is_a ctypr class_ctype) ctypr) (if (!= ctypr ctype_value) (error_at sloc "non value receiver for message send of selector $1" (unsafe_get_field :named_name selnam))) ) (multicall (nargs nbindargs) (normalize_tuple msargs env ncx sloc) (assert_msg "check nbindargs" (is_list_or_null nbindargs) nbindargs) ;; add a void binding to check interrupts (let ( (cintsym (clone_symbol selnam)) (nint (instance class_nrep_checksignal :nrep_loc sloc)) (cintbind (instance class_normal_let_binding :letbind_loc sloc :binder cintsym :letbind_type ctype_void :letbind_expr nint)) ) (if (is_list nbindargs) (list_append nbindargs cintbind) (setq nbindargs (list cintbind))) ) ;; (setq nbindrecv (list_append2list nbindrecv nbindargs)) (check_ctype_nargs nargs env sloc) (let ( (selformals (cond ( (is_a selbind class_selector_binding) (get_field :sdefsel_formals (get_field :sbind_selectordef selbind) ) ) ( (is_a selbind class_value_binding) (let ( (valsel (get_field :vbind_value selbind)) ) (assert_msg "check valsel" (is_a valsel class_selector) valsel) (get_field :sel_signature valsel)) ) (:else (assert_msg "invalid selbind" () selbind) ()))) (csym (clone_symbol selnam)) (nsend (instance class_nrep_msend :nrep_loc sloc :nexpr_ctyp ctype_value :nsend_sel nsel :nsend_recv nrecv :nexpr_args nargs )) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type ctype_value :letbind_expr nsend)) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_value :nocc_symb csym :nocc_bind cbind)) ) (debug "normexp_msend nsend middle" nsend) (assert_msg "check nrecv" (is_object nrecv) nrecv) (if (is_multiple selformals) (let ( (recvformal (multiple_nth selformals 0)) (:long nbformals (multiple_length selformals)) ) (debug "normexp_msend" selformals) (assert_msg "check recvformal" (== (get_field :fbind_type recvformal) ctype_value) recvformal) (if (!=i nbformals (+i 1 (multiple_length nargs))) (error_at sloc "unexpected number of arguments for method $1 with $2 formals" (get_field :named_name selnam) nbformals) ) (foreach_in_multiple (nargs) (curnarg :long nix) (let ( (curformal (multiple_nth selformals (+i nix 1))) (curctyp (get_ctype curnarg env)) (formctyp (get_field :fbind_type curformal)) (formbinder (get_field :binder curformal)) ) (assert_msg "check curformal" (is_a curformal class_formal_binding) curformal) (if (!= curctyp formctyp) (progn (warning_strv sloc "c-type mismatch in method send argument" (get_field :named_name selnam)) (inform_strv sloc "mismatched method formal name" (get_field :named_name formbinder)) (inform_strv sloc "mismatched method actual type" (get_field :named_name curctyp)) (inform_strv sloc "mismatched method expected type" (get_field :named_name formctyp)) ) ) )))) (unsafe_put_fields clocc :nocc_bind cbind) (if (not (is_list nbindrecv)) (setq nbindrecv (make_list discr_list))) (list_append nbindrecv cbind) (debug "normexp_msend final nbindrecv=" nbindrecv " clocc=" clocc) (return clocc nbindrecv) ))))) (install_method class_source_msend normal_exp normexp_msend) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; normalize a return (defun normexp_return (recv env ncx psloc) (debug "normexp_return recv=" recv "\n ncx=" ncx) (assert_msg "check return recv" (is_a recv class_source_return) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (or (get_field :loca_location recv) psloc)) (srets (unsafe_get_field :sargop_args recv)) (:long nbrets (multiple_length srets)) (csym (clone_symbol 'return_)) (curproc (get_field :nctx_curproc ncx)) (restype (cond ( (is_a curproc class_nrep_routproc) ctype_value) ( (is_a curproc class_nrep_hookproc) (get_field :nrhook_ctype curproc)) ( :else (error_at sloc "RETURN outside of LAMBDA or DEFUN procedure or DEFHOOK") (return)))) ;; while the return effectively go out, it is preferable to give it a value type ;; to avoid make warning on code like (if (p x) (return) (.....)) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type restype ;; :letbind_expr is filled later )) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp restype :nocc_symb csym :nocc_bind cbind)) ) (debug "normexp_return srets=" srets " curproc=" curproc) ;; special case for empty return (if (<=i nbrets 0) (let ( (nbindemp (make_list discr_list)) (nemptret (instance class_nrep_return :nrep_loc sloc :nret_main () :nret_rest () )) ) (unsafe_put_fields cbind :letbind_expr nemptret) (list_append nbindemp cbind) (debug "normexp_return empty; return clocc=" clocc " nbindemp=" nbindemp) (return clocc nbindemp)) (multicall (nrets nbindrets) (normalize_tuple srets env ncx sloc) (debug "normexp_return nrets=" nrets " nbindrets=" nbindrets) (when (and (>i nbrets 1) (is_a curproc class_nrep_hookproc)) (error_at sloc "multiple RETURN not allowed inside hooks") (return)) (let ( (nret0 (multiple_nth nrets 0)) (toth (make_multiple discr_multiple (-i nbrets 1))) (ctyp0 (get_ctype nret0 env)) ) (when (and (!= ctyp0 ctype_value) (is_a curproc class_nrep_routproc)) (error_at sloc "primary RETURN-ed result from procedure is not a value") (return)) (when (is_a curproc class_nrep_hookproc) (when (>i nbrets 1) (error_at sloc "RETURN with secondary results impossible in a hook") (return)) (when (and nret0 ctyp0 (!= ctyp0 restype)) (error_at sloc "RETURN with incompatible type in hook expected type $1 gotten $2"_ (get_field :named_name restype) (get_field :named_name ctyp0)) (return)) ) (if (null nbindrets) (setq nbindrets (make_list discr_list))) ;; add a void binding to check interrupts (let ( (rintsymb (clone_symbol '_retint_)) (nchint (instance class_nrep_checksignal :nrep_loc sloc)) (rintbind (instance class_normal_let_binding :binder rintsymb :letbind_type ctype_void :letbind_expr nchint )) ) (list_append nbindrets rintbind) ) ;; (foreach_in_multiple (nrets) (ncomp :long ix) (let ( (nctyp (get_ctype ncomp env)) ) (assert_msg "check nctyp" (is_a nctyp class_ctype) nctyp) (unless (get_field :ctype_parchar nctyp) (error_at sloc "impossible secondary result type $1"_ (get_field :named_name nctyp))) ) (if (>i ix 0) (multiple_put_nth toth (-i ix 1) ncomp))) ;;; (let ( (nret (instance class_nrep_return :nrep_loc sloc :nret_main nret0 :nret_rest (if (>i nbrets 0) toth))) ) (unsafe_put_fields cbind :letbind_expr nret) (list_append nbindrets cbind) (debug "normexp_return result clocc=" clocc " nbindrets=" nbindrets) (return clocc nbindrets) )))))) (install_method class_source_return normal_exp normexp_return) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; normalize an if (defun normexp_if (recv env ncx psloc) (assert_msg "check if recv" (is_a recv class_source_if) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (debug "normexp_if recv" recv) (let ( (sloc (unsafe_get_field :loca_location recv)) (stest (unsafe_get_field :sif_test recv)) (ctypif ctype_void) (sthen (unsafe_get_field :sif_then recv)) (cintsymb (clone_symbol '_if_inter_)) (nchint (instance class_nrep_checksignal :nrep_loc sloc)) (cintbind (instance class_normal_let_binding :binder cintsymb :letbind_type ctype_void :letbind_expr nchint)) ) (multicall (ntest nbindif) ;nbindif is also the whole result binding (normal_exp stest env ncx sloc) (assert_msg "check nbindif test" (is_list_or_null nbindif) nbindif) (debug "normexp_if ntest=" ntest " cintbind=" cintbind) ;; prepend the check interrupt binding (if (null nbindif) (setq nbindif (list cintbind)) (list_prepend nbindif cintbind)) ;; ;; in practice we don't need to make a common super- ;; environment with nbindif since all relevant bindings there are ;; generated, with unique cloned symbols, and these bindings ;; are local to the test part (multicall (nthen nbindthen) (normal_exp sthen env ncx sloc) (debug "normexp_if nthen" nthen) (assert_msg "check nbindthen" (is_list_or_null nbindthen) nbindthen) (let ( (newthenenv (fresh_env env)) ) (list_every nbindthen (lambda (b) (put_env newthenenv b))) ;; the ctyp of the whole if is initialized to the ctype of the then part (setq ctypif (get_ctype nthen newthenenv)) ;; (let ( (csym (clone_symbol '_if_)) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctypif :nocc_symb csym)) (wthen (wrap_normal_let1 nthen nbindthen sloc)) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type ctypif :letbind_expr (instance class_nrep_if :nrep_loc sloc :nif_test ntest :nif_then wthen :nif_else () :nexpr_ctyp ctypif ))) ) (unsafe_put_fields clocc :nocc_bind cbind) (if (not (is_list nbindif)) (setq nbindif (make_list discr_list))) (list_append nbindif cbind) (debug "normexp_if result clocc=" clocc " nbindif=" nbindif) (return clocc nbindif) )) )))) (install_method class_source_if normal_exp normexp_if) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; normalize an ifelse (defun normexp_ifelse (recv env ncx psloc) (debug "normexp_ifelse recv=" recv "\n.. env=" debug_more env "\n.. of prec=" debug_less (get_field :env_prev env) "\n") (assert_msg "check if recv" (is_a recv class_source_ifelse) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (stest (unsafe_get_field :sif_test recv)) (ctypif ctype_void) (sthen (unsafe_get_field :sif_then recv)) (selse (unsafe_get_field :sif_else recv)) ) (debug "normexp_ifelse sloc=" debug_less sloc "; stest=" stest) (multicall (ntest nbindif) ;nbindif is also the whole result binding (normal_exp stest env ncx sloc) (debug "normexp_ifelse ntest=" ntest "; nbindif=" nbindif) (assert_msg "check nbindif test" (is_list_or_null nbindif) nbindif) ;; prepend interrupt check void binding (let ( (cintsymb (clone_symbol '_ifelse_inter_)) (nchint (instance class_nrep_checksignal :nrep_loc sloc)) (cintbind (instance class_normal_let_binding :binder cintsymb :letbind_type ctype_void :letbind_expr nchint)) ) (if (is_list nbindif) (list_prepend nbindif cintbind) (setq nbindif (list cintbind)))) ;; in practice we don't need to make a common super- ;; environment with nbindif since all relevant bindings there are ;; generated, with unique cloned symbols, and these bindings ;; are local to the test part (debug "normexp_ifelse sloc=" debug_less sloc "; sthen=" sthen) (multicall (nthen nbindthen) (normal_exp sthen env ncx sloc) (debug "normexp_ifelse nthen=" nthen " nbindthen=" nbindthen) (assert_msg "check nbindthen" (is_list_or_null nbindthen) nbindthen) (let ( (newthenenv (fresh_env env)) ) (debug "normexp_ifelse sloc=" debug_less sloc "; newthenenv=" newthenenv) (list_every nbindthen (lambda (b) (put_env newthenenv b))) ;; the ctyp of the whole if is initialized to the ctype of the then part (setq ctypif (get_ctype nthen newthenenv)) (debug "normexp_ifelse sloc=" debug_less sloc "; selse=" selse) (multicall (nelse nbindelse) (normal_exp selse env ncx sloc) (debug "normexp_ifelse nelse=" nelse " nbindelse=" nbindelse) (assert_msg "check nbindelse" (is_list_or_null nbindelse) nbindelse) ;; if we have both then & else branches, ;; ensure their compatibility of types (let ( (newelseenv (let ( (nenv (fresh_env env)) ) (list_every nbindelse (lambda (b) (put_env nenv b))) nenv )) (ctypelse (get_ctype nelse newelseenv)) ) (debug "normexp_ifelse sloc=" debug_less sloc " newelseenv=" newelseenv) (assert_msg "check ctypif" (is_a ctypif class_ctype) ctypif) (assert_msg "check ctypelse" (is_a ctypelse class_ctype) ctypelse) (cond ( (== ctypif ctypelse) () ) ( (and (!= ctypif ctype_void) (== ctypelse ctype_void)) () ;; ctypif is correct ) ( (and (== ctypif ctype_void) (!= ctypelse ctype_void)) (setq ctypif ctypelse) ) (:else (error_at sloc "incompatible types in conditional IF/OR/COND branches: then type is $1 else type is $2"_ (unsafe_get_field :named_name ctypif) (unsafe_get_field :named_name ctypelse)) (setq ctypif ctype_void) ) )) ;; ;; (let ( (csym (clone_symbol '_ifelse_)) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctypif :nocc_symb csym)) (wthen (wrap_normal_let1 nthen nbindthen sloc)) (welse (wrap_normal_let1 nelse nbindelse sloc)) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type ctypif :letbind_expr (instance class_nrep_if :nrep_loc sloc :nif_test ntest :nif_then wthen :nif_else welse :nexpr_ctyp ctypif ))) ) (unsafe_put_fields clocc :nocc_bind cbind) (if (not (is_list nbindif)) (setq nbindif (make_list discr_list))) (list_append nbindif cbind) (debug "normexp_ifelse result clocc=" clocc " nbindif=" nbindif) (return clocc nbindif) ))))))) (install_method class_source_ifelse normal_exp normexp_ifelse) ;;;;;;;;;;;;;;;; normalize a cppif (defun normexp_cppif (recv env ncx psloc) (assert_msg "check cppif recv" (is_a recv class_source_cppif) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (debug "normexp_cppif recv" recv) (let ( (sloc (unsafe_get_field :loca_location recv)) (scond (unsafe_get_field :sifp_cond recv)) (ctypif ctype_void) (sthen (unsafe_get_field :sifp_then recv)) (selse (unsafe_get_field :sifp_else recv)) ) ;; normalize the then-part (multicall (nthen nbindthen) (normal_exp sthen env ncx sloc) (debug "normexp_cppif nthen" nthen) (assert_msg "check nbindthen" (is_list_or_null nbindthen) nbindthen) (let ( (newthenenv (fresh_env env)) ) (list_every nbindthen (lambda (b) (put_env newthenenv b))) ;; the ctyp of the whole cppif is initialized to the ctype of the then part (setq ctypif (get_ctype nthen newthenenv)) (assert_msg "check ctypif" (is_a ctypif class_ctype) ctypif) ;; normalize the else-part (multicall (nelse nbindelse) (normal_exp selse env ncx sloc) (debug "normexp_cppif nelse" nelse) (assert_msg "check nbindelse" (is_list_or_null nbindelse) nbindelse) (let ( (newelseenv (fresh_env env)) ) (foreach_pair_component_in_list (nbindelse) (curpairelse elsebind) (put_env newelseenv elsebind)) (let ( (ctypelse (get_ctype nelse newelseenv)) ) (when (and (!= ctypif ctypelse) (!= ctypif ctype_void) (!= ctypelse ctype_void)) (error_at sloc "CPPIF incompatible then $1 & else $2 types"_ (unsafe_get_field :named_name ctypif) (unsafe_get_field :named_name ctypelse)) )) (let ( (csym (clone_symbol 'ifcpp_)) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctypif :nocc_symb csym)) (wthen (wrap_normal_let1 nthen nbindthen sloc)) (welse (wrap_normal_let1 nelse nbindelse sloc)) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type ctypif :letbind_expr (instance class_nrep_cppif :nrep_loc sloc :nifp_cond scond :nifp_then wthen :nifp_else welse :nifp_ctyp ctypif ))) (nbindres (make_list discr_list)) ) (unsafe_put_fields clocc :nocc_bind cbind) (list_append nbindres cbind) (debug "normexp_cppif result clocc=" clocc " nbindres=" nbindres) (return clocc nbindres) ))))))) (install_method class_source_cppif normal_exp normexp_cppif) ;;;;;;;;;;;;;;;; normalize an or ;; (OR (f1 a1)) is let d1 = (f1 a1) in d1 ;; (OR (f1 a1) (f2 a2)) is let o1 = (let d1 = (f1 a1) in (if d1 d1 (let d2 = (f2 a2) in d2))) in o1 (defun normexp_or (recv env ncx psloc) (assert_msg "check or recv" (is_a recv class_source_or) recv) (assert_msg "check env" (is_a env class_environment)) (assert_msg "check nctxt" (is_a ncx class_normalization_context)) (debug "normexp_or recv" recv) (let ( (boxorcount (make_integerbox discr_integer (melt_callcount))) (sloc (unsafe_get_field :loca_location recv)) (sdisj (unsafe_get_field :sor_disj recv)) (:long nbdisj (multiple_length sdisj)) (:long ix (-i nbdisj 1)) (norcont (reference ())) (nbindorcont (reference (make_list discr_list))) (ctyporcont (reference ctype_void)) (newenv (fresh_env env)) ) (multiple_backward_every sdisj (lambda (scur :long six) (debug "normexp scur=" scur "call#" (get_int boxorcount)) (multicall (ncur nbind) (normal_exp scur env ncx sloc) (debug "normexp ncur=" ncur " nbind=" nbind " call#" (get_int boxorcount)) (list_every ncur (lambda (bnd) (put_env newenv bnd))) (if (null (deref norcont)) (progn (set_ref nbindorcont nbind) (set_ref norcont ncur) (set_ref ctyporcont (get_ctype ncur newenv)) () ) (let ( (ctypcur (get_ctype ncur newenv)) ) (assert_msg "check ctypcur" (is_a ctypcur class_ctype)) (if (!= ctypcur (deref ctyporcont)) (error_at sloc "disjuncts' type mismatch in OR | COND got $1 expecting $2"_ ctypcur (deref ctyporcont))) (let ( ;; ncur is normal, so simple (nifor (instance class_nrep_if :nrep_loc sloc :nif_test ncur :nif_then ncur :nif_else (wrap_normal_let1 (deref norcont) (deref nbindorcont) sloc) :nexpr_ctyp ctypcur ) ) (csymor (clone_symbol 'or_)) (corbind (instance class_normal_let_binding :binder csymor :letbind_loc sloc :letbind_type ctypcur :letbind_expr nifor)) (corocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctypcur :nocc_symb csymor :nocc_bind corbind)) ) (set_ref nbindorcont (make_list discr_list)) (list_append2list (deref nbindorcont) nbind) (list_append (deref nbindorcont) corbind) (set_ref norcont corocc) () ) ) ) ) ) ) (debug "normexp_or result nor=" !norcont " nbindor=" !nbindorcont) (return !norcont !nbindorcont) ) ) (install_method class_source_or normal_exp normexp_or) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; normalize a PROGN ;;;; (PROGN a1 a2 ... an) is based upon the normalization of (LET () a1 a2 ... an) (defun normexp_progn (recv env ncx psloc) (assert_msg "check progn recv" (is_a recv class_source_progn)) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check nctxt" (is_a ncx class_normalization_context)) (debug "normexp_progn recv" recv) (let ( (sloc (unsafe_get_field :loca_location recv)) (sbody (unsafe_get_field :sprogn_body recv)) (:long lnbody (multiple_length sbody)) (boxlnbody (make_integerbox discr_integer lnbody)) ) (if (<=i lnbody 0) (let ( (onull (instance class_nrep_nil :nrep_loc sloc)) ) (error_at sloc "empty PROGN") (debug "normexp_progn return empty onull" onull) (return onull))) (multicall (nbody nbind) (normalize_tuple sbody env ncx sloc) (debug "normexp_progn nbody=" nbody " nbind=" nbind) (let ( (nlast (multiple_nth nbody -1)) (:long lenbody (multiple_length nbody)) (nallbutlast (if (>i lenbody 0) (make_multiple discr_multiple (-i lenbody 1)))) ) ;; fill nallbutlast (let ( (:long ix (-i lenbody 1)) ) (forever bodyloop (if ( [:field1 ...]) expression") (return ()) ) ( (is_not_a cladata class_nrep) (debug "normexp_instance bad cladata" cladata) (error_at sloc "invalid class $1 in (INSTANCE [:field1 ...]) expression" (get_field :named_name sclass)) (return ())) ) ;; normalize the field assigments (let ( (nfields (multiple_map sfields (lambda (curflda :long curk) (debug "normexp_instance.lambda curflda" curflda) (assert_msg "check curflda" (is_a curflda class_source_fieldassign) curflda) (let ( (curfloc (unsafe_get_field :loca_location curflda)) (curfield (unsafe_get_field :sfla_field curflda)) (curexp (unsafe_get_field :sfla_expr curflda)) ) (if (null curfloc) (setq curfloc sloc)) ;; check the curfield (cond ( (is_not_a curfield class_field) (debug "normexp_instance corrupted curflda=" curflda " curfield=" curfield) (error_at sloc "invalid field #$1 in (INSTANCE $2 [:field1 ...]) expression" curk (get_field :named_name sclass)) (return)) ( (not (subclass_or_eq sclass (unsafe_get_field :fld_ownclass curfield))) (debug "normexp_instance corrupted curflda=" curflda " curfield=" curfield) (error_at sloc "unexpected field $1 from class $2 in (INSTANCE $3 [:field1 ...]) expression"_ (get_field :named_name curfield) (get_field :named_name (get_field :fld_ownclass curfield)) (get_field :named_name sclass) ) (return)) ) ;; (multicall (nexp nbind) (normal_exp curexp env ncx curfloc) (assert_msg "check nbind" (is_list_or_null nbind) nbind) (let ( (fctyp (get_ctype nexp env)) ) (debug "normexp_instance fctyp" fctyp) (if (!= fctyp ctype_value) (error_at curfloc "invalid field $1 type $2 in (INSTANCE ..); expecting a :value" (get_field :named_name curfield) (get_field :named_name fctyp)))) (list_append2list bindlist nbind) (instance class_nrep_fieldassign :nrep_loc curfloc :nfla_field curfield :nfla_val nexp) ))))) (nmkins (instance class_nrep_instance :nrep_loc sloc :nmins_class sclass :nmins_cladata cladata :nmins_fields nfields)) (csym (clone_symbol 'inst_)) (cbind (instance class_normal_let_binding :binder csym :letbind_loc sloc :letbind_type ctype_value :letbind_expr nmkins)) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_value :nocc_symb csym :nocc_bind cbind)) ) (list_append bindlist cbind) (debug "normexp_instance result clocc=" clocc " bindlist=" bindlist) (return clocc bindlist) ) ) ) (install_method class_source_instance normal_exp normexp_instance) (install_method class_source_instance get_ctype (lambda (recv env) ctype_value)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; normalize a forever (defun normexp_forever (recv env ncx psloc) (assert_msg "check forever recv" (is_a recv class_source_forever) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (debug "normexp_forever recv=" recv) (let ( (sloc (unsafe_get_field :loca_location recv)) (slbind (unsafe_get_field :slabel_bind recv)) (sbody (unsafe_get_field :sfrv_body recv)) (newenv (fresh_env env)) ) (assert_msg "check slbind" (is_a slbind class_label_binding) slbind) (put_env newenv slbind) (let ( (resy (clone_symbol (unsafe_get_field :binder slbind))) ) (debug "normexp_forever putting resy=" resy " in slbind=" slbind) (unsafe_put_fields slbind :labind_clonsy resy) (debug "normexp_forever updated slbind" slbind) (assert_msg "check resy" (is_a resy class_cloned_symbol) resy) (debug "normexp_forever got1 clonsy "(unsafe_get_field :labind_clonsy slbind) ) (assert_msg "check did1 put resy" (== (unsafe_get_field :labind_clonsy slbind) resy) resy slbind) (multicall (nbody nbodbindings) (normalize_tuple sbody newenv ncx sloc) (debug "normexp_forever again slbind=" slbind " nbody=" nbody " nbodbindings=" nbodbindings) ;; prepend an interrupt check binding (let ( (cintsymb (clone_symbol 'forever_inter_)) (nchint (instance class_nrep_checksignal :nrep_loc sloc)) (cintbind (instance class_normal_let_binding :binder cintsymb :letbind_type ctype_void :letbind_expr nchint)) ) (if (null nbodbindings) (setq nbodbindings (list cintbind)) (list_prepend nbodbindings cintbind)) ) (assert_msg "check size slbind" (i tuplen 0) (multiple_nth tup (-i tuplen 1)))) ) (cond ;;; last expression is already a return - do nothing ( (is_a lastcomp class_nrep_return) (return tup) ) ;;; last expression is a symbol occurrence (closed or local) - return it if it is a value ( (is_a lastcomp class_nrep_symocc) (if (== (unsafe_get_field :nocc_ctyp lastcomp) ctype_value) (multiple_put_nth tup (-i tuplen 1) (instance class_nrep_return :nrep_loc sloc :nret_main lastcomp))) (return tup) ) ;;; last expression is a normal data, return it ( (is_a lastcomp class_nrep_bound_data) (multiple_put_nth tup (-i tuplen 1) (instance class_nrep_return :nrep_loc sloc :nret_main lastcomp)) (return tup) ) ;;; no last expression - don't bother to return ( (null lastcomp) (return tup) ) ;;; last expression is a normalized let, recurse on the body within a new env ( (is_a lastcomp class_nrep_let) (let ( (lbody (unsafe_get_field :nlet_body lastcomp)) (lbinding (unsafe_get_field :nlet_bindings lastcomp)) (lloc (unsafe_get_field :nrep_loc lastcomp)) (newenv (fresh_env env)) ) (multiple_every lbinding (lambda (bnd :long ix) (put_env newenv bnd) )) (if (is_multiple lbody) (replace_last_by_return lbody newenv lloc)) (return tup) )) ;;; last expression is some more complex normalized stuff ;;; if it is a value wrap it into a normalized let with return ( (is_a lastcomp class_nrep) (let ( (lastyp (get_ctype lastcomp env)) (loc (unsafe_get_field :nrep_loc lastcomp)) ) (if (== lastyp ctype_value) (let ( (rclosym (clone_symbol '_retval_)) (rclocc (instance class_nrep_locsymocc :nrep_loc loc :nocc_symb rclosym :nocc_ctyp ctype_value)) (retn (instance class_nrep_return :nrep_loc loc :nret_main rclocc )) (rbind (instance class_normal_let_binding :binder rclosym :letbind_type ctype_value :letbind_expr lastcomp :letbind_loc loc )) (rbintup (tuple rbind)) (rlet (instance class_nrep_let :nrep_loc loc :nlet_bindings rbintup :nlet_body (tuple retn))) ) (unsafe_put_fields rclocc :nocc_bind rbind) (multiple_put_nth tup (-i tuplen 1) rlet) (return tup) ))))) (return tup) ; returns the original tuple ;;; general case, do nothing ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; normalize a DEFUN or a DEFMACRO (defun normexp_defun_defmacro (recv env ncx psloc) (debug "normexp_defun_defmacro recv=" recv "\n env=" debug_more env "\n") (shortbacktrace_dbg "normexp_defun_defmacro" 8) (assert_msg "check defun recv" (is_a recv class_source_defun) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (or (unsafe_get_field :loca_location recv) psloc)) (snam (unsafe_get_field :sdef_name recv)) (sformals (unsafe_get_field :sformal_args recv)) (sbody (unsafe_get_field :sfun_body recv)) (:long ismacro (is_a recv class_source_defmacro)) (modctx (get_field :nctx_modulcontext ncx)) (modinienv (get_field :mocx_initialenv modctx)) (macroenv (get_field :mocx_macroenv modctx)) (basenv (let ( (be (if ismacro macroenv env)) ) (debug "normexp_defun_defmacro sloc=" debug_less sloc "; ismacro=" ismacro "; basenv=" be) be)) (sfubind (find_env basenv snam)) (newenv (fresh_env basenv)) (oldproc (unsafe_get_field :nctx_curproc ncx)) (oldsymbcache (unsafe_get_field :nctx_symbcachemap ncx)) (closblis (make_list discr_list)) (cnstlist (make_list discr_list)) (nproc (instance class_nrep_defunroutproc ;;; dont forget to put the nil fields at end :nrep_loc sloc :nproc_body () ;filled later :nrclop_name snam :nrclop_argbindtuple sformals :nrclop_clobindlist closblis :nrclop_constlist cnstlist :nrclop_objconstcachemap (make_mapobject discr_map_objects 31) :nrpro_thunklist (make_list discr_list) :nrpro_datarout () ; filled below :nrpro_dataclos () ; filled below :nrpro_variadic () ; filled below )) (ndatarout (instance class_nrep_dataroutine :ndata_name snam :ndata_discrx (normal_predef discr_routine ncx sloc "discr_routine") :ndrou_proc nproc )) (ndataclos (instance class_nrep_dataclosure :ndata_name snam :ndata_discrx (if ismacro (normal_predef discr_macro_closure ncx sloc "discr_macro_closure") (normal_predef discr_closure ncx sloc "discr_closure")) :ndclo_proc nproc :ndclo_closv () ;filled below )) ) (debug "normexp_defun_defmacro ismacro=" ismacro "; sloc=" debug_less sloc "\n.. basenv=" (if ismacro debug_more debug_less) basenv "\n.. newenv=" newenv) (unsafe_put_fields ncx :nctx_curproc nproc :nctx_symbcachemap (make_mapobject discr_map_objects 40)) (debug "normexp_defun_defmacro nproc=" nproc "\n.. ndatarout=" ndatarout "\n.. ndataclos=" ndataclos "\n.. newenv=" newenv) (add_nctx_data ncx ndatarout) (add_nctx_data ncx ndataclos) (debug "normexp_defun_defmacro updated ncx=" debug_less ncx "\n.. sloc=" debug_less sloc "\n.. sfubind=" sfubind) (when (null sfubind) (debug "normexp_defun_defmacro null sfubind ismacro=" ismacro " from basenv=" debug_more basenv "\n... snam=" snam "\n.. recv=" recv "\n") (if ismacro (error_at sloc "bad defmacro-ed function $1 without binding" (get_field :named_name snam)) (error_at sloc "bad defun-ed function $1 without binding" (get_field :named_name snam))) (shortbacktrace_dbg "normexp_defun_defmacro bad DEFUNed unbound function" 14) (return)) (when (and (is_not_a sfubind class_function_binding) (is_not_a sfubind class_macro_binding) (is_not_a sfubind class_defined_macro_binding)) (if ismacro (error_at sloc "bad defmacro-ed function $1 with binding of $2 [nested definitions are prohibited]" (get_field :named_name snam) (get_field :named_name (discrim sfubind))) (error_at sloc "bad defun-ed function $1 with binding of $2 [nested definitions are prohibited]" (get_field :named_name snam) (get_field :named_name (discrim sfubind)))) (shortbacktrace_dbg "normexp_defun_defmacro bad DEFUNed function" 14) (return)) (unsafe_put_fields nproc :nrpro_datarout ndatarout :nrpro_dataclos ndataclos) (debug "normexp_defun_defmacro updated nproc=" nproc) (foreach_in_multiple (sformals) (fbi :long ix) (assert_msg "check fbi" (is_a fbi class_formal_binding) fbi) (put_env newenv fbi)) (if (is_a sformals discr_variadic_formal_sequence) (put_fields nproc :nrpro_variadic snam)) (unsafe_put_fields newenv :env_proc nproc) (debug "normexp_defun_defmacro updated :env_proc of of newenv" newenv) ;; add nproc into ncx (let ( (ncplis (get_field :nctx_proclist ncx)) ) (list_append ncplis nproc) (debug "normexp_defun_defmacro appended to nctxproclist ncplis=" ncplis)) ;; (multicall (nbody nbindings) (normalize_tuple sbody newenv ncx sloc) (debug "normexp_defun_defmacro nbody before replace_last_by_return" nbody) (multiple_every nbindings (lambda (nbi :long ix) (put_env newenv nbi))) (let ( (nrbody (replace_last_by_return nbody newenv sloc)) (npbody (wrap_normal_letseq nrbody nbindings sloc)) ) (unsafe_put_fields nproc :nproc_body npbody) (debug "normexp_defun_defmacro after replace_last_by_return npbody=" npbody "\n.. nproc=" nproc) ) (unsafe_put_fields ncx :nctx_curproc oldproc :nctx_symbcachemap oldsymbcache) (debug "normexp_defun_defmacro restored ncx=" ncx) (let ( (clovtup (list_to_multiple closblis discr_multiple (lambda (bnd) (assert_msg "normexp_defun_defmacro check bnd" (is_a bnd class_any_binding) bnd) (let ( (sy (unsafe_get_field :binder bnd)) ;; since sy is a symbol, its normalized form does not add any binding ;; we normalize it in the *old* base environment, not the new one (nsy (normal_exp sy basenv ncx sloc)) ) nsy )))) ) (unsafe_put_fields ndataclos :ndclo_closv clovtup) ) ;; link the binding and the data (cond ( (is_a sfubind class_function_binding) (unsafe_put_fields sfubind :fixbind_data ndataclos)) ( (is_a sfubind class_defined_macro_binding) (unsafe_put_fields sfubind :mbind_data ndataclos)) ( (is_a sfubind class_macro_binding) (cond ( (and (melt_is_bootstrapping) (== (get_field :binder sfubind) (get_field :ndata_name ndataclos))) (debug "normexp_defun_defmacro good bootstrapping macro sfubind=" sfubind "\n ndataclos=" ndataclos) (void)) (:else (error_at sloc "messy definition of $1 with existing macro binding" snam) (assert_msg "strange macro sfubind & ndataclos" () sfubind ndataclos) (return)))) (:else (debug "normexp_defun_defmacro strange sfubind=" sfubind "\n.. for ndataclos=" ndataclos) (assert_msg "bad sfubind" () sfubind ndataclos))) (debug "normexp_defun_defmacro return ndataclos=" ndataclos) (return ndataclos ()) ) )) (install_method class_source_defun normal_exp normexp_defun_defmacro) ;;; normalize the installation of a macro (defun normexp_macro_installation (recv env ncx psloc) (debug "normexp_macro_installation recv=" recv "\n... env=" env) (assert_msg "check recv" (is_a recv class_source_macro_installation) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (loc (or (unsafe_get_field :loca_location recv) psloc)) (sdefmacro (unsafe_get_field :smacinst_defmacro recv)) (modctx (get_field :nctx_modulcontext ncx)) (macroenv (get_field :mocx_macroenv modctx)) (modname (get_field :mocx_modulename modctx)) ) (debug "normexp_macro_installation loc=" debug_less loc "; sdefmacro=" sdefmacro "\n.. macroenv=" macroenv) (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx) (assert_msg "check macroenv" (is_a macroenv class_environment) macroenv) (shortbacktrace_dbg "normexp_macro_installation" 10) (assert_msg "check sdefmacro" (is_a sdefmacro class_source_defmacro) sdefmacro) (let ( (nclos (normexp_defun_defmacro sdefmacro macroenv ncx loc)) (mbind (get_field :smacro_binding sdefmacro)) (msymb (get_field :binder mbind)) ) (debug "normexp_macro_installation loc=" debug_less loc "; nclos=" nclos "\n.. mbind=" mbind "\n.. macroenv=" macroenv) (assert_msg "check modctx" (is_a modctx class_running_extension_module_context) modctx) (assert_msg "check nclos" (is_a nclos class_nrep_dataclosure) nclos env) (assert_msg "check mbind" (is_a mbind class_defined_macro_binding) mbind env) (let ( (nlitsym (clone_symbol msymb)) (nclosym (clone_symbol msymb)) (nlitbind (let ( (nli (register_literal_value mbind modctx)) ) (debug "normexp_macro_installation nlitbind=" nli) nli)) (clobind (instance class_normal_let_binding :letbind_loc loc :binder nclosym :letbind_type ctype_value :letbind_expr nclos)) (closocc (instance class_nrep_locsymocc :nrep_loc loc :nocc_ctyp ctype_value :nocc_symb nclosym :nocc_bind clobind)) (nlitval (let ( (nlv (instance class_nrep_literalnamedvalue :nlitval_regval nlitbind :nlitval_symbol nlitsym)) ) (debug "normexp_macro_installation nlitval=" nlv) nlv)) (nhcall (let ( (nhc (instance class_nrep_hook_call :nrep_loc loc :nexpr_ctyp ctype_void :nhook_name '"HOOK_MACRO_INSTALLER" :nexpr_args (tuple nlitval closocc) :nhook_called (normal_predef hook_macro_installer ncx loc "hook_macro_installer") :nhook_outs (tuple) :nhook_descr (hook_data hook_macro_installer) )) ) (debug "normexp_macro_installation nhcall=" nhc) nhc)) (csym (clone_symbol (get_field :binder mbind))) (cbind (instance class_normal_let_binding :letbind_loc loc :binder csym :letbind_type ctype_void :letbind_expr nhcall)) (symocc (instance class_nrep_locsymocc :nrep_loc loc :nocc_ctyp ctype_void :nocc_symb csym :nocc_bind cbind)) ) (debug "normexp_macro_installation nlitval=" nlitval) (debug "normexp_macro_installation csym=" csym " nhcall=" nhcall) (debug "normexp_macro_installation final closocc=" closocc "\n.. symocc=" symocc "\n.. cbind=" cbind "\n.. clobind=" clobind) (return (tuple closocc symocc) (list clobind cbind)) )))) (install_method class_source_macro_installation normal_exp normexp_macro_installation) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; normalize a DEFHOOK (defun normexp_defhook (recv env ncx psloc) (debug "normexp_defhook recv=" recv "\n.. ncx=" ncx "\n.. env=" env) (assert_msg "check defhook recv" (is_a recv class_source_defhook) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (symb (get_field :sdef_name recv)) (symbname (progn (debug "normexp_defhook symb=" symb) (let ( (sn (get_field :named_name symb)) ) (debug "normexp_defhook symbname=" sn) sn))) (sinformals (unsafe_get_field :sformal_args recv)) (soutformals (unsafe_get_field :shook_out_formals recv)) (sctype (unsafe_get_field :shook_ctype recv)) (spredef (unsafe_get_field :shook_predef recv)) (smodvar (unsafe_get_field :shook_variable recv)) (sbody (unsafe_get_field :shook_body recv)) (shobind (find_env env symb)) (newenv (fresh_env env)) (oldproc (unsafe_get_field :nctx_curproc ncx)) (oldsymbcache (unsafe_get_field :nctx_symbcachemap ncx)) (closbindlist (make_list discr_list)) (constlist (make_list discr_list)) (nproc (instance class_nrep_hookproc :nrep_loc sloc :nproc_body () :nrclop_name symbname :nrclop_argbindtuple () :nrhook_outb () :nrhook_ctype sctype :nrhook_datahook () :nrclop_clobindlist closbindlist :nrclop_constlist constlist :nrclop_objconstcachemap (make_mapobject discr_map_objects 31) )) (descrhook (instance class_hook_descriptor :named_name symbname :hookdesc_in_formals sinformals :hookdesc_out_formals soutformals :hookdesc_ctype sctype :hookdesc_hook ())) (ndatahook (instance class_nrep_datahook :ndata_name symbname :ndata_discrx (normal_predef discr_hook ncx sloc "discr_hook") :ndhook_proc nproc :ndhook_data () :ndhook_closv () :ndhook_predef spredef :ndhook_modvarbind () )) ;; map of formal symbol -> data of formal_binding (formsymbmap (make_mapobject discr_map_objects (+i 9 (*i (+i (multiple_length sinformals) (multiple_length soutformals)) 2)))) (formintuple (make_multiple discr_multiple (multiple_length sinformals))) (formoutuple (make_multiple discr_multiple (multiple_length soutformals))) (namstrdata (instance class_nrep_datastring :nrep_loc sloc :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") :nstr_string symbname)) (slotup (make_multiple discr_multiple (multiple_length (unsafe_get_field :class_fields class_hook_descriptor)))) (insdata (instance class_nrep_datainstance :nrep_loc sloc :ndata_name symbname :ndata_discrx (normal_predef class_hook_descriptor ncx sloc "class_hook_descriptor") :ninst_hash (make_integerbox discr_integer (obj_hash descrhook)) :ninst_slots slotup )) ) (put_fields ndatahook :ndhook_data insdata) (put_fields nproc :nrhook_datahook ndatahook) (debug "normexp_defhook newenv=" newenv "\n.. oldproc=" oldproc "\n.. nproc=" nproc) (debug "normexp_defhook ndatahook=" ndatahook "\n.. sctype=" sctype) (debug "normexp_defhook descrhook=" descrhook "\n.. smodvar=" smodvar) (if smodvar (let ( (modvarbind (find_env env smodvar)) ) (debug "normexp_defhook symbname=" symbname " smodvar=" smodvar " modvarbind=" modvarbind) (when (is_not_a modvarbind class_normal_module_variable_binding) (error_at sloc "DEFHOOK $1 has bad :VAR annotation, should be a module variable"_ symbname) (return) ) (put_fields ndatahook :ndhook_modvarbind modvarbind) (debug "normexp_defhook updated ndatahook=" ndatahook) )) (assert_msg "check sctype" (is_a sctype class_ctype) sctype) (assert_msg "check symbname" (is_string symbname) symbname) (assert_msg "check sinformals" (and (is_multiple_or_null sinformals) (is_not_a sinformals discr_variadic_formal_sequence)) sinformals) (assert_msg "check soutformals" (and (is_multiple_or_null soutformals) (is_not_a soutformals discr_variadic_formal_sequence)) soutformals) (debug "normexp_defhook shobind=" shobind "\n oldproc=" oldproc " \n nproc=" nproc "\n ndatahook=" ndatahook) (put_fields ncx :nctx_curproc nproc :nctx_symbcachemap (make_mapobject discr_map_objects 40)) (add_nctx_data ncx ndatahook) (add_nctx_data ncx insdata) (when (is_not_a shobind class_hook_binding) (error_at sloc "bad hook definition $1, not bound to a hook but $2 [nested hooks are prohibited]" symbname (get_field :named_name (discrim shobind))) (return)) ;;; fill the named_name of insdata (debug "normexp_defhook namstrdata=" namstrdata) (add_nctx_data ncx namstrdata) (multiple_put_nth slotup (get_int named_name) namstrdata) ;; fill the hookdesc_in_formals of insdata (fill_normal_formals sinformals formintuple formsymbmap env ncx sloc) (let ( (nintupdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name symbname :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") :ntup_comp formintuple)) ) (add_nctx_data ncx nintupdata) (multiple_put_nth slotup (get_int hookdesc_in_formals) nintupdata) (debug "normexp_defhook nintupdata=" nintupdata)) ;; fill the hookdesc_out_formals of insdata (fill_normal_formals soutformals formoutuple formsymbmap env ncx sloc) (let ( (noutupdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name symbname :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") :ntup_comp formoutuple)) ) (add_nctx_data ncx noutupdata) (multiple_put_nth slotup (get_int hookdesc_out_formals) noutupdata) (debug "normexp_defhook noutupdata=" noutupdata)) ;; fill the hookdesc_ctype of insdata (multiple_put_nth slotup (get_int hookdesc_ctype) (normal_predef sctype ncx sloc "hook ctype")) ;; (debug "normexp_defhook slotup=" slotup) ;; (debug "normexp_defhook updated ncx=" ncx "\n .. nproc=" nproc) (foreach_in_multiple (sinformals) (fbi :long ix) (assert_msg "check fbi" (is_a fbi class_formal_binding) fbi) (put_env newenv fbi)) (foreach_in_multiple (soutformals) (fbo :long ix) (assert_msg "check fbo" (is_a fbo class_formal_binding) fbo) (put_env newenv fbo)) (put_fields nproc :nrclop_argbindtuple sinformals :nrhook_outb soutformals) (put_fields newenv :env_proc nproc) (debug "normexp_defhook newenv=" newenv) ;; (multicall (nbody nbindings) (normalize_tuple sbody newenv ncx sloc) (debug "normexp_defhook nbody=" nbody "\n.. nbindings=" nbindings) ;; add nproc into ncx (let ( (ncplis (get_field :nctx_proclist ncx)) ) (list_append ncplis nproc) (debug "normexp_defhook sbody=" sbody "\n.. updated ncx=" ncx "\n.. ncplis=" ncplis) ) (shortbacktrace_dbg "normexp_defhook" 12) ;; make the bindings in the newenv (foreach_in_multiple (nbindings) (nbi :long bix) (put_env newenv nbi)) (debug "normexp_defhook updated newenv=" newenv) ;; restore the previous symbol cache map & the old proc (put_fields ncx :nctx_symbcachemap oldsymbcache :nctx_curproc oldproc ) (debug "normexp_defhook restored ncx=" ncx) (debug "normexp_defhook closbindlist=" closbindlist "\n.. constlist=" constlist) (assert_msg "check closbindlist" (is_list closbindlist) closbindlist) (assert_msg "check constlist" (is_list constlist) constlist) ;; normalize the closed and the const values (let ( (nseq (wrap_normal_letseq nbody nbindings sloc)) (:long nbclosbind (list_length closbindlist)) (:long nbconst (list_length constlist)) (:long ix 0) (closvtup (make_multiple discr_multiple (+i nbclosbind nbconst))) ) (debug "normexp_defhook nbclosbind#" nbclosbind " nbconst#" nbconst) ;; (foreach_pair_component_in_list (closbindlist) (curpair curclobnd) (debug "normexp_defhook curclobnd=" curclobnd " ix#" ix) (assert_msg "check curclobnd" (is_a curclobnd class_any_binding) curclobnd) (let ( (sy (unsafe_get_field :binder curclobnd)) ;; normalize in the *old* environment (nsy (normal_exp sy env ncx sloc)) ) (debug "normal_exp nsy=" nsy) (multiple_put_nth closvtup ix nsy) (setq ix (+i ix 1)) )) ;end foreach closbindlist (debug "normexp_defhook after closbindloop ix=" ix " closvtup=" closvtup) ;; (debug "normexp_defhook closing constlist=" constlist) (foreach_pair_component_in_list (constlist) (curpair curconst) (debug "normexp_defhook curconst=" curconst " ix#" ix) (assert_msg "check curconst" (is_a curconst class_nrep) curconst) (multiple_put_nth closvtup ix curconst) (setq ix (+i ix 1)) ) ;end foreach constlist (debug "normexp_defhook after constlistloop ix=" ix " closvtup=" closvtup) (assert_msg "check final ix" (==i ix (+i nbclosbind nbconst)) ix) ;; (debug "normexp_defhook nseq=" nseq "\n ..final closvtup=" closvtup) (put_fields nproc :nproc_body nseq) (put_fields ndatahook :ndhook_closv closvtup) (put_fields shobind :fixbind_data ndatahook) (debug "normexp_defhook final nproc=" nproc) (debug "normexp_defhook final ndatahook=" ndatahook "\n.. shobind=" shobind) ;; (debug "normexp_defhook result nproc=" nproc) (return nproc ()) )))) (install_method class_source_defhook normal_exp normexp_defhook) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; normalize a LAMBDA ;;; an internal routine useful for lambda inside letrec ... to share ;;; code between normexp_lambda and handling of lambda-s inside letrec (defun normalize_lambda (recv env newenv ncx psloc) (debug "normalize_lambda recv=" recv " env=" env " newenv=" newenv) (shortbacktrace_dbg "normalize_lambda" 15) (assert_msg "check lambda recv" (is_a recv class_source_lambda) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check newenv" (is_a newenv class_environment)) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (sformalargs (unsafe_get_field :slam_argbind recv)) (sbody (unsafe_get_field :slam_body recv)) (csym (clone_symbol 'lambda_)) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_value :nocc_symb csym)) (oldproc (unsafe_get_field :nctx_curproc ncx)) (savedcachemap (unsafe_get_field :nctx_symbcachemap ncx)) (closedblist (make_list discr_list)) (cnstlist (make_list discr_list)) (nproc (instance class_nrep_lambdaroutproc :nrep_loc sloc :nproc_body () ;filled later :nrclop_name csym :nrclop_argbindtuple sformalargs :nrclop_clobindlist closedblist :nrclop_constlist cnstlist :nrclop_objconstcachemap (make_mapobject discr_map_objects 31) :nrpro_datarout () ; filled below :nrpro_dataclos () ; not filled :nrpro_thunklist (make_list discr_list) :nrpro_variadic () ; filled below )) (ndatarout (instance class_nrep_dataroutine :ndata_name csym :ndata_discrx (normal_predef discr_routine ncx sloc "discr_routine") :ndrou_proc nproc )) ) (debug "normalize_lambda made nproc=" nproc "\n.. ndatarout=" ndatarout) (shortbacktrace_dbg "normalize_lambda" 10) (add_nctx_data ncx ndatarout) ;; update the context for the new proc & a fresh symbol cache map (unsafe_put_fields ncx :nctx_curproc nproc :nctx_symbcachemap (make_mapobject discr_map_objects 40)) (put_fields nproc :nrpro_datarout ndatarout) (debug "normalize_lambda updated ncx=" ncx "\n.. nproc=" nproc) (foreach_in_multiple (sformalargs) (fbi :long ix) (assert_msg "check fbi" (is_a fbi class_formal_binding) fbi) (put_env newenv fbi)) (if (is_a sformalargs discr_variadic_formal_sequence) (put_fields nproc :nrpro_variadic csym)) (put_fields newenv :env_proc nproc) (debug "normalize_lambda updated newenv=" newenv) (shortbacktrace_dbg "normalize_lambda" 15) ;; add nproc into ncx (let ( (ncplis (get_field :nctx_proclist ncx)) ) (list_append ncplis nproc) (debug "normalize_lambda updated ncplis=" ncplis "\n.. ncx=" ncx) ) ;; (multicall (nbody nbindings) (normalize_tuple sbody newenv ncx sloc) (debug "normalize_lambda nbody=" nbody "\n.. nbindings=" nbindings) (foreach_in_multiple (nbindings) (nbi :long ix) (put_env newenv nbi)) (put_fields nproc :nproc_body (wrap_normal_letseq (replace_last_by_return nbody newenv sloc) nbindings sloc) ) ;; restore the previous symbol cache map & the old proc and return the normalized lambda (put_fields ncx :nctx_symbcachemap savedcachemap :nctx_curproc oldproc ) (debug "normalize_lambda restored ncx=" ncx "\n.. updated nproc=" nproc) (let ( ;; we make an anonymous constant for the routine unless in toplevel (:long insideflag (is_a oldproc class_nrep_closproc)) (krout (if insideflag (instance class_nrep_constant :nrep_loc sloc :nconst_sval recv :nconst_data ndatarout :nconst_proc oldproc))) (clovtup (list_to_multiple closedblist discr_multiple (lambda (bnd) (assert_msg "normalize_lambda check bnd" (is_a bnd class_any_binding) bnd) (let ( (sy (unsafe_get_field :binder bnd)) ;; since sy is a symbol, its normalized form does not add any binding ;; we normalize it in the *old* environment, not the new one (nsy (normal_exp sy env ncx sloc)) ) nsy)))) (constrout (if insideflag krout ndatarout)) ) (debug "normalize_lambda return nproc=" nproc "\n.. clocc=" clocc "\n.. constrout=" constrout "\n.. insideflag=" insideflag "\n") (return nproc csym clocc constrout clovtup sloc oldproc ndatarout insideflag) )))) ;;;; (defun normexp_lambda (recv env ncx psloc) (debug "normexp_lambda recv=" recv "\n..env=" env "\n.. ncx=" ncx) (assert_msg "check lambda recv" (is_a recv class_source_lambda) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (newenv (fresh_env env)) ) (debug "normexp_lambda before normalize_lambda newenv=" newenv) (multicall (nproc csym clocc constrout clovtup sloc oldproc ndatarout :long insideflag) (normalize_lambda recv env newenv ncx psloc) (debug "normexp_lambda after normalize_lambda nproc=" nproc "\n.. csym=" csym "\n.. clocc=" clocc "\n.. constrout=" constrout "\n.. clovtup=" clovtup "\n.. sloc=" sloc "\n.. oldproc=" oldproc "\n.. ndatarout=" ndatarout "\n.. insideflag=" insideflag) (let ( (nlambda (instance class_nrep_lambda :nrep_loc sloc :nlambda_proc nproc :nlambda_constrout constrout :nlambda_closedv clovtup )) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type ctype_value :letbind_expr nlambda)) (nbindlist (make_list discr_list)) ) (unsafe_put_fields clocc :nocc_bind cbind) (list_append nbindlist cbind) (debug "normexp_lambda insideflag=" insideflag " oldproc=" oldproc) (when insideflag (list_append (get_field :nrclop_constlist oldproc) ndatarout) (debug "normexp_lambda updated constlist in oldproc=" oldproc) ) (debug "normexp_lambda return clocc=" clocc " nbindlist=" nbindlist) (return clocc nbindlist) )))) (install_method class_source_lambda normal_exp normexp_lambda) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun normexp_multicall (recv env ncx psloc) (assert_msg "check multicall recv" (is_a recv class_source_multicall) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (debug "normexp_multicall recv" recv) (let ( (sloc (unsafe_get_field :loca_location recv)) (sresbind (unsafe_get_field :smulc_resbind recv)) (scall (unsafe_get_field :smulc_call recv)) (sbody (unsafe_get_field :smulc_body recv)) (newenv (fresh_env env)) ) (debug "normexp_multicall scall" scall) (multicall (ncall ncallbindings) (normal_exp scall env ncx sloc) (debug "normexp_multicall ncall=" ncall " ncallbindings=" ncallbindings) ;;; since ncall is normalized, it is a class_nrep_locsymocc and ;;; the last binding in ncallbindings is a class_normal_let_binding ;;; whose binder is the nocc_symb of the ncall (assert_msg "normexp_multicall check ncall" (is_a ncall class_nrep_locsymocc) ncall) (let ( (ncallsym (unsafe_get_field :nocc_symb ncall)) (ncontcall (reference ())) ;container to contain the real normalized call (nrealcall ()) ;the real call (nincallbindings (make_list discr_list)) ;list of internal bindings to the call ) (list_iterate_test ;loop exited when cbnd is for ncallsym ncallbindings (lambda (cbnd) (assert_msg "normexp_multicall check cbnd" (is_a cbnd class_normal_let_binding) cbnd) (if (== ncallsym (unsafe_get_field :binder cbnd)) (let ( (nrealcallex (unsafe_get_field :letbind_expr cbnd)) ) (set_ref ncontcall nrealcallex) (return () ())) (progn (list_append nincallbindings cbnd) (return cbnd ()))) )) (setq nrealcall (deref ncontcall)) (debug "normexp_multicall got nrealcall" nrealcall) (multiple_every sresbind (lambda (bnd :long ix) (put_env newenv bnd))) (multicall (nbody nbodybindings) (normalize_tuple sbody newenv ncx sloc) (debug "normexp_multicall nbody=" nbody " nbodybindings=" nbodybindings) (let ( (wnbodylet (wrap_normal_letseq nbody nbodybindings sloc)) ) ;;; remove every locally bound symbol from the symbol cache map (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) ) (multiple_every sresbind (lambda (bnd) (mapobject_remove sycmap (unsafe_get_field :binder bnd)) ))) (let ( (lastnbody (multiple_nth nbody -1)) (lastntype (if lastnbody (get_ctype lastnbody newenv) ctype_void)) (csym (clone_symbol 'multi_)) (cbind (instance class_normal_let_binding :binder csym :letbind_loc sloc :letbind_type lastntype ; :letbind_expr filled below )) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp lastntype :nocc_symb csym :nocc_bind cbind)) ) ;;; handle differently apply & sends (cond ( (is_a scall class_source_apply) (assert_msg "normexp_multicall check nrealcall apply" (is_a nrealcall class_nrep_apply) nrealcall) (let ( (nres (instance class_nrep_multiapply :nrep_loc sloc :napp_fun (unsafe_get_field :napp_fun nrealcall) :nexpr_args (unsafe_get_field :nexpr_args nrealcall) :nexpr_ctyp lastntype :nmulapp_bindings sresbind :nmulapp_body wnbodylet)) ) (unsafe_put_fields cbind :letbind_expr nres) (list_append nincallbindings cbind) (debug "normexp_multicall multiapply result clocc=" clocc " nincallbindings=" nincallbindings) (return clocc nincallbindings) ) ) ( (is_a scall class_source_msend) (debug "normexp_multicall multicall nrealcall" nrealcall) (compile_warning "in normexp_multicall we should check against the formals of the selector if available") (assert_msg "normexp_multicall check nrealcall send" (is_a nrealcall class_nrep_msend) nrealcall) (let ( (nrecv (get_field :nsend_recv nrealcall)) (nres (instance class_nrep_multimsend :nrep_loc sloc :nexpr_ctyp lastntype :nsend_sel (unsafe_get_field :nsend_sel nrealcall) :nsend_recv nrecv :nexpr_args (unsafe_get_field :nexpr_args nrealcall) :nmulsend_bindings sresbind :nmulsend_body wnbodylet)) ) (debug "normexp_multicall nrecv from multicall=" nrecv) (assert_msg "check nrecv" (is_object nrecv) nrecv) (unsafe_put_fields cbind :letbind_expr nres) (list_append nincallbindings cbind) (debug "normexp_multicall multisend result clocc=" clocc " nincallbindings=" nincallbindings) (return clocc nincallbindings) ) ) ( :else (error_at sloc "MULTICALL-ed expression neither apply nor send") (return ()) ) )))))))) (install_method class_source_multicall normal_exp normexp_multicall) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun normexp_tuple (recv env ncx psloc) (assert_msg "check tuple recv" (is_a recv class_source_tuple) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (debug "normexp_tuple recv" recv) (let ( (sloc (unsafe_get_field :loca_location recv)) (sargs (unsafe_get_field :sargop_args recv)) (csymrec (clone_symbol 'tuplrec_)) (csymtup (clone_symbol 'tuple_)) (normdiscrmult (normal_predef discr_multiple ncx sloc "discr_multiple")) (newenv (fresh_env env)) ) (debug "normexp_tuple csymrec" csymrec) (multicall (nargs nbindings) (normalize_tuple sargs env ncx sloc) (debug "normexp_tuple nargs=" nargs " nbindings=" nbindings) ;; insight: normalize (tuple x1 x2) exactly as ;; as an anonymous letrec (letrec ( (constupbind (instance class_normal_constructed_tuple_binding :binder csymrec :nconsb_loc sloc :nconsb_discr normdiscrmult :nconsb_nletrec nletrec :ntupb_comp nargs )) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_value :nocc_symb csymrec :nocc_bind constupbind)) (tup1bind (tuple constupbind)) (tup1loc (tuple clocc)) (nbdy (tuple clocc)) (nletrec (instance class_nrep_letrec :nrep_loc sloc :nlet_bindings tup1bind :nlet_body nbdy :nletrec_fill_bindings () :nletrec_body_bindings () ;; perhaps we should avoid having tup1loc to share the same location ;; for the letrec and the tuple result? :nletrec_locsyms tup1loc )) (ctupbind (instance class_normal_let_binding :binder csymtup :letbind_loc sloc :letbind_type ctype_value :letbind_expr nletrec)) (ctuplocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_value :nocc_symb csymtup :nocc_bind ctupbind)) (ctupbindlist (list ctupbind)) ) (if (null nbindings) (setq nbindings ctupbindlist) (list_append nbindings ctupbind) ) (debug "normexp_tuple ctupbind" ctupbind) (foreach_pair_component_in_list (nbindings) (curpair curbind) (put_env newenv curbind) ) (foreach_in_multiple (nargs) (curnarg :long nix) (let ( (curctype (get_ctype curnarg newenv)) ) (assert_msg "check curctype" (is_a curctype class_ctype)) (when (!= curctype ctype_value) (debug "normexp_tuple bad curnarg=" curnarg " of curctype=" curctype) (error_at sloc "(TUPLE ...) argument #$1 should be value got $2" nix (get_field :named_name curctype)) (return))) ) (debug "normexp_tuple return ctuplocc=" ctuplocc " nbindings=" nbindings) (return ctuplocc nbindings) ) ;; ))) (install_method class_source_tuple normal_exp normexp_tuple) ;;;;;;;;;;;;;;;; (defun normexp_list (recv env ncx psloc) (assert_msg "check list recv" (is_a recv class_source_list) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (debug "normexp_list recv" recv) (let ( (sloc (or (unsafe_get_field :loca_location recv) psloc)) (sargs (unsafe_get_field :sargop_args recv)) (csymrec (clone_symbol 'listrec_)) (csymlist (clone_symbol 'list_)) (normdiscrpair (normal_predef discr_pair ncx sloc "discr_pair")) (normdiscrlist (normal_predef discr_pair ncx sloc "discr_list")) (newenv (fresh_env env)) (:long nbargs (multiple_length sargs)) (consbindtup (list_to_multiple (prepare_constructor_binding recv csymlist ncx sloc))) (resbindings (make_list discr_list)) (conslistbind (multiple_nth consbindtup -1)) (tuprecloc (multiple_map consbindtup (lambda (curbind :long bindix) (debug "normexp_list curbind" curbind) (assert_msg "check curbind" (is_a curbind class_normal_constructor_binding) curbind) (instance class_nrep_locsymocc :nrep_loc (or (get_field :nconsb_loc curbind) sloc) :nocc_ctyp ctype_value :nocc_symb (get_field :binder curbind) :nocc_bind curbind) ) )) ) (debug "normexp_list csymrec=" csymrec " consbindtup=" consbindtup " conslistbind=" conslistbind " tuprecloc=" tuprecloc) (assert_msg "check conslistbind" (is_a conslistbind class_normal_constructed_list_binding) conslistbind) (multicall (nargs nbindings) (normalize_tuple sargs env ncx sloc) (debug "normexp_list nargs=" nargs " nbindings=" nbindings) (assert_msg "check nbindings" (is_list_or_null nbindings) nbindings) (list_append2list resbindings nbindings) (foreach_pair_component_in_list (resbindings) (curpairbind curbind) (put_env newenv curbind) ) (foreach_in_multiple (nargs) (curnarg :long nix) (if (!= (get_ctype curnarg newenv) ctype_value) (progn (debug "normexp_list bad curnarg" curnarg) (error_at sloc "(LIST ...) argument #$1 should be value" nix) (return)))) (letrec ( (creclocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_value :nocc_symb csymrec :nocc_bind conslistbind)) (nbdy (tuple creclocc)) (nletrec (instance class_nrep_letrec :nrep_loc sloc :nlet_bindings consbindtup :nlet_body nbdy :nletrec_fill_bindings () :nletrec_body_bindings () :nletrec_locsyms tuprecloc )) (clistbind (instance class_normal_let_binding :binder csymlist :letbind_loc sloc :letbind_type ctype_value :letbind_expr nletrec)) (clistlocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_value :nocc_symb csymlist :nocc_bind clistbind)) (clistbindlist (list clistbind)) ) (foreach_in_multiple (nargs) (curnarg :long nix) (let ( (curpairb (multiple_nth consbindtup nix)) (nextb (multiple_nth consbindtup (+i nix 1))) ) (put_int curpairb nix) (debug "normexp_list curpairb" curpairb) (assert_msg "check curpairb" (is_a curpairb class_normal_constructed_pair_binding) curpairb) (assert_msg "check curpairb objnum" (==i (get_int curpairb) nix) curpairb nix) (debug "normexp_list curnarg=" curnarg " nextb=" nextb) (assert_msg "check nextb" (is_a nextb class_normal_constructor_binding) nextb) (let ( (nextsym (get_field :binder nextb)) (nextloc (if (is_a nextb class_normal_constructed_pair_binding) (nreclist_find_locsym nextsym nletrec))) ) (put_fields curpairb :npairb_head curnarg :npairb_tail nextloc :nconsb_nletrec nletrec) (debug "normexp_list updated curpairb" curpairb) ) )) ;; ;; update the list binding (let ( (firstpairb (multiple_nth consbindtup 0)) (lastpairb (multiple_nth consbindtup -2)) (firstpairsymb (if (is_a firstpairb class_normal_constructed_pair_binding) (unsafe_get_field :binder firstpairb))) (lastpairsymb (if (is_a lastpairb class_normal_constructed_pair_binding) (unsafe_get_field :binder lastpairb))) (firstpairloc (if firstpairsymb (nreclist_find_locsym firstpairsymb nletrec))) (lastpairloc (if lastpairsymb (nreclist_find_locsym lastpairsymb nletrec))) ) (put_fields conslistbind :nlistb_first firstpairloc :nlistb_last lastpairloc :nconsb_nletrec nletrec) (put_int conslistbind nbargs) (debug "normexp_list updated conslistbind" conslistbind) ) ;; (if (null nbindings) (setq nbindings clistbindlist) (list_append nbindings clistbind) ) (debug "normexp_list final nletrec=" nletrec " clistlocc=" clistlocc " nbindings=" nbindings) (return clistlocc nbindings) )))) (install_method class_source_list normal_exp normexp_list) ;;;;;;;;;;;;;;;; (defun normexp_arithmetic_variadic_operation (recv env ncx psloc) (debug "normexp_arithmetic_variadic_operation recv" recv) (assert_msg "check recv" (is_a recv class_source_arithmetic_variadic_operation) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (or (unsafe_get_field :loca_location recv) psloc)) (sargs (unsafe_get_field :sargop_args recv)) (sneutral (unsafe_get_field :sarithvar_neutral recv)) (sprimitive (unsafe_get_field :sarithvar_primitive recv)) ) (debug "normexp_arithmetic_variadic_operation sprimitive=" sprimitive " sneutral=" sneutral) (assert_msg "check sprimitive" (is_a sprimitive class_primitive) sprimitive) (assert_msg "check sneutral" (is_integerbox sneutral) sneutral) ;; actually, we normalize only to check the type here. We produce ;; a source primitive which is normalized again. (multicall (nargs nbindings) (normalize_tuple sargs env ncx sloc) (debug "normexp_arithmetic_variadic_operation nargs=" nargs " nbindings=" nbindings) (assert_msg "check nbindings" (is_list_or_null nbindings) nbindings) ;; check that all arguments are :long (foreach_in_multiple (nargs) (curnarg :long argix) (let ( (argctyp (get_ctype curnarg env)) ) (when (!= argctyp ctype_long) (error_at sloc "variadic arithmetic operation requires only :long arguments got $1 at #$2"_ (get_field :named_name argctyp) argix) (return)) )) (match sargs (?(tuple ?s0) (let ( (sprim (instance class_source_primitive :loca_location sloc :sprim_oper sprimitive :sargop_args (tuple sneutral s0))) ) (debug "normexp_arithmetic_variadic_operation unary sprim=" sprim) (multicall (nrealargs nrealbindings) (normexp_primitive sprim env ncx psloc) (debug "normexp_arithmetic_variadic_operation unary result nrealargs=" nrealargs " nrealbindings=" nrealbindings) (return nrealargs nrealbindings) (void) ))) (?(tuple ?s0 ?s1) (let ( (sprim (instance class_source_primitive :loca_location sloc :sprim_oper sprimitive :sargop_args (tuple s0 s1))) ) (debug "normexp_arithmetic_variadic_operation binary sprim=" sprim) (multicall (nrealargs nrealbindings) (normexp_primitive sprim env ncx psloc) (debug "normexp_arithmetic_variadic_operation binary result nrealargs=" nrealargs " nrealbindings=" nrealbindings) (return nrealargs nrealbindings) (void) ))) (?_ (assert_msg "check #args>2" (>i (multiple_length sargs) 2) sargs) (let ( (sprim (instance class_source_primitive :loca_location sloc :sprim_oper sprimitive :sargop_args (tuple (multiple_nth sargs 0) (multiple_nth sargs 1)))) ) (foreach_in_multiple (sargs) (cursarg :long six) (if (>i six 1) (let ( (newsprim (instance class_source_primitive :loca_location sloc :sprim_oper sprimitive :sargop_args (tuple sprim cursarg))) ) (setq sprim newsprim))) ) (debug "normexp_arithmetic_variadic_operation nary sprim=" sprim) (multicall (nrealargs nrealbindings) (normexp_primitive sprim env ncx psloc) (debug "normexp_arithmetic_variadic_operation nary result nrealargs=" nrealargs " nrealbindings=" nrealbindings) (return nrealargs nrealbindings) (void) ))) )))) (install_method class_source_arithmetic_variadic_operation normal_exp normexp_arithmetic_variadic_operation) ;;;;;;;;;;;;;;;; (defselector prepare_constructor_binding class_selector :doc #{The $PREPARE_CONSTRUCTOR_BINDING selector applied to: an constructible expression $RECV, a symbol $SYMB, a normalization context $NCX, a source location $SLOC gives a half-filled instance of a sub-class of $CLASS_NORMAL_CONSTRUCTOR_BINDING.}# :formals (recv symb ncx sloc) ) (defun badmeth_prepare_constructor_binding (recv symb ncx sloc) (debug "bad_prepare_constructor_binding recv=" recv " symb=" symb) (error_at sloc "invalid constructor binding $1 of receiver dicriminant $2"_ (get_field :named_name symb) (get_field :named_name (discrim recv))) (assert_msg "@$@badmeth_prepare_constructor_binding" () recv symb) ) (install_method discr_any_receiver prepare_constructor_binding badmeth_prepare_constructor_binding) ;;;;;;;;;;;;;;;; (defselector normal_letrec_constructive class_selector :doc #{The $NORMAL_LETREC selector applied to: a constructive expression $CEXPR for receiver, a symbol $SYMB, a normal constructive binding $CBIND, an environment $ENV, a normal context $NCX, a location $SLOC}# :formals (cexpr symb cbind env ncx sloc)) (defun badmeth_normal_letrec_constructive (cexpr symb cbind env ncx sloc) (debug "badmeth_normal_letrec_constructive cexpr=" cexpr " symb=" symb " cbind=" cbind) (error_at sloc "invalid letrec constructive symbol $1 for reciever $2" (get_field :named_name symb) (get_field :named_name (discrim cexpr))) (assert_msg "@$@badmeth_normal_letrec_constructive" () cexpr symb) ) (install_method discr_any_receiver normal_letrec_constructive badmeth_normal_letrec_constructive) ;;;;;;;;;;;;;;;; (defun prepcons_lambda (recv symb ncx sloc) (debug "prepcons_lambda recv=" recv " symb=" symb) (assert_msg "check recv" (is_a recv class_source_lambda) recv) (let ( (conslam (instance class_normal_constructed_lambda_binding :binder symb :nconsb_loc sloc :nconsb_discr (normal_predef discr_closure ncx sloc "discr_closure") )) ) (debug "prepcons_lambda gives conslam" conslam) (return conslam) )) (install_method class_source_lambda prepare_constructor_binding prepcons_lambda) ;;;; (defun normletrec_lambda (cexpr symb cbind env ncx psloc) (debug "normletrec_lambda cexpr=" cexpr " symb=" symb " cbind=" cbind " env=" env) (assert_msg "check cbind" (is_a cbind class_normal_constructed_lambda_binding) cbind) (let ( (newenv (fresh_env env)) ) (debug "normletrec_lambda newenv" newenv) (assert_msg "check newenv" (is_a newenv class_environment) newenv) (multicall (nproc csym clocc constrout clovtup sloc oldproc ndatarout :long insideflag) ;;bad (normalize_lambda cexpr newenv newenv ncx psloc) (normalize_lambda cexpr env newenv ncx psloc) (debug "normletrec_lambda after normalize_lambda csym=" csym " clocc=" clocc " constrout=" constrout " clovtup=" clovtup " oldproc=" oldproc " ndatarout=" ndatarout) (if insideflag (list_append (get_field :nrclop_constlist oldproc) ndatarout)) (put_fields cbind :nlambdab_nclosed clovtup :nlambdab_constrout constrout :nlambdab_datarout ndatarout) (debug "normletrec_lambda updated cbind" cbind) (compile_warning "unimplemented normletrec_lambda, maybe store the newenv in the cbind") (shortbacktrace_dbg "normletrec_lambda ended" 15) ))) (install_method class_source_lambda normal_letrec_constructive normletrec_lambda) ;;;;;;;;;;;;;;;; (defun prepcons_tuple (recv symb ncx sloc) (debug "prepcons_tuple recv=" recv " symb=" symb) (assert_msg "check recv" (is_a recv class_source_tuple) recv) (let ( (loc (get_field :loca_location recv)) (tuparg (get_field :sargop_args recv)) (:long nbtuparg (multiple_length tuparg)) (ntup (make_multiple discr_multiple nbtuparg)) (constup (instance class_normal_constructed_tuple_binding :binder symb :nconsb_loc (or loc sloc) :nconsb_discr (normal_predef discr_multiple ncx sloc "discr_multiple") :ntupb_comp ntup )) ) (debug "prepcons_tuple gives constup" constup) (return constup) )) (install_method class_source_tuple prepare_constructor_binding prepcons_tuple) ;;;; (defun normletrec_tuple (cexpr symb cbind env ncx sloc) (debug "normletrec_tuple cexpr=" cexpr " symb=" symb " cbind=" cbind) (assert_msg "check cexpr" (is_a cexpr class_source_tuple) cexpr) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check cbind" (is_a cbind class_normal_constructed_tuple_binding) cbind) (let ( (loc (or (get_field :loca_location cexpr) sloc)) (sargs (unsafe_get_field :sargop_args cexpr)) (bcomp (get_field :ntupb_comp cbind)) (nletrec (get_field :nconsb_nletrec cbind)) (nrecbinds (get_field :nletrec_fill_bindings nletrec)) ) (debug "normletrec_tuple sargs=" sargs " bcomp=" bcomp " nletrec=" nletrec " nrecbinds=" nrecbinds) (assert_msg "check nletrec" (is_a nletrec class_nrep_letrec) nletrec) (assert_msg "check nrecbinds" (is_list nrecbinds) nrecbinds) (multicall (nargs nbinds) (normalize_tuple sargs env ncx loc) (debug "normletrec_tuple nargs=" nargs " nbinds=" nbinds) (assert_msg "check nargs & bcomp samelength" (==i (multiple_length bcomp) (multiple_length nargs)) nargs bcomp) (assert_msg "check nbinds" (is_list_or_null nbinds) nbinds) (foreach_in_multiple (nargs) (curnarg :long nix) (multiple_put_nth bcomp nix curnarg)) (debug "normletrec_tuple updated bcomp" bcomp) (list_append2list nrecbinds nbinds) (debug "normletrec_tuple updated nrecbinds" nrecbinds) (shortbacktrace_dbg "normletrec_tuple ended" 15) ))) (install_method class_source_tuple normal_letrec_constructive normletrec_tuple) ;;;;;;;;;;;;;;;; (defun prepcons_list (recv symb ncx sloc) (debug "prepcons_list recv=" recv " symb=" symb) (assert_msg "check recv" (is_a recv class_source_list) recv) (let ( (reslist (make_list discr_list)) (loc (get_field :loca_location recv)) (listarg (get_field :sargop_args recv)) (:long nblistarg (multiple_length listarg)) (pairsb (make_multiple discr_multiple nblistarg)) (conslist (instance class_normal_constructed_list_binding :binder symb :nconsb_loc (or loc sloc) :nconsb_discr (normal_predef discr_list ncx sloc "discr_list") :nlistb_first () :nlistb_last () :nlistb_pairsb pairsb )) ) (foreach_in_multiple (listarg) (curarg :long curix) (debug "prepcons_list curarg" curarg) (let ( (pairsymb (clone_symbol (if (is_a curarg class_named) curarg '_pairoflist))) (conspair (instance class_normal_constructed_pair_binding :binder pairsymb :nconsb_loc (or (get_field :loca_location curarg) loc sloc) :nconsb_discr (normal_predef discr_pair ncx sloc "discr_pair") :npairb_head () :npairb_tail () )) ) (multiple_put_nth pairsb curix conspair) (list_append reslist conspair) )) (list_append reslist conslist) (debug "prepcons_list gives reslist" reslist) (return reslist) )) (install_method class_source_list prepare_constructor_binding prepcons_list) ;;;; ;; auxiliary function to find a symbol in the locsym of a nletrec (defun nreclist_find_locsym (symb nletrec) (debug "nreclist_find_locsym symb=" symb) (assert_msg "check symb" (is_a symb class_symbol) symb) (assert_msg "check nletrec" (is_a nletrec class_nrep_letrec) nletrec) (let ( (nlocsyms (get_field :nletrec_locsyms nletrec)) ) (foreach_in_multiple (nlocsyms) (curlocsym :long locsymix) (if (== (get_field :nocc_symb curlocsym) symb) (progn (debug "nreclist_find_locsym found curlocsym" curlocsym) (return curlocsym)))) (debug "nreclist_find_locsym not found") (return) )) (defun normletrec_list (cexpr symb cbind env ncx sloc) (debug "normletrec_list cexpr=" cexpr " symb=" symb " cbind=" cbind) (assert_msg "check cexpr" (is_a cexpr class_source_list) cexpr) ;; here cbind is a tuple of constructor bindings -for all the pairs ;; & the list (assert_msg "check cbind is tuple" (is_multiple cbind) cbind) (let ( (loc (or (get_field :loca_location cexpr) sloc)) (sargs (get_field :sargop_args cexpr)) (conslibind (multiple_nth cbind -1)) (nletrec (get_field :nconsb_nletrec conslibind)) (nrecbinds (get_field :nletrec_fill_bindings nletrec)) (nlocsyms (get_field :nletrec_locsyms nletrec)) (firstpairbind (multiple_nth cbind 0)) (lastpairbind (multiple_nth cbind -2)) ) (debug "normletrec_list conslibind" conslibind) (assert_msg "check conslibind" (is_a conslibind class_normal_constructed_list_binding) conslibind) (debug "normletrec_list sargs=" sargs " nletrec=" nletrec " nrecbinds=" nrecbinds) (assert_msg "check nletrec" (is_a nletrec class_nrep_letrec) nletrec) (assert_msg "check nrecbinds" (is_list nrecbinds) nrecbinds) (multicall (nargs nbinds) (normalize_tuple sargs env ncx loc) (debug "normletrec_list nargs=" nargs " nbinds=" nbinds) (assert_msg "check nbinds" (is_list_or_null nbinds) nbinds) (assert_msg "check nargs's length vs cbind's length" (==i (multiple_length nargs) (-i (multiple_length cbind) 1)) nargs cbind) (foreach_in_multiple (nargs) (curnarg :long nix) (debug "normletrec_list curnarg" curnarg) (let ( (curcbind (multiple_nth cbind nix)) (nextcbind (multiple_nth cbind (+i 1 nix))) (nextpairsymb (if (is_a nextcbind class_normal_constructed_pair_binding) (get_field :binder nextcbind))) ) (debug "normletrec_list curcbind=" curcbind " nextcbind=" nextcbind " nextpairsymb=" nextpairsymb) (assert_msg "check curcbind" (is_a curcbind class_normal_constructed_pair_binding) curcbind) (let ( (nextpairloc (if nextpairsymb (nreclist_find_locsym nextpairsymb nletrec))) ) (debug "normletrec_list got nextpairloc" nextpairloc) (put_fields curcbind :npairb_head curnarg :npairb_tail nextpairloc) (debug "normletrec_list updated curcbind" curcbind) (assert_msg "check curcbind" (is_a curcbind class_normal_constructed_pair_binding) curcbind) ))) (debug "normletrec_list firstpairbind=" firstpairbind " lastpairbind=" lastpairbind " conslibind=" conslibind) (and (is_a firstpairbind class_normal_constructed_pair_binding) (is_a lastpairbind class_normal_constructed_pair_binding) (let ( (firstpairsymb (get_field :binder firstpairbind)) (lastpairsymb (get_field :binder lastpairbind)) (firstpairlocsy (nreclist_find_locsym firstpairsymb nletrec)) (lastpairlocsy (nreclist_find_locsym lastpairsymb nletrec)) ) (debug "normletrec_list firstpairlocsy=" firstpairlocsy " lastpairlocsy=" lastpairlocsy) (put_fields conslibind :nlistb_first firstpairlocsy :nlistb_last lastpairlocsy) (debug "normletrec_list updated conslibind" conslibind) (void) )) (debug "normletrec_list appending nbinds" nbinds) (list_append2list nrecbinds nbinds) (debug "normletrec_list ended updated nrecbinds" nrecbinds) ))) (install_method class_source_list normal_letrec_constructive normletrec_list) ;;;;;;;;;;;;;;;; (defun prepcons_instance (recv symb ncx sloc) (debug "prepcons_instance recv=" recv " symb=" symb) (assert_msg "check recv" (is_a recv class_source_instance) recv) (let ( (loc (get_field :loca_location recv)) (cla (get_field :smins_class recv)) (clabind (get_field :smins_clabind recv)) (sclasym (if (is_a clabind class_any_binding) (unsafe_get_field :binder clabind))) (:long nbclafld (multiple_length (get_field :class_fields cla))) (tupslot (make_multiple discr_multiple nbclafld)) (consinst (instance class_normal_constructed_instance_binding :binder symb :nconsb_loc (or loc sloc) :nconsb_discr (compile_warning "don't forget to set the discr later...") :ninstb_slots tupslot :ninstb_clabind clabind )) ) (assert_msg "prepcons_instance check class" (is_a cla class_class) cla) (debug "prepcons_instance gives consinst" consinst) (return consinst) ) ) (install_method class_source_instance prepare_constructor_binding prepcons_instance) ;;;; (defun normletrec_instance (cexpr symb cbind env ncx sloc) (debug "normletrec_instance cexpr=" cexpr " symb=" symb " cbind=" cbind) (let ( (loc (or (unsafe_get_field :loca_location cexpr) sloc)) (bslots (get_field :ninstb_slots cbind)) (nletrec (get_field :nconsb_nletrec cbind)) (nrecbinds (get_field :nletrec_fill_bindings nletrec)) (sclass (unsafe_get_field :smins_class cexpr)) (sclabind (unsafe_get_field :smins_clabind cexpr)) (sfields (unsafe_get_field :smins_fields cexpr)) (sclasym (if (is_a sclabind class_any_binding) (unsafe_get_field :binder sclabind))) (cladata (if (is_a sclasym class_symbol) (normal_exp sclasym env ncx sloc))) (bindlist (make_list discr_list)) ) (debug "normletrec_instance nletrec" nletrec) (when (not (is_a cladata class_nrep)) (error_at sloc "invalid class in (INSTANCE $1 ...)" (unsafe_get_field :named_name sclass)) (return ())) (let ( (nfields (multiple_map sfields (lambda (curflda :long curk) (assert_msg "check curflda" (is_a curflda class_source_fieldassign) curflda) (let ( (curfloc (unsafe_get_field :loca_location curflda)) (curfield (unsafe_get_field :sfla_field curflda)) (curexp (unsafe_get_field :sfla_expr curflda)) ) (if (null curfloc) (setq curfloc sloc)) (multicall (nexp nbind) (normal_exp curexp env ncx curfloc) (debug "normletrec_instance nexp" nexp) (assert_msg "check nbind" (is_list_or_null nbind) nbind) (list_append2list bindlist nbind) (instance class_nrep_fieldassign :nrep_loc curfloc :nfla_field curfield :nfla_val nexp) ))))) ) (debug "normletrec_instance nfields" nfields) (foreach_in_multiple (nfields) (curnfieldass :long fldix) (debug "normletrec_instance curnfieldass" curnfieldass) (let ( (curfield (get_field :nfla_field curnfieldass)) (curfval (get_field :nfla_val curnfieldass)) (curfloc (get_field :nrep_loc curnfieldass)) (:long curfoff (get_int curfield)) ) (assert_msg "check curfield " (is_a curfield class_field) curfield) (let ( (fctyp (get_ctype curfval env)) ) (if (!= fctyp ctype_value) (error_at curfloc "invalid field $1 type in (LETREC .. (INSTANCE ..); expecting a :value gotten a $2"_ (get_field :named_name curfield) (get_field :named_name fctyp)))) (multiple_put_nth bslots curfoff curfval) )) (list_append2list nrecbinds bindlist) (debug "normletrec_instance ended updated nrecbinds" nrecbinds) ) )) (install_method class_source_instance normal_letrec_constructive normletrec_instance) ;;;;;;;;;;;;;;;; (defun normexp_letrec (recv env ncx psloc) (assert_msg "check letrec recv" (is_a recv class_source_letrec) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (debug "normexp_letrec recv" recv) (let ( (sloc (unsafe_get_field :loca_location recv)) (sbinds (unsafe_get_field :slet_bindings recv)) (sbody (unsafe_get_field :slet_body recv)) (:long nbbind (multiple_length sbinds)) (bindlist (make_list discr_list)) (consbindlist (make_list discr_list)) (newenv (fresh_env env)) (:long maplen (+i 5 (*i nbbind 2))) (symbexprmap (make_mapobject discr_map_objects maplen)) (symbindmap (make_mapobject discr_map_objects maplen)) ) ;;; first preparation loop (foreach_in_multiple (sbinds) (cursbind :long sbix) (debug "normexp_letrec cursbind" cursbind) (assert_msg "check cursbind" (is_a cursbind class_source_letrec_binding) cursbind) (let ( (locb (or (unsafe_get_field :loca_location cursbind) sloc psloc)) (cursymb (unsafe_get_field :sletb_binder cursbind)) (curexpr (unsafe_get_field :sletb_expr cursbind)) ) (debug "normexp_letrec curexpr=" curexpr " cursymb=" cursymb) (assert_msg "check curexpr" (is_a curexpr class_source) curexpr) (assert_msg "check cursymb" (is_a cursymb class_symbol) cursymb) (mapobject_put symbexprmap cursymb curexpr) (let ( (curconsbind (prepare_constructor_binding curexpr cursymb ncx locb)) ) (debug "normexp_letrec curconsbind" curconsbind) (cond ( (is_a curconsbind class_normal_constructor_binding) (debug "normexp_letrec curconsbind plain consbind" curconsbind) (list_append consbindlist curconsbind) (mapobject_put symbindmap cursymb curconsbind) ) ( (is_multiple curconsbind) (debug "normexp_letrec curconsbind multiple" curconsbind) (foreach_in_multiple (curconsbind) (subconsbind :long subix) (assert_msg "normexp_letrec check subconsbind" (is_a subconsbind class_normal_constructor_binding) subconsbind) (list_append consbindlist subconsbind)) (mapobject_put symbindmap cursymb curconsbind) ) ( (is_list curconsbind) (debug "normexp_letrec curconsbind list" curconsbind) (foreach_pair_component_in_list (curconsbind) (subconspair subconsbind) (assert_msg "normexp_letrec check subconsbind" (is_a subconsbind class_normal_constructor_binding) subconsbind) (list_append consbindlist subconsbind)) (mapobject_put symbindmap cursymb (list_to_multiple curconsbind discr_multiple)) ) (:else (assert_msg "normexp_letrec bad curconsbind" () curconsbind) )) ) ) ) (debug "normexp_letrec consbindlist" consbindlist) (let ( (:long nbconsbind (list_length consbindlist)) (:long curcix 0) (nlocsyms (make_multiple discr_multiple nbconsbind)) (ncbindtup (make_multiple discr_multiple nbconsbind)) (recfillbindings (make_list discr_list)) (nletrec (instance class_nrep_letrec :nrep_loc sloc :nlet_bindings ncbindtup :nletrec_fill_bindings recfillbindings :nletrec_locsyms nlocsyms ;; nlet_body & nletrec_body_bindings is set after :nlet_body () :nletrec_body_bindings () )) ) (debug "normexp_letrec unfilled nletrec" nletrec) ;; ;; second loop to make an environment where each constructive ;; binding is set, and to create the local symbol occurrences (foreach_pair_component_in_list (consbindlist) (curpair curcbind) (debug "normexp_letrec curcbind" curcbind) (assert_msg "check curcbind" (is_a curcbind class_normal_constructor_binding) curcbind) (multiple_put_nth ncbindtup curcix curcbind) (put_int curcbind curcix) (put_fields curcbind :nconsb_nletrec nletrec) (let ( (curbdiscr (unsafe_get_field :nconsb_discr curcbind)) (curbinder (unsafe_get_field :binder curcbind)) (nlocsym (instance class_nrep_locsymocc :nrep_loc (or (get_field :nconsb_loc curcbind) sloc psloc) :nocc_ctyp ctype_value :nocc_symb curbinder :nocc_bind curcbind )) ) (multiple_put_nth nlocsyms curcix nlocsym) (if (null curbdiscr) (let ( (clabind (get_field :ninstb_clabind curcbind)) (clasym (get_field :binder clabind)) ) (debug "normexp_letrec clabind=" clabind " clasym=" clasym) ;; the only case when this happens is for instance constructors... (assert_msg "check curcbind for instance" (is_a curcbind class_normal_constructed_instance_binding) curcbind) (let ( ;; we normalize the class symbol in the parent environment, not the new one! (cladata (normal_exp clasym env ncx sloc)) ) (debug "normexp_letrec cladata" cladata) (assert_msg "check cladata" (is_a cladata class_nrep) cladata) (put_fields curcbind :nconsb_discr cladata) ))) ) (setq curcix (+i curcix 1)) (put_env newenv curcbind) (compile_warning "normexp_letrec should normalize the expression using symbexprmap & curbinder...") ) ;;; third loop to normalize the bindings content (foreach_in_multiple (sbinds) (cursbind :long sbix) (debug "normexp_letrec thirdloop cursbind=" cursbind " sbix=" sbix) (assert_msg "check cursbind" (is_a cursbind class_source_letrec_binding) cursbind) (let ( (locb (or (unsafe_get_field :loca_location cursbind) sloc psloc)) (cursymb (unsafe_get_field :sletb_binder cursbind)) (curexpr (unsafe_get_field :sletb_expr cursbind)) (curbind (mapobject_get symbindmap cursymb)) (cursexpr (mapobject_get symbexprmap cursymb)) ) (debug "normexp_letrec thirdloop curexpr=" curexpr " cursymb=" cursymb " curbind=" curbind " cursexpr=" cursexpr) (assert_msg "check curxpr same cursexpr" (== curexpr cursexpr) cursexpr cursexpr) (normal_letrec_constructive curexpr cursymb curbind newenv ncx sloc) (debug "normexp_letrec thirdloop done curexpr" curexpr) ) ) (debug "normexp_letrec recfillbindings before normalizing the body" recfillbindings) ;;; ;;; normalize the body (debug "normexp_letrec normalizing sbody" sbody) (multicall (nbody nbodbindings) (normalize_tuple sbody newenv ncx sloc) (debug "normexp_letrec nbody=" nbody " nbodbindings=" nbodbindings) (assert_msg "normexp_letrec check nbodbindings" (is_list_or_null nbodbindings) nbodbindings) (put_fields nletrec :nlet_body nbody :nletrec_body_bindings nbodbindings) (debug "normexp_letrec updated nletrec" nletrec) (assert_msg "normexp_letrec check bindlist" (is_list_or_null bindlist) bindlist) ;;; remove every locally bound symbol from the symbol cache map (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) ) (foreach_pair_component_in_list (bindlist) (curpair bnd) (debug "normexp_letrec removing from sycmap bnd" bnd) (assert_msg "normexp_letrec check bnd" (is_a bnd class_normal_let_binding) bnd) (mapobject_remove sycmap (unsafe_get_field :binder bnd)) )) ;;;; make the result (let ( (nlastbody (multiple_nth nbody -1)) ;; the type of a let with empty body is void (nlastyp (or (get_ctype nlastbody newenv) ctype_void)) (csym (clone_symbol 'letrec_)) (cbind (instance class_normal_let_binding :binder csym :letbind_loc sloc :letbind_type nlastyp :letbind_expr nletrec)) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp nlastyp :nocc_bind cbind)) (resbinds (make_list discr_list)) ) (list_append resbinds cbind) (debug "normexp_letrec result clocc=" clocc " nletrec=" nletrec " resbinds=" resbinds) (shortbacktrace_dbg "normexp_letrec ending" 15) (return clocc resbinds) ))))) (install_method class_source_letrec normal_exp normexp_letrec) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; create the normal predef (or fail with a msg) (defun normal_predef (pred ncx sloc :cstring predname) (debug "normal_predef pred=" pred) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (predefmap (unsafe_get_field :nctx_predefmap ncx)) (brk (or (mapobject_get predefmap pred) (get_raw_symbol predname))) ) (debug "normal_predef brk=" brk) (if (or (is_integerbox brk) (is_a brk class_symbol)) (let ( (res (instance class_nrep_predef :nrep_loc sloc :nrpredef brk)) ) (debug "normal_predef res=" res) (return res)) (progn (debug "normalpredef fail predefmap=" predefmap " pred=" pred) (error_at sloc "not a predef: $1" (make_stringconst discr_verbatim_string predname)) (return ()) )))) ;; retrieve or create the normalized datasym for a symbol (defun normal_symbol_data (sym ncx sloc) ;; sym should be strictly a symbol (not be in a subclass of class_symbol!) (debug "normal_symbol_data start sym=" sym) (shortbacktrace_dbg "normal_symbol_data" 12) (assert_msg "check sym" (== (discrim sym) class_symbol) sym) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (valmap (unsafe_get_field :nctx_valmap ncx)) (osydata (mapobject_get valmap sym)) ) (debug "normal_symbol_data osydata=" osydata) (when osydata (debug "normal_symbol_data found osydata" osydata) (return osydata)) (let ( (:long syhash (obj_hash sym)) (synamstr (unsafe_get_field :named_name sym)) ;; make the datastring from synamstr (synamstrdata (instance class_nrep_datastring :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") :nstr_string synamstr )) (syslots (make_multiple discr_multiple (multiple_length (unsafe_get_field :class_fields class_symbol)))) (sydata (instance class_nrep_datasymbol :ndata_name sym :ndata_discrx (normal_predef class_symbol ncx sloc "class_symbol") :ninst_hash (make_integerbox discr_integer syhash) :ninst_slots syslots :ndsy_namestr synamstr)) ) (debug "normal_symbol_data sydata=" sydata "\n.. synamstrdata=" synamstrdata) (multiple_put_nth syslots (obj_num named_name) synamstrdata) (add_nctx_data ncx sydata) (add_nctx_data ncx synamstrdata) (mapobject_put valmap sym sydata) (mapstring_putstr (unsafe_get_field :nctx_symbmap ncx) synamstr sydata) (debug "normal_symbol_data return sydata" sydata) (return sydata) ))) ;; retrieve or create the normalized datakeyword for a keyword (defun normal_keyword_data (keyw ncx sloc) ;; keyw should be strictly a keyword (not be in a subclass of class_keyword!) (debug "normal_keyword_data keyw=" keyw) (assert_msg "check keywb" (== (discrim keyw) class_keyword) keyw) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (valmap (unsafe_get_field :nctx_valmap ncx)) (osydata (mapobject_get valmap keyw)) ) (if osydata osydata (let ( (:long syhash (obj_hash keyw)) (synamstr (unsafe_get_field :named_name keyw)) ;; make the datastring from synamstr (synamstrdata (instance class_nrep_datastring :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") :nstr_string synamstr )) (syslots (make_multiple discr_multiple (multiple_length (unsafe_get_field :class_fields class_keyword)))) (sydata (instance class_nrep_datakeyword :ndata_name keyw :ndata_discrx (normal_predef class_keyword ncx sloc "class_keyword") :ninst_hash (make_integerbox discr_integer syhash) :ninst_slots syslots :ndsy_namestr synamstr)) ) (shortbacktrace_dbg "normal_keyword_data" 15) (debug "normal_keyword_data sydata=" sydata "\n ..keyw=" keyw) (multiple_put_nth syslots (obj_num named_name) synamstrdata) (add_nctx_data ncx sydata) (add_nctx_data ncx synamstrdata) (mapobject_put valmap keyw sydata) (mapstring_putstr (unsafe_get_field :nctx_keywmap ncx) synamstr sydata) (debug "normal_keyword_data return sydata=" sydata) (return sydata) )))) ;; create the tuples of slots of a datainstance for a particular class (defun create_data_slots (cla) (assert_msg "check cla" (is_a cla class_class) cla) (debug "create_data_slots cla" cla) (let ( (tupslo (make_multiple discr_multiple (multiple_length (unsafe_get_field :class_fields cla)))) ) (debug "create_data_slots tupslo" tupslo) tupslo )) ;; fill a slot of a datainstance (defun fill_data_slot (di field val) (assert_msg "check di" (is_a di class_nrep_datainstance) di) (assert_msg "check field" (is_a field class_field)) (let ( (:long fix (obj_num field)) (slots (unsafe_get_field :ninst_slots di)) ) (multiple_put_nth slots fix val) )) ;;;;;; normalize a QUOTE-d symbol, string or integer (defun normexp_quote (recv env ncx psloc) (debug "normexp_quote recv=" recv) (assert_msg "check quote recv" (is_a recv class_source_quote) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (shortbacktrace_dbg "normexp_quote" 16) (let ( (sloc (unsafe_get_field :loca_location recv)) (quoted (unsafe_get_field :squoted recv)) (curproc (unsafe_get_field :nctx_curproc ncx)) (ndata (cond ( (== (discrim quoted) class_symbol) (debug "normexp_quote symbol quoted=" quoted) (normal_symbol_data quoted ncx psloc)) ( (is_integerbox quoted) (debug "normexp_quote integer quoted=" quoted) (let ( (nintdata (instance class_nrep_databoxedinteger :ndata_discrx (normal_predef discr_constant_integer ncx sloc "discr_constant_integer") :nboxint_num quoted)) ) (debug "normexp_quote nintdata=" nintdata) (add_nctx_data ncx nintdata) nintdata )) ( (is_string quoted) (debug "normexp_quote string quoted=" quoted) (let ( (nstrdata (instance class_nrep_datastring :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") :nstr_string quoted)) ) (debug "normexp_quote nstrdata=" nstrdata) (add_nctx_data ncx nstrdata) nstrdata)) (:else ;; this should not happen, because it is checked at ;; macroexpansion time. (assert_msg "unexpected quoted stuff" () quoted)) )) ) (debug "normexp_quote ndata=" ndata "\n.. curproc=" curproc) (if (is_a curproc class_nrep_closproc) (let ( (nconst (instance class_nrep_constant :nrep_loc sloc :nconst_sval quoted :nconst_data ndata :nconst_proc curproc )) ) (list_append (get_field :nrclop_constlist curproc) ndata) (debug "normexp_quote in routine nconst=" nconst) (return nconst ())) (progn (debug "normexp_quote in init ndata=" ndata) (return ndata ()) )))) (install_method class_source_quote normal_exp normexp_quote) ;;;;;; normalize a COMMENT (defun normexp_comment (recv env ncx psloc) (debug "normexp_comment start recv" recv) (assert_msg "check comment recv" (is_a recv class_source_comment) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (scomm (unsafe_get_field :scomm_str recv)) (ncomm (instance class_nrep_comment :nrep_loc sloc :ncomm_string scomm )) (csym (clone_symbol 'comment_)) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type ctype_void :letbind_expr ncomm)) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_void :nocc_symb csym :nocc_bind cbind)) (bindlist (make_list discr_list)) ) (if scomm (assert_msg "check scomm" (is_string scomm) scomm)) (list_append bindlist cbind) (debug "normexp_comment end ncomm=" ncomm " return clocc=" clocc " bindlist=" bindlist) (return clocc bindlist) )) (install_method class_source_comment normal_exp normexp_comment) ;;;;;; normalize a keyword (defun normexp_keyword (recv env ncx psloc) (debug "normexp_keyword recv=" recv) (shortbacktrace_dbg "normexp_keyword" 10) (assert_msg "check keyword recv" (is_a recv class_keyword) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (curproc (unsafe_get_field :nctx_curproc ncx)) (constlist (get_field :nrclop_constlist curproc)) (objconstmap (get_field :nrclop_objconstcachemap curproc)) (cacheres (mapobject_get objconstmap recv)) ) (when cacheres (debug "normexp_keyword return cacheres=" cacheres) (return cacheres ())) (let ( (kdata (normal_keyword_data recv ncx psloc)) ) (debug "normexp_keyword kdata=" kdata "\n.. curproc=" curproc) (assert_msg "check curproc" (is_a curproc class_nrep_anyproc) curproc) (if (is_a curproc class_nrep_closproc) (let ( (nconst (instance class_nrep_constant :nrep_loc psloc :nconst_sval recv :nconst_data kdata :nconst_proc curproc)) ) (debug "normexp_keyword closproc curproc=" curproc "\n.. adding const kdata=" kdata) (list_append constlist kdata) (mapobject_put objconstmap recv nconst) (debug "normexp_keyword updated constlist=" constlist "\n.. objconstmap=" objconstmap) (debug "normexp_keyword result nconst=" nconst) (return nconst ()) ) (progn (debug "normexp_keyword routineinit result kdata=" kdata) (return kdata ()) ))))) (install_method class_keyword normal_exp normexp_keyword) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; utilities for normalization of DEFPRIMITIVE & DEFCITERATOR ;;;; fill the normal single formal bind (defun fill_normal_formalbind (fargb formsymbmap env ncx sloc) (assert_msg "check fargb" (is_a fargb class_formal_binding) fargb) (let ( (ftyp (unsafe_get_field :fbind_type fargb)) (fsymb (unsafe_get_field :binder fargb)) (fdataslot (create_data_slots class_formal_binding)) (fargdata (instance class_nrep_datainstance :nrep_loc sloc :ndata_discrx (normal_predef class_formal_binding ncx sloc "class_formal_binding") :ninst_hash (make_integerbox discr_integer (nonzero_hash)) :ninst_slots fdataslot )) (fsymbdata (normal_symbol_data fsymb ncx sloc)) (ftypdata (normal_predef ftyp ncx sloc "primitive arg type")) ) (assert_msg "check ftyp" (is_a ftyp class_ctype) ftyp) (add_nctx_data ncx fargdata) (fill_data_slot fargdata binder fsymbdata) (fill_data_slot fargdata fbind_type ftypdata) (mapobject_put formsymbmap fsymb fargdata) (return fargdata) )) ;;;; fill the normal formal args (defun fill_normal_formals (sargs nargtuple formsymbmap env ncx sloc) (foreach_in_multiple (sargs) (fargb :long ix) (let ( (fargdata (fill_normal_formalbind fargb formsymbmap env ncx sloc)) ) (assert_msg "check fargdata" (is_a fargdata class_nrep_datainstance) fargdata) (unsafe_put_fields fargdata :ninst_objnum (make_integerbox discr_integer ix)) (multiple_put_nth nargtuple ix fargdata) ))) ;;;; fill the normal expansion for primitive etc... (defun fill_normal_expansion (sexp nexptuple ncx sloc) (multiple_every sexp (lambda (expcomp :long ix) (let ( (discrcomp (discrim expcomp)) (compdata (cond ( (== discrcomp discr_verbatim_string) (add_nctx_data ncx (instance class_nrep_datastring :ndata_discrx (normal_predef discr_verbatim_string ncx sloc "discr_verbatim_string") :nstr_string expcomp ))) ( (== discrcomp class_symbol) (normal_symbol_data expcomp ncx sloc) ) ( :else (debug "bad component in C code expansion expcomp" expcomp) (error_at sloc "unexpected component #$1 of dicriminant $2 in C code expansion" ix (get_field :named_name discrcomp))))) ) (multiple_put_nth nexptuple ix compdata) ))) ) ;;;;;; normalize a DEFPRIMITIVE (defun normexp_defprimitive (recv env ncx psloc) (debug "normexp_defprimitive recv=" recv) (assert_msg "check defprimitive recv" (is_a recv class_source_defprimitive) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (sname (unsafe_get_field :sdef_name recv)) (sargs (unsafe_get_field :sformal_args recv)) (stype (unsafe_get_field :sprim_type recv)) (sexp (unsafe_get_field :sprim_expansion recv)) (sprimbind (find_env env sname)) ;; we compile to the making of an instance of class_primitive (nslotuple (create_data_slots class_primitive)) (nexptuple (make_multiple discr_multiple (multiple_length sexp))) (nargtuple (make_multiple discr_multiple (multiple_length sargs))) (nexpdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") :ntup_comp nexptuple)) (nargdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") :ntup_comp nargtuple)) (nprimdata (instance class_nrep_datainstance :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef class_primitive ncx sloc "class_primitive") :ninst_hash (make_integerbox discr_integer (nonzero_hash)) :ninst_slots nslotuple)) (nsymdata (normal_symbol_data sname ncx sloc)) ;; map of formal symbol -> data of formal_binding (formsymbmap (make_mapobject discr_map_objects (+i 3 (*i (multiple_length sargs) 2)))) ) (add_nctx_data ncx nprimdata) (add_nctx_data ncx nexpdata) (add_nctx_data ncx nargdata) ;; dont add nsymdata, it has already been added ;; fill the formal arguments of the data (fill_normal_formals sargs nargtuple formsymbmap env ncx sloc) ;; fill the expansion of the data (fill_normal_expansion sexp nexptuple ncx sloc) ;;; fill the primitive data (fill_data_slot nprimdata named_name (add_nctx_data ncx (instance class_nrep_datastring :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") :nstr_string (unsafe_get_field :named_name sname)))) (fill_data_slot nprimdata prim_formals nargdata) (fill_data_slot nprimdata prim_expansion nexpdata) (fill_data_slot nprimdata prim_type (normal_predef stype ncx sloc "primitive res type")) ;;; put the data into the primitive binding (if (is_a sprimbind class_primitive_binding) (put_fields sprimbind :fixbind_data nprimdata)) (return () ()) ;normalized defprimitive is empty )) (install_method class_source_defprimitive normal_exp normexp_defprimitive) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; normalize a DEFCITERATOR (defun normexp_defciterator (recv env ncx psloc) (debug "normexp_defciterator recv=" recv) (assert_msg "check defciterator recv" (is_a recv class_source_defciterator) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (sname (unsafe_get_field :sdef_name recv)) (sciter (let ( (sc (unsafe_get_field :sciterdef_citerator recv)) ) (assert_msg "check sciter" (is_a sc class_citerator) sc) sc)) (citbind (find_env env sname)) (citstafor (unsafe_get_field :citer_start_formals sciter)) (slotup (make_multiple discr_multiple (multiple_length (unsafe_get_field :class_fields class_citerator)))) (formstatup (make_multiple discr_multiple (multiple_length citstafor))) (citbodfor (unsafe_get_field :citer_body_formals sciter)) (formbodtup (make_multiple discr_multiple (multiple_length citbodfor))) (citstatsy (unsafe_get_field :citer_state sciter)) (citexpbef (unsafe_get_field :citer_expbefore sciter)) (expbeftup (make_multiple discr_multiple (multiple_length citexpbef))) (citexpaft (unsafe_get_field :citer_expafter sciter)) (expafttup (make_multiple discr_multiple (multiple_length citexpaft))) ;; map of formal symbol -> data of formal_binding (formsymbmap (make_mapobject discr_map_objects (+i 5 (*i (+i (multiple_length citstafor) (multiple_length citbodfor)) 2)))) (namstrdata (instance class_nrep_datastring :nrep_loc sloc :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") :nstr_string (unsafe_get_field :named_name sname))) (insdata (instance class_nrep_datainstance :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef class_citerator ncx sloc "class_citerator") :ninst_hash (make_integerbox discr_integer (nonzero_hash)) :ninst_slots slotup )) ) (add_nctx_data ncx insdata) (add_nctx_data ncx namstrdata) ;;; fill the named_name of insdata (multiple_put_nth slotup (get_int named_name) namstrdata) ;;; fill the citer_start_formals of insdata (fill_normal_formals citstafor formstatup formsymbmap env ncx sloc) (let ( (nstatupdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") :ntup_comp formstatup)) ) (add_nctx_data ncx nstatupdata) (multiple_put_nth slotup (get_int citer_start_formals) nstatupdata) ) ;;; fill the citer_state (assert_msg "check citstatsy" (is_a citstatsy class_symbol) citstatsy) (let ( (nstatsydata (normal_symbol_data citstatsy ncx sloc)) ) (multiple_put_nth slotup (get_int citer_state) nstatsydata) ) ;;; fill the citer_body_formals of insdata (fill_normal_formals citbodfor formbodtup formsymbmap env ncx sloc) (let ( (nbodtupdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") :ntup_comp formbodtup)) ) (add_nctx_data ncx nbodtupdata) (multiple_put_nth slotup (get_int citer_body_formals) nbodtupdata) ) ;;; fill the citer_expbefore of insdata (fill_normal_expansion citexpbef expbeftup ncx sloc) (let ( (nbeftupdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") :ntup_comp expbeftup)) ) (add_nctx_data ncx nbeftupdata) (multiple_put_nth slotup (get_int citer_expbefore) nbeftupdata) ) ;;; fill the citer_expafter of insdata (fill_normal_expansion citexpaft expafttup ncx sloc) (let ( (nafttupdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") :ntup_comp expafttup)) ) (add_nctx_data ncx nafttupdata) (multiple_put_nth slotup (get_int citer_expafter) nafttupdata) ) (assert_msg "check citbind" (is_a citbind class_citerator_binding) citbind) (put_fields citbind :fixbind_data insdata) ;;;;;;; ;; return the data (debug "normexp_defciterator return insdata" insdata) (return insdata ()) )) (install_method class_source_defciterator normal_exp normexp_defciterator) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; normalize a citeration (defun normexp_citeration (recv env ncx psloc) (debug "normexp_citeration recv" recv) (assert_msg "check citeration recv" (is_a recv class_source_citeration) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (soper (unsafe_get_field :sciter_oper recv)) (sargs (unsafe_get_field :sargop_args recv)) (svbind (unsafe_get_field :sciter_varbind recv)) (sbody (unsafe_get_field :sciter_body recv)) (nbndtup (make_multiple discr_multiple (multiple_length svbind))) (bodyenv (fresh_env env)) ;; we need to remove or add stuff from the symbol cache map, as normexp_let does (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) ;; the list of symbol to remove at end from the above map (uncachelist (make_list discr_list)) ) (assert_msg "check soper" (is_a soper class_citerator) soper) ;; normalize the iterator input arguments (multicall (nargs nbindings) (normalize_tuple sargs env ncx sloc) (if (null nbindings) (setq nbindings (make_list discr_list))) (debug "normexp_citeration nargs=" nargs " nbindings=" nbindings) (let ( (starformals (unsafe_get_field :citer_start_formals soper)) ) (debug "normexp_citeration starformals" starformals) (let ( (:long nbformals (multiple_length starformals)) (:long nbargs (multiple_length nargs)) ) (when (!=i nbformals nbargs) (error_at sloc "start formals $1 and actuals $2 lengths mismatch in citerator $3" nbformals nbargs (unsafe_get_field :named_name soper)) (return))) (multiple_every_both nargs starformals (lambda (curnarg curforb :long ix) (debug "normexp_citeration curnarg=" curnarg " curforb=" curforb " ix=" ix) (assert_msg "check curforb" (is_a curforb class_formal_binding) curforb) (let ( (curctyp (get_ctype curnarg env)) (formctyp (unsafe_get_field :fbind_type curforb)) (formarg (unsafe_get_field :binder curforb)) ) (if (== curctyp formctyp) (let ( (nlbind (instance class_normal_let_binding :letbind_loc sloc :binder formarg :letbind_type curctyp :letbind_expr curnarg )) ) (multiple_put_nth nbndtup ix nlbind) ) (progn (error_at sloc "start formal $1 and actual arg #$2 type mismatch, got $3 expecting $4, in citerator $5"_ (get_field :named_name formarg) ix (get_field :named_name curctyp) (get_field :named_name formctyp) (unsafe_get_field :named_name soper)) )) )) ) (debug "normexp_citeration nbndtup" nbndtup) ;; bind the local vars (debug "normexp_citeration svbind" svbind) (let ( (citbform (unsafe_get_field :citer_body_formals soper)) (:long nbcitbform (multiple_length citbform)) (nlocbindtup (make_multiple discr_multiple nbcitbform)) (nsymocctup (make_multiple discr_multiple nbcitbform)) ) (debug "normexp_citeration citbform" citbform) (let ( (:long nbsvbind (multiple_length svbind)) ) (when (!=i nbcitbform nbsvbind) (error_at sloc "body formals #$1 and actuals #$2 length mismatch in citerator $3"_ nbcitbform nbsvbind (unsafe_get_field :named_name soper)) (return))) (multiple_every_both svbind citbform (lambda (curvbind curbform :long ix) (debug "normexp_citeration curvbind=" curvbind " curbform=" curbform " ix=" ix) (assert_msg "check curvbind" (is_a curvbind class_formal_binding) curvbind) (assert_msg "check curbform" (is_a curbform class_formal_binding) curbform) (let ( (curvsym (unsafe_get_field :binder curvbind)) (curctyp (unsafe_get_field :fbind_type curvbind)) (curvfor (unsafe_get_field :binder curbform)) (forctyp (unsafe_get_field :fbind_type curbform)) ) (if (== curctyp forctyp) (let ( (nlvbind (instance class_normal_let_binding :letbind_loc sloc :binder curvsym :letbind_type curctyp :letbind_expr () )) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp curctyp :nocc_symb curvsym :nocc_bind nlvbind)) ) (multiple_put_nth nlocbindtup ix nlvbind) (multiple_put_nth nsymocctup ix clocc) (debug "normexp_citeration nlvbind" nlvbind) ;;(put_env bodyenv nlvbind) ;; update the curvsym in the symbol cache map to ;; ensure that it will be normalized as the same ;; local symbol occurence (mapobject_put sycmap curvsym clocc) (debug "normexp_citeration updated sycmap=" sycmap " clocc=" clocc) (list_append uncachelist curvsym) ) (progn (error_at sloc "local formal type $1 and actual type $2 for formal $3 #$4 mismatch in citerator $5"_ (get_field :named_name forctyp) (get_field :named_name curctyp) (get_field :named_name curvsym) ix (unsafe_get_field :named_name soper)) )) ) (put_env bodyenv curvbind) )) (debug "normexp_citeration nlocbindtup=" nlocbindtup " nsymocctup=" nsymocctup) (multicall (nbody nbodbindings) (normalize_tuple sbody bodyenv ncx sloc) (debug "normexp_citeration nbody=" nbody " nbodbindings=" nbodbindings) (let ( (citstate (unsafe_get_field :citer_state soper)) (citstsym (clone_symbol citstate)) (nchint (instance class_nrep_checksignal :nrep_loc sloc)) (citstbind (instance class_normal_let_binding :letbind_loc sloc :binder citstsym :letbind_type ctype_void :letbind_expr nchint)) (citstocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_void :nocc_symb citstsym :nocc_bind citstbind)) (citexpbefore (unsafe_get_field :citer_expbefore soper)) (citexpafter (unsafe_get_field :citer_expafter soper)) (citlocmap (make_mapobject discr_map_objects (+i 10 nbcitbform))) (citexpander (lambda (xtup) (debug "normexp_citeration expanding xtup=" xtup) (multiple_map xtup (lambda (curelem :long ix) (if (is_a curelem class_symbol) (let ( (exelem (mapobject_get citlocmap curelem)) ) (if (null exelem) (debug "normexp_citeration bad curelem" curelem)) (assert_msg "check exelem in citeration" exelem) exelem) curelem) )) )) ) (mapobject_put citlocmap citstate citstocc) (debug "normexp_citeration again starformals=" starformals " nsymocctup=" nsymocctup) (multiple_every_both starformals nargs (lambda (curvloc curnarg :long ix) (debug "normexp_citeration curvloc=" curvloc " curnarg=" curnarg) (mapobject_put citlocmap (unsafe_get_field :binder curvloc) curnarg) )) (debug "normexp_citeration middle citlocmap=" citlocmap " citbform=" citbform) (multiple_every citbform (lambda (curformb :long ix) (assert_msg "check curform" (is_a curformb class_formal_binding) curformb) (mapobject_put citlocmap (unsafe_get_field :binder curformb) (multiple_nth nsymocctup ix)) )) (debug "normexp_citeration citlocmap done" citlocmap) (let ( (chkbefore (citexpander citexpbefore)) (chkafter (citexpander citexpafter)) ) (debug "normexp_citeration chkbefore=" chkbefore " chkafter=" chkafter) (let ( (nciter (instance class_nrep_citeration :nrep_loc sloc :nciter_citerator soper :nciter_locbindings nlocbindtup :nciter_chunkbefore chkbefore :nciter_body nbody :nciter_statocc citstocc :nciter_bodbindings nbodbindings :nciter_chunkafter chkafter )) (csym (clone_symbol (unsafe_get_field :named_name soper))) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type ctype_void :letbind_expr nciter)) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_void :nocc_symb csym :nocc_bind cbind)) ) (list_append nbindings cbind) ;; remove all required stuff from the symbol cache (list_every uncachelist (lambda (csy) (mapobject_remove sycmap csy))) (debug "normexp_citeration nciter=" nciter " result clocc=" clocc " nbindings=" nbindings) (return clocc nbindings) )))))))) ) (install_method class_source_citeration normal_exp normexp_citeration) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;; normalize a DEFCMATCHER (defun normexp_defcmatcher (recv env ncx psloc) (assert_msg "check defcmatcher recv" (is_a recv class_source_defcmatcher) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (debug "normexp_defcmatcher recv" recv) (let ( (sloc (unsafe_get_field :loca_location recv)) (sname (unsafe_get_field :sdef_name recv)) (sformals (unsafe_get_field :sformal_args recv)) (cmatcher (let ( (cm (unsafe_get_field :scmatdef_cmatcher recv)) ) (debug "normexp_defcmatcher cmatcher" cm) (assert_msg "check cmatcher" (is_a cm class_cmatcher) cm) cm)) (cmbind (let ( (b (find_env env sname)) ) (debug "normexp_defcmatcher cmbind" b) (assert_msg "check cmbind" (is_a b class_cmatcher_binding) b) b)) (slotup (make_multiple discr_multiple (object_length cmatcher))) (inscma (unsafe_get_field :amatch_in cmatcher)) (mbicma (unsafe_get_field :amatch_matchbind cmatcher)) (outscma (unsafe_get_field :amatch_out cmatcher)) (statcma (unsafe_get_field :cmatch_state cmatcher)) (testcma (unsafe_get_field :cmatch_exptest cmatcher)) (fillcma (unsafe_get_field :cmatch_expfill cmatcher)) (opercma (unsafe_get_field :cmatch_expoper cmatcher)) (instup (make_multiple discr_multiple (multiple_length inscma))) (outstup (make_multiple discr_multiple (multiple_length outscma))) (testtup (if testcma (make_multiple discr_multiple (multiple_length testcma)))) (filltup (if fillcma (make_multiple discr_multiple (multiple_length fillcma)))) (opertup (if opercma (make_multiple discr_multiple (multiple_length opercma)))) ;; map of formal symbol -> data of formal_binding (formsymbmap (make_mapobject discr_map_objects (+i 5 (*i (+i (multiple_length inscma) (multiple_length outscma)) 2)))) (namstrdata (instance class_nrep_datastring :nrep_loc sloc :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") :nstr_string (unsafe_get_field :named_name sname))) (insdata (instance class_nrep_datainstance :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef class_cmatcher ncx sloc "class_cmatcher") :ninst_hash (make_integerbox discr_integer (obj_hash cmatcher)) :ninst_slots slotup )) ) (add_nctx_data ncx insdata) (add_nctx_data ncx namstrdata) ;;; fill the named_name of insdata (multiple_put_nth slotup (get_int named_name) namstrdata) ;;; fill the amatch_in of insdata (fill_normal_formals inscma instup formsymbmap env ncx sloc) (let ( (instupdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") :ntup_comp instup)) ) (add_nctx_data ncx instupdata) (multiple_put_nth slotup (get_int amatch_in) instupdata) ) ;;; fill the amatch_matchbind of insdata (let ( (mbdata (fill_normal_formalbind mbicma formsymbmap env ncx sloc)) ) (multiple_put_nth slotup (get_int amatch_matchbind) mbdata) ) ;;; fill the amatch_out of insdata (fill_normal_formals outscma outstup formsymbmap env ncx sloc) (let ( (outstupdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") :ntup_comp outstup)) ) (add_nctx_data ncx outstupdata) (multiple_put_nth slotup (get_int amatch_out) outstupdata) ) ;;; fill the cmatch_state of insdata (assert_msg "check statcma" (is_a statcma class_symbol) statcma) (let ( (nstatcmadata (normal_symbol_data statcma ncx sloc)) ) (multiple_put_nth slotup (get_int cmatch_state) nstatcmadata) ) ;;; fill the cmatch_exptest of insdata (if (is_multiple testcma) (progn (fill_normal_expansion testcma testtup ncx sloc) (let ( (ntesttupdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") :ntup_comp testtup)) ) (add_nctx_data ncx ntesttupdata) (multiple_put_nth slotup (get_int cmatch_exptest) ntesttupdata) ) )) ;;; fill the cmatch_expfill of insdata (if (is_multiple fillcma) (progn (fill_normal_expansion fillcma filltup ncx sloc) (let ( (nfilltupdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") :ntup_comp filltup)) ) (add_nctx_data ncx nfilltupdata) (multiple_put_nth slotup (get_int cmatch_expfill) nfilltupdata) ) )) ;;; fill the cmatch_expoper of insdata (if (is_multiple opercma) (progn (fill_normal_expansion opercma opertup ncx sloc) (let ( (nopertupdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") :ntup_comp opertup)) ) (add_nctx_data ncx nopertupdata) (multiple_put_nth slotup (get_int cmatch_expoper) nopertupdata) ) )) ;;; put the data in the binding (put_fields cmbind :fixbind_data insdata) ;; return the data (debug "normexp_defcmatcher return insdata" insdata) (return insdata ()) ) ) (install_method class_source_defcmatcher normal_exp normexp_defcmatcher) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; normalize a DEFUNMATCHER (defun normexp_defunmatcher (recv env ncx psloc) (debug "normexp_defunmatcher start recv=" recv) (assert_msg "normexp_defunmatcher check recv" (is_a recv class_source_defunmatcher) recv) (assert_msg "normexp_defunmatcher check env" (is_a env class_environment)) (assert_msg "normexp_defunmatcher check ncx" (is_a ncx class_normalization_context)) (let ( (sloc (unsafe_get_field :loca_location recv)) (sname (unsafe_get_field :sdef_name recv)) (smatched (multiple_nth (get_field :sformal_args recv) 0)) (sins (unsafe_get_field :sfumatdef_ins recv)) (souts (unsafe_get_field :sfumatdef_outs recv)) (smatchf (unsafe_get_field :sfumatdef_matchf recv)) (sapplyf (unsafe_get_field :sfumatdef_applyf recv)) (sdata (unsafe_get_field :sfumatdef_data recv)) (resbinds (make_list discr_list)) (insfma (subseq_multiple sins 1 -1)) (mbifma (multiple_nth sins 0)) (fmbind (let ( (b (find_env env sname)) ) (debug "normexp_defunmatcher fmbind" b) (assert_msg "check fmbind" (is_a b class_funmatcher_binding) b) b)) (funmatcher (get_field :fmbind_funmatcher fmbind)) ) (debug "normexp_defunmatcher made funmatcher" funmatcher) (assert_msg "check smatched" (is_a smatched class_formal_binding) smatched) (assert_msg "check sins" (is_multiple sins) sins) (assert_msg "check souts" (is_multiple souts) souts) (assert_msg "check mbifma" (is_a mbifma class_formal_binding) mbifma) (multicall (nmatchf nmabinds) (normal_exp smatchf env ncx sloc) (debug "normexp_defunmatcher nmatchf" nmatchf) (list_append2list resbinds nmabinds) (multicall (napplf napbinds) (normal_exp sapplyf env ncx sloc) (debug "normexp_defunmatcher napplf" napplf) (list_append2list resbinds napbinds) (multicall (ndata ndabinds) (normal_exp sdata env ncx sloc) (debug "normexp_defunmatcher ndata=" ndata " resbinds=" resbinds) (let ( (namstrdata (instance class_nrep_datastring :nrep_loc sloc :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") :nstr_string (unsafe_get_field :named_name sname))) (slotup (make_multiple discr_multiple (object_length funmatcher))) (insdata (instance class_nrep_datainstance :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef class_cmatcher ncx sloc "class_funmatcher") :ninst_hash (make_integerbox discr_integer (nonzero_hash)) :ninst_slots slotup )) (instup (make_multiple discr_multiple (multiple_length insfma))) (outstup (make_multiple discr_multiple (multiple_length souts))) ;; map of formal symbol -> data of formal_binding (formsymbmap (make_mapobject discr_map_objects (+i 5 (*i (+i (multiple_length insfma) (multiple_length souts)) 2)))) ) (add_nctx_data ncx namstrdata) (add_nctx_data ncx insdata) ;;; fill the named_name of insdata (multiple_put_nth slotup (get_int named_name) namstrdata) ;;; fill the amatch_in of insdata (fill_normal_formals insfma instup formsymbmap env ncx sloc) (let ( (instupdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") :ntup_comp instup)) ) (add_nctx_data ncx instupdata) (multiple_put_nth slotup (get_int amatch_in) instupdata) ) ;;; fill the amatch_matchbind of insdata (let ( (mbdata (fill_normal_formalbind mbifma formsymbmap env ncx sloc)) ) (multiple_put_nth slotup (get_int amatch_matchbind) mbdata) ) ;;; fill the amatch_out of insdata (fill_normal_formals souts outstup formsymbmap env ncx sloc) (let ( (outstupdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") :ntup_comp outstup)) ) (add_nctx_data ncx outstupdata) (multiple_put_nth slotup (get_int amatch_out) outstupdata) ) ;;; fill the fmatch_matchf of insdata (multiple_put_nth slotup (get_int fmatch_matchf) nmatchf) ;;; fill the fmatch_applyf of insdata (multiple_put_nth slotup (get_int fmatch_applyf) napplf) ;;; fill the fmatch_data of insdata (multiple_put_nth slotup (get_int fmatch_data) ndata) ;;; put the data in the binding (put_fields fmbind :fixbind_data insdata) ;;; make a funmatcher binding (debug "normexp_defunmatcher final fmbind" fmbind) (compile_warning "$@$incomplete normexp_defunmatcher" ()) ;;; return insdata and resbinds (debug "normexp_defunmatcher return insdata=" insdata " resbinds=" resbinds) (return insdata resbinds) ) ))) )) (install_method class_source_defunmatcher normal_exp normexp_defunmatcher) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; normalize a DEFCLASS (defun normexp_defclass (recv env ncx psloc) (debug "normexp_defclass recv=" recv) (assert_msg "check defclass recv" (is_a recv class_source_defclass) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (sname (unsafe_get_field :sdef_name recv)) (spredef (unsafe_get_field :sobj_predef recv)) (sclabind (unsafe_get_field :sclass_clabind recv)) (superbind (unsafe_get_field :sclass_superbind recv)) (sfldbinds (unsafe_get_field :sclass_fldbinds recv)) ) (assert_msg "check sclabind" (is_a sclabind class_class_binding) sclabind) (let ( (claobj (unsafe_get_field :cbind_class sclabind)) (namsymdata (normal_symbol_data sname ncx sloc)) (namstr (unsafe_get_field :named_name sname)) (namstrdata (instance class_nrep_datastring :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") :nstr_string namstr )) (claslots (make_multiple discr_multiple (obj_len claobj))) (cladata (instance class_nrep_datainstance :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef class_class ncx sloc "class_class") :ninst_hash (make_integerbox discr_integer (obj_hash claobj)) :ninst_predef spredef :ninst_slots claslots :ninst_objnum 'MELTOBMAG_OBJECT )) (ancseq (unsafe_get_field :class_ancestors claobj)) (:long nbanc (multiple_length ancseq)) (anctup (make_multiple discr_multiple nbanc)) (ancdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef discr_class_sequence ncx sloc "discr_class_sequence") :ntup_comp anctup )) (fldseq (unsafe_get_field :class_fields claobj)) (:long nbfld (multiple_length fldseq)) ;total number of fields (:long nbownfld (multiple_length sfldbinds)) ;number of own fields (:long nbsupfld (-i nbfld nbownfld)) ;number of super(ie inherited) fields (:long ix 0) ;temporary index (fldtup (make_multiple discr_multiple nbfld)) (flddata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef discr_field_sequence ncx sloc "discr_field_sequence") :ntup_comp fldtup )) ;; the data representing the superclass (superdata (if (is_a superbind class_any_binding) (normal_exp (unsafe_get_field :binder superbind) env ncx sloc))) ) (assert_msg "chechk namstr" (is_string namstr) namstr) ;; Issue a warning if we have no super class and if the class is ;; not predefined. (if (and (null superbind) (null spredef)) (warning_strv sloc "DEFCLASS of class without :SUPER -class" namstr)) ;; Issue a warning if namstr does not start with "CLASS_" to ;; enforce a coding convention. (let ( (:long dontstartwith_class 0) ) (code_chunk startwithclass #{ $DONTSTARTWITH_CLASS = strncmp (melt_string_str ((melt_ptr_t) $NAMSTR), "CLASS_", strlen("CLASS_")); }#) (if dontstartwith_class (warning_strv sloc "DEFCLASS-ed name should start with CLASS_ !" namstr))) ;; (assert_msg "check claobj" (is_a claobj class_class) claobj) (add_nctx_data ncx cladata) (add_nctx_data ncx namstrdata) (add_nctx_data ncx ancdata) (add_nctx_data ncx flddata) (fill_data_slot cladata named_name namstrdata) (fill_data_slot cladata class_ancestors ancdata) (fill_data_slot cladata class_fields flddata) (assert_msg "check sclabind" (is_a sclabind class_class_binding) sclabind) (put_fields sclabind :fixbind_data cladata) ;; for each field which is not own, make a data to copy it from the superclass (setq ix 0) (forever loopsuperfield (if (>=i ix nbsupfld) (exit loopsuperfield)) (let ( (supfldata (instance class_nrep_multacc :nrep_loc sloc :naccm_mul (instance class_nrep_fieldacc :nrep_loc sloc :naccf_obj superdata :naccf_fld class_fields ) :naccm_ix (make_integerbox discr_integer ix) )) ) (multiple_put_nth fldtup ix supfldata) ) (setq ix (+i ix 1)) ) (setq ix 0) ;; for each own field, make an instance of it (forever loopownfield (if (>=i ix nbownfld) (exit loopownfield)) (let ( (ownfldbind (multiple_nth sfldbinds ix)) ) (assert_msg "check ownfldbind" (is_a ownfldbind class_field_binding) ownfldbind) (let ( (ownfldsym (unsafe_get_field :binder ownfldbind)) (ownfld (unsafe_get_field :flbind_field ownfldbind)) ) (assert_msg "check ownfldsym" (is_a ownfldsym class_symbol) ownfldsym) (assert_msg "check ownfld" (is_a ownfld class_field) ownfld) (let ( (ownfldsymdata (normal_symbol_data ownfldsym ncx sloc)) (ownfldslots (make_multiple discr_multiple (obj_len ownfld))) (ownflstrdata (instance class_nrep_datastring :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") :nstr_string (unsafe_get_field :named_name ownfld) )) (ownfldata (instance class_nrep_datainstance :nrep_loc sloc :ndata_name ownfldsym :ndata_discrx (normal_predef class_field ncx sloc "class_field") :ninst_hash (make_integerbox discr_integer (obj_hash ownfld)) :ninst_objnum (make_integerbox discr_integer (obj_num ownfld)) :ninst_slots ownfldslots)) ) (add_nctx_data ncx ownfldata) (add_nctx_data ncx ownflstrdata) (fill_data_slot ownfldata named_name ownflstrdata) (fill_data_slot ownfldata fld_ownclass cladata) (multiple_put_nth fldtup (+i ix nbsupfld) ownfldata) ;; fill the field binding with its compiled data (put_fields ownfldbind :fixbind_data ownfldata) ))) (setq ix (+i ix 1)) ) ;; set the disc_super field to the superclass (if superdata (fill_data_slot cladata disc_super superdata)) ;; compute the class_ancestors into anctup (setq ix 0) ;; loop on the ancestors of the superclass (forever loopancestorsuper (if (>=i ix (-i nbanc 1)) (exit loopancestorsuper)) (let ( (supancdata (instance class_nrep_multacc :nrep_loc sloc :naccm_mul (instance class_nrep_fieldacc :nrep_loc sloc :naccf_obj superdata :naccf_fld class_ancestors) :naccm_ix (make_integerbox discr_integer ix))) ) (multiple_put_nth anctup ix supancdata) ) (setq ix (+i ix 1)) ) ;; add the superdata as the last component of anctup (if superdata (multiple_put_nth anctup (-i nbanc 1) superdata)) ;; the normalized form of the defclass is the classdata (return cladata ()) ))) (install_method class_source_defclass normal_exp normexp_defclass) ;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; normalize a DEFINSTANCE (defun normexp_definstance (recv env ncx psloc) (debug "normexp_definstance recv=" recv) (assert_msg "check definstance recv" (is_a recv class_source_definstance) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (sname (unsafe_get_field :sdef_name recv)) (spredef (unsafe_get_field :sobj_predef recv)) (sdocstr (unsafe_get_field :sdef_doc recv)) (sinstclass (unsafe_get_field :sinst_class recv)) (sinstclabnd (unsafe_get_field :sinst_clabind recv)) (sinstclasym (if (is_a sinstclabnd class_any_binding) (unsafe_get_field :binder sinstclabnd))) (sinstobjnum (unsafe_get_field :sinst_objnum recv)) (sinstfields (unsafe_get_field :sinst_fields recv)) (nbindlist (make_list discr_list)) (nbindcont (reference nbindlist)) (bindins (find_env env sname)) (namdata (normal_symbol_data sname ncx sloc)) ;; data representing the class (icladata (if (is_a sinstclasym class_symbol) (normal_exp sinstclasym env ncx sloc))) ) (debug "normexp_definstance bindins" bindins) (assert_msg "check bindins" (is_a bindins class_instance_binding) bindins) (when (is_not_a icladata class_nrep) (error_at sloc "invalid class $1 in definstance" (unsafe_get_field :named_name sname)) (return ())) (cond ( (null spredef) () ) ( (is_integerbox spredef) () ) ( (is_a spredef class_symbol) () ) (:else (error_at sloc "bad predef $1 in DEFINSTANCE" (unsafe_get_field :named_name sname)) (return ()))) (assert_msg "check sinstclass" (is_a sinstclass class_class) sinstclass) (assert_msg "check sinstclasym" (is_a sinstclasym class_symbol) sinstclasym) (let ( (slotup (make_multiple discr_multiple (multiple_length (unsafe_get_field :class_fields sinstclass)))) (insdata (instance class_nrep_datainstance :nrep_loc sloc :ndata_name sname :ndata_discrx icladata :ninst_hash (make_integerbox discr_integer (nonzero_hash)) :ninst_predef spredef :ninst_slots slotup :ninst_objnum sinstobjnum )) ) (add_nctx_data ncx insdata) (put_env env bindins) (put_fields bindins :fixbind_data insdata) ;; scan the fields initialization (foreach_in_multiple (sinstfields) (flda :long ix) (debug "normexp_definstance flda" flda) (assert_msg "check flda" (is_a flda class_source_fieldassign) flda) (let ( (curfld (unsafe_get_field :sfla_field flda)) (curexp (unsafe_get_field :sfla_expr flda)) (:long curoff (obj_num curfld)) ) (assert_msg "check curfld" (is_a curfld class_field) curfld) (when (!= (multiple_nth (unsafe_get_field :class_fields sinstclass) curoff) curfld) (error_at sloc "inappropriate field $1 in DEFINSTANCE" (get_field :named_name curfld) ) (return)) (debug "normexp_definstance field curexp" curexp) (multicall (ncur nbindcur) (normal_exp curexp env ncx sloc) (debug "normexp_definstance field ncur=" ncur " nbindcur=" nbindcur) (let ( (curctype (get_ctype ncur env)) ) (if (!= curctype ctype_value) (error_at sloc "field $1 in DEFINSTANCE don't get a value but a $2" (get_field :named_name curfld) (get_field :named_name curctype))) ) (multiple_put_nth slotup curoff ncur) (if (is_list nbindcur) (let ( (thebindlist (deref nbindcont))) (setq thebindlist (list_append2list thebindlist nbindcur)) (set_ref nbindcont thebindlist)))))) ;;; put the binding into the data (let ( (thebindlist (deref nbindcont)) (nbindtup (list_to_multiple thebindlist discr_multiple)) ) (if (>i (multiple_length nbindtup) 0) (unsafe_put_fields insdata :ndata_locbind nbindtup)) ;; return the data (debug "normexp_definstance return insdata" insdata) (return insdata ()) )))) (install_method class_source_definstance normal_exp normexp_definstance) ;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; normalize a DEFVAR for a static variable (defun normexp_defvar (recv env ncx psloc) (debug "normexp_defvar recv=" recv) (assert_msg "check defvar recv" (is_a recv class_source_defvar) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (sname (unsafe_get_field :sdef_name recv)) (modctx (unsafe_get_field :nctx_modulcontext ncx)) (curproc (unsafe_get_field :nctx_curproc ncx)) (bnbvar (unsafe_get_field :mocx_varcount modctx)) (varlist (unsafe_get_field :mocx_varlist modctx)) (:long numvar (+i (get_int bnbvar) 1)) ) (debug "normexp_defvar modctx=" modctx) (when (is_not_a curproc class_nrep_initproc) (error_at sloc "(DEFVAR $1) can appear only at top-level"_ sname) (return)) (multicall (vbind procs gotenv) (find_enclosing_env env sname) (debug "normexp_defvar vbind=" vbind "\n procs=" procs "\n gotenv=" gotenv) (when (or (!= gotenv env) (is_not_a vbind class_variable_binding)) (error_at sloc "cannot redefine variable $1 with DEFVAR"_ (get_field :named_name sname)) (return)) (debug "normexp_defvar class_normal_module_variable_binding=" class_normal_module_variable_binding) (let ( (bnumvar (constant_box numvar)) (varbnd (instance class_normal_module_variable_binding :binder sname :nvarb_num bnumvar)) ) (debug "normexp_defvar varbnd=" varbnd) (put_int bnbvar numvar) (put_env env varbnd) (list_append varlist varbnd) (debug "normexp_defvar updated varlist=" varlist) (return) )))) (install_method class_source_defvar normal_exp normexp_defvar) ;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; normalize a DEFINE for a constant (defun normexp_define (recv env ncx psloc) (assert_msg "check define recv" (is_a recv class_source_define) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (debug "normexp define recv" recv) (shortbacktrace_dbg "normexp_define" 7) (let ( (sloc (unsafe_get_field :loca_location recv)) (sname (unsafe_get_field :sdef_name recv)) (sbody (unsafe_get_field :sdefine_body recv)) (binddef (let ( (bdf (find_env env sname)) ) (debug "normexp_define binddef bdf=" bdf) bdf )) (namdata (normal_symbol_data sname ncx sloc)) (curproc (unsafe_get_field :nctx_curproc ncx)) (newenv (fresh_env env)) (locbind (instance class_normal_let_binding :letbind_loc sloc :binder sname :letbind_type ctype_value :letbind_expr () )) (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) ) (debug "normexp_define namdata=" namdata " binddef=" binddef " sycmap=" sycmap) (assert_msg "check body tuple" (is_multiple sbody) sbody) (assert_msg "check binddef" (is_a binddef class_defined_value_binding) binddef) (debug "normexp_define curproc=" curproc " newenv=" newenv) ;; TODO:: maybe we could have internal defines for constants... (when (is_not_a curproc class_nrep_initproc) (error_at sloc "(DEFINE $1 ...) can appear only at top-level"_ sname) (return)) (put_env newenv locbind) (debug "normexp_define sbody=" sbody "\n newenv=" newenv) (multicall (nbody nbindings) (normalize_tuple sbody newenv ncx sloc) (debug "normexp_define nbody=" nbody " nbindings=" nbindings " sname=" sname) (if (null nbindings) (setq nbindings (make_list discr_list))) (let ( (procdefbinds (get_field :ninit_defbinds curproc)) (ndefname (normexp_symbol sname env ncx sloc)) (:long nbodylen (multiple_length nbody)) (nlastbody (multiple_nth nbody -1)) (newbody (make_multiple discr_multiple (+i nbodylen 2))) (snamestr (get_field :named_name sname)) (nlastassign (instance class_nrep_setq :nrep_loc sloc :nstq_var ndefname :nstq_exp nlastbody)) ) (debug "normexp_define nlastassign=" nlastassign " ndefname=" ndefname) (list_every nbindings (lambda (nb) (put_env newenv nb))) (foreach_in_multiple (nbody) (curnbody :long bodix) (multiple_put_nth newbody bodix curnbody)) (multiple_put_nth newbody nbodylen nlastassign) (multiple_put_nth newbody (+i nbodylen 1) ndefname) (list_append procdefbinds binddef) (debug "normexp_define updated procdefbinds=" procdefbinds " ndefname=" ndefname " newbody=" newbody) (let ( (curctype (get_ctype ndefname env)) (lastctype (get_ctype nlastbody newenv)) ) (if (!= curctype ctype_value) (error_at sloc "DEFINE-d name $1 is not a value but a $2"_ snamestr (get_field :named_name curctype))) (if (!= lastctype ctype_value) (error_at sloc "(DEFINE $1 ...) body don't end with a value but with a $2"_ snamestr (get_field :named_name lastctype))) ) (debug "normexp_define newbody=" newbody " sname=" sname " sycmap=" sycmap) (let ( (nwrlet (wrap_normal_letseq newbody nbindings sloc)) (nlocbindings (list locbind)) (syca (mapobject_get sycmap sname)) ) (debug "normexp_define nwrlet=" nwrlet) (debug "normexp_define syca=" syca " locbind=" locbind) (assert_msg "check syca" (is_a syca class_nrep_defined_constant) syca) (mapobject_remove sycmap sname) (debug "normexp_define shrinked updated sycmap=" sycmap) (debug "normexp_define return nwrlet=" nwrlet " nlocbindings=" nlocbindings) (return nwrlet nlocbindings) ))))) (install_method class_source_define normal_exp normexp_define) ;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; normalize a DEFSELECTOR (defun normexp_defselector (recv env ncx psloc) (debug "normexp defselector recv=" recv) (assert_msg "check defselector recv" (is_a recv class_source_defselector) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (sname (unsafe_get_field :sdef_name recv)) (spredef (unsafe_get_field :sobj_predef recv)) (sdocstr (unsafe_get_field :sdef_doc recv)) (sinstclass (unsafe_get_field :sinst_class recv)) (sinstclabnd (unsafe_get_field :sinst_clabind recv)) (sinstclasym (if (is_a sinstclabnd class_any_binding) (unsafe_get_field :binder sinstclabnd))) (sinstobjnum (unsafe_get_field :sinst_objnum recv)) (sinstfields (unsafe_get_field :sinst_fields recv)) (sformals (unsafe_get_field :sdefsel_formals recv)) (nbindlist (make_list discr_list)) (nbindcont (reference nbindlist)) (bindsel (find_env env sname)) (namdata (normal_symbol_data sname ncx sloc)) ;; data representing the class (icladata (if (is_a sinstclasym class_symbol) (normal_exp sinstclasym env ncx sloc))) ) (assert_msg "check bindsel" (is_a bindsel class_selector_binding) bindsel) (when (is_not_a icladata class_nrep) (error_at sloc "invalid class in DEFSELECTOR $1"_ (unsafe_get_field :named_name sname)) (return ())) (if spredef (when (not (or (is_integerbox spredef) (is_a spredef class_symbol))) (error_at sloc "bad predef in DEFSELECTOR $1" (unsafe_get_field :named_name sname)) (return ()))) (assert_msg "check sinstclass" (is_a sinstclass class_class) sinstclass) (assert_msg "check sinstclasym" (is_a sinstclasym class_symbol) sinstclasym) (assert_msg "check sname" (is_a sname class_symbol) sname) (let ( (slotup (make_multiple discr_multiple (multiple_length (unsafe_get_field :class_fields sinstclass)))) (namstrdata (instance class_nrep_datastring :nrep_loc sloc :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") :nstr_string (unsafe_get_field :named_name sname))) (insdata (instance class_nrep_datainstance :nrep_loc sloc :ndata_name sname :ndata_discrx icladata :ninst_hash (make_integerbox discr_integer (nonzero_hash)) :ninst_predef spredef :ninst_slots slotup :ninst_objnum sinstobjnum )) (formsymbmap (make_mapobject discr_map_objects (+i 3 (*i (multiple_length sformals) 2)))) (nformtup (if sformals (let ( (:long nbformals (multiple_length sformals)) (nformaltuple (make_multiple discr_multiple nbformals)) (nformdata (instance class_nrep_datatuple :nrep_loc sloc :ndata_name sname :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") :ntup_comp nformaltuple)) ) (fill_normal_formals sformals nformaltuple formsymbmap env ncx sloc) (add_nctx_data ncx nformdata) (fill_data_slot insdata sdefsel_formals nformdata) nformaltuple ))) ) (add_nctx_data ncx insdata) (add_nctx_data ncx namstrdata) (put_fields bindsel :fixbind_data insdata) ;; scan the fields initialization (foreach_in_multiple (sinstfields) (flda :long ix) (assert_msg "check flda" (is_a flda class_source_fieldassign) flda) (let ( (curfld (unsafe_get_field :sfla_field flda)) (curexp (unsafe_get_field :sfla_expr flda)) (:long curoff (obj_num curfld)) ) (assert_msg "check curfld" (is_a curfld class_field) curfld) (assert_msg "good curfld" (== (multiple_nth (unsafe_get_field :class_fields sinstclass) curoff) curfld) curoff curfld) (multicall (ncur nbindcur) (normal_exp curexp env ncx sloc) (multiple_put_nth slotup curoff ncur) (if (is_list nbindcur) (let ( (thebindlist (deref nbindcont))) (setq thebindlist (list_append2list thebindlist nbindcur)) (set_ref nbindcont thebindlist)))))) ;;; put the binding into the data (let ( (thebindlist (deref nbindcont)) (nbindtup (list_to_multiple thebindlist discr_multiple)) ) (if (>i (multiple_length nbindtup) 0) (unsafe_put_fields insdata :ndata_locbind nbindtup)) ;; force the name of the selectordata (multiple_put_nth slotup (get_int named_name) namstrdata) (if (is_a bindsel class_selector_binding) (put_fields bindsel :fixbind_data insdata)) ;; return the data (debug "normexp_defselector return insdata" insdata) (return insdata ()) )))) (install_method class_source_defselector normal_exp normexp_defselector) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; internal function for value export ;; ;;; sym is the exported symbol ;; ;;; nexp is the normalized expression of its value ;; (defun normal_exported_value (sym nexp env ncx psloc bindslist) (debug "normal_exported_value start sym=" sym " nexp=" nexp) (assert_msg "check sym" (is_a sym class_symbol) sym) (assert_msg "check nexp" (is_a nexp class_nrep) nexp) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context)) (assert_msg "check bindslist" (is_list bindslist) bindslist) (let ( (csymexpo (clone_symbol '_exported_)) (symdata (normal_symbol_data sym ncx psloc)) (iniproc (unsafe_get_field :nctx_initproc ncx)) (curproc (unsafe_get_field :nctx_curproc ncx)) (csbuf (let ( (sb (make_strbuf discr_strbuf)) ) (add2sbuf_strconst sb "norm.exp.val : ") (add2sbuf_string sb (unsafe_get_field :named_name sym)) sb)) (scurenvbox (instance class_source_current_module_environment_reference :loca_location psloc :cmec_comment (strbuf2string discr_string csbuf))) ) (debug "normal_exported_value scurenvbox=" scurenvbox) (multicall (ncurenvbox curenvbinds) (normal_exp scurenvbox env ncx psloc) (debug "normal_exported_value ncurenvbox=" ncurenvbox " curenvbinds=" curenvbinds) ;;; if we are not at toplevel it has no sense to call the cont_fresh_env! (list_append2list bindslist curenvbinds) (let ( (argtup (tuple symdata nexp ncurenvbox)) (cbind (instance class_normal_let_binding :letbind_loc psloc :binder csymexpo :letbind_type ctype_void :letbind_expr (instance class_nrep_hook_call :nrep_loc psloc :nexpr_ctyp ctype_value :nhook_name '"HOOK_VALUE_EXPORTER" :nexpr_args argtup :nhook_called (normal_predef hook_value_exporter ncx psloc "hook_value_exporter") :nhook_outs (tuple) :nhook_descr (hook_data hook_value_exporter) ) )) (syocc (instance class_nrep_locsymocc :nrep_loc psloc :nocc_ctyp ctype_void :nocc_symb csymexpo :nocc_bind cbind) ) ) (debug "normal_exported_value cbind=" cbind " syocc=" syocc) (list_append bindslist cbind) syocc ;; )))) ;;;; normalize an export_values (defun normexp_export_values (recv env ncx psloc) ;; actually, export of values & classes could be simple. the ;; export of a symbol should be expanded as the invocation of the ;; value exporter on the current module environment. we don't need ;; anything special in the initproc for the export. ;;;; this implies that a locally let-bound symbol could be passed to ;;;; export_values, some kind of strange practice. (debug "normexp_export_values recv=" recv) (assert_msg "check exportval recv" (is_a recv class_source_export_values) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (sxnames (unsafe_get_field :sexport_names recv)) (bindslist (make_list discr_list)) (nilnrep (instance class_nrep_nil :nrep_loc sloc)) ) (foreach_in_multiple (sxnames) (xnam :long ix) (assert_msg "check xnam" (is_a xnam class_symbol) xnam) (debug "normexp_export_values xnam" xnam) (multicall (nsym nsymbinds) (normal_exp xnam env ncx sloc) (debug "normexp_export_values nsym=" nsym " nsymbinds=" nsymbinds) (list_append2list bindslist nsymbinds) (debug "normexp_export_values again xnam=" xnam " bindslist=" bindslist) (let ( (nexpv (normal_exported_value xnam nsym env ncx sloc bindslist)) ) (debug "normexp_export_values normal_exported_value gave nexpv" nexpv) ))) (debug "normexp_export_values final nilnrep=" nilnrep " bindslist=" bindslist) (return nilnrep bindslist) )) (install_method class_source_export_values normal_exp normexp_export_values) ;;;; normalize an export_synonym (defun normexp_export_synonym (recv env ncx psloc) ;; it should be a bit like export_values, since it create a value binding.. (debug "normexp_export_synonym recv=" recv) (assert_msg "check exportsyn recv" (is_a recv class_source_export_synonym) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (newname (unsafe_get_field :sexpsyn_newname recv)) (oldname (unsafe_get_field :sexpsyn_oldname recv)) (bindslist (make_list discr_list)) (nilnrep (instance class_nrep_nil :nrep_loc sloc)) ) (debug "normexp_export_synonym newname=" newname " oldname=" oldname) (assert_msg "check newname" (is_a newname class_symbol) newname) (assert_msg "check oldname" (is_a oldname class_symbol) oldname) ;; when a class has a synonym, we should generate in the C code ;;; const int meltclasslen__ ;; when a field has a synonym, we should generate in the C code ;;; const int meltfieldoff__ (compile_warning "export_synonym should also generate a class length or field offset when needed") (multicall (noldsym noldsymbinds) (normal_exp oldname env ncx sloc) (debug "normexp_export_synonym noldsym=" noldsym " noldsymbinds=" noldsymbinds) (list_append2list bindslist noldsymbinds) (let ( (nexpv (normal_exported_value newname noldsym env ncx sloc bindslist)) ) (debug "normexp_export_synonym normal_exported_value gave nexpv=" nexpv " final nilnrep=" nilnrep " bindslist=" bindslist) (return nilnrep bindslist) )))) (install_method class_source_export_synonym normal_exp normexp_export_synonym) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; normalize an export_class (defun normexp_export_class (recv env ncx psloc) (debug "normexp export_class recv=" recv) (assert_msg "check export_class recv" (is_a recv class_source_export_class) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (sxnames (unsafe_get_field :sexport_names recv)) (bindslist (make_list discr_list)) (nilnrep (instance class_nrep_nil :nrep_loc sloc)) (mocx (unsafe_get_field :nctx_modulcontext ncx)) ) (assert_msg "check mocx" (is_a mocx class_any_module_context) mocx) (foreach_in_multiple (sxnames) (xnam :long ix) (assert_msg "check xnam" (is_a xnam class_symbol) xnam) (let ( (xbind (find_env env xnam)) (xsymdata (normal_symbol_data xnam ncx sloc)) ) (debug "normexp_export_class xbind" xbind) (assert_msg "check xsymdata" (is_a xsymdata class_nrep_datasymbol) xsymdata) (when (is_not_a xbind class_class_binding) (error_at sloc "EXPORT_CLASS with non-class-bound symbol $1"_ (unsafe_get_field :named_name xnam)) (return)) (let ( (xdata (unsafe_get_field :fixbind_data xbind)) (xclass (unsafe_get_field :cbind_class xbind)) ) (debug "normexp_export_class xdata" xdata) (if (is_not_a xdata class_nrep_bound_data) (error_at sloc "forward defined class symbol $1 to EXPORT_CLASS" (unsafe_get_field :named_name xnam))) (let ( (nclav (normal_exported_value xnam xdata env ncx sloc bindslist)) ) (debug "normexp_export_class nclav" nclav) (assert_msg "check xclass" (is_a xclass class_class) xclass) (let ( (xclfields (unsafe_get_field :class_fields xclass)) (expcladic (get_field :mocx_expclassdict mocx)) (expfldic (get_field :mocx_expfieldict mocx)) ) (assert_msg "check expcladic" (is_mapstring expcladic) expcladic) (assert_msg "check expfldic" (is_mapstring expfldic) expfldic) (mapstring_putstr expcladic (unsafe_get_field :named_name xclass) xclass) (foreach_in_multiple (xclfields) (curfld :long ix) (assert_msg "check curfld" (is_a curfld class_field) curfld) (let ( (fldnam (unsafe_get_field :named_name curfld)) (fldclass (unsafe_get_field :fld_ownclass curfld)) ) ;; export as value each field belonging to this class (if (== fldclass xclass) (let ( (fldsym (get_symbolstr fldnam)) (fldbind (find_env env fldsym)) ) (assert_msg "check fldbind" (is_a fldbind class_field_binding) fldbind) (let ( (fldata (unsafe_get_field :fixbind_data fldbind)) (field (unsafe_get_field :flbind_field fldbind)) (nfld (normal_exported_value fldsym fldata env ncx sloc bindslist)) ) (assert_msg "check field" (is_a field class_field) field) (assert_msg "check expfldic" (is_mapstring expfldic) expfldic) (mapstring_putstr expfldic (unsafe_get_field :named_name field) field) (debug "normexp_export_class nfld=" nfld) ))))) )))) ) (debug "normexp_export_class final nilnrep=" nilnrep " bindslist=" bindslist) (return nilnrep bindslist) )) (install_method class_source_export_class normal_exp normexp_export_class) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;; ;; return the normalized application to do the macro expport (defun normal_exported_macro (sym nexp env ncx psloc bindslist) (debug "normal_exported_macro start sym=" sym "; psloc=" psloc "\n.. nexp=" nexp "\n.. env=" env) (assert_msg "check sym" (is_a sym class_symbol) sym) (assert_msg "check nexp" (is_a nexp class_nrep) nexp) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context)) (assert_msg "check bindslist" (is_list bindslist) bindslist) (let ( (csymexpo (clone_symbol '_exportedm_)) (symdata (normal_symbol_data sym ncx psloc)) (csbuf (let ( (sb (make_strbuf discr_strbuf)) ) (add2sbuf_strconst sb "norm.exp.val : ") (add2sbuf_string sb (unsafe_get_field :named_name sym)) sb)) (scurenvbox (instance class_source_current_module_environment_reference :loca_location psloc :cmec_comment (strbuf2string discr_string csbuf))) ) (debug "normal_exported_macro sgetcurenvbox" scurenvbox) (multicall (ncurenvbox curenvbinds) (normal_exp scurenvbox env ncx psloc) (debug "normal_exported_macro ncurenvbox=" ncurenvbox " curenvbinds=" curenvbinds) (if (is_list curenvbinds) (list_append2list bindslist curenvbinds)) (let ( (argtup (tuple symdata nexp ncurenvbox)) (cbind (instance class_normal_let_binding :letbind_loc psloc :binder csymexpo :letbind_type ctype_void :letbind_expr (instance class_nrep_hook_call :nexpr_ctyp ctype_void :nhook_name '"HOOK_MACRO_EXPORTER" :nexpr_args argtup :nhook_called (normal_predef hook_macro_exporter ncx psloc "hook_macro_exporter") :nhook_outs (tuple) :nhook_descr (hook_data hook_macro_exporter)) )) (syocc (instance class_nrep_locsymocc :nrep_loc psloc :nocc_ctyp ctype_void :nocc_symb csymexpo :nocc_bind cbind) ) ) (debug "normal_exported_macro cbind=" cbind " syocc=" syocc) (list_append bindslist cbind) syocc ;; )))) ;;;; normalize an export_macro with an explicit expander (defun normexp_export_macro (recv env ncx psloc) (debug "normexp export_macro recv=" recv " env=" debug_less env) (assert_msg "check export_macro recv" (is_a recv class_source_export_macro) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (mname (unsafe_get_field :sexpmac_mname recv)) (mvalexp (unsafe_get_field :sexpmac_mval recv)) (bindslist (make_list discr_list)) (nrepnil (instance class_nrep_nil :nrep_loc sloc)) ) (assert_msg "check mname" (is_a mname class_symbol) mname) (multicall (nexp nbinds) (normal_exp mvalexp env ncx sloc) (list_append2list bindslist nbinds) (let ( (nexpm (normal_exported_macro mname nexp env ncx sloc bindslist)) ) (debug "normexp_export_macro nexpm" nexpm) ) (debug "normexp_export_macro final nrepnil=" nrepnil " bindslist=" bindslist) (return nrepnil bindslist) ))) (install_method class_source_export_macro normal_exp normexp_export_macro) ;;;; normalize an export_macro for a defmacro (defun normexp_export_defmacro (recv env ncx psloc) (debug "normexp_export_defmacro recv=" recv " env=" debug_more env) (assert_msg "check export_defmacro recv" (is_a recv class_source_export_defmacro) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (modctx (get_field :nctx_modulcontext ncx)) (macroenv (get_field :mocx_macroenv modctx)) (sloc (unsafe_get_field :loca_location recv)) (mname (unsafe_get_field :sexpmac_mname recv)) (bindslist (make_list discr_list)) (nrepnil (instance class_nrep_nil :nrep_loc sloc)) ) (assert_msg "check mname" (is_a mname class_symbol) mname) (debug "normexp_export_defmacro sloc=" debug_less sloc "; macroenv=" debug_more macroenv) (multicall (nexp nbinds) (normal_exp mname macroenv ncx sloc) (list_append2list bindslist nbinds) (debug "normexp_export_defmacro sloc=" debug_less sloc "; nexp=" nexp " nbinds=" nbinds) (let ( (nexpm (normal_exported_macro mname nexp macroenv ncx sloc bindslist)) ) (debug "normexp_export_defmacro sloc=" debug_less sloc "; nexpm=" nexpm) ) (debug "normexp_export_macro final nrepnil=" nrepnil " bindslist=" bindslist) (return nrepnil bindslist) ))) (install_method class_source_export_defmacro normal_exp normexp_export_defmacro) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; return the normalized application to do the patmacro expport ;; sym is the symbol which is export_patmacro-ed ;; nmacroxp is the nrep of the macro expander ;; npattxp is the nrep of the pattern expander (defun normal_exported_patmacro (sym nmacroxp npattxp env ncx psloc bindslist) (debug "normal_exported_patmacro start sym=" sym " nmacroxp=" nmacroxp " npattxp=" npattxp) (assert_msg "check sym" (is_a sym class_symbol) sym) (assert_msg "check nmacroxp" (is_a nmacroxp class_nrep) nmacroxp) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (assert_msg "check bindslist" (is_list bindslist) bindslist) (let ( (csymexpo (clone_symbol '_exportedpat_)) (symdata (normal_symbol_data sym ncx psloc)) (csbuf (let ( (sb (make_strbuf discr_strbuf)) ) (add2sbuf_strconst sb "norm.exp.pat : ") (add2sbuf_string sb (unsafe_get_field :named_name sym)) sb)) (scurenvbox (instance class_source_current_module_environment_reference :loca_location psloc :cmec_comment (strbuf2string discr_string csbuf))) ) (debug "normal_exported_patmacro sgetcurenvbox" scurenvbox) (multicall (ncurenvbox curenvbinds) (normal_exp scurenvbox env ncx psloc) (debug "normal_exported_patmacro ncurenvbox=" ncurenvbox " curenvbinds=" curenvbinds) (if (is_list curenvbinds) (list_append2list bindslist curenvbinds)) (let ( (argtup (tuple symdata nmacroxp npattxp ncurenvbox)) (cbind (instance class_normal_let_binding :letbind_loc psloc :binder csymexpo :letbind_type ctype_void :letbind_expr (instance class_nrep_hook_call :nexpr_ctyp ctype_void :nhook_name '"HOOK_PATMACRO_EXPORTER" :nexpr_args argtup :nhook_called (normal_predef hook_patmacro_exporter ncx psloc "hook_patmacro_exporter") :nhook_outs (tuple) :nhook_descr (hook_data hook_patmacro_exporter)) )) (syocc (instance class_nrep_locsymocc :nrep_loc psloc :nocc_ctyp ctype_void :nocc_symb csymexpo :nocc_bind cbind) ) ) (debug "normal_exported_patmacro cbind=" cbind " return syocc=" syocc) (list_append bindslist cbind) syocc ;; )))) ;;;;;;;;;;;;;;;; ;;;; normalize an export_patmacro (defun normexp_export_patmacro (recv env ncx psloc) (debug "normexp export_patmacro recv=" recv) (assert_msg "check export_patmacro recv" (is_a recv class_source_export_patmacro) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (mname (unsafe_get_field :sexpmac_mname recv)) (mvalexp (unsafe_get_field :sexpmac_mval recv)) (mpatexp (unsafe_get_field :sexppat_pval recv)) (bindslist (make_list discr_list)) (nrepnil (instance class_nrep_nil :nrep_loc sloc)) ) (debug "normexp export_patmacro mname=" mname) (assert_msg "check mname" (is_a mname class_symbol) mname) (multicall (nexpmac nbindms) (normal_exp mvalexp env ncx sloc) (list_append2list bindslist nbindms) (debug "normexp_export_patmacro nexpmac" nexpmac) (multicall (nexppat nbindps) (normal_exp mpatexp env ncx sloc) (list_append2list bindslist nbindps) (debug "normexp_export_patmacro nexppat" nexpmac) (let ( (nexpm (normal_exported_patmacro mname nexpmac nexppat env ncx sloc bindslist)) ) (debug "normexp_export_patmacro nexpm=" nexpm) (debug "normexp_export_patmacro final nrepnil=" nrepnil " bindslist=" bindslist) (return nrepnil bindslist) ) )) )) (install_method class_source_export_patmacro normal_exp normexp_export_patmacro) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; normalize current_module_environment_reference (defun normexp_current_module_environment_reference (recv env ncx psloc) (debug "normexp_current_module_environment_reference recv=" recv) (assert_msg "check current_module_environment_reference recv" (is_a recv class_source_current_module_environment_reference) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (scomm (unsafe_get_field :cmec_comment recv)) (ncurmodenvlist (unsafe_get_field :nctx_procurmodenvlist ncx)) (curproc (unsafe_get_field :nctx_curproc ncx)) (qdatcur (unsafe_get_field :nctx_qdatcurmodenvbox ncx)) (nquasi (instance class_nrep_quasiconst_current_module_environment_reference :nrep_loc sloc :nconst_sval recv :nconst_proc curproc :nconst_data qdatcur :nqcmec_comment scomm )) ) (assert_msg "check qdatcur" (is_a qdatcur class_nrep_quasidata_current_module_environment_reference) qdatcur) (when (is_a curproc class_nrep_hookproc) (error_at sloc "(CURRENT_MODULE_ENVIRONMENT_REFERENCE) cannot be used within hooks"_) (return)) (when (is_a curproc class_nrep_routproc) (list_append (get_field :nrclop_constlist curproc) qdatcur) (list_append ncurmodenvlist curproc) ) (debug "normexp_current_module_environment_reference nquasi" nquasi) (return nquasi ()) )) (install_method class_source_current_module_environment_reference normal_exp normexp_current_module_environment_reference) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; normalize parent_module_environment (defun normexp_parent_module_environment (recv env ncx psloc) (debug "normexp_parent_module_environment recv=" recv) (assert_msg "check parent_module_environment recv" (is_a recv class_source_parent_module_environment) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (curproc (unsafe_get_field :nctx_curproc ncx)) (qdatpar (unsafe_get_field :nctx_qdatparmodenv ncx)) (nquasi (instance class_nrep_quasiconst_parent_module_environment :nrep_loc sloc :nconst_sval recv :nconst_proc curproc :nconst_data qdatpar )) ) (when (is_a curproc class_nrep_hookproc) (error_at sloc "(PARENT_MODULE_ENVIRONMENT) cannot be used within hooks"_) (return)) (assert_msg "check qdatpar" (is_a qdatpar class_nrep_quasidata_parent_module_environment) qdatpar) (if (is_a curproc class_nrep_routproc) (list_append (get_field :nrclop_constlist curproc) qdatpar)) (debug "normexp_parent_module_environment nquasi" nquasi) (return nquasi ()) )) (install_method class_source_parent_module_environment normal_exp normexp_parent_module_environment) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; normalize update_current_module_environment_reference (defun normexp_update_current_module_environment_reference (recv env ncx psloc) (debug "normexp_update_current_module_environment_reference recv=" recv "\n env=" env "\n ncx=" debug_less ncx) (assert_msg "check update_current_module_environment_reference recv" (is_a recv class_source_update_current_module_environment_reference) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (shortbacktrace_dbg "normexp_update_current_module_environment_reference" 15) (let ( (sloc (unsafe_get_field :loca_location recv)) (scomm (unsafe_get_field :sucme_comment recv)) (curproc (unsafe_get_field :nctx_curproc ncx)) (iniproc (unsafe_get_field :nctx_initproc ncx)) (modctx (unsafe_get_field :nctx_modulcontext ncx)) (modnam (get_field :mocx_modulename modctx)) ) (when (!= curproc iniproc) (error_at sloc "(UPDATE_CURRENT_MODULE_ENVIRONMENT_REFERENCE) not at toplevel"_) (return)) (debug "normexp_update_current_module_environment_reference modctx=" debug_less modctx) (cond ((is_a modctx class_running_extension_module_context) (let ( (nchk (instance class_nrep_check_running_module_environment_container :nrep_loc sloc :nchrumod_comment scomm )) (csym (clone_symbol 'checkrunmodenvbox_)) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type ctype_void ;; ctype_void because the sideffect is in nchk :letbind_expr nchk)) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_void :nocc_symb csym :nocc_bind cbind)) (bindlist (list cbind)) ) (debug "normexp_update_current_module_environment_reference gives nchk=" nchk " clocc=" clocc " bindlist=" bindlist) (return clocc bindlist) )) ((is_a modctx class_any_module_context) (assert_msg "check modctx not running" (is_not_a modctx class_running_extension_module_context) modctx) (let ( (nup (instance class_nrep_update_current_module_environment_reference ;; :ncumeb_expr filled later :nrep_loc sloc :ncumeb_comment scomm )) (csym (clone_symbol 'updatcurmodenvbox_)) (cbind (instance class_normal_let_binding :letbind_loc sloc :binder csym :letbind_type ctype_void ;; ctype_void because the sideffect is in nup :letbind_expr nup)) (clocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_void :nocc_symb csym :nocc_bind cbind)) (csbuf (let ( (sb (make_strbuf discr_strbuf)) ) (add2sbuf_strconst sb "cur.mod.env.cont : ") (add2sbuf_string sb scomm) sb)) (scurenvbox (instance class_source_current_module_environment_reference :loca_location sloc :cmec_comment (strbuf2string discr_string csbuf))) (sgetcurenvbox (instance class_source_or :loca_location psloc :sor_disj (tuple scurenvbox (instance class_source_hook_call :loca_location psloc :shook_called hook_fresh_environment_reference_maker :sargop_args (tuple (instance class_source_parent_module_environment :loca_location psloc) modnam )) ))) ) (multicall (ncurenvbox bindlist) (normal_exp sgetcurenvbox env ncx sloc) (list_append bindlist cbind) (unsafe_put_fields nup :nucmeb_expr ncurenvbox) (debug "normexp_update_current_module_environment_reference result bindlist=" bindlist" clocc=" clocc) (return clocc bindlist) ) )) (:else (assert_msg "normexp_update_current_module_environment_reference unexpected module context" () modctx)) ))) (install_method class_source_update_current_module_environment_reference normal_exp normexp_update_current_module_environment_reference) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; normalize a fetch_predefined (defun normexp_fetch_predefined (recv env ncx psloc) (debug "normexp_fetch_predefined recv=" recv) (assert_msg "check fetch_predefined recv" (is_a recv class_source_fetch_predefined) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (spred (unsafe_get_field :sfepd_predef recv)) (predefmap (unsafe_get_field :nctx_predefmap ncx)) ) (cond ( (is_a spred class_symbol) ;; if the spred is a symbol, check that it is a value in the predefmap (let ( (contk (reference ())) ) (mapobject_every predefmap (lambda (key val) (if (== val spred) (set_ref contk key)))) (if (null (deref contk)) (warning_strv sloc "FETCH_PREDEFINED unknown predef name" (unsafe_get_field :named_name spred))) ) ) ( (is_integerbox spred) ;; if spred is an integer, check it (let ( (:long predrk (get_int spred)) ) (if (or (<=i predrk 0) (>=i predrk (last_globpredef_index))) (warning_plain sloc "FETCH_PREDEFINED invalid predef rank")) ) ) (:else (assert_msg "FETCH_PREDEFINED bad predef" () spred)) ) (let ( (npre (instance class_nrep_predef :nrep_loc sloc :nrpredef spred )) ) (debug "normexp_fetch_predefined result npre" npre) (return npre ()) ))) (install_method class_source_fetch_predefined normal_exp normexp_fetch_predefined) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; normalize a store_predefined (defun normexp_store_predefined (recv env ncx psloc) (debug "normexp_store_predefined recv=" recv) (assert_msg "check store_predefined recv" (is_a recv class_source_store_predefined) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (spred (unsafe_get_field :sstpd_predef recv)) (sval (unsafe_get_field :sstpd_value recv)) (predefmap (unsafe_get_field :nctx_predefmap ncx)) ) (cond ( (is_a spred class_symbol) ;; if the spred is a symbol, check that it is a value in the predefmap (let ( (contk (reference ())) ) (mapobject_every predefmap (lambda (key val) (if (== val spred) (set_ref contk key)))) (if (null (deref contk)) (warning_strv sloc "STORE_PREDEFINED unknown predef name" (unsafe_get_field :named_name spred))) ) ) ( (is_integerbox spred) ;; if spred is an integer, check it (let ( (:long predrk (get_int spred)) ) (if (or (<=i predrk 0) (>=i predrk (last_globpredef_index))) (warning_plain sloc "STORE_PREDEFINED invalid predef rank")) ) ) (:else (assert_msg "STORE_PREDEFINED bad predef" () spred)) ) (multicall (nval nbinds) (normal_exp sval env ncx sloc) (if (null nbinds) (setq nbinds (make_list discr_list))) (let ( (csym (clone_symbol '_storepredef_)) (nfpre (instance class_nrep_store_predefined :nrep_loc sloc :nstpd_predef spred :nstpd_value nval)) (cbind (instance class_normal_let_binding :binder csym :letbind_type ctype_value :letbind_expr nfpre)) (syocc (instance class_nrep_locsymocc :nrep_loc sloc :nocc_ctyp ctype_value :nocc_symb csym :nocc_bind cbind)) ) (list_append nbinds cbind) (debug "normexp_store_predefined result nbinds=" nbinds " syocc=" syocc) (return syocc nbinds) )))) (install_method class_source_store_predefined normal_exp normexp_store_predefined) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; normalize a cheader (defun normexp_cheader (recv env ncx psloc) (debug "normexp_cheader recv=" recv "\n* ncx=" ncx) (assert_msg "check cheader recv" (is_a recv class_source_cheader) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (modctx (get_field :nctx_modulcontext ncx)) (mcheadlist (get_field :mocx_cheaderlist modctx)) ) (debug "normexp_cheader modctx=" modctx "\n mcheadlist=" mcheadlist) (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx) (assert_msg "check mcheadlist" (is_list mcheadlist) mcheadlist) (list_append mcheadlist recv) (debug "normexp_cheader updated mcheadlist=" mcheadlist "\n modctx=" modctx "\n") (return () ()) )) (install_method class_source_cheader normal_exp normexp_cheader) ;;;; normalize a cimplement (defun normexp_cimplement (recv env ncx psloc) (debug "normexp_cimplement recv=" recv "\n* ncx=" ncx) (assert_msg "check cimplement recv" (is_a recv class_source_cimplement) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (modctx (get_field :nctx_modulcontext ncx)) (mcimplemlist (get_field :mocx_cimplementlist modctx)) ) (debug "normexp_cimplement modctx=" modctx "\n mcimplemlist=" mcimplemlist) (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx) (assert_msg "check mcimplemlist" (is_list mcimplemlist) mcimplemlist) (list_append mcimplemlist recv) (debug "normexp_cimplement updated mcimplemlist=" mcimplemlist "\n modctx=" modctx "\n") (return () ()) )) (install_method class_source_cimplement normal_exp normexp_cimplement) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; normalize a use_package_from_pkg_config (defun normexp_use_package_from_pkg_config (recv env ncx psloc) (debug "normexp_use_package_from_pkg_config recv=" recv "\n* ncx=" ncx) (assert_msg "check cheader recv" (is_a recv class_source_use_package_from_pkg_config) recv) (assert_msg "check env" (is_a env class_environment) env) (assert_msg "check ncx" (is_a ncx class_normalization_context) ncx) (let ( (sloc (unsafe_get_field :loca_location recv)) (pkgtup (get_field :susepackage_pkgtuple recv)) (modctx (get_field :nctx_modulcontext ncx)) (mcpackagelist (get_field :mocx_packagepclist modctx)) ) (debug "normexp_use_package_from_pkg_config initial mcpackagelist=" mcpackagelist) (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx) (assert_msg "check mcpackagelist" (is_list mcpackagelist) mcpackagelist) ;; append each package name only if it is not already in the list (foreach_in_multiple (pkgtup) (curpkgname :long pkgix) (debug "normexp_use_package_from_pkg_config curpkgname=" curpkgname) (assert_msg "check curpkgname" (is_string curpkgname) curpkgname) (let ( (:long found 0) ) (foreach_pair_component_in_list (mcpackagelist) (curpair oldpkgname) (when (==s oldpkgname curpkgname) (setq found 1) (setq curpair ()))) (unless found (list_append mcpackagelist curpkgname)) ) ) ;; (debug "normexp_use_package_from_pkg_config final mcpackagelist=" mcpackagelist) )) (install_method class_source_use_package_from_pkg_config normal_exp normexp_use_package_from_pkg_config) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (export_values check_ctype_nargs compile_obj create_normcontext create_normal_extending_context discr_normalizing_closure get_ctype normal_exp normal_letrec_constructive normal_predef normal_import normalize_binding normalize_tuple prepare_constructor_binding register_literal_value wrap_normal_let1 wrap_normal_letseq ) ;; compatibility with old code (export_synonym class_nrep_data class_nrep_bound_data) (export_synonym class_nrep_checkinterrupt class_nrep_checksignal) (export_synonym class_nrep_quasiconst_current_module_environment_container class_nrep_quasiconst_current_module_environment_reference) (export_synonym class_nrep_quasidata_current_module_environment_container class_nrep_quasidata_current_module_environment_reference) (export_synonym class_nrep_update_current_module_environment_container class_nrep_update_current_module_environment_reference) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; eof warmelt-normal.melt