;  FP interpreter/compiler
;  Copyright (c) 1982  Scott B. Baden
;  Berkeley, California
;
;  Copyright (c) 1982 Regents of the University of California.
;  All rights reserved.  The Berkeley software License Agreement
;  specifies the terms and conditions for redistribution.
;
(setq SCCS-scanner.l "@(#)scanner.l	5.1 (Berkeley) 05/31/85")

; Scanner code.

; get the next token: names, numbers, special symbols
; this is the top-level scanner section.

(include specials.l)
(declare (localf alpha$ numer$ get_num$ get_nam$ namtyp two_kind))

(defun get_tkn nil
  (do ((char_num (Getc) (Getc))
       (scan_fn nil))
      
      ((eq char_num -1) (*throw 'parse$err 'eof$$))		; eof control D
      
      ; if the first character is a letter then the next token is a name
      
      (cond ((alpha$ char_num) (return (namtyp char_num)))
	    
	    ; if the first character is a number then next token is a number 
	    
	    ((numer$ char_num) (return 
				(list 'select$$
				      (get_num$ char_num))))
	    
	    ((memq char_num #.whiteSpace))
	    ((eq char_num 35) (clr_teol)) 	; # is the comment char.
	    (t (setq scan_fn (get char_set (ascii char_num)))
	       (cond ((null scan_fn)
		      (*throw 'parse$err `(err$$ bad_char ,(ascii char_num))))
		     (t (return (funcall scan_fn))))))))
	   
; these are the scanner action functions


(defun (scan$asc |[|) nil
  'lbrack$$)

(defun (scan$asc |]|) nil
  'rbrack$$)

(defun (scan$asc |{|) nil
  'lbrace$$)

(defun (scan$asc |}|) nil
  'rbrace$$)

(defun (scan$asc |(|) nil
  'lparen$$)

(defun (scan$asc |)|) nil
  'rparen$$)

(defun (scan$asc |@|) nil
  'compos$$)

(defun (scan$asc |!|) nil
  'insert$$)

(defun (scan$asc |\||) nil ; tree insert
  'ti$$)

(defun (scan$asc |&|) nil
  'alpha$$)

(defun (scan$asc |;|) nil
  'semi$$)

(defun (scan$asc |:|) nil
  'colon$$)

(defun (scan$asc |,|) nil
  'comma$$)


(defun (scan$asc |+|) nil 			; plus or pos select
  (cond ((numer$ (peekc)) (list 'select$$ (get_num$ #/0)))
	(t '(builtin$$ plus))))
  
  
(defun (scan$asc |*|) nil
  '(builtin$$ times))

(defun (scan$asc |/|) nil
  '(builtin$$ div))

(defun (scan$asc |=|) nil
  '(builtin$$ eq))

  
  ; either a 1 or 2-char token
(defun (scan$asc |-|) nil
  (cond ((numer$ (peekc))				; subtract or neg select
	 (list 'select$$ (minus (get_num$ #/0))))
	(t (two_kind #/> 'arrow$$ '(builtin$$ sub)))))	; or arrow
  
(defun (scan$asc |>|) nil 				; > or >=
  (two_kind #/= '(builtin$$ ge) '(builtin$$ gt)))

(defun (scan$asc |<|) nil				 ; < or <=
  (two_kind #/= '(builtin$$ le) '(builtin$$ lt)))

(defun (scan$asc |~|) nil 				; ~= or error
  (two_kind #/= '(builtin$$ ne)
	    `(badtkn$$ ,(ascii char_num))))
  
  
  ; if a % then read in the next constant (object)

(defun (scan$asc |%|) nil
  (let ((v (get_obj nil)))
       (list 'constant$$ (list 'quote v))))
  

; these are the  support routines 

; routine to tell if a character is a letter

(defun alpha$ (x)
  (or (and (greaterp x 96) (lessp x 123))
      (and (greaterp x 64) (lessp x 91))))


; routine to  tell if character is a number

(defun numer$ (x)
  (and (greaterp x 47) (lessp x 58)))


; routine to read in a number 

(defun get_num$  (first_c)
  (do ((num$ (diff first_c 48 ))
       (c (peekc) (peekc)))
      ((memq c num_delim$) (return num$))
      (cond ((not (numer$ c)) (*throw 'parse$err  '(err$$ badnum)))
	    (t (setq num$ (plus (times 10 num$) (diff (Getc) 48 )))))))



; routine to read in a name

(defun get_nam$ (first_c)
  (do ((name$ (cons first_c nil))
       (c (peekc) (peekc)))
      ((not (or (numer$ c) (alpha$ c) (eq #/_ c))) (implode (nreverse name$)))
      (setq name$ (cons (Getc) name$))))

; routine to determine whether the name represents a builtin
; or not

(defun namtyp (c)
  (let ((x (get_nam$ c)))
       (cond ((eq x 'while) 'while$$)
	     (t (list 
		 (cond ((null (memq x builtins)) 'defined$$)
		       (t 'builtin$$)) x)))))


; read in a lisp sequence

(defun readit nil
  (If (not (memq (car in_buf) '(< % :)))
      then (setq in_buf (cons 32 in_buf)))

  (setq in_buf (cons #/< in_buf))
  (cond ((and ptport (null infile)) (patom '< ptport)))
  (let ((readtable newreadtable))
       (do ((xx (*catch 'parse$err  (get_obj t)) (*catch  'parse$err (get_obj t)))
	    (result nil))
	   ((eq xx '>) (nreverse result))

	   (cond ((find 'err$$ xx) (*throw 'parse$err `(err$$ bad_obj ,xx))))
	   (cond ((eq '\, xx))
		 (t (setq result (cons xx result)))))))


; peek ahead to see if the single character token in really
; a double character token

(defun two_kind (char2 dbl_nm sing_nm)
  (cond ((eq (peekc) char2)
	 (prog (dummy)
	       (setq dummy (Getc)) (return dbl_nm)))
	(t sing_nm)))

; check if any ? (bottom) in sequence

(defun chk_bot$ (x)
  (cond ((atom x) (eq x '?))
	(t (or (chk_bot$ (car x)) (chk_bot$ (cdr x))))))

; get an object and check for bottom (?) or errors (reserved symbols)

(defun get_obj (read_seq)
  (let ((readtable newreadtable))
       (prog (x)
	     (setq x (read_inp))
	     (cond ((chk_bot$ x) (return '?))
		   ((boolp x) (return x))
		   ((and (atom x) (memq x '(|,| |>|)))
		    (cond (read_seq (return x))
			  (t (*throw 'parse$err  '(err$$ bad_comma)))))
		   ((and (atom x) (memq x '(+ -)))
		    (cond ((numer$ (peekc))
			   (let ((z (*catch 'parse$err (get_obj nil))))
				(cond ((find 'err$$ z)
				       (*throw 'parse$err `(err$$ bad_num ,z)))
				      ((not (numberp z))
				       (*throw 'parse$err `(err$$ bad_num ,z)))
				      (t (cond ((eq x '+) (return z))
					       (t (return (diff z))))))))
			  (t (*throw 'parse$err `(err$$ bad_num ,x)))))
		   ((and (symbolp x) (numer$ (car (exploden x))))
		    (*throw 'parse$err `(err$$ bad_num ,x)))
		   ((and (atom x) (memq x e_rsrvd)) (*throw 'parse$err `(err$$ bad_obj ,x)))
		   (t (return x))))))


(defun read_inp nil
  (let ((c
	 (let ((piport infile))
	      (Read))))
       (If (not (listp c))
	   then (let ((ob (exploden c)))
		     (let ((OB
			    (If (and (not (= (car in_buf) #/<))
				     (not (= (car in_buf) #/>))
				     (not (= c '>)))
				then (cons 32 ob)
				else ob)))
			  
			  (If (onep (length OB))
			      then (setq in_buf (cons (car OB) in_buf))
			      else (setq in_buf (append (reverse OB) in_buf))))))
       c))



(defun clr_teol nil
  (let ((piport infile))
       (do ((c (Getc) (Getc)))
	   ((eq c #.CR) 
	    (cond ((not in_def) (setq in_buf nil)))
	    (cond ((and (not infile) (not in_def)) 
		   (patom "      ")))))))

(defun p_strng (s)
  (patom (ascii s)))