;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;; $Header: /ct/interp/pser.l,v 1.55 85/06/21 12:30:56 bill Exp $
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                            pser.l                                ;;;
;;; Paul Robertson                                  January 30, 1983 ;;;
;;;                                                                  ;;;
;;;              The C*T Ada Interpreters Parser Driver              ;;;
;;;                                                                  ;;;
;;; This file is part of a proprietary software project.  Source     ;;;
;;; code and documentation describing implementation details are     ;;;
;;; available on a confidential, non-disclosure basis only.  These   ;;;
;;; materials, including this file in particular, are trade secrets  ;;;
;;; of Computer * Thought Corporation.                               ;;;
;;;                                                                  ;;;
;;; (c) Copyright 1982 and 1983,  Computer * Thought Corporation.    ;;;
;;;     All Rights Reserved.                                         ;;;
;;;                                                                  ;;;
;;; Reference materials:                                             ;;;
;;;   Miller, 1982.  The C*T Ada Tutor: Guide to the Implementation. ;;;
;;;   Charniak et al., 198?.  Artificial Intelligence Programming.   ;;;
;;;                                                                  ;;;
;;; The following code assumes familiarity with the above.           ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(eval-when (compile load eval) (ct_load 'aip))	      ;AIP macros pkg. 

(eval-when (compile load eval) (ct_load 'compat))     ;Franz/LM compat pkg. 

(eval-when (compile load eval) (ct_load 'time))       ;Timing functions. 

(eval-when (compile load eval) (ct_load 'diana))       ;diana_nodes

(eval-when (compile load eval) (ct_load 'sema))	       ;sema functions and macros

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

#+franz (declare (macros t))
(declare (ct_includef 'intrpdcl))			; get the specials
(eval-when (compile load eval) (ct_load 'ferec))	; get the macros etc.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Call-able Functions/Macros -- 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Macros -- 
;;; Prefix interpretation.
;;; pr_    	Parser directives.
;;; sc_		Static Semantic Checker Directives.
;;; oper_		Operator and delimiter lexical symbols.
;;; symb_		Reserved words.

(declare (special definlist synname first* start* *nonterminals* optional*))
       ;;;;;;;;
(defun clean_up ()
       ;;;;;;;;

  (mapc #'(lambda (nt)
	    (putprop nt nil 'first*list))
	*nonterminals*))

       ;;;;;;;;;;;;;;;;;;;;;;;
(defun initialize_nonterminals()
       ;;;;;;;;;;;;;;;;;;;;;;;

  (clean_up)
  (mapc
    #'initialize_nonterminal 
    *nonterminals*))

;;; Gets rid of redundancies in a list
(defun uniqueify (l)
  (map #'(lambda (x) (rplacd x (delete (car x) (cdr x)))) l))

       ;;;;;;;;;;;;;;;;;;;;;;
(defun initialize_nonterminal(nt)
       ;;;;;;;;;;;;;;;;;;;;;;

  
  (let ((first* (get nt 'firstlist))
	(nononterms t))
    (putprop
      nt
      (uniqueify
	(mapcan
	  #'(lambda(tt)
	      (let ((syntype (get tt 'syntax_type)))
		(ct_selectq
		  syntype
		  (non_terminal
		    ;; check if it has a first*list-been done
		    (let ((f*l (get tt 'first*list)))
		      (cond (f*l (subst nil nil f*l))
			    (t (initialize_nonterminal tt)
			       (subst nil nil
				      (get tt 'first*list))))))
		  (terminal(list tt))
		  (otherwise (break)
			     (format (terminal_output)
				     "*** Don't know about ~A ***~%" nt)))))
	  first*))
      'first*list)))



#|
       ;;;;;;;;;;;;;
(defun is_ada_syntax macro (l)	; hangs syntax onto property lists.
       ;;;;;;;;;;;;;

       `(progn 'compile
	       (defprop ,(cadr l) ,(caddr l) ada_syntax)
	       (defprop ,(cadr l) non_terminal syntax_type)))
|#

(eval-when (compile load eval)
  
       ;;;;;;;;;;;;;;;;;
(defun create_definition (thing)
       ;;;;;;;;;;;;;;;;;

       (let ((fname (concat synname (gensym))))
	 (ct_push `(defun ,fname () ,(macroexpand thing)) definlist)
	 `(function ,fname))))

(eval-when (compile load eval)
  
       ;;;;;;;;;;;;;;
(defun def_ada_syntax macro (body)
       ;;;;;;;;;;;;;;

       (let* ((first* nil)
	      (start* t)
	      (definlist nil)
	      (synname (cadr body))
	      (defbody (macroexpand (caddr body)))
	      (bodyname (concat (cadr body) (gensym))))
	 (ct_push
	   `(defun ,bodyname nil ,defbody)
	   definlist)
	 `(progn 'compile
		 #|(declare (localf .
				  ,(mapcan
				     #'(lambda (d)
					 (cond ((eq (cadr d) bodyname) nil)
					       (t (list (cadr d)))))
				     definlist)))|#
		 ,@definlist
		 (cond ((not (boundp '*nonterminals*))(setq *nonterminals* nil)))
		 (ct_push ',(cadr body) *nonterminals*)
		 (putprop ',(cadr body) ',first* 'firstlist)
		 (putprop ',(cadr body) nil 'first*list)
		 (putprop ',(cadr body) ',bodyname 'ada_syntax)
		 (putprop ',(cadr body) 'non_terminal 'syntax_type)))))

(eval-when (compile load eval)
       ;;;;;
(defun pr_or macro (body)
       ;;;;;
       
       (let ((fname (concat synname (gensym)))
	     )
	 (cond
	   ((null (cadr body)) (setq fname nil))
	   ((atom (cadr body)) (setq fname `(function ,(cadr body))))
;	  ((and (null (atom (cadr body))) (eq (caadr body) 'lambda))
	   (t				  ; Must be a lambda expression
	    (setq definlist 
		  (cons
		    `(defun ,fname ,(cadadr body) . ,(cddadr body))
		    definlist))
	    (setq fname `(function ,fname)))
;	  (t (setq fname (cadr body)))
	   )
	 `(pr_or_aux
	    ,fname 
	    . 
	    ,(mapcar 
	       '(lambda (x) 
		  (cond 
		    ((null x)
		     (setq optional* t) nil)
		    ((atom x)
		     (cond (start* (ct_push x first*)))
		     `',x)
		    ((eq (car x) 'pr_or)
		     (create_definition x))
		    ((eq (car x) 'pr_and)
		     (create_definition x))
		    ((eq (car x) 'pr_and2)
		     (create_definition x))
		    ((eq (car x) 'pr_and2c)
		     (create_definition x))
		    ((eq (car x) 'pr_repeat)
		     (create_definition x))
		    (t
		     (cond
		       ( (eq (car x) 'pr_restrict)
			(ct_push (third x) first*))
		       ( (memq (car x) '(pr_in_block pr_in_proc))
			(ct_push (second x) first*)))
		     (create_definition x))))
	       (cddr body)))
	 )
       )
)

(eval-when (compile load eval)
       ;;;;;;
(defun pr_and macro (body)
       ;;;;;;

       (let* ((fname (concat synname (gensym)))
	      (optional* nil)
	     (start* start*)
	     (ofirst* first*))
	     (do ((conj (cddr body)(cdr conj)))
		 ((or (not conj)
		      (and (not optional*)
			   (not  (eq first* ofirst*))))
		  (setq start* nil))
	       (setq optional* nil)
	       (cond ((and start* (atom (car conj)))
		      (setq start* nil)
		      (ct_push (car conj) first*))
		     ((and start* (eq (caar conj) 'pr_restrict))
		      (ct_push (third (car conj)) first*)
		      (setq start* nil))
		     ((and start* (memq (caar conj) '(pr_in_block pr_in_proc)))
		      (ct_push (second (car conj)) first*)
		      (setq start* nil))
		     (t (macroexpand (car conj)))
		     ))
	 (cond
	   ((null (cadr body)) (setq fname nil))
	   ((atom (cadr body)) (setq fname `(function ,(cadr body))))
;	  ((and (null (atom (cadr body))) (eq (caadr body) 'lambda))
	   (t				  ; Must be a lambda expression
	    (setq definlist 
		  (cons
		    `(defun ,fname ,(cadadr body) . ,(cddadr body))
		    definlist))
	    (setq fname `(function ,fname)))
;	  (t (setq fname (cadr body)))
	   )
	 `(pr_and_aux
	    ,fname 
	    . 
	    ,(mapcar 
	       '(lambda (x) 
		  (cond 
		    ((null x) nil)
		    ((atom x) `',x)
		    ((eq (car x) 'pr_or)
		     (create_definition x))
		    ((eq (car x) 'pr_and)
		     (create_definition x))
		    ((eq (car x) 'pr_and2)
		     (create_definition x))
		    ((eq (car x) 'pr_and2c)
		     (create_definition x))
		    ((eq (car x) 'pr_repeat)
		     (create_definition x))		    
		    (t (create_definition x))))
	       (cddr body)))
	 )
       )
)

(eval-when (compile load eval)
       ;;;;;;;
(defun pr_and2 macro (body)
       ;;;;;;;

       (let* ((fname (concat synname (gensym)))
	     (start* start*)
	     (ofirst* first*)
	     (optional* nil))
	 (do ((conj (cddr body)(cdr conj)))
		 ((or (not conj)
		      (and (not optional*)
			   (not  (eq first* ofirst*))))
		  (setq start* nil))
	       (setq optional* nil)
	       (cond ((and start* (atom (car conj)))
		      (setq start* nil)
		      (ct_push (car conj) first*))
		     ((and start* (eq (caar conj) 'pr_restrict))
		      (ct_push (third (car conj)) first*)
		      (setq start* nil))
		     ((and start* (memq (caar conj) '(pr_in_block pr_in_proc)))
		      (ct_push (second (car conj)) first*)
		      (setq start* nil))
		     (t (macroexpand (car conj)))
		     )
	       )
	 (cond
	   ((null (cadr body)) (setq fname nil))
	   ((atom (cadr body)) (setq fname `(function ,(cadr body))))
;	  ((and (null (atom (cadr body))) (eq (caadr body) 'lambda))
	   (t				  ; Must be a lambda expression
	    (setq definlist 
		  (cons
		    `(defun ,fname ,(cadadr body) . ,(cddadr body))
		    definlist))
	    (setq fname `(function ,fname)))
;	  (t (setq fname (cadr body)))
	   )
	 `(pr_and2_aux
	    ,fname 
	    . 
	    ,(mapcar 
	       '(lambda (x) 
		  (cond 
		    ((null x) nil)
		    ((atom x) `',x)
		    ((eq (car x) 'pr_or)
		     (create_definition x))
		    ((eq (car x) 'pr_and)
		     (create_definition x))
		    ((eq (car x) 'pr_and2)
		     (create_definition x))
		    ((eq (car x) 'pr_repeat)
		     (create_definition x))
		    (t (create_definition x))))
	       (cddr body)))
	 )
       )
)

(eval-when (compile load eval)
       ;;;;;;;;
(defun pr_and2c macro (body)
       ;;;;;;;;

       (let* ((fname (concat synname (gensym)))
	     (start* start*))
	 (cond ((and start* (atom (caddr body)))
		(setq start* nil)
		(ct_push (caddr body) first*))
	       (t (macroexpand (caddr body))
		  (setq start* nil)))
	 (cond
	   ((null (cadr body)) (setq fname nil))
	   ((atom (cadr body)) (setq fname `(function ,(cadr body))))
;	  ((and (null (atom (cadr body))) (eq (caadr body) 'lambda))
	   (t				  ; Must be a lambda expression
	    (setq definlist 
		  (cons
		    `(defun ,fname ,(cadadr body) . ,(cddadr body))
		    definlist))
	    (setq fname `(function ,fname)))
;	  (t (setq fname (cadr body)))
	   )
	 `(pr_and2c_aux
	    ,fname 
	    . 
	    ,(mapcar 
	       '(lambda (x) 
		  (cond 
		    ((null x) nil)
		    ((atom x) `',x)
		    ((eq (car x) 'pr_or)
		     (create_definition x))
		    ((eq (car x) 'pr_and)
		     (create_definition x))
		    ((eq (car x) 'pr_and2)
		     (create_definition x))
		    ((eq (car x) 'pr_and2c)
		     (create_definition x))
		    ((eq (car x) 'pr_repeat)
		     (create_definition x))
		    (t (create_definition x))))
	       (cddr body)))
	 )
       )
)

(eval-when (compile load eval)
       ;;;;;;;;;
(defun pr_repeat macro (body)
       ;;;;;;;;;

       (let* ((fname (concat synname (gensym))))
	 (cond
	   ((null (cadr body)) (setq fname nil))
	   ((atom (cadr body)) (setq fname `(function ,(cadr body))))
;	  ((and (null (atom (cadr body))) (eq (caadr body) 'lambda))
	   (t				  ; Must be a lambda expression
	    (setq definlist 
		  (cons
		    `(defun ,fname ,(cadadr body) . ,(cddadr body))
		    definlist))
	    (setq fname `(function ,fname)))
;	  (t (setq fname (cadr body)))
	   )
	 (setq optional* t)
	 `(pr_repeat_aux
	    ,fname 
	    . 
	    ,(mapcar 
	       '(lambda (x) 
		  (cond 
		    ((null x) nil)
		    ((atom x)
		     (cond (start* (ct_push x first*)))
		     `',x)
		    ((eq (car x) 'pr_or)
		     (create_definition x))
		    ((eq (car x) 'pr_and)
		     (create_definition x))
		    ((eq (car x) 'pr_and2)
		     (create_definition x))
		    ((eq (car x) 'pr_and2c)
		     (create_definition x))
		    ((eq (car x) 'pr_repeat)
		     (create_definition x))
		    (t
		     (cond
		       ( (eq (car x) 'pr_restrict)
			(ct_push (third x) first*))
		       ( (memq (car x) '(pr_in_block pr_in_proc))
			(ct_push (second x) first*)))
		     (create_definition x))))
	       (cddr body)))
	 
	 )
       )
)

;;; Returns true if arg has a property list. All atoms have property lists.
;;; otherwise disembodied property lists must have null car.
       ;;;
(defun pl?(u)(or (atom u)(null (car u))))
       ;;;

	     
;;;  The parser driver.
       ;;;;;;;
(defun parserd(syntaxspec)	; parse from node syntaxspec.
       ;;;;;;;

  (let (
	(result
	  (cond
	    ((symbolp syntaxspec)
			      ;  (ct_princ syntaxspec)(ct_princ "?")(ct_terpri)
	     (let ((sy_net (get syntaxspec 'ada_syntax))
		   (res nil)
		   (type (get syntaxspec   'syntax_type)))
	       (cond 
		 ((eq type 'terminal)	  ; expect this token from the lana.
		  (cond 
		    ((or (eq la_current_symbol syntaxspec) 
			 (and (consp la_current_symbol)
			      (eq (car la_current_symbol) syntaxspec)))
		     (prog1 
		       la_current_symbol  ; return this symbol.
		       (la_lex)))	  ; eat the symbol.
		    ))
		 ((and 
		    (eq type 'non_terminal)
		    (prog2
		      (ct_push syntaxspec *current_non_terminal*)
		      (cond 
			((and
			   (memq
			     (cond ((atom la_current_symbol)
				    la_current_symbol)
				   (t (car  la_current_symbol)))
			     (get syntaxspec 'first*list))
			   (eq 
			   (*catch 
			     'embedded_error 
			     (setq res (funcall sy_net)))
			   'embedded_error)
			   )
			 (let ((error_proc (get syntaxspec 'embedded_error)))
			   (cond ((null error_proc)
				  (gripe `(error in ,syntaxspec)))
				 (t (funcall error_proc))))
			 (setq res 'nulconj))
			(t res))
		      (ct_pop *current_non_terminal*)))
					  ; recursively invoke parser if its a
					  ; non-terminal.
		  res)
		 ((null type) (setq res (funcall syntaxspec))))))
	    (t (funcall syntaxspec)))))
    (cond ((and *debugparser* result (symbolp syntaxspec))
	   (ct_format t "Parsed ~A~&" syntaxspec))
    )
        result
  )
)

;;; Parses a conjunctive production. Conjunctions are parsed left to right and
;;; result in a syntax tree reversed in order of parsing. If the first
;;; conjunctive fails, nil is returned, failure of later conjunctions gives
;;; rise to a gripe. Resulting syntax tree is reversed before returning so as 
;;; to recover original order.
;;; The parameters to pr_and are code and a list of conjunctions. After the
;;; conjunction has been assembled, code is run over it, If code is nil, the
;;; assembled conjunction is returned unchanged.
       ;;;;;;;;;;
(defun pr_and_aux (&rest conjlist)	        ; parse sequential conjunction.
       ;;;;;;;;;;
  
  (do ((cl (cdr conjlist) (cdr cl))	  ; incrementally parse it.
       (*preparsecc* *pcharcount*)	  ; cc before parse.
       (*postparsecc* 0)		  ; with preparsecc defines region.
       (*srcposbeg* la_psrcpos)
       (*linposbeg* la_plinpos)
       (code (car conjlist))
       (committed nil)			  ; after first match must proceed.
       (ress nil)
       (semerr nil nil)
       (*syntree* nil))			  ; result of parse.
      ((null cl)
       (cond ((consp *syntree*)(setq *syntree* (reverse *syntree*)))) 
       (let ((conjres (cond ((null code) *syntree*)
			    (t (funcall code *syntree*)))))
	 (cond ((null conjres) 'nulconj)
	       ((eq conjres 'fail) nil)
	       (t conjres))))
    (cond
      ((setq ress (parserd (car cl) ))
       (setq *postparsecc* *pcharcount*) 
       (setq *syntree* 
	     (cond ((eq ress t) *syntree*)
		   ((memq ress '(trivdisj norepeats nulconj))
		    (cons nil *syntree*)) ;retain order of and.
		   (t (cons ress *syntree*))))
       (setq committed (null (memq ress '(t trivdisj norepeats nulconj)))))
      ;; We are committed if we get success.
      ;; trivial success not counted!
      (committed 
       (if *debugparser*
	   (gripe `(,(format nil "A ~a was expected in a ~a."
			     (car cl)
			     *current_non_terminal*))))
       (let ((error_recovery 
	       (cond 
		 ((atom (find_needed (car cl)))
		  (get (find_needed (car cl)) 'error_missing))
		 (t nil))))		  ;What do we do if there is an error?
	 (cond ((null error_recovery)
		(gripe `(,(format nil "A ~a was expected."
				  (find_needed (car cl))))))
	       (t (funcall error_recovery))))
       (cond
	 ((and (null *syntree*)(null (cdr cl)))(setq *syntree* 'nulconj))
	 (t (ct_push nil *syntree*))	  ; ?? cud.b.dangerus
	 )
       )
      (t (return nil))			  ; Return nil. Not this production.
      )
    )
  )

;;;ll(2) version of pr_and, same format as pr_and. Additional restriction is that
;;;the first two syntactic entries must consist of exactly one symbol.
       ;;;;;;;;;;;
(defun pr_and2_aux (&rest conjlist)	        ; parse sequential conjunction.
       ;;;;;;;;;;;

  (let ((previous_symbol la_current_symbol))
    (cond ((parserd (second conjlist) )
	   (let ((this_symbol la_current_symbol))
	     (cond ((parserd (third conjlist))
		    (putback_symbol this_symbol)
		    (putback_symbol previous_symbol)
		    (apply (function pr_and_aux) conjlist))
		   (t (putback_symbol previous_symbol) nil))))
	  (t nil))))

;;;ll(2) version of pr_and, same format as pr_and. Additional restriction is that
;;;The first entry is a symbol, and the second is a symbol
;;;that will be unread after being found, so that it must be repeated in the
;;;third etc..
       ;;;;;;;;;;;;
(defun pr_and2c_aux (&rest conjlist)	        ; parse sequential conjunction.
       ;;;;;;;;;;;;

  (let ((previous_symbol la_current_symbol))
    (cond ((parserd (second conjlist) )	  ;does the first symbol match?
	   (let ((this_symbol la_current_symbol))
	     (cond ((parserd (third conjlist))	  ;does the second match?
		    (putback_symbol this_symbol)  ;yes, put back both parts
		    (putback_symbol previous_symbol)
		    (apply (function pr_and_aux)	  ;try real thing!
			   (cons (first conjlist)
				 (cdddr conjlist))))
		   (t (putback_symbol previous_symbol) nil))))
	  (t nil))))			  ;failed on first symbol.

;;; Parses up a list of zero or more components of type syntaxtype. Always
;;; succeeds. Resultant parse tree is in reverse order of parsing.
;;; Result is reversed to recover original order.
;;; Two arguments to pr_repeat, are code and syntaxspec, the former should be
;;; a lambda expression of one variable which will transform the produced
;;; piece of syntax. nil implies no transformation is required. The
;;; transformation function MUST NOT return a nil value.
       ;;;;;;;;;;;;;
(defun pr_repeat_aux (&rest syntaxspec)
       ;;;;;;;;;;;;;

  (do ((*syntree* nil)			  ; accumulate repetitions.
       (*preparsecc* *pcharcount*)
       (*postparsecc* 0)
       (*srcposbeg* la_psrcpos)
       (*linposbeg* la_plinpos)
       (success (parserd (cadr syntaxspec) )
		(parserd (cadr syntaxspec) )))
      ((null success) 
       (%= *postparsecc* *pcharcount*)
       (cond (*syntree*
	      (cond ((null (car syntaxspec))(reverse *syntree*))
		    (t (apply (car syntaxspec) (list (reverse *syntree*))))))
	     (t 'norepeats)))
    (cond
      ((null (eq success t))(setq *syntree* (cons success *syntree*))))))

;;; Parses a disjunctive production. A disjunctive containing nil always
;;; succeeds. Disjunctions are tried in the order presented, the first
;;; successful parse results in a successful return.
       ;;;;;;;;;
(defun pr_or_aux (&rest disjlist)	; Parse disjunction, nil always succeeds.
       ;;;;;;;;;

  (let ((old_committment committed))
    (let ((choices (cdr disjlist))	  ;the acceptable choices.
	  (code    (car disjlist)))	  ;nil or a possible way out!!(error handler).
      (do ((dl choices (cdr dl))	  ; Search for first successful match.
	   (*syntree* nil))		  ; non-nil if succeeds.
	  ((or *syntree* (null dl))
	   (cond (*syntree*)
		 (code (funcall code))))
	(setq committed (and (null (cdr dl)) old_committment))
					  ; only the last entry can
					  ; inherit commitment.
	(setq *syntree* (cond ((null (car dl)) 'trivdisj)
			    (t (parserd (car dl) ))))))))

       ;;;;
(defun dpl?(l)(and (consp l)(consp (cdr l))(null (cadr l))))
       ;;;;

       ;;;;;;;;;
(defun conj_part(n)
       ;;;;;;;;;
  (n_th (- (1+ (length *syntree*)) n) *syntree*))

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

;;; Static semantic code schemas are structured as follows.
;;; Body contains lisp code that returns a piece of diana tree or nil.
;;; The main way of building a diana tree is with the sc_diana functon.
;;; Simple node will consist only of these nodes. sc_diana looks like this...
;;; (sc_diana dn_foo slotname code slotname code slotname code .. .. .. ..)
;;; The above example creates a diana node with the names slots, and calls the
;;; appropriate code to fill the slots. One reason why this function should be
;;; used is that it hides the internal representation of a diana node making
;;; future modifications easy (which would be necessary for say a production
;;; compiler.
;;; The abstract syntax is available for inclusion in  the diana tree or
;;; other in a free variable called *abstract_syntax*. This variable may be
;;; altered by the code for effeciency reasons without intefering with the
;;; parsing process. Syntax nodes that do not have ssemantics code will
;;; produce abstract syntax subtree's. To return a null node have a ssemantic
;;; property that returns nil.






       ;;;;;;;;;;;;;
(defun diana_pointer(v)		; diana lists are terminated by voids, not
       ;;;;;;;;;;;;;

				; nils
   (cond ((null v)(sc_diana dn_void  lx_comments '("generated")))
         (t v)))

;;; Build a function call node. handles infix operators. Expects a list of the
;;; general form (dnode ((operator dnode) (operator dnode) ..))
;;; generates a function call tree for the above. (left associative).

(eval-when (compile load eval)
(def_record_type infix_call infix (leftleaf rightsubtree))
(def_record_type subtree nil      (operator rightleaf))
)

(declare (special foo))
       ;;;;;;;;;;;;;;;;;;;
(defun sc_function_call_op ()	; build function_call node
       ;;;;;;;;;;;;;;;;;;;
  (cond
    ((memq (subtree%operator (first (infix_call%rightsubtree
				      *abstract_syntax*)))
	   '(symb_and_then symb_or_else))
     (let ((right
	     (cond ((cdr (infix_call%rightsubtree
			   *abstract_syntax*)) 
		    (let ((*abstract_syntax*
			    (infix_call 
			      (cadar
				(infix_call%rightsubtree
				  *abstract_syntax*))
			      (cdr
				(infix_call%rightsubtree
				  *abstract_syntax*)))))
		      (sc_function_call_op)))
		   (t (cadar
			(infix_call%rightsubtree
			  *abstract_syntax*))))))
       
       (sc_diana dn_binary
		 as_exp1 (infix_call%leftleaf *abstract_syntax*)
		 as_exp2 right
		 as_binary_op
		 (cond
		   ((eq (subtree%operator (first (infix_call%rightsubtree
						   *abstract_syntax*)))
			'symb_and_then)
		    (sc_diana dn_and_then))
		   (t
		    (sc_diana dn_or_else))))))
    (t
     (prog (foo)			  ; what a crock!!!
	   (return
	     (let
	       ((firstcall		  ; The first function call (perhaps only)
		  (normalize_params
		    (dissambiguate_function_reference
		      (sc_diana dn_function_call
				lx_prefix nil	  ; this was an infix operator.
				as_name nil
				as_param_assoc_s
				(sc_diana
				  dn_param_assoc_s
				  as_list
				  (let ((rst
					  (subtree%rightleaf
					    (first 
					      (infix_call%rightsubtree
						*abstract_syntax*)))))
				    (cond
				      (rst
				       (list
					 (infix_call%leftleaf *abstract_syntax*)
					 rst))
				      (t
				       (list
					 (infix_call%leftleaf *abstract_syntax*))))))
				tp_vfuns (ada_declared
					   `(lex_ident
					      ,(cadr
						 (op_name
						   (subtree%operator
						     (first (infix_call%rightsubtree
							      *abstract_syntax*))))))
					   nil
					   'function
					   t)))))
		(restcalls			  
		  ;; remaining subtree - elaborated recursively.
		  (cdr (infix_call%rightsubtree *abstract_syntax*))))
	       (cond
		 (restcalls
		  (setq *abstract_syntax*
			(infix_call firstcall restcalls))
		  (sc_function_call_op))
		 (t firstcall))))))))

       ;;;;;;;
(defun op_name (intnam)
       ;;;;;;;
  (ct_selectq intnam
	      (oper_lt '(lex_string (#/<)))
	      (oper_gt '(lex_string (#/>)))
	      (oper_plus '(lex_string (#/+)))
	      (oper_minus '(lex_string (#/-)))
	      (oper_star '(lex_string (#/*)))
	      (oper_slash '(lex_string (#//)))
	      (oper_starstar '(lex_string (#/* #/*)))
	      (oper_le '(lex_string (#/< #/=)))
	      (oper_ge '(lex_string (#/> #/=)))
	      (oper_equals '(lex_string (#/=)))
	      (oper_notequals '(lex_string (#// #/=)))
	      (oper_ampersand '(lex_string (#/&)))
	      (symb_mod '(lex_string (#/m #/o #/d)))
	      (symb_abs '(lex_string (#/a #/b #/s)))
	      (symb_rem '(lex_string (#/r #/e #/m)))
	      (symb_not '(lex_string (#/n #/o #/t)))
	      (symb_and '(lex_string (#/a #/n #/d)))
	      (symb_or '(lex_string (#/o #/r )))
	      (symb_xor '(lex_string (#/x #/o #/r)))
;	      (t (break))))	; 
	      (otherwise (lose 'ct_uko 'op_name))))

       ;;;;;;;;;;;;;
(defun operator_name(lextoken)	; converts lexical token into a name.
       ;;;;;;;;;;;;;

    `(lex_operator ,(cdddddr (exploden lextoken))))

       ;;;;;;;;;;;;;;;;
(defun sc_function_call (*abstract_syntax*); this is a terrible crock that
       ;;;;;;;;;;;;;;;;
					  
	(sc_function_call_op))		  ;MUST be deleted asap!!!!!!

       ;;;;;;;;;;;;;;;;;;
(defun find_selected_name (dn)
       ;;;;;;;;;;;;;;;;;;

  (cond ((null dn) nil)
	((consp dn)(find_selected_name (car dn)))
	(t (ct_selectq (diana_nodetype_get dn)
		       (dn_selected (find_selected_name
				      (diana_get dn 'as_designator_char)))
		       (otherwise (diana_get dn 'lx_symrep))))))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun complain_about_awaiting_disambiguation()
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (mapc #'dissambiguate_function_reference *awaiting_disambiguation*)
  (mapc
    #'(lambda(dn)
	(semgripe 'ambig_subprog_ref
		  (let* ((tpvfuns (first (diana_get dn 'tp_vfuns)))
			 (lxsr (and
				 tpvfuns (find_selected_name tpvfuns))))
		    (implode
		      (cadr
			  lxsr)))
		  (source_region%linstart (diana_get dn 'lx_srcpos)))
	(%= *awaiting_parameter_normalization* (delq dn *_*)))
    *awaiting_disambiguation*))

(declare (special *class_restriction* *no_function*))
       ;;;;;;;;;;;
(defun no_function fexpr (syntactic_unit)
       ;;;;;;;;;;;

  (let* ((*no_function* t)
	 (*class_restriction* '(object formal_parameter number
				 constant package
				 pragma_parameter
				 generic_unit
				 library_unit
				 task procedure entry))
	 (parsed (parserd (car syntactic_unit))))
    parsed))

;;; Checks that the identifier exists and has the correct CLASS. A semantic
;;; error results if the identifier either doesn't exist (hasn't appeared in
;;; a declaration) or has an incompatible CLASS such as being a type when a
;;; task was expected. Note that CLASS is used here to mean a broad taxonomy
;;; of identifier such as tasks types packages etc. Ada types provide a more
;;; detailed categorization.

       ;;;;;;;;;;;
(defun pr_restrict fexpr (object) ; (pr_restrict class syntactic_unit)
       ;;;;;;;;;;;
       ;;used by ada_declared-for name.
       (cond
	 ((and *no_function* (eq (car object) 'function))
	  nil)
	 (t
	  (let ((*class_restriction* (car object))) 
	    (let 
	      ((parsed (parserd (cadr object))))
	      (cond (parsed		  ; if we parsed the object,
					  ;lets see if its
					  ; class is ok.
		     (cond		  ; object may be an id a
					  ;lex_ident or other
		       ((and (not (diana_nodep parsed))
			     (memq (car parsed) '(lex_ident lex_string)))
			
					  ; The parsed object is an identifier,
					  ; find_name should yield its declaration
					  ; which must have CLASS (car object).
			(let
			  ((defs
			     (walk_env_rec
			       (get_id `(lex_ident ,(cadr parsed))
				       (la_hash (cadr parsed)))
			       **current_block**
			       nil)))		     
			  (cond 
			    ((memq 
			       (car object)
			       (mapcar (function (lambda (symboltableentry)
						   (la_id%class symboltableentry)))
				       defs))
			     `(lex_ident ,(cadr parsed))) ; class matched OK.
			    ((not committed)
			     (putback_symbol parsed)	  ; symbol didnt match,
					  ; put it back so that
					  ; a future match can
					  ; be attempted.
			     nil)	  ; report failure for this one.
			    (t (semgripe  'obj_expected (car object)) 
			       (sc_diana dn_used_name_id
					 sm_defn
					 #|(sc_diana dn_semantic_error
						sm_wegot parsed)|#
					 nil))
			    )))
		       ((and (diana_nodep parsed)
			     (memq 'lx_symrep (diana_actual_attributes parsed)))
;;			  (diana_get  parsed 'lx_symrep))
					  ; if it is a diana node with
					  ;a symrep slot
					  ; lookup that slot in the
					  ;symbol table and
					  ; check its type.
			(cond
			  ((memq 
			     (car object)
			     (mapcar
			       (function (lambda (symboltableentry)
					   (la_id%class symboltableentry)))
			       (get_id 
				 (diana_get parsed 'lx_symrep)
				 (la_hash (cadr (diana_get parsed 'lx_symrep))))))
			   parsed)	  ; class matched OK.
					  ; later we will want
					  ; to add the back
					  ; pointer to the
					  ; definition for this
					  ; case.
			  ((not committed)
			   (putback_symbol parsed); symbol didnt match,
					  ; put it back so that
					  ; a future match can
					  ; be attempted.
			   nil)		  ; report failure for this one.
			  (t (semgripe  'obj_expected (car object)) 
			     (sc_diana dn_used_name_id
				       sm_defn
				       #|(sc_diana dn_semantic_error
					      sm_wegot parsed)|#
				       nil))
			  ))
		       (t parsed)))))))))


;;; predicate that determines if a diana node is a subprogram call.
       ;;;;;;;;;;;;;;;;;;;;;;
(defun subprogram_call_node_p(dn); returns t if dn is a subprogram diana node.
       ;;;;;;;;;;;;;;;;;;;;;;

    (and (diana_nodep dn)
	 (memq (diana_nodetype_get dn) '(dn_procedure_call dn_function_call))))

       ;;;;;;;;;;;;;
(defun find_selected(dn)
       ;;;;;;;;;;;;;

  (cond
    ((null dn) nil)
    ((eq (diana_nodetype_get dn) 'dn_selected)
     (find_selected (diana_get dn 'as_designator_char)))
    ((eq (diana_nodetype_get dn) 'dn_used_name_id)
     dn)
    ((eq (diana_nodetype_get dn) 'dn_generic_id)
     (sc_diana dn_used_name_id
	       sm_defn dn))
    ((eq (diana_nodetype_get dn) 'dn_proc_id)
     (sc_diana dn_used_name_id
	       sm_defn dn))
    ((eq (diana_nodetype_get dn) 'dn_procedure_call)
     (find_selected (car (diana_get dn 'tp_vfuns))))
    ((eq (diana_nodetype_get dn) 'dn_function_call)
     (find_selected (car (diana_get dn 'tp_vfuns))))
    ((eq (diana_nodetype_get dn) 'dn_entry_id)
     dn)
    ((eq (diana_nodetype_get dn) 'dn_function_id)
     (sc_diana dn_used_name_id
	       sm_defn dn))
    ((and (consp dn)(= (length dn) 1))
    (find_selected (car dn)))
    (t (lose 'fe_edn 'find_selected ))))

;;; Get the definition of the name (if it is a name)
       ;;;;;;;;;;
(defun strip_name(name)
       ;;;;;;;;;;
  (cond
    ((null name) nil)  
    ((eq (diana_nodetype_get name) 'dn_used_name_id)
     (strip_name (diana_get name 'sm_defn)))
    (t name)))



	;;;;;;;;;;;;;;;
(defun  pairify_formals (formals)
        ;;;;;;;;;;;;;;;
  (mapcan
    #'(lambda(id)
	(list `(,(diana_get id 'lx_symrep)
		,(diana_get id 'sm_obj_type))))
    (mapcan
      #'(lambda(fg)
	  (#+franz copy_dn #+lispm copylist (diana_get fg 'as_id_s)))
      formals)))
    
       ;;;;;;;;
(defun last_car(l)
       ;;;;;;;;

  (cond
    ((null (cdr l))(car l))
    (t (last_car (cdr l)))))

       ;;;;;;;;;
(defun find_defo(ids)
       ;;;;;;;;;

  (let ((sm_first
	  (mapcan
	    #'(lambda(id)
		(let ((defined_in (diana_get id 'ct_st_defining_block)))
		  (cond
		    ((null defined_in)
		     (semgripe  'no_def_block
				  (implode (cadr (diana_get id 'lx_symrep)))))
		    ((or t		  ; need to find local context++
			 (eq defined_in **current_block**);either defined here.
			 (memq defined_in
			       (diana_get **current_block** 'ct_mixin_s)));or there
		     (list id)))))
	    ids)))
    (cond
      ((> (length sm_first) 1)
       (semgripe 'mult_def_occur)
       nil)
      (t (cond ((null sm_first) nil)
#|	       ((diana_get (car sm_first) 'sm_first)
		(diana_get (car sm_first) 'sm_first))|#
	       (t (car sm_first)))))))

;;; eof
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;