;;; Code stored as:  {turing}<3-lisp.problem-sets>3-lisp-internalizer.3-lisp
;;;                  {phylum}<3-lisp>course>problem-sets>3-lisp-internalizer.3-lisp


;;;==========================================================================
;;;                     Simple 3-LISP Expression Internalizer ;;;==========================================================================
;;;
;;; Internalizes 3-LISP expressions including rails, pairs and simple symbols.
;;; Does not handle numerals, handles, strings, or booleans.  Builds internal
;;; structure for the expression.

;;; Assumed grammar:  (<token> is the primitive lexical item)
;;;
;;;     <expression> ::= <rail-exp> | <pair-exp> | <identifier>
;;; 
;;;     <rail-exp>   ::= "[" <expression>* "]"
;;;     <pair-exp>   ::= "(" <expression>+ ")"
;;;     <identifier> ::= <alphanumeric token>

;;; (INTERNALIZATION string)   Builds the 3-LISP internal structure corresponding to string.
;;; ========================   

(define INTERNALIZATION
   (lambda [string]
      (init-lexan)      
      (letseq [[s (token-list string)]
               [answer (dynamic-catch (internalize-expression s))]]
         (if (and (not (= answer $false))
                  (= (next-token s) 'eot))
             answer
             "Rejected"))))


;;; Ancillary internalize functions:
;;;
;;;    All the following internalize functions are responsible for internalizing
;;;    just one type of 3-LISP expression.  They use GET-TOKEN and other such methods,
;;;    defined in the lexical-analyser package, on TOKEN-LIST objects.  They
;;;    call the procedure ERROR-IN-INTERNALIZATION immediately upon finding
;;;    a grammatical error of any sort, which should not return (the procedures
;;;    below are not designed to do anything sensible about continuing from
;;;    errors), but instead should error or do a DYNAMIC-THROW (q.v.).
;;;
;;;    All of the procedures return handles to the 3-LISP structure built.


;;; INTERNALIZE-EXPRESSION  Attempts to internalize an arbitrary 3-LISP
;;; ======================  expression, returning the corresponding structure.

(define INTERNALIZE-EXPRESSION
   (lambda [s]
      (select (next-token s)
         ["[" (internalize-rail s)]
         ["(" (internalize-pair s)]
         [$true (internalize-identifier s)])))


;;; INTERNALIZE-RAIL  attempts to internalize a 3-LISP rail expression
;;; ================

(define INTERNALIZE-RAIL
   (lambda [s]
      (get-token s)                                ; skip the open bracket
      (let [[answer (internalize-exp-list s "]")]]
         (get-token s)                             ; skip the close bracket   
         (rcons . answer))))


;;; INTERNALIZE-PAIR  attempts to internalize a 3-LISP pair expression
;;; ================

(define INTERNALIZE-PAIR
   (lambda [s]
      (get-token s)                                ; skip the open parenthesis
      (let [[answer (internalize-exp-list s ")")]]
         (get-token s)                             ; skip the close parenthesis
         (pcons (first answer) (rcons . (rest answer))))))


;;; INTERNALIZE-EXP-LIST  attempts to internalize a list of 3-LISP expressions
;;; ====================  delimited by (but not including) the token
;;;                       ENDING-TOKEN, returning a rail of handles
;;; designating the structures notated by the various elements in the
;;; list read. (Whew.)

(define INTERNALIZE-EXP-LIST
   (lambda [s ending-token]
      (if (= (next-token s) ending-token)
          []
          (cons (internalize-expression s)
                (internalize-exp-list s ending-token)))))


;;; INTERNALIZE-IDENTIFIER  attempts to internalize a  3-LISP identifier
;;; ======================

(define INTERNALIZE-IDENTIFIER
   (lambda [s]
      (let [[tok (get-token s)]]
         (if (member tok ['eot "[" "]" "(" ")"])
             (error-in-internalization)
             (atom-notated tok)))))

;;; ERROR-IN-INTERNALIZATION   Signals an error.
;;; ========================

(define ERROR-IN-INTERNALIZATION
   (lambda []
      (dynamic-throw $false)))