;;
;;
;;      Title : D-ReadAtom
;;
;;      Function : Read an atom from a given port,  this is used to 
;;         replace the idiosycratic franz reader with one of my own.
;;
;;      Author :  Alan W Black   June 1986
;;     
;;      Copyright : Graeme Ritchie, Alan Black,
;;                  Steve Pulman and Graham Russell 1987
;;   
;;         ---------------------------------------------
;;         |    Not to be used for military purposes   |
;;         ---------------------------------------------
;;
;;      Description :
;;        This routine is written to replace the lisp reader.  This is
;;        to try to cut down the dependence on the given LISP reader.
;;
;;        If you are trying to port the code, this file is the one
;;        you should concentrate on.  Once this one is working most
;;        other things do.
;;
;;        The function returns the next atom read from the given port. 
;;        (If the atom can be read as an integer number the integer number
;;        is returned instead of the string with that print name).  Or
;;        an s-expression saying an unquoted # has been found.  This is
;;        used to identify the compiler directive.
;;
;;        There is a list of single character atoms.  These will break the
;;        reading of an atom unless in double quotes.  The given eofmarker
;;        is returned if end of file found.
;;
;;        The characters are read from the port as integers (ascii) and
;;        dealt with that way before being converted to characters.
;;
;;        The functions D-MakeEOLNSymbol and D-MakeEOLNNotSymbol make
;;        make the end of line character into a single character symbol
;;        (and not).
;;
;;
;;      Parameters :
;;        port: an open input port, or t for standard input
;;        eofmarker: returned if end of file found
;;      Returns :
;;        atom: the next atom (or integer) or eofmarker 
;;              or (DK-COMPILERDIRECTIVE)  (which is '(compiler directive))
;;              if an unquoted # is found
;;      Side Effect :
;;
;;      External references :
;;        Note these are lists of integers NOT atoms
;;
;;        D-SINGLE_CHARACTER_SYMBOLS  a list of single character atoms
;;          that have to be treated as symbols in the their own right
;;        D-WHITE_SPACE_CHARACTERS  the symbols that are not significant 
;;          (except these can be used to terminate atoms). 
;;        D-QUOTE the quote character
;;
;;      System functions used :
;;        (tyi port)  reads the next character as an integer
;;        (tyipeek port) returns the next character (as an integer) from
;;                    the port without actually reading it
;;
;;      Restrictions :
;;
;;

(declare
   (special
      D-READERQUOTE D-READERENDOFLINE
      D-MINUS_SIGN
      D-BANG
      D-NEWLINE
      D-SINGLE_CHARACTER_SYMBOLS D-WHITE_SPACE_CHARACTERS
      D-STRINGSON)
   (localf
      D-InitReader
      D-ReadAtom
      D-ConvertToSymbol               
      D-AllNumerals                   
      D-ConvertToInteger              
      D-EndOfString                   
      D-MakeEOLNSymbol 
      D-MakeEOLNNotSymbol 
      D-ReadLispS-Expression
   )
)

(defun D-InitReader ()
;;
;;  Sets up the globals for the reader
;;  by default EOLN is NOT a single character symbol
;;
   (let ( (leftparen (DK-LEFTPAREN))
          (rightparen (DK-RIGHTPAREN))
          (hash (DK-HASH))
          (semicolon (DK-SEMICOLON))
          (colon (DK-COLON))
          (leftbrace (DK-LEFTBRACE))
          (rightbrace (DK-RIGHTBRACE))
          (leftangle (DK-LEFTANGLE))
          (rightangle (DK-RIGHTANGLE))
          (rightbracket (DK-RIGHTBRACKET))
          (leftbracket (DK-LEFTBRACKET))
          (comma (DK-COMMA))
          (space (DK-SPACE))
	  (simplequote (DK-SIMPLEQUOTE))
	  (bang (DK-BANG))
          (tab (DK-TAB)) )
      (setq D-READERQUOTE (DK-READERQUOTE))
      (setq D-READERENDOFLINE (DK-READERENDOFLINE))
      (setq D-MINUS_SIGN (DK-MINUS_SIGN))

      (setq D-SINGLE_CHARACTER_SYMBOLS 
         (list leftparen rightparen semicolon hash
	       colon leftbrace rightbrace leftangle 
	       leftbracket rightbracket comma
	       simplequote bang
	       rightangle))

      (setq D-WHITE_SPACE_CHARACTERS
         (list space tab D-READERENDOFLINE))
      (setq D-BANG '|!|)
      (setq D-NEWLINE '|
|)

  )
)
		
(defun D-ReadAtom (port eofmarker)
;;
;;
   (let  (ch symbol expandedsymbol (eof (DK-D-EOF)))
      (D-while (memq (setq ch (tyipeek port))
		     D-WHITE_SPACE_CHARACTERS)
         (tyi port)
      )
      (cond
	 ((eq ch eof)      ;; End of File
	    (setq symbol eofmarker)    
         )
	 ((eq ch (DK-HASH))    ;; compiler directive
	    (setq symbol (DK-COMPILERDIRECTIVE))
	    (tyi port))
	 ((memq ch D-SINGLE_CHARACTER_SYMBOLS)
	    (setq symbol (implode (ncons ch))) ;; a single character symbol
	    (tyi port)   ;; skip to next character
         )
	 ((eq ch D-READERQUOTE)       ;; test to see if it is a string
	    (tyi port)
	    (D-while (not (or (D-EndOfString 
			          (setq ch (tyi port)) port)
			      (eq ch eof)))
	       (setq expandedsymbol (cons ch expandedsymbol))
            )
	    (cond
	       ((eq ch eof)
		  (error "End of File found within quoted string")))
            (cond
	       (D-STRINGSON              ;; returns a string
	          (setq symbol    
	             (apply #'strcat
		        (mapcar
		           #'(lambda (x)
			      (implode (ncons x)))
			      (nreverse expandedsymbol)))))
               (t                      ;; returns a symbol
	          (setq symbol (implode (nreverse expandedsymbol)))))
         )
	 (t                     ;; atom or number
	    (D-while (not (or (memq ch D-WHITE_SPACE_CHARACTERS)
			      (memq ch D-SINGLE_CHARACTER_SYMBOLS)
			      (eq ch eof)))
               (setq expandedsymbol (cons ch expandedsymbol))
	       (tyi port)
	       (setq ch (tyipeek port))
            )
            (setq symbol
	      (D-ConvertToSymbol (nreverse expandedsymbol)))
         )
      )
      symbol    ;; return the found symbol
   )
)
   
(defun D-ConvertToSymbol (listofchars)
;;
;;  Takes an expanded list of characters and first tests to see if
;;  can be converted to a integer, if they can they are and that integer
;;  is returned, if not then they are imploded and returned
;;
   (cond
      ((D-AllNumerals listofchars)
	 (D-ConvertToInteger (nreverse listofchars))
      )
      ((and (cdr listofchars)    ;; more than one character long
	    (eq (car listofchars) D-MINUS_SIGN)
	    (D-AllNumerals (cdr listofchars)))
         (minus (D-ConvertToInteger (cdr listofchars)))
      )
      (t
	 (implode listofchars)   ;; just a simple atom
      )
   )
)

(defun D-AllNumerals (listofchars)
;;
;;  checks the list to see if they are all in the range 0-9
;;  t if so, nil otherwise
;;
;;  This will never work
;;
   (cond
      (t nil)      ;; hacky solution to test something
      ((null listofchars) t)
      ((memq (car listofchars) (DK-NUMBERSLIST))
	 (D-AllNumerals (cdr listofchars)))
      (t nil))
)

(defun D-ConvertToInteger (listofchars)
;;
;;  Converts the given list of numerals into a number
;;  Note that the digits are given least significant first
;;
   (cond
      ((eq (length listofchars) 1) (D-NumeralToNumber (car listofchars)))
      (t
	 (plus (D-NumeralToNumber (car listofchars))
	       (times 10 (D-ConvertToInteger (cdr listofchars))))
      )
   )
)
    
(defun D-EndOfString (currentch port)
;;
;;   If currentch is the quote character and the next character
;;   to be read is not the quote character then end of string is true
;;   false otherwise.  If the next character to read is a quote character
;;   it is read (skipped)
;;
   (cond
      ((eq currentch D-READERQUOTE)
	 (cond
	    ((eq (tyipeek port) D-READERQUOTE) (tyi port) nil);; skip the quote
	    (t t)  ;; not two quotes so 
         )
      )
      (t nil)
   )
)

(defun D-MakeEOLNSymbol ()
;;
;;   this makes the end of line character become a single
;;   character symbol
;;
   (cond
      ((memq D-READERENDOFLINE D-SINGLE_CHARACTER_SYMBOLS)
	 t     ;; already a single character symbol
      )
      (t
	 (setq D-WHITE_SPACE_CHARACTERS
	    (remove D-READERENDOFLINE D-WHITE_SPACE_CHARACTERS))
         (setq D-SINGLE_CHARACTER_SYMBOLS
	    (cons D-READERENDOFLINE D-SINGLE_CHARACTER_SYMBOLS))
      )
   )
)

(defun D-MakeEOLNNotSymbol ()
;;
;;   this makes the end of line character become a white 
;;   space character and not a single character symbol
;;
   (cond
      ((memq D-READERENDOFLINE D-WHITE_SPACE_CHARACTERS)
	 t     ;; already white space 
      )
      (t
	 (setq D-WHITE_SPACE_CHARACTERS
	    (cons D-READERENDOFLINE D-WHITE_SPACE_CHARACTERS))
         (setq D-SINGLE_CHARACTER_SYMBOLS
	    (remove D-READERENDOFLINE D-SINGLE_CHARACTER_SYMBOLS))
      )
   )
)

(defun D-ReadToEndOfLine (eofmarker)
;;
;;   reads the next atom from the terminal.  If end of line is found first
;;   nil is retruned.  If an atom is found it is returned and then input
;;   is skipped up to next end of line.  If a left bracket is found first
;;   on s-expression is read then everthing is skipped up to the next
;;   end of line
;;
   (let ( nextthing command )
      (D-MakeEOLNSymbol)   ;; make end of line a symbol
      (setq nextthing (D-ReadAtom t eofmarker))
      (cond
	 ((eq nextthing D-NEWLINE)      ;; nothing typed
	    (setq command nil)
         )
	 ((eq nextthing D-BANG)    ;; an s-expression
	    (setq command
	       (cons (DK-COM-EVAL) (D-ReadLispS-Expression eofmarker)))
         )
	 (t                           ;; just simple atomic string    
	    (D-while (not (or (eq nextthing D-NEWLINE)
			      (eq nextthing eofmarker)))
	       (setq command (cons nextthing command))
	       (setq nextthing (D-ReadAtom 't eofmarker))
	    )
	    (cond
	       ((and (null command) (eq nextthing eofmarker))
		  (setq command eofmarker))
	       (t (setq command (reverse command))))
         )
      )
      (D-MakeEOLNNotSymbol)           ;; try and be nice
      command
   )
)

(defun D-ReadLispS-Expression (eofmarker)
;;
;;  This uses my reader to read a lisp s-expression.  Note that
;;  this only deals with lists and atoms and not all the fancy junk
;;  of read macros.  Simple quote is dealt with too. This could be a problem.
;;
   (let (expr)
      (setq expr (read))
      (D-ReadToEndOfLine eofmarker)   ;; zap the rest
      expr
   )
)

