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

    This file is part of GCC.

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

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

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

;; the copyright notice above apply both to warmelt-moremacro.melt and 
;; to the generated files warmelt-moremacro*.c


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

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

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

;; this file should define macros which are used only later in
;; warmelt* files...

;; the each_component_in_list macro has to be in a file after the
;; expand_tuple_slice_as_tuple function

(defmacro each_component_in_list (sexp env mexpander modctx)
  :doc #{Macro $EACH_COMPONENT_IN_LIST to be invoked with a
  list-giving @var{expr} and a local variable @var{compvar} expands into
  @code{(foreach_pair_component_in_list (@var{expr}) 
					(@var{curpairvar} @var{compvar}) @var{body...})} 
  where @var{curpairvar} is fresh.}#
  (debug "each_component_in_list macro sexp=" sexp "\n env=" debug_less env)
  (let (
	(sloc (get_field :loca_location sexp))
	(sexcont (get_field :sexp_contents sexp))
	)
    (debug "each_component_in_list sloc=" debug_less sloc " sexcont=" sexcont)
    (assert_msg "check sexcont" (is_list sexcont) sexcont)
    (let ( 
	  (tcont (list_to_multiple sexcont discr_multiple))
	  (:long tcontlen (multiple_length tcont))
	  )
      (debug "each_component_in_list tcont=" tcont "; tcontlen=" tcontlen)
      (assert_msg "check tcont" (is_multiple tcont) tcont sexcont)
      (assert_msg "check tcontlen" (>i tcontlen 0) tcontlen tcont)
      (when (<i tcontlen 4)
	(error_plain sloc "EACH_COMPONENT_IN_LIST <expr-list> <var-comp> too short")
	(return () ()))
      (let ( 
	    (sexplist (let ( (se (multiple_nth tcont 1)) 
			     )
			(debug "each_component_in_list sexplist=" se)
			se))
	    (svarcomp  (let ( (sv (multiple_nth tcont 2))
			      )
			 (debug "each_component_in_list svarcomp=" sv)
			 sv))
	    (mlistexp (let ( (me (mexpander sexplist env mexpander modctx))
			     )
			(debug "each_component_in_list mlistexp=" me)
			me))
	    (mvarcomp  (let ( (mv (mexpander svarcomp env mexpander modctx))
			      )
			 (debug "each_component_in_list mvarcomp=" mv)
			 mv))
	    (bodyexp (progn 
		       (debug "each_component_in_list tcont=" tcont
			      "\n.. before expand_tuple_slice_as_tuple=" expand_tuple_slice_as_tuple)
		       (let ( (be (expand_tuple_slice_as_tuple tcont 3 -1 env mexpander modctx))
			      )
		       (debug "each_component_in_list bodyexp=" be)
		       be)))
	    )
	(when (is_not_a mvarcomp class_symbol)
	  (error_plain sloc "EACH_COMPONENT_IN_LIST <expr-list> <var-comp> bad second argument for component variable")
	  (return () ()))
	(with_cloned_symb 
	 (curpairinlistsymb)
	 (let ( (resexp
		 `(foreach_pair_component_in_list 
		   (,mlistexp)
		   (,curpairinlistsymb ,mvarcomp)
		   ,bodyexp))
		)
	   (debug "each_component_in_list resexp=" resexp)
	   (let ( (mexp (mexpander resexp env mexpander modctx))
		  )
	     (put_fields mexp :loca_location sloc)
	     (debug "each_component_in_list final mexp=" mexp)
	     (return mexp)
	     )
	   ))))))

(export_macro each_component_in_list)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; gccif support
(defun filtergccversion (versionstr)
  (assert_msg "check versionstr" (is_string versionstr) versionstr )
  (let ( (:long versionlen (string_length versionstr))
	 (res ())
	 (:cstring gccverstr "?")
	 (:cstring gccverest "-?-")
	 )
    ;;; versionstr should be e.g. "4.9" or "4.8"
    ;;; melt_gccversionstr starts with e.g. "4.8 20140217" for a plugin
    ;;; or "4.9.0 20140226" for a MELT branch
    (code_chunk 
     filtergcc
     #{ /* filtergccversion $FILTERGCC*/
        $GCCVERSTR = melt_gccversionstr;
        $GCCVEREST = melt_gccversionstr+$VERSIONLEN;
        if ($VERSIONLEN>0
	    && !strncmp (melt_string_str((melt_ptr_t)$VERSIONSTR),
			 melt_gccversionstr,
			 $VERSIONLEN)
	    && !ISDIGIT (melt_gccversionstr[$VERSIONLEN]))
        $RES = $VERSIONSTR; 
	}#)
    (debug "filtergccversion versionlen=" versionlen " versionstr=" versionstr
	   " gccverstr='" gccverstr "'; gccverest='" gccverest "'\n.. res=" res)
    (return res)))

;;;;
(defun mexpand_gccif (sexpr env mexpander modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (debug "mexpand_gccif sexpr=" sexpr)
  (let (
	(cont (unsafe_get_field :sexp_contents sexpr))
	(sloc  (unsafe_get_field :loca_location sexpr))
	(curpair (pair_tail (list_first cont)))
	(curif (pair_head curpair)) 
	(restpair (pair_tail curpair))
	)
    (debug "mexpand_gccif restpair=" restpair "\n.. first curif=" curif)
    (if (is_a curif class_sexpr)
	(let ( (xcurif (get_field :sexp_contents curif))
	       )
	  (debug "mexpand_gccif xcurif=" xcurif " sloc=" debug_less sloc)
	  (setq curif xcurif)
	  ))
    (cond 
     ((is_string curif)
      (debug "mexpand_gccif string curif=" curif " sloc=" debug_less sloc)
      (cond ((filtergccversion curif)
	     (debug "mexpand_gccif filtered curif=" curif)
	     (let ( (exprestlist (expand_pairlist_as_list restpair env mexpander modctx))
		    )
	       (debug "mexpand_gccif stringy exprestlist=" exprestlist)
	    (let ( (expfirst (list_first_element exprestlist))
		   (exptail (progn (list_pop_first exprestlist) exprestlist))
		   )
	      (debug "mexpand_gccif stringy return expfirst=" expfirst " exptail=" exptail)
	      (return expfirst exptail)))
	     )
	(:else
	  (debug "mexpand_gccif gcc version mismatched curif=" curif " sloc=" debug_less sloc)
	  (return))))
     ((is_list curif)
      (debug "mexpand_gccif list curif=" curif " sloc=" debug_less sloc)
      (let ( (ok ())
	     )
	(foreach_pair_component_in_list 
	 (curif)
	 (curpair curstr)
	 (if (not (is_string curstr))
	     (error_plain sloc "GCCIF condition not a list of strings"))
	 (if (filtergccversion curstr)
	     (setq ok :true))
	 )
	(debug "mexpand_gccif ok=" ok " sloc=" debug_less sloc)
	(if ok
	    (let ( (exprestlist (expand_pairlist_as_list restpair env mexpander modctx))
		   )
	      (debug "mexpand_gccif multicond exprestlist=" exprestlist
		     " sloc=" debug_less sloc)
	      (let ( (expfirst (list_first_element exprestlist))
		     (exptail (progn (list_pop_first exprestlist)
				     exprestlist))
		     )
		(debug "mexpand_gccif multicond  return expfirst=" expfirst
		       "\n.. exptail=" exptail)
		(shortbacktrace_dbg "mexpand_gccif multicond" 8)
		(return expfirst exptail))
	      )
	  (progn
	    (debug "mexpand_gccif sexpr gcc version multicond mismatched" sexpr)
	    (return))))
      )
     (:else 
      (error_plain sloc "GCCIF bad condition, should be a string or a list of strings")
      (return)
      ))))

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

;;;;;;;;;;;;;;;;
;;;; obsolete CONTAINER same as REFERENCE

(defun mexpandobsolete_container (sexpr env mexpander modctx)
  (debug "mexpandobsolete_container sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (warning_plain (get_field :loca_location sexpr)
		 "obsolete use of CONTAINER in expression; use REFERENCE instead")
  (mexpand_reference sexpr env mexpander modctx))

(defun patexpandobsolete_container (sexpr env pctx)
  (debug "patexpandobsolete_container sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (warning_plain (get_field :loca_location sexpr)
		 "obsolete use of CONTAINER in pattern; use REFERENCE instead")
  (patexpand_reference sexpr env pctx))
  
(install_initial_patmacro 'container patexpandobsolete_container mexpandobsolete_container)
(export_patmacro container patexpandobsolete_container mexpandobsolete_container
 :doc #{The $CONTAINER syntax for expressions or patterns is obsolete. Use $REFERENCE instead}#)


;;;;;;;; for QUOTE 
;; utility to expand an s-expression into a suitable invocation of melt_make_sexpr
(defun expand_quoted_sexpr (sexpr env antiquotefun mexpander modctx)
  (debug "expand_quoted_sexpr sexpr=" sexpr)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (:long dline (get_int loc))
	 (dfilnam (cond
		   ((is_mixint loc) (mixint_val loc))
		   ((is_mixloc loc) (mixloc_val loc))))
	 (locexp (instance class_source_hook_call
			   :loca_location loc
			   :shook_called hook_melt_make_location
			   :sargop_args (tuple dfilnam (constant_box dline))))
	 (arglist (make_list discr_list))
	 )
    (debug "expand_quoted_sexpr dline=" dline " dfilnam=" dfilnam)
    (foreach_pair_component_in_list
     (cont)
     (curpair curcomp)
     (debug "expand_quoted_sexpr curcomp=" curcomp "\n.. arglist=" arglist)
     (cond ( (null curcomp)
	     (list_append arglist ())
	     )
	   ( (is_integerbox curcomp)
	     (list_append arglist curcomp))
	   ( (is_string curcomp)
	     (list_append arglist curcomp))
	   ( (is_a curcomp class_keyword)
	     (list_append arglist curcomp))
	   ( (is_a curcomp class_symbol)
	     (let ( (qsymb (instance class_source_quote
				     :loca_location loc
				     :squoted curcomp))
		    )
	       (list_append arglist qsymb)))
	   ( (is_a curcomp class_sexpr)
	     (if (is_closure antiquotefun)
		 (let ( (curloc (unsafe_get_field :loca_location curcomp))
			(curcont (unsafe_get_field :sexp_contents curcomp))
			)
		   (if (and 
			(==i (list_length curcont) 2)
			(== (list_first_element curcont) 'comma))
		       (let ( (commaexp (list_nth_element curcont 1))
			      )
			 (debug "expand_quoted_sexpr commaexp=" commaexp " curloc=" curloc)
			 (antiquotefun commaexp arglist curloc env mexpander modctx)
			 (debug "expand_quoted_sexpr after antiquotefun arglist=" arglist)
			 )
		     (list_append arglist (expand_quoted_sexpr curcomp env antiquotefun mexpander modctx))))
	       (list_append arglist (expand_quoted_sexpr curcomp env antiquotefun mexpander modctx))
	       ))
	   ;; the below cases don't happen for expressions which have
	   ;; been read, only for computed s-exprs...
	   ( (is_list curcomp)
	     (list_append2list arglist curcomp))
	   ( (is_multiple curcomp)
	     (foreach_in_multiple
	      (curcomp)
	      (subcomp :long ix)
	      (list_append arglist subcomp)))
	   (:else
	    (list_append arglist curcomp))
	   )
     )					; end foreach_pair_component_in_list
    (debug "expand_quoted_sexpr arglist=" arglist)
    (list_prepend arglist locexp)
    (debug "expand_quoted_sexpr final arglist=" arglist)
    (let ( (xexp (instance class_source_apply
			   :loca_location loc
			   :sapp_fun 'melt_make_sexpr
			   :sargop_args (list_to_multiple arglist discr_multiple)))
	   )
      (debug "expand_quoted_sexpr result xexp=" xexp)
      (return xexp)
      )
    )
  )

(defun mexpand_quote (sexpr env mexpander modctx)
  (assert_msg "check sexpr" (is_a sexpr class_sexpr) sexpr)
  (assert_msg "check env" (is_a env class_environment) env)
  (assert_msg "check modctx" (is_object modctx) modctx)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (quoted (pair_head curpair))
	 )
    (if (pair_tail curpair)
	(error_plain loc "QUOTE should have only one argument"_))
    (cond ( (is_a quoted class_symbol) 
	    ()
	    )
	  ( (is_string quoted)
	    ()
	    )
	  ( (is_integerbox quoted)
	    ()
	    )
	  ( (is_a quoted class_source)
	    (debug "mexpand_quote sexpr return source=" quoted)
	    (return quoted))
	  ( (is_a quoted class_sexpr)
	      (debug "mexpand_quote sexpr quoted=" quoted)
	    (let ( (expquo (expand_quoted_sexpr quoted env () mexpander modctx))
		   )
	      (debug "mexpander expquo=" expquo)
	      (return expquo)))
	  (:else
	   (error_plain loc "QUOTE should have a symbol, string, or integer or s-expr argument"_))
	  )
    (if (is_a quoted class_keyword)
	(return quoted))
    (let ( (squ (instance class_source_quote
			  :loca_location loc
			  :squoted quoted)) )
      (return squ)
      )))
(install_initial_macro 'quote mexpand_quote)
(export_macro
 quote mexpand_quote
 :doc #{The $QUOTE syntax (usually noted with a prefix quote-character
 @code{'}) is for quotations. A quoted literal reifies a value, so
 @code{'2} is a value of $DISCR_CONSTANT_INTEGER. A quoted
 s-expression invokes $MELT_MAKE_SEXPR using
 $HOOK_MELT_MAKE_LOCATION.}#)


;; could be passed to expand_quoted_sexpr for future
;; mexpand_backquote; the result of antiquoter is ignored, but it
;; usually updates the arglist.
(defun antiquoter (aexp arglist loc env mexpander modctx)
  (debug "antiquoter aexp=" aexp " arglist=" arglist)
  (shortbacktrace_dbg "antiquoter" 15)
  (let ( (mexp (mexpander aexp env mexpander modctx))
	 )
    (debug "antiquoter mexp=" mexp)
    (list_append arglist mexp)
    )
  (debug "antiquoter ends with arglist=" arglist))




;;;;;;; for BACKQUOTE
(defun mexpand_backquote (sexpr env mexpander modctx)
  (debug "mexpand_backquote sexpr=" sexpr)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 (backquoted (pair_head curpair))
	 )
    (if (pair_tail curpair)
	(error_plain loc "BACKQUOTE should have only one argument"_))
    (cond ( (is_a backquoted class_sexpr)
	    (debug "mexpand_backquote backquoted sexpr " backquoted)
	    (let ( (expbk (expand_quoted_sexpr backquoted env antiquoter mexpander modctx))
		   )
	      (debug "mexpand_backquote result expbk=" expbk)
	      (return expbk)
	      ))
	  (:else
	   (debug "mexpand_backquote backquoted return verbatim " backquoted)
	   (return backquoted)))
    ))
(install_initial_macro 'backquote mexpand_backquote)
(export_macro
 backquote mexpand_backquote
 :doc #{The $BACKQUOTE macro is expanding into an s-expr, except for
$COMMA It is often noted with a prefix backquote-character
@code{`}....}# )



;;;;;;; for COMMA
(defun mexpand_comma (sexpr env mexpander modctx)
  (debug "mexpand_comma sexpr=" sexpr)
  (let ( (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc  (unsafe_get_field :loca_location sexpr))
	 (curpair (pair_tail (list_first cont))) 
	 )
    (error_plain loc "COMMA outside of BACKQUOTE-d expression")
))
(install_initial_macro 'comma mexpand_comma)
(export_macro
 comma mexpand_comma
 :doc #{The $COMMA macro is related to $BACKQUTE.
$COMMA It is often noted with a prefix comma-character
@code{,}....}# )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; utility function, e.g. to substitute *some* symbols in macrostrings.
(defun substitute_sexpr (sexpr symbrepf insidef)
  :doc #{The $SUBSTITUTE_SEXPR is substituting some symbols inside the
  given $SEXPR. Each symbol inside $SEXPR is passed to the $SYMBREPF
  function which can return a list or a tuple to be replaced by
  @i{several} -or none- elements. When a component of $SEXPR is itself
  an s-expression, the function $INSIDEF, if given, decides -by
  returning non-nil- if the substitution goes inside recursively. By
  default the substitution does not recurse inside inner
  sub-s-expressions.}#
  (debug "substitute_sexpr" " sexpr=" sexpr)
  (when (is_not_a sexpr class_sexpr)
    (debug "substitute_sexpr" " not an S-expr:" sexpr)
    (return sexpr))
  (let ( (clist (make_list discr_list))
	 (cont (unsafe_get_field :sexp_contents sexpr))
	 (loc (unsafe_get_field :loca_location sexpr))
	 (newsexpr (if (is_a sexpr class_sexpr_macrostring)
		       (instance class_sexpr_macrostring
				 :loca_location loc
				 :sexp_contents clist)
		     (instance class_sexpr
			       :loca_location loc
			       :sexp_contents clist)))
	 )
    (each_component_in_list
     cont
     curcont
     (debug "substitute_sexpr" " curcont=" curcont)
     (cond
      ( (is_a curcont class_keyword)
	(list_append clist curcont))
      ( (is_a curcont class_symbol)
	(let ( (repsymb (if (is_closure symbrepf)
			    (symbrepf curcont)
			  curcont))
	       )
	  (cond
	   ( (is_multiple repsymb)
	     (foreach_in_multiple
	      (repsymb)
	      (currep :long rix)
	      (list_append clist currep)
	      )
	     (void)
	     )
	   ( (is_list repsymb)
	     (each_component_in_list
	      repsymb
	      curlrep
	      (list_append clist curlrep))
	     (void))
	   (:else
	    (list_append clist repsymb))))
	)
      ( (is_a curcont class_sexpr)
	(let (
	      (insidev (if (is_closure insidef) (insidef curcont)))
	      (replcont (if insidev (substitute_sexpr curcont symbrepf insidef) curcont))
	      )
	  (cond
	   ( (is_multiple replcont)
	     (foreach_in_multiple
	      (insidev)
	      (curins :long insix)
	      (list_append clist curins)))
	   ( (is_list replcont)
	     (each_component_in_list
	      replcont
	      subcont
	      (list_append clist subcont)))
	   (:else
	    (list_append clist replcont)))
	  )
	)
      (:else
       (list_append clist curcont)
       )
      )
     )
    ;;
    (debug "substitute_sexpr" " result newsexpr=" newsexpr)
    (return newsexpr)
    )
  )
(export_values substitute_sexpr)
;; eof warmelt-moremacro.melt