;;; -*- Mode: COMMON-LISP; Fonts:(MEDFNT HL12B HL12I MEDFNB); Package: PASCALX; Base: 10 -*-

(DEFMACRO check-type2 (ARG-NAME TYPE &OPTIONAL TYPE-STRING)
  "Generate an error unless (TYPEP ARG-NAME 'TYPE).
TYPE-STRING is a string to use in the error message, such as 2\*"a list2\*".
If you omit it, it will be computed from TYPE's pname."
  (IF (NULL TYPE-STRING)
      (SETQ TYPE-STRING (si:TYPE-PRETTY-NAME TYPE)))
  `(DO () ((TYPEP ,ARG-NAME ,TYPE))
     (SETQ ,ARG-NAME
	   (CERROR '(:ARGUMENT-VALUE) NIL 'WRONG-TYPE-ARGUMENT
		   "The argument ~2@*~A was ~1@*~S, which is not ~3@*~A."
		   ,TYPE ,ARG-NAME ',ARG-NAME ',TYPE-STRING))))

3(DEFCONSTANT NON-STANDARD-LETTERS* '(#\_) 2"The nonstandard legal characters in an identifier"*)
3(DEFCONSTANT COMMENT-BEGIN *        #\{    2"Delimits the beginning of a comment"*)
3(DEFCONSTANT ALT-COMMENT-BEGIN*     "(*"   2"Alternate delimiter for the beginning of a comment"*)
3(DEFCONSTANT COMMENT-END*            #\}    2"Delimits the end of a comment"*)
3(DEFCONSTANT ALT-COMMENT-END*        "*)"  2"Alternate delimiter for the end of a comment"*)
3(DEFCONSTANT NON-STANDARD-SYMBOLS* '(#\&)  2"The list of all non-standard symbols"*)
3(DEFCONSTANT SPECIAL-SYMBOLS* `(#\+ #\- #\* #\/ #\= #\< #\> #\[ #\] #\. #\, #\: #\; #\^ #\@ #\( #\)
				 ,@NON-STANDARD-SYMBOLS) 2"The list of all the special symbols"*)

3(DEFCONSTANT SYMBOL-ALIST*
	       '((#\+  . PLUS)      (#\-  . MINUS)       (#\*  . STAR)       (#\/  . SLASH)
		 (#\=  . EQUAL)
		 (#\<  . LT)        ("<>" . NE)          ("<=" . LE)         (#\>  . GT)     (">=" . GE)
		 (#\[  . LEFT-BRCK) (#\]  . RIGHT-BRCK)
		 ("(." . LEFT-BRCK) (".)" . RIGHT-BRCK)
		 (#\.  . PERIOD)    (".." . DOT-DOT)
		 (#\,  . COMMA)
		 (#\:  . COLON)
		 (":=" . ASSIGN)
		 (#\;  . SEMI-COLON)
		 (#\^  . UP-ARROW)   (#\@  . UP-ARROW)
		 (#\(  . LEFT-PAREN) (#\)  . RIGHT-PAREN)
		 (#\&  . AND)
		 ("AND"       . AND)       ("ARRAY"   . ARRAY)   ("BEGIN"  . BEGIN)
		 ("CASE"      . CASE)      ("CONST"   . CONST)   ("DIV"    . DIV)
		 ("DO"        . DO)        ("DOWNTO"  . DOWNTO)  ("ELSE"   . ELSE)
		 ("END"       . END)       ("FILE"    . FILE)    ("FOR"    . FOR)
		 ("FUNCTION"  . FUNCTION)  ("GOTO"    . GOTO)    ("IF"     . IF)
		 ("IN"        . IN)        ("LABEL"   . LABEL)   ("MOD"    . MOD)
		 ("NIL"       . NILX)      ("NOT"     . NOT)     ("OF"     . OF)
		 ("OTHERS"    . OTHERS)    ("OR"      . OR)      ("PACKED" . PACKED)
		 ("PROCEDURE" . PROCEDURE) ("PROGRAM" . PROGRAM) ("RECORD" . RECORD)
		 ("REPEAT"    . REPEAT)    ("SET"     . SET)     ("THEN"   . THEN)
		 ("TO"        . TO)        ("TYPE"    . TYPE)    ("UNTIL"  . UNTIL)
		 ("VAR"       . VAR)       ("WHILE"   . WHILE)   ("WITH"   . WITH))
   2"The alist to fill up the token table, gives read form and then token."*
   );1symbol-alist

3(DEFVAR *TOKEN-TABLE* **(let* ((DEFAULT-CONS-AREA *PASCALX-STATIC-AREA*)
			        (table (make-hash-table :test #'equal :size 100)))
			   (dolist (key-value-pair SYMBOL-ALIST table)
			     (setf (gethash (first key-value-pair) table) (rest key-value-pair))))
2   "hash table to hold tokens and info about tokens"*)
(proclaim '(type hash-table *TOKEN-TABLE*))


3(DEFVAR *TOKEN-QUEUE** nil 2"the list of tokens already read but not processed"*)



3(DEFUN INIT-LEXI ()*
  2"Initializes the lexical analzyer LEXI"*
   (setf *LINE-IMAGE*          "")
   (setf *LINE-NO*             0)
   (setf *PASCAL-STREAM-EOF-P* nil)
   (setf *TOKEN-QUEUE*         () )
   (read-a-line)
   (move-begin-token)
  );1init-lexi


3(DEFMACRO CURRENT-CHAR ()**
   2"returns current character form line image"*
   (declare (values character))
   `(schar *LINE-IMAGE* *LINE-END-POS*))


3(DEFUN NEXT-CHAR ()*
   2"increment line image position and returns that character"*
   (declare (function next-char () string-char)
	    (values character))
   (cond ((char= (current-char) #\Newline)
	  (read-a-line))
	 (t (incf *LINE-END-POS*)
	    (schar *LINE-IMAGE* *LINE-END-POS*)))
  );1next-char


3(DEFMACRO LOOK-AT-NEXT-CHAR ()**
   (declare (values character))
  `(if (< (1+ *LINE-END-POS*) (length *LINE-IMAGE*))
       (schar *LINE-IMAGE* (1+ *LINE-END-POS*))
       ""))


3(DEFMACRO SUB-IMAGE (start end)*
   (declare (values string))
  `(subseq *LINE-IMAGE* ,start ,end))


3(DEFUN READ-A-LINE ()*
  2"Reads the next line of input (echoing it), stores the image in *LINE-IMAGE*,
   setting *PASCAL-STREAM-EOF-P* if eof is reached"*
  (setf *LINE-END-POS* (setf *LINE-START-POS* 0))
  (cond ((listen *PASCAL-STREAM*)
	 (incf *LINE-NO*)
	 (setf *LINE-IMAGE* (concatenate 'string (read-line *PASCAL-STREAM*) (string #\Newline)))
	 (format *LOG-STREAM* "~5D:  ~A" *LINE-NO* *LINE-IMAGE*)
	 (current-char))			1; return the first character in this line*
	(t (setf *PASCAL-STREAM-EOF-P* t)))
  );1read-a-line


3(DEFMACRO LOOK-SOME-MORE (ch)**
  "2returns true if a special symbol can be more then 1 character"*
  `(consp ,ch))


3(DEFUN LETTER? (ch)*
  2"returns true of CH is a character" *
  (or (alpha-char-p ch)
      (non-standard-letter? ch)))


3(DEFUN NON-STANDARD-LETTER? (ch)*
  "2returns true if CH is a non-standard character"*
   (char= ch #\_))


3(DEFUN SPEC-SYM? (ch)*
  2"Returns true if CH is a special symbol character"*
  (or (member ch special-symbols) (non-standard-spec-sym? ch)))


3(DEFUN NON-STANDARD-SPEC-SYM? (ch)*
  2"returns true if CH is  a non standard special symbol character"*
  (not (null (member ch non-standard-symbols))))


3(DEFMACRO STRING-BEGIN? (ch)*
   "2returns true if CH is start of a string"*
   `(char= ,ch #\'))


3(DEFMACRO STRING-END? (ch)*
  "2returns true if CH is the end of a string"*
  `(char= ,ch #\'))


3(DEFMACRO SPACE? (ch)*
  "2returns true if CH is whitespace"*
  `(or (char= ,ch #\Space) (char= ,ch #\Tab) (char= ,ch #\Linefeed)))


3(DEFMACRO RETURN? (ch)*
  "2returns true if CH is a newline"*
  `(char= ,ch #\Newline))


3(DEFMACRO PLUS-OR-MINUS (ch)*
  "2Return -1 is CH is #\- and +1 if #\+ then verifiy that next character is a digit.  Otherwise, return +1."*
  `(case ,ch
	 (#\- (if (digit-char-p (next-char)) -1
	      (error-handler "illegal number found, +/- followed by non-digit in exponent in"
			     'plus-or-minus
			     *LINE-START-POS*)))
	 (#\+ (if (digit-char-p (next-char)) 1
	      (error-handler "illegal number found, +/- followed by non-digit in exponent in"
			     'plus-or-minus
			     *LINE-START-POS*)))
	 (otherwise 1))
  );1plus-or-minus


3(DEFUN MOVE-BEGIN-TOKEN ()**
   "2Read over whitespace and comments to beginning of next token.  Comments encountered are returned
with 'major 'minor indicator"*
  (loop with comments-read = "" and old-line-no = *LINE-NO* and poss-ret = ""
	do (loop for ch first (current-char) then (next-char)	  ; get next non-space or return
		 when *PASCAL-STREAM-EOF-P* do (return nil)
		 while (or (space? ch) (return? ch))
		 finally (return ch))
	for current-comment = (consume-comment)
	while (and (not (null current-comment)) (not *PASCAL-STREAM-EOF-P*))
	do (setf comments-read (concatenate 'STRING
					    comments-read (STRING poss-ret) current-comment)
		 poss-ret #\Newline)
	finally (return (if (not (equal comments-read ""))
			    (list comments-read  (if (<= old-line-no (1+ *LINE-NO*))
						     'minor 'major)))))
  );1move-begin-token*


;1;; This is highly incorrect (* }
3(DEFUN CONSUME-COMMENT ()**
   "2If at beginning of comment, then consume it and return it.  Else return NIL."*
   (declare (values comment-or-nil))
  (setf *LINE-START-POS* *LINE-END-POS*)
  (cond ((not (member (current-char) (list comment-begin (schar alt-comment-begin 0))))
	 nil)
	(t (loop with comment-string = "{"
		 initially (select (current-char)
			     (comment-begin (incf *LINE-START-POS*))
			     (((schar alt-comment-begin 0))
			      (if (eq (look-at-next-char) (schar alt-comment-begin 1))
				  (next-char)
				  (return nil))
			      (incf *LINE-START-POS*)))
		 for ch = (next-char)
		 do (cond ((return? ch)
			   (concatenate 'string comment-string (sub-image *LINE-START-POS* *LINE-END-POS*)
					(string #\Newline)))
			  ((or *PASCAL-STREAM-EOF-P*
			       (char= ch comment-end)
			       (and (string-equal (coerce (list ch (look-at-next-char)) 'string)
						  alt-comment-end)
				    (next-char)))
			   (next-char)
			   (return (concatenate 'string comment-string
						  (sub-image *LINE-START-POS*
							     (- *LINE-END-POS*
								(if (char= ch comment-end) 1 2)))
						  "}")))))))
  );1consume-comment


3(DEFUN MAKE-NUMBER (index1 index2)**
  2"Returns the number gotten from the character codes of *LINE-IMAGE* from INDEX1 to INDEX2"*
   (declare (values number))
   (when-type-checking
     (check-type2 index1 '(integer 0 *))
     (check-type2 index2 `(integer ,index1 *)))
   (read-from-string (sub-image index1 index2)))


3(DEFUN GET-RID-OF-2-APOS (str)*
  2"Returns the string that is STR with any '' turned into a '"*
   (declare (values modified-string))
   (when-type-checking
     (check-type str string))
   (let ((pos (search "''" str :test #'string=)))
     (if (null pos)
	 str
	 (remove #\' str :test #'char= :start pos :count 1))
    );1let*
  );1get-rid-of-2-apos


3(DEFUN LEXI ()**
  2"returns the next token to use from stack or from input"*
   (declare (values token))
   (if (null *TOKEN-QUEUE*)
       (lexi1)
       (pop *TOKEN-QUEUE*))
   );1lexi


3(DEFUN PEEK-AT-TOKEN (&optional (number 1))**
  2"peeks NUMBER tokens ahead pushing all on *TOKEN-QUEUE* returning last"*
   (declare (values nth-token))
   (when-type-checking
     (check-type number counter))
   1;; look on queue first*
   (when (> number (length *TOKEN-QUEUE*))
     ;1; then we are trying to peek beyond the end of the token que, so read some more*
     (dotimes (i (- number (length *TOKEN-QUEUE*)))
       (setf *TOKEN-QUEUE* (append *TOKEN-QUEUE* (list (lexi1))))))
   (nth (1- number) *TOKEN-QUEUE*)
   );1peek-at-token


3(DEFUN LEXI1** (&aux temp tok)
  2"does the actual lexical analysis"*
   (declare (function lexi1 () token)
	    (values token))
  (when (not *PASCAL-STREAM-EOF-P*)
    (setf *LINE-START-POS* *LINE-END-POS*)
    (setf tok
	  (cond ((spec-sym? (current-char))
	     1;; find what symbol this is, first check if it is 2 characters, then 1 character*
	     (cond ((null (setf temp (gethash (coerce (list (current-char) (look-at-next-char)) 'string)
					      *TOKEN-TABLE*)))
		    (setf temp (gethash (current-char) *TOKEN-TABLE*)))
		   (t (next-char) temp))
	     (next-char)
	     (make-token :value temp :start *LINE-START-POS* :end *LINE-END-POS*))
	    
	    ((letter? (current-char))	   1; then this should be a reserved word or an identifier*
	     (make-token :value (multiple-value-bind (b e)
				    (while-in #'alphanumericp)
				  (cond ((gethash (string-upcase (sub-image b e))   1; this should be a reserved word*
						  *TOKEN-TABLE*))   1; return it*
					(t	   ; return the variable
					 (make-identifier (sub-image b e)))))
			 :start *LINE-START-POS* :end *LINE-END-POS*))
	    
	    ((digit-char-p (current-char)) 1; then this should be a number [6.1.5 p.26]*
	     (while-in #'digit-char-p)
	     1;; Check if this is a floating point number*
	     (cond ((and (char= (current-char) #\.)	   1; first check that this isn't*
			 (char/= (look-at-next-char) #\.))	   1; a range indicator (i.e. "..")[6.4.2.4 p. 36]*
		    (next-char)
		    (if (digit-char-p (current-char))
			(while-in #'digit-char-p)
			(parser-error "illegal number found in" 'lexi1 *LINE-START-POS*))))
	     (cond ((char-equal (current-char) #\E)
		    (setf temp (plus-or-minus (next-char)))
		    (if (digit-char-p (current-char)) (while-in #'digit-char-p))))
	     (make-token :value (make-number
				    (FIX *LINE-START-POS*)
				    (FIX *LINE-END-POS*))
			 :start *LINE-START-POS*
			 :end   *LINE-END-POS*))
	    
	    ((string-begin? (current-char))	   1; then this is a string*
	     (make-token
	       :value (get-rid-of-2-apos
			(loop with str = ""
			      initially (incf *LINE-START-POS*)	   1; read past initial '*
			      for ch = (next-char)
			      do (cond ((return? ch)
					(setf str (concatenate 'string str
							       (sub-image *LINE-START-POS* *LINE-END-POS*)
							       (string #\Newline))))
				       ((string-end? ch)
					(next-char)	   ;skip the '
					(if (not (string-end? (current-char)))
					    (return (concatenate 'string str
								 (sub-image *LINE-START-POS*
									    (1- *LINE-END-POS*)))))))))
	       :start (1- *LINE-START-POS*)
	       :end    *LINE-END-POS*))
	    
	    (t (error-handler "illegal character read - fatal error in" 'lexi1
			      *LINE-START-POS*))))
    (setf (token-comment tok) (move-begin-token))
    tok
    );1when*
  );1lexi1


3(DEFUN WHILE-IN (fun)**
  2"Reads characters until it finds one that returns NIL when FUN is applied.
Returns indices into *LINE-IMAGE* of string found"*
   (declare (values string-start-index string-end-index))
   (when-type-checking
     (check-type fun (satisfies functionp)))
   (let ((begin-of-string *LINE-END-POS*))
     (do ((ch (next-char) (next-char)))
	 ((not (funcall fun ch)) (values begin-of-string *LINE-END-POS*))))
   );1while-in