;; file parse-infix-syntax.melt -*- Lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(comment "***
    Copyright 2009, 2010 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 parse-infix-syntax.melt and 
;; to the generated file or warmelt-infixsyntax*.c

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



#|
  Extended BNF syntax.
  ====================

The lexer is parsing with the meltgc_infix_lexeme function in file
melt-runtime.c and reads: 

  * ordinary symbols -starting with letter, underscore _ or dollar $
    or any symbol starting with a skipped backslash \ ; in every
    symbol, case in insensitive and read as uppercase

  * additive symbols -starting with plus + minus - or vertical-bar |

  * multiplicative symbols -starting with star *, slash /, amperstand
    &, percent %

  * relational symbols -starting with less <, greater >, equal =,
    exclamation !, tilde ~, or at @

  * integers, like 23, +123, 0x34, -678, and characters read as
    integer codes like #'a for lowercase a, #\t for tabulation

  * strings like in C eg "boo" or "bar\ntab"

  * macrostrings like in Melt #{ .... $aa ....}#


We note in capital uppercase letters any Lisp symbol like LET or INSTANCE etc.

Delimiters or operator-symbols are quoted in double-quotes

Non-terminals are in lower cases

Parenthesis are meta-linguistic [unless double-quoted]. The
meta-lingustic * and + suffixes are denoting 0 to many or 1 to many
repetitions. The meta-linguistic ? suffix is for optionality.  The
meta-linguistic | is an infix binary alternative.

|#

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

(defprimitive open_infix_file (:cstring filpath) :void
#{meltgc_open_infix_file($filpath)}#)
(defprimitive close_infix_file (:cstring filpath) :void
#{meltgc_close_infix_file($filpath)}#)

(defprimitive infix_lexeme (locnam delimap) :value
  #{meltgc_infix_lexeme((melt_ptr_t)($locnam), (melt_ptr_t)($delimap))}#)

(defclass class_infix_parser
  :super class_named
  :doc #{The $CLASS_INFIX_PARSER is an internal class for infix
  parsing. $IFXP_FILNAM is the parsed file name, $IFXP_ENV is the topmost
  parsing environment, $IFXP_DELIMAP is the delimiter string map,
  $IFXP_TOKENLIST is the lexical token list.}#
  :fields (ifxp_filnam
	   ifxp_env
	   ifxp_delimap
	   ifxp_tokenlist
	   ))


;; peek the next (or (N+1)-th next) lexeme but don't consume it
(defun infix_peeklex (ipars :long n)
  (assert_msg "check ipars" (is_a ipars class_infix_parser))
  (assert_msg "check n" (>=i n 0))
  (let ( (toklist (unsafe_get_field :ifxp_tokenlist ipars)) 
	 (:long nbtok (list_length toklist))
	 )
    (assert_msg "check toklist" (is_list toklist))
    (forever getlexloop
	     (if (>=i nbtok n) 
		 (exit getlexloop))
	     (let ( (newtok 
		     (infix_lexeme (unsafe_get_field :ifxp_filnam ipars)
				   (unsafe_get_field :ifxp_delimap ipars)))
		    )
	       (list_append toklist newtok)
	       (setq nbtok (+i nbtok 1))
	     ))
    (cond ( (==i n 0)
	    (pair_head (list_first toklist)))
	  ( (==i n 1)
	    (pair_head (pair_tail (list_first toklist))))
	  (:else
	   (let ( (:long cnt 0) )
	     (foreach_in_list
	      (toklist)
	      (curpair curtok)
	      (if (>=i cnt n)
		  (return curtok))
	      (setq cnt (+i cnt 1))
	      ))))))
  

;; return the next lexeme and consume it
(defun infix_getlex (ipars)
  (assert_msg "check ipars" (is_a ipars class_infix_parser))
  (let ( (toklist (unsafe_get_field :ifxp_tokenlist ipars)) 
	 (token (list_popfirst toklist))
	 )
    (if (null token)
	(let ( (peektok  (infix_peeklex ipars 0))
	       (poptok (list_popfirst toklist))
	       )
	  (assert_msg "check peektop=potok" (== peektok poptok))
	  (setq token poptok)
	  (debug_msg token "infix_getlex returns parsed token")
	  )
      (debug_msg token "infix_getlex returns buffered token")
      )
    (return token)
  ))

;; pop a given number of lexemes
(defun infix_poplex (ipars :long n)
  (assert_msg "check ipars" (is_a ipars class_infix_parser))
  (assert_msg "check n" (>=i n 0))
  (infix_peeklex ipars n)
  (let ( (toklist (unsafe_get_field :ifxp_tokenlist ipars)) )
  (foreach_long_upto 
   (1 n)
   (:long ix)
   (list_popfirst toklist))))
  
(defclass class_infix_delimiter
  :super class_named
  :fields (idelim_string)
  :doc #{The $CLASS_INFIX_DELIMITER is an internal class for infix delimiters.
  $IDELIM_STRING is the delimiter.}#
)

(definstance infix_delimiter_left_paren class_infix_delimiter
  :named_name '"infix_delimiter_LEFT_PAREN"
  :idelim_string '"(")

(definstance infix_delimiter_right_paren class_infix_delimiter
  :named_name '"infix_delimiter_RIGHT_PAREN"
  :idelim_string '")")

(definstance infix_delimiter_left_brace class_infix_delimiter
  :named_name '"infix_delimiter_LEFT_BRACE"
  :idelim_string '"{")

(definstance infix_delimiter_right_brace class_infix_delimiter
  :named_name '"infix_delimiter_RIGHT_BRACE"
  :idelim_string '"}")


(definstance infix_delimiter_comma class_infix_delimiter
  :named_name '"infix_delimiter_COMMA"
  :idelim_string '",")

(definstance infix_delimiter_dot class_infix_delimiter
  :named_name '"infix_delimiter_DOT"
  :idelim_string '".")

(definstance infix_delimiter_semi_colon class_infix_delimiter
  :named_name '"infix_delimiter_SEMI_COLON"
  :idelim_string '";")

(definstance infix_delimiter_equal class_infix_delimiter
  :named_name '"infix_delimiter_EQUAL"
  :idelim_string '"=")


(defun infix_make_binary_expression (opsym left right loca env)
  (assert_msg "check opsym" (is_a opsym class_symbol))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (opbind (find_env opsym env))
	 )
    (match opbind 
	   (?(instance class_function_binding)
	     (instance class_source_apply
		       :loca_location loca
		       :sapp_fun opsym
		       :sargop_args (tuple left right)))
	   (?(instance class_primitive_binding
		       :pbind_primitive ?prim)
	     (instance class_source_primitive
		       :loca_location loca
		       :sprim_oper prim
		       :sargop_args (tuple left right)))
	   (?(instance class_selector_binding)
	     (instance class_source_msend
		       :loca_location loca
		       :msend_selsymb opsym
		       :msend_recv left
		       :sargop_args (tuple right)))
	   (?(instance class_value_binding
		       :vbind_value ?(and ?prim ?(instance class_primitive)))
	     (instance class_source_primitive
		       :loca_location loca
		       :sprim_oper prim
		       :sargop_args (tuple left right)))
	   (?(instance class_value_binding
		       :vbind_value ?(instance class_selector))
	     (instance class_source_msend
		       :loca_location loca
		       :msend_selsymb opsym
		       :msend_recv left
		       :sargop_args (tuple right)))
	   (?(instance class_value_binding
		       :vbind_value ?(closure))
	     (instance class_source_apply
		       :loca_location loca
		       :sapp_fun opsym
		       :sargop_args (tuple left right)))
	     (?_
	      (error_strv loca "invalid infix binary operation" 
			  (get_field :named_name opsym)))
)))

#|
;; iparse_field crash the MELT translator :-(
(defun iparse_field (iparser env)
  (assert_msg "check iparser" (is_a iparser class_infix_parser))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (ctok (infix_peeklex iparser 0))
	 )
    (match ctok
	   (?(or
	      ?(instance class_infix_symbol 
			 :loca_location ?loc
			 :lexeme_data ?(and ?sy 
					   ?(instance class_symbol 
						     :named_name ?nm)))
	      ?(instance class_infix_keyword
			 :loca_location ?loc 
			 :lexeme_data ?(instance class_keyword 
						:named_name ?nm)))
	     (if (null sy) (setq sy (create_symbolstr nm)))
	     (let ( (fldbind (find_env env sy)) 
		    )
	       (match fldbind
		      (?(instance class_field_binding
				  :flbind_field ?fld)
		       (infix_poplex iparser 1)
		       (debug_msg fld "iparse_field got straight field")
		       (return fld))
		      (?(instance class_value_binding
				  :vbind_value
				  ?(and ?fld ?(instance class_field)))
			(infix_poplex iparser 1)
			(debug_msg fld "iparse_field got value field")
			(return fld))
		      (?_
		       (error_strv loc "incorrect infix field" nm))))
	    )
	   (?(instance class_located :loca_location ?loc)
	     (error_plain loc "expecting field in infix notation")))))

(defun iparse_simple_expression (iparser env)
  (assert_msg "check iparser" (is_a iparser class_infix_parser))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (ctok (infix_peeklex iparser 0))
	 )
    (match ctok
	   (?(instance class_infix_integer_literal :lexeme_data ?i)
	     (infix_getlex iparser)
	     (debug_msg i "iparse_simple_expression got integer")
	     i)
	   (?(instance class_infix_string_literal :lexeme_data ?s)
	     (infix_getlex iparser)
	     (debug_msg s "iparse_simple_expression got string")
	     s)
	   (?(instance class_infix_symbol :lexeme_data ?sy)
	     (infix_getlex iparser)
	     (let ( (transformer (iparse_simple_transformer iparser env)) )
	       (if (is_closure transformer)
		   (transformer sy env)
		 sy)
	   )))
))

(defun iparse_multiplicative_expression (iparser env)
  (assert_msg "check iparser" (is_a iparser class_infix_parser))
  (assert_msg "check env" (is_a env class_environment))
  (let (
	(leftexp (iparse_simple_expression iparser env))
	(ctok (infix_peeklex iparser 0))
	)
    (match ctok
	   (?(instance class_infix_multiplicative_symbol :lexeme_data ?sy
		       :loca_location ?loc)
	     (infix_poplex iparser 1)
	     (let (
		   (rightexp (iparse_simple_expression iparser env))
		   )
	       (if rightexp
		   (let (
			 )

)))))))
|#


(defun get_lexeme_location (lx)
  (get_field :loca_location lx))

(defun iparse_simple_transformer (iparser env)
  (assert_msg "check iparser" (is_a iparser class_infix_parser))
  (assert_msg "check env" (is_a env class_environment))
  (let ( (ctok (infix_peeklex iparser 0))
	 (ntok (infix_peeklex iparser 1))
	 )
#|
    (match ctok
	   (?(instance class_infix_delimiter :loca_location ?loc
		       :lexeme_data infix_delimiter_dot)
	     (infix_poplex iparser 1)
	     (let ( (fld (iparse_field iparser env)) 
		    )
	       (if (is_a fld class_field) 
		   (let (
			 (transformer (iparse_simple_transformer iparser env))
			 )
			 (if (is_closure transformer)
			     (lambda (exp env)
			       (transformer (instance class_source_get_field
						      :loca_location loc
						      :suget_obj exp
						      :suget_field fld)))
			   (lambda (exp env)
			     (instance class_source_get_field
				     :loca_location loc
				     :suget_obj exp
				     :suget_field fld)
			   )
			 ))
		 (error_plain loc "infix field expected after dot")
		 ))
	   ))
|#
))

(defun parse_infix_file (filnam env)
  (debug_msg filnam "parse_infix_file start filnam")
  (assert_msg "check filnam" (is_string filnam))
  (assert_msg "check env" (is_a env class_environment))
  (let (
	(iparsnam (let ( (buf (make_strbuf discr_strbuf)) )
		    (add2sbuf_strconst buf "infpars.")
		    (add2sbuf_string buf filnam)
		    (strbuf2string discr_string buf)))
	(delimap  (make_mapstring discr_map_strings 31))
	(toklist (make_list discr_list))
	(iparser (instance class_infix_parser
			   :named_name iparsnam
			   :ifxp_filnam filnam
			   :ifxp_env env
			   :ifxp_delimap delimap
			   :ifxp_tokenlist toklist))
	)
    ;; install all our delimiters
    (foreach_in_multiple
     ((tuple infix_delimiter_left_paren infix_delimiter_right_paren
	    infix_delimiter_left_brace infix_delimiter_right_brace
	    infix_delimiter_comma infix_delimiter_semi_colon
	    infix_delimiter_equal infix_delimiter_dot
	    ))
     (idel :long dix)
     (assert_msg "check idel" (is_a idel class_infix_delimiter))
     (let ( (idelstr (unsafe_get_field :idelim_string idel)) 
	    (:long idelstrlen (string_length idelstr))
	    )
       (assert_msg "check idelstr" (is_string idelstr))
       (assert_msg "check idelstrlen" (and
					(>i idelstrlen 0)
					(<=i idelstrlen 2)))
       (mapstring_putstr delimap idelstr idel)))
    ;;
    (assert_msg "@$@unimplemented parse_infix_file" ())
))

(compile_warning "parse-infix-syntax.melt is incomplete")

(export_class 
 class_infix_parser 
 class_infix_delimiter
)

(export_values
 infix_getlex
 infix_peeklex
 infix_poplex
 infix_make_binary_expression
 infix_delimiter_comma 
 infix_delimiter_dot
 infix_delimiter_equal
 infix_delimiter_left_brace
 infix_delimiter_left_paren
 infix_delimiter_right_brace
 infix_delimiter_right_paren
 infix_delimiter_semi_colon 
)
;; eof parse-infix-syntax.melt