; -*- Mode:Lisp; Package:lambda; Base:8; readtable: ZL -*-
;	** (c) Copyright 1980 Massachusetts Institute of Technology **
;       ** (c) Enhancements Copyright 1984,1985,1986  -  Lisp Machine, Inc.


(DEFVAR LAM-GETSYL-UNRCH NIL)
(DEFVAR LAM-GETSYL-UNRCH-TOKEN NIL)

(DEFUN LAM-GETSYL-RCH NIL 
 (PROG (CH)
	(COND (LAM-GETSYL-UNRCH 
		(SETQ CH LAM-GETSYL-UNRCH)
		(SETQ LAM-GETSYL-UNRCH NIL))
	      (T (COND (LAM-LOW-LEVEL-FLAG (LAM-REPLACE-STATE)))
		 (DO-FOREVER
		   (SETQ CH (FUNCALL STANDARD-INPUT ':ANY-TYI))
		   (COND ((ATOM CH) (RETURN NIL))
			 ((EQ (CAR CH) :TYPEOUT-EXECUTE)
			  (HANDLE-TYPEOUT-EXECUTE CH STANDARD-INPUT))))
		 (COND ((< (LOGAND CH 377) 200)
			(FORMAT STANDARD-OUTPUT "~C" CH)))))
     X	(RETURN CH)))

;Returns: for digits, a number.
;for other alphanumerics, a symbol.
;Otherwise, a symbol whose name starts with "#".
(DEFUN LAM-GETSYL-READ-TOKEN (&OPTIONAL FORCE-SYMBOL)
  (PROG (TOK CH TERM-TOKEN)
	(COND (LAM-GETSYL-UNRCH-TOKEN
		(SETQ TOK LAM-GETSYL-UNRCH-TOKEN)
		(SETQ LAM-GETSYL-UNRCH-TOKEN NIL)
		(RETURN TOK)))
   L	(SETQ CH (LAM-GETSYL-RCH))
	(COND ((= CH #\RUBOUT)
	       (OR TOK (RETURN '*RUB*))		;OVER-RUBOUT
	       (SETQ TOK (CDR TOK))
	       (CURSORPOS 'X)
	       (GO L))
	      ((OR ( #/A CH #/Z)
		   ( #/0 CH #/9)
		   (= CH #/.))
	       (GO ALPHA-NUM))
	      (( #/a CH #/z)
	       (SETQ CH (CHAR-UPCASE CH))
	       (GO ALPHA-NUM))
	      ((MEMQ CH '(#/- #/%))
	       (GO ALPHA-NUM)))
;DROP THRU ON "SCO"
	(SETQ TERM-TOKEN
	      (INTERN (STRING-APPEND "#"
				     (STRING-UPCASE (FORMAT:OUTPUT NIL
						      (FORMAT:OCHAR CH ':EDITOR))))
		      (SYMBOL-PACKAGE 'FOO)))
  SEP 
  X	(COND (TOK 
	       (SETQ TOK (NREVERSE TOK))
	       (SETQ TOK
		     (COND ((OR FORCE-SYMBOL
				(EQUAL TOK '(#/.))
				(DO L TOK (CDR L) (NULL L)
				    (OR (AND (<= #/0 (CAR L)) (<= (CAR L) #/9))
					(= (CAR L) #/-)
					(= (CAR L) #/+)
					(= (CAR L) #/.)
					(= (car l) #/%)
					(RETURN T))))
			    (inhibit-style-warnings (IMPLODE TOK)))	;HAS LETTERS IN IT
			   (T (READLIST TOK))))	;A NUMBER (DIGITS, PLUS, MINUS)
		(SETQ LAM-GETSYL-UNRCH-TOKEN TERM-TOKEN)
		(RETURN TOK))
	      (TERM-TOKEN
		(RETURN TERM-TOKEN))
	      (T (GO L)))
  ALPHA-NUM
	(SETQ TOK (CONS CH TOK))
	(GO L)))