2015-06-12 Basile Starynkevitch <basile@starynkevitch.net>

[official-gcc.git] / gcc / melt / warmelt-moremacro.melt

;; 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.8" for @code{gcc-4.8} 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))
         )
    (when (pair_tail curpair)
      (debug "mexpand_quote polyarg sexpr=" sexpr " cont=" cont)
      (unless (is_a sexpr class_sexpr_macrostring)
        (warning_at loc "QUOTE used with $1 arguments outside of macro-string [as $2], consider using antiquotations"
                    (list_length cont) sexpr))
      (let (
            (restlist (make_list_from_pair discr_list curpair))
            (newsexpr (instance class_sexpr_macrostring :sexp_contents restlist :loca_location loc))
            (expmquo (expand_quoted_sexpr newsexpr env () mexpander modctx))
             )
        (debug "mexpand_quot polyarg sexpr=" sexpr " newsexpr=" newsexpr " result expmquo=" expmquo)
        (return expmquo)
        )      
      )
    (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_at loc "QUOTE should have a symbol, string, or integer or s-expr argument bit is $1" cont))
          )
    (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