diff options
Diffstat (limited to 'gcc/melt')
| -rw-r--r-- | gcc/melt/warmelt-base.melt | 23 | ||||
| -rw-r--r-- | gcc/melt/warmelt-macro.melt | 54 | ||||
| -rw-r--r-- | gcc/melt/warmelt-normal.melt | 42 |
3 files changed, 109 insertions, 10 deletions
diff --git a/gcc/melt/warmelt-base.melt b/gcc/melt/warmelt-base.melt index bf228083d0d..e7de373ca1e 100644 --- a/gcc/melt/warmelt-base.melt +++ b/gcc/melt/warmelt-base.melt @@ -3013,6 +3013,28 @@ typedef struct melthook_st *melthook_ptr_t; :doc #{Count the number of MELT errors.}# #{melt_error_counter}#) + +(defun symbol_cname (sy) + :doc #{Give the cname of a symbol, keyword or else NULL}# + (cond ( (is_a sy class_cloned_symbol) + (let ( (sbuf (make_strbuf discr_strbuf)) ) + (add2sbuf_cident sbuf (get_field :named_name sy)) + (add2out sbuf "cl" (get_field :csym_urank sy)) + (strbuf2string discr_verbatim_string sbuf) + )) + ( (is_a sy class_keyword) + (let ( (sbuf (make_strbuf discr_strbuf)) ) + (add2sbuf_cident sbuf (get_field :named_name sy)) + (add2sbuf_strconst sbuf "kw") + (strbuf2string discr_verbatim_string sbuf) + )) + ( (is_a sy class_symbol) + (let ( (sbuf (make_strbuf discr_strbuf)) ) + (add2sbuf_cident sbuf (get_field :named_name sy)) + (strbuf2string discr_verbatim_string sbuf) + )) + (:else + ()))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (export_values ;; keep the alphanumerical order @@ -3240,6 +3262,7 @@ typedef struct melthook_st *melthook_ptr_t; subclass_of subclass_or_eq subseq_multiple + symbol_cname tuple_nth tuple_sized valdesc_bucketlongs diff --git a/gcc/melt/warmelt-macro.melt b/gcc/melt/warmelt-macro.melt index 6126a561cb3..aaef2ee89db 100644 --- a/gcc/melt/warmelt-macro.melt +++ b/gcc/melt/warmelt-macro.melt @@ -100,6 +100,14 @@ $SARGOP_ARGS is the tuple of arguments.}# :fields (sprim_oper ;the primitive operation )) +(defclass class_source_hook_call + :doc #{The internal $CLASS_SOURCE_HOOK_CALL is for hook +call abstract syntax. $SHOOK_CALLED is the called hook or hook definition, +$SARGOP_ARGS is the tuple of arguments.}# + :super class_source_argumented_operator + :fields (shook_called ;the called hook + )) + ;;; source arithmetic variadic operation (defclass class_source_arithmetic_variadic_operation @@ -1387,6 +1395,10 @@ $SPAC_OUTARGS are the output sub-patterns.}# ;;;;;;;;;;;;;;;; the main macro expander of one expression (defun macroexpand_1 (sexpr env mexpander modctx) + :doc #{Function to macro-expand a single s-expr $SEXPR in + environment $ENV using the macroexpander $MEXPAND in module context + $MODCTX. Return the expanded form, subclass of $CLASS_SOURCE, and + perhaps other expansions.}# (if (null mexpander) (setq mexpander macroexpand_1)) (assert_msg "check env" (is_a env class_environment)) (assert_msg "check mexpander" (is_closure mexpander)) @@ -1429,7 +1441,14 @@ $SPAC_OUTARGS are the output sub-patterns.}# (let ( (citer (unsafe_get_field :cbind_citerator opbind)) (resc (expand_citeration citer sexpr env mexpander modctx)) ) - (debug "macroexpand_1 result for citerator resc" resc) + (debug "macroexpand_1 result for citerator resc=" resc) + (return resc ()) + )) + ( (is_a opbind class_hook_binding) + (let ( (hookdef (unsafe_get_field :hookbind_defhook opbind)) + (resc (expand_hook hookdef sexpr env mexpander modctx)) + ) + (debug "macroexpand_1 result for hook resc=" resc) (return resc ()) )) ( (is_a opbind class_cmatcher_binding) @@ -1469,6 +1488,9 @@ $SPAC_OUTARGS are the output sub-patterns.}# ( (is_a val class_primitive) (return (expand_primitive val sexpr env mexpander modctx) ()) ) + ( (is_hook val) + (return (expand_hook val sexpr env mexpander modctx) ()) + ) ( (is_a val class_selector) (let ( (ress (expand_msend soper sexpr env mexpander modctx)) ) @@ -1562,6 +1584,27 @@ $SPAC_OUTARGS are the output sub-patterns.}# :sprim_oper sprim :sargop_args xargtup))) +;;; expand a hook s-expression +(defun expand_hook (shook sexpr env mexpander modctx) + (debug "expand_hook shook=" shook " sexpr=" sexpr) + (assert_msg "check sexpr" (is_a sexpr class_sexpr)) + (assert_msg "check end" (is_a env class_environment)) + (assert_msg "check mexpander" (is_closure mexpander)) + (assert_msg "check modctx" (is_object modctx)) + (assert_msg "check shook" (or (is_hook shook) (is_a shook class_source_defhook))) + (let ( (scont (unsafe_get_field :sexp_contents sexpr)) + (sloc (unsafe_get_field :loca_location sexpr)) + (soper (pair_head (list_first scont))) + (xargtup (expand_restlist_as_tuple scont env mexpander modctx)) + (resh (instance class_source_hook_call + :loca_location sloc + :sargop_args xargtup + :shook_called shook + )) + ) + (debug "expand_hook gives resh=" resh) + (return resh ()) +)) ;;; class for pattern expansion context (defclass class_pattern_expansion_context @@ -2997,6 +3040,7 @@ is ($DEFVAR @var{varame} [:doc @var{documentation}]).}#) (curpair (pair_tail (list_first cont))) (symb (pair_head curpair)) (symbname (get_field :named_name symb)) + (sycname (symbol_cname symb)) (intup ()) ;formal input tuple (outup ()) ;formal output tuple (restypkw ()) ;the ctype keyword of result @@ -3014,12 +3058,16 @@ is ($DEFVAR @var{varame} [:doc @var{documentation}]).}#) (error_plain loc "missing symbol for (DEFHOOK <symb> <informals> <outformals> <ctype-key> [:predef <predef>] [:doc <doc>] <body....>)") (return)) + (when (>=i (string_length sycname) + (expr_chunk maxlen_chk :long #{/*mexpand_defhook $MAXLEN_CHK*/MELT_HOOKNAME_LEN}#)) + (error_strv loc + "too long cname for symbol of DEFHOOK" sycname) + (return)) (setq curpair (pair_tail curpair)) (warn_if_redefined symb env loc) ;; parse the formal input arguments (setq intup (let ( (insexp (pair_head curpair)) - (symbname (get_field :named_name symb)) ) (debug "mexpand_defhook insexp=" insexp) (cond ( (is_a insexp class_sexpr) @@ -3040,7 +3088,6 @@ is ($DEFVAR @var{varame} [:doc @var{documentation}]).}#) ;; parse the formal output arguments (setq outup (let ( (outsexp (pair_head curpair)) - (symbname (get_field :named_name symb)) ) (debug "mexpand_defhook outsexp=" outsexp) (cond ( (is_a outsexp class_sexpr) @@ -7732,6 +7779,7 @@ $CURRENT_MODULE_ENVIRONMENT_REFERENCE. Was previously called incorrectly class_source_funmatchexpr class_source_generator_device class_source_get_field + class_source_hook_call class_source_if class_source_ifelse class_source_ifvariadic diff --git a/gcc/melt/warmelt-normal.melt b/gcc/melt/warmelt-normal.melt index ee6cb583e94..0def2a59e8d 100644 --- a/gcc/melt/warmelt-normal.melt +++ b/gcc/melt/warmelt-normal.melt @@ -107,6 +107,13 @@ 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.}# + :fields (nhook_called + nhook_outs)) ;; normalized multiresult apply (defclass class_nrep_multiapply @@ -831,6 +838,7 @@ procedure in a module, defined with $DEFHOOK. }# class_nrep_fieldassign class_nrep_forever class_nrep_hookproc + class_nrep_hook_call class_nrep_if class_nrep_ifcommon class_nrep_ifisa @@ -1664,6 +1672,7 @@ source location.}# " psloc=" psloc ) (assert_msg "check ncx" (is_a ncx class_normalization_context)) + (assert_msg "check recv" (is_a recv class_symbol)) (multicall (bind procs gotenv) (find_enclosing_env env recv) @@ -1676,12 +1685,17 @@ source location.}# (if (null psloc) (shortbacktrace_dbg "normex_symbol null psloc" 10) ) - (if (null bind) - (progn - (error_strv psloc "unknown name; symbol is not bound" - (unsafe_get_field :named_name recv)) - (shortbacktrace_dbg "normexp_symbol null bind" 15) - (return () ()))) + (when (null bind) + (error_strv psloc "unknown name; symbol is not bound" + (unsafe_get_field :named_name recv)) + (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")) + (return () ())) ;; (if (is_a bind class_normal_magic_binding) (let ( (magval (get_field :nmagic_value bind)) @@ -2129,7 +2143,21 @@ source location.}# (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) + (assert_msg "check recv" (is_a recv class_source_hook_call)) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check nctxt" (is_a ncx class_normalization_context)) + (let ( (sloc (unsafe_get_field :loca_location recv)) + (shook (unsafe_get_field :shook_called recv)) + (sargs (unsafe_get_field :sargop_args recv)) + ) + (debug "normexp_hook_call shook=" shook " sargs=" sargs) + (assert_msg "$@$unimplemented normexp_hook_call") +)) +(install_method class_source_hook_call normal_exp normexp_hook_call) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |