;;; -*- Mode:Common-Lisp; Package:L; Base:10 -*-
;;;
;;; parse
;;;
;;; jsp 12-April-88



;;; parse-source-to-il
;;;
;;; --- some notes go here ---

(defun parse-source-to-il (source env start-n)
  (let ((out-code) (functions-to-parse))
    
    (loop for statement in source
	  as n upfrom start-n
	  as s = (convert-source statement env)
	  collecting
	  (let ((inst) (position) (il-node))
	    (multiple-value-setq (inst position)
	      (find-instruction-and-pos s))
	    (setq il-node
		  (cond ((null inst)
			 (error-message 2 "No recognizeable il-instruction in ~a" s))
			((= position (or (il-instruction-pos inst) 0))
			 (parse-statement inst s n))
			(t
			 (error-message 2 "Position of instruction ~a does not match expected ~a for ~a"
					position (il-instruction-pos inst) s))))
	    
	    (when (and il-node (not (null (il-node-defined il-node))))
	      (define-symbol il-node env))
	    
	    ;; Special processing for FUNDEF instructions.
	    (when (eq inst *il-fundef-instruction*)
	      (push-end (list s env n) functions-to-parse))
	    
	    ;; Look for other special processing.
	    (when (il-instruction-processing inst)
	      (funcall (il-instruction-processing inst) il-node env))
	    
	    ;; Check that all destinations are writable (not constants).
	    (dolist (dest (il-node-written il-node))
	      (if (eq KIND-CONST (declaration-kind dest))
		  (error-message 1 "Constant destination in ~a" il-node)))

	    ;; Check for constant folding.
	    (let ((all-constants? t))
	      (mapc #'(lisp:lambda (arg) (if (neq KIND-CONST (declaration-kind arg)) (setq all-constants? '())))
		    (il-node-read il-node))
	      (if (and all-constants?
		       (il-instruction-c-fold inst))
		  (setq il-node
			(gen-il-constant (funcall (il-instruction-c-fold inst)
						  (il-node-read il-node))
					 (first (il-node-written il-node))
					 env)))
	      )

	    (push il-node out-code)
	    
	    )
	  )
    (values (nreverse out-code) functions-to-parse)
    
    )
  )



;;; convert-source
;;;
;;; This takes a source statement which contains operands, and returns a very similar statement that
;;; contains declarations.

(defun convert-source (source env)
  (loop for s in source
	collect (cond ((symbolp s) s)
		      ((operand? s) (get-declaration (operand-name s) env))
		      (t s))))


;;; define-symbol
;;;
;;; --- some notes go here ---

(defun define-symbol (il-node env)
  
  (let ((kind (il-instruction-defkind (il-node-op il-node)))
	(syms (il-node-defined il-node))
	(types (il-node-type il-node))
	(values (il-node-value il-node)))

    (do ((sym (pop syms)   (pop syms sym))
	 (typ (pop types)  (pop types typ))
	 (val (pop values) (pop values val)))
	((null sym))

      (let* ((prev (if (declaration? sym) sym (get-declaration sym env)))
	     (decl (or prev
		       (put-declaration (new-declaration :symbol sym :kind kind :type typ :value val) env))))
	
	(if (not (declaration? sym))
	    (zip-replace decl sym (il-node-defined il-node)))

	(if (and prev (neq (declaration-kind prev) 'undefined))
	    ;; If previously defined, then check for any errors
	    (if (neq (declaration-kind prev) 'undefined)
		(cond ((neq (declaration-kind prev) kind)
		       (error-message 0 "Redeclaration of ~a from kind ~a to ~a"
				      (declaration-symbol prev) (declaration-kind prev) kind))
		      ((neq (declaration-type decl) typ)
		       (error-message 0 "Redeclaration of ~a from type ~a to ~a"
				      (declaration-symbol prev) (declaration-type prev) typ))
		      ((neq (declaration-value prev) val)
		       (error-message 0 "Redeclaration of ~a from value ~a to ~a"
				      (declaration-symbol prev) (declaration-value prev) val))
		      ))
	    )
	
	(setf (declaration-kind decl) kind)
	(setf (declaration-type decl) typ)
	(case kind
	  (label (setf (declaration-value decl) (new-label :il-node il-node)))
	  (fn    '())
	  (t     (setf (declaration-value decl) val)))
	)
      )
    )
  )




;;; find-instruction-and-pos
;;;
;;; --- some notes go here ---

(defun find-instruction-and-pos (s)
  (let ((out (loop for arg in s
		   as pos upfrom 0
		   and val = (get-il-instruction arg '())
		   do (if val (return (list val pos)))
		   finally (return (list '() 0)))
	     ))
    (values (first out) (second out))
    )
  )


;;; check-syntax
;;;
;;; --- some notes go here ---

(defun check-syntax (syntax source out &optional (optional? '()))

  (let ((save-source source))

    (loop with syn1 do (pop syntax syn1)
	  with syn2 do (setq syn2 (first syntax))
	  with src  do (pop source src)
	  do (if (null syn1)
		 (if (null src)
		     (return)
		     (progn
		       (error-message 2 "Too much source")
		       (return (cons src source))))
		 (if (null src)
		     (if (or (eq syn1 '+)
			     (eq syn1 '[)
			     optional?)
			 (return)
			 (progn
			   (error-message 2 "Not enough source in ~a" save-source)
			   '()))))
	  do
	  (loop doing
		(if (listp syn1)
		    (if (listp src)
			(if (not (null (check-syntax syn1 src out optional?)))
			    '())				; error -- should force return ?
			'())					; error
		    (case syn1
		      (cx (push-end src (il-node-cdx out)))
		      (d  (push-end src (il-node-defined out)))
		      (i  '())					; ignore
		      (l  (push-end src (il-node-targets out)))
		      (r  (push-end src (il-node-read out)))
		      (s  (push-end src (il-node-source out)))
		      (ty (push-end src (il-node-type out)))
		      (v  (push-end src (il-node-value out)))
		      (w  (push-end src (il-node-written out)))
		      ([  (setq optional? t))
		      (]  (setq optional? '()))
		      (otherwise (when (not optional?) (error-message 2 "Illegal syntax element ~a" syn1)))
		      ))
		while (and (eq '+ syn2)
			   (pop source src))
		)
	  ))
  )



;;; parse-statement
;;;
;;; --- some notes go here ---

(defun parse-statement (inst source n)
  (let* ((out (new-il-node :op inst :n n))
	 (syntaxes (il-instruction-syntax inst))
	 (syntax (if (= 1 (length syntaxes)) (first syntaxes)
		     (loop for s in syntaxes
			   when (= (length s) (length source)) return s
			   finally (error-message 2 "Syntax length error in ~a, expecting ~a" source syntaxes))))
	 (left-over (check-syntax syntax source out)))

    (if (not (null left-over))
	(error-message 2 "Syntax error in ~a, expecting ~a, ~a left over" source syntax left-over))

    out)
  )






;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Code below this line has not been included with the code above.  It should be.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;; check-condition
;;;;
;;;; This checks the conditional part of an if statement, insuring that a valid condition has been
;;;; specified.  If so, then it returns true; if not, then it prints an error message, and returns nil.
;;;; Recall:  Condition => gt | ge | lt | le | eq | ne | plus | minus

;(defvar *cond-kinds* '(gt ge lt le eq ne plus minus) "valid conditions for an IF statement")

;(defun check-condition (cond-source n source)
;  "Checks validity of IF condition.  Returns t or nil."
;  (if (member cond-source *cond-kinds*)
;      t
;      (error-message 1 "Invalid case ~a in IF statement at #~d: ~a" cond-source n source)))


;;;; check-asm-type
;;;;
;;;; This checks the validity of a type as specified in a definition statement.  If a valid type is
;;;; given, then it returns true; if not, then it prints an error message, and returns nil.
;;;; xxx Recall:  Type => int64 | int32 | int16 | int8 | float | chunkid | fn | bool | cc
;;;; Recall:  Type => int32 | ref | fn

;(defun check-asm-type (type-source n source)
;  "Checks validity of a type.  Returns t or nil."
;  (or (eq type-source TYPE-INT32)
;      (eq type-source TYPE-REF)
;      (eq type-source TYPE-FN)
;      (type-eq type-source %function-header%)
;      (type-eq type-source %integer%)
;      (type-eq type-source %any%)
;      (type-eq type-source %reference%)
;      (type-eq type-source %closure%)
;      (type-eq type-source %type%)
;      (type-eq type-source %boolean%)
;      (type-eq type-source %et%)
;      (type? type-source)
;      (error-message 1 "Invalid type ~a in definition statement at #~d: ~a" type-source n source)))
     

;;;; check-value
;;;;
;;;; This checks the DefaultValue in a definition statement, making sure that if it is a symbol, then the
;;;; symbol is defined accordingly.  If a symbol is found, then it is returned.

;(defun check-value (value-source env n)
;  "Creates a symbol for DefaultValue as necessary.  Returns a symbol or nil."
;  (cond ((symbolp value-source)
;	 (let ((sym (get-declaration value-source env)))
;	   (if (not sym)
;	       (if (string= (string value-source) "%$" :end1 2)
;		   (setq sym (new-declaration :symbol value-source :value (string-to-integer (string value-source) 2)
;					 :kind KIND-CONST))
;		   (setq sym (new-declaration :symbol value-source))))
;	   (add-read-reference sym n)
;	   sym))
;	(t value-source))
;  )





;;; process-reserve
;;;
;;; This appropriately processes a RESERVE statement.  Processing is limited to recording the list of
;;; reigsters reserved.

(defun process-reserve (il-node env)
  "Adds the list of reserved registers specified in IL-NODE to the list in ENV.  Returns nil."
  (let* ((reserved (second (il-node-source il-node)))
	 (new-reserved (set-difference reserved (fn-reserved env))))
    (setf (fn-reserved env) (nconc new-reserved (fn-reserved env)))
    '()
    )
  )



;;; process-static
;;;
;;; This appropriately processes a STATIC statement.  Processing is limited to recording the list of
;;; reigsters staticd.

(defun process-static (il-node env)
  "Adds the list of static symbols specified in IL-NODE to the list in ENV.  Returns nil."
  (let* ((statics (second (il-node-source il-node)))
	 (new-statics (set-difference statics (fn-statics env))))
    (setf (fn-statics env) (nconc new-statics (fn-statics env)))
    '()
    )
  )




;;; gen-il-constant
;;;
;;; This generates an IL constant in a target location.  Generation includes definition of the constant, as well
;;; as creation of an il-node.

(defun gen-il-constant (value target env)
  (let ((temp (gen-temp)))
    (setf (declaration-kind temp) KIND-CONST)
    (setf (declaration-value temp) value)
    (put-declaration temp env)
    (new-il-node :op *il-move-instruction* :read (list temp) :written (list target))
    )
  )