;;; May 20, 1984 --- Jim des Rivieres

;;; Temporary patchs to 3-Lisp 1.0 LETREC and LOAD.
;;; This revised definition to LETREC fixes two bugs
;;; in the release version that caused the uncompiled
;;; version of LETREC to be unuseable.  As it turned out,
;;; LOAD was written in such a way as to cause the
;;; processor to run one level higher than necessary.
;;; Hence the revised version of LOAD. Both of these
;;; changes have been propagated to the appropriate
;;; {phylum}<3-lisp>new> sources.


(rebind-in-system-environment 'letrec
 (kernel-macro-ccons
  ^(lambda [call]
    (let [[args (pargs call)]]
      (if (and (rail args)
               (>= (length args) 1)
               (rail (first args))
               (every (lambda [x]
                         (and (rail x)
                              (= (length x) 2)
                              (atom (first x))))
                      (first args)))
          (let [[body (rest args)]
                [vars (map first (first args))]]
            (pcons
               (pcons ^lambda 
                  (append
                     (rcons vars)                     
                     (map (lambda [x] (pcons ^set x)) (first args))
                     body))
               (map (lambda [x] '"unbound") (first args))))
          (pcons ^trap (rcons '"malformed letrec" call))))) 
 'letrec-macro))

; (LOAD file-name)

(letrec
[[load-helper
  (lambda [stream file-name]
     (let [[structure (forgiving-read-structure stream)]]
       (if (string structure)
           (begin
              (close-all-streams) ; Work around.
              (if (= structure "end of stream")
                  'ok
                  (error (string-append structure
                            " while LOADing the file " file-name)
                         'ok))) 
           (normalize structure global
               (lambda [a b c d e f g]
                  (close-all-streams) ; Work around.
                  (standard-escape a b c d e f g))               
               (lambda [result-nf]
                  (print-structure primary-stream result-nf)
                  (print primary-stream cr)
                  (load-helper stream file-name))))))]
 [forgiving-read-structure
  (lambda [stream]
   (cps-error-protect (read-structure stream) id id))]] 
  (system-define load
      (lambda [file-name]
        (let [[stream (open-stream file-name)]]
           (load-helper stream file-name)
           (close-stream stream)
           file-name))))



;;; May 14, 1984 --- Jim des Rivieres

;;; Patch to 3-lisp 1.0 to remedy problem with
;;; (internalize "foo") causing an error.
;;; Problem is with end of stream being encountered.
;;; Workaround: always append a space to the string
;;; before internalizing it.


(let [[old-internalize
        \(primitive-ccons global '[string] 
            '(internalize string)
            "internalize"
            'prim-internalize)]] 
    (system-define internalize
        (lambda [string]
            (old-internalize
               (string-append string " ")))))


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


;;; =================================================================
;;;                       SEQUENCE UTILITIES
;;; =================================================================

;;; (FILTER predicate sequence)   Designates the sequence consisting
;;; ===========================   of each element of sequence for which
;;;                               (predicate element) is true.

(define FILTER
   (lambda [predicate sequence]
      (collect (lambda [element]
                  (if (predicate element)
                      [element]
                      []))
               sequence)))

;;; (COLLECT fun args1 ... argsk)   Appends together the results of
;;; =============================   mapping fun (of arity k) to the
;;;                                 sequences of args args1 ... argsk.
;;; Useful, in combination with SINGLETON and NOTHING, for assembling
;;; some results from a sequence of args.

(define COLLECT
   (lambda args
      (append . (map . args))))

;;; (SINGLETON exp)   To be used by COLLECT and F-COLLECT
;;; (NOTHING)
;;; ===============

(define SINGLETON (lambda [element] [element]))
(define NOTHING (lambda [] []))

;;; (FILTERED-MAP fun predicate sequence)  Maps <fun> down a version of <sequence>
;;; =====================================  that has been filtered by <predicate>.
;;;                                             

(define FILTERED-MAP
   (lambda [fun predicate sequence]
      (map fun (filter predicate sequence))))

;;; =================================================================
;;; General purposes COMPOSE:
;;;
;;; ((compose f1 f2 ... fk) a1 a2 ... an)     ; 1 =< k
;;; 
;;;   =>  (f1 (f2 ... (fk a1 a2 ... an)...))  ; 0 =< n
;;; =================================================================

(define COMPOSE
   (lambda funs
      (cond [(null funs) (lambda args args)]
            [(null (rest funs)) (first funs)]
            [$true
             (lambda args
                ((first funs)
                 ((compose . (rest funs)) . args)))])))

;;; CONSTANT
;;; ========

(define CONSTANT
   (lambda [constant]
      (lambda args constant)))

;;; ===============================================================
;;;          STRANGE CONTROL STRUCTURES
;;; ===============================================================

;;; DYNAMIC-CATCH
;;; DYNAMIC-THROW
;;; =============

(define DYNAMIC-CATCH
   (rlambda [call env esc cont]
      (cont (normalize (arg 1 call) env esc id))))

(define DYNAMIC-THROW
   (rlambda [call env esc cont]
      (normalize (arg 1 call) env esc id)))


;;; =================================================================
;;;          OBJECTS:
;;; =================================================================
;;; 
;;; General form:
;;; 
;;;  (object [init-var-1 ... init-var-k]
;;;          [[var-1 init-1] ... [var-n init-n]]
;;;     [<mess1> <fun1>]
;;;     [<mess2> <fun2>]
;;;        ...
;;;     [<messk> <funk>])
;;; =================================================================

(define OBJECT
  (let [[define-message
           (lambda [name]
              '(define ,name
                  (lambda args
                     (((first args) ,^name) . (rest args)))))]]
    (mlambda [call]
      (letseq [[state-vars (arg 1 call)]
               [inited-vars (arg 2 call)]
               [pairs (tail 2 (pargs call))]
               [fun-names (map (lambda [pair] (acons)) pairs)]]
         '(begin
             ,(map (lambda [pair]
                      (define-message (first pair)))
                   pairs)
             (lambda ,state-vars
               (let ,inited-vars
                 (letrec ,(map (lambda [pair fun-name]
                                 '[,fun-name ,(second pair)])
                               pairs
                               fun-names)
                    (lambda [message]
                       (cond . ,(map (lambda [pair fun-name]
                                        '[(= message ,^(first pair))
                                          ,fun-name])
                                     pairs
                                     fun-names)))))))))))


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


;;;            ======================== 
;;;            3-LISP Lexical Analyser:
;;;            ========================

;;; ===============================================================
;;;          PUBLIC ROUTINES
;;; ===============================================================

;;; (INIT-LEXAN)     Initializes all tables.
;;; ============
;;;     
;;; (LEXAN-OBJECT string)  A type of object that embodies the tokenization of a 
;;; =====================  given string.  Supports the following messages:
;;;     
;;;    (CURRENT-TOKEN lexan-object)  Returns the token currently being scanned (i.e.,.
;;;    ============================  the one made current by the last use of GET-TOKEN)
;;;
;;;    (GET-TOKEN lexan-object)      Also returns the current token being scanned but 
;;;    ========================      moves past the token in the input.  This is the
;;;                                  normal method to be used in accessing tokens.
;;;
;;;    (NEXT-TOKEN lexan-object)     Returns the 'look-ahead' token, the token just
;;;    =========================     about to be scanned.  Useful for dispatching without
;;;                                  actually reading the token.
;;; 
;;; (LEXICAL-ANALYSIS string)        Designates the sequence of tokens into which
;;; =========================        string is lexically analyzed.  For example
;;;                                  (lexical-analysis "a (b)") => ["a" "(" "b" ")"].
;;; 
;;; (IDENTIFIER-EXPRESSION token)  True just in case token is a sequence of alphanumeric
;;; =============================  characters, but is not a numeral-expression.
;;; 
;;; (NUMERAL-EXPRESSION token)     True just in case token is a sequence of digits, 
;;; ==========================     possibly including a leading "+" or "-".


(define INIT-LEXAN
   (lambda []
      (set *special-chars* [ #( #) #[ #] #$ #' #, #. #^ #\ #{ #} ])
      (set *white-space-chars* [ #  cr ])
      (set *delimiters* (append *white-space-chars* *special-chars*))
      (set *digits* [ #0 #1 #2 #3 #4 #5 #6 #7 #8 #9 ])
      (set *comment-begin* #;)
      (set *comment-end* cr)
      "ok"))

(define LEXAN-OBJECT
   (let [[create-lexan-object
            (object [string]
                    [[current-tok ""]
                     [next-tok ""]]
               [GET-TOKEN
                  (lambda []
                     (let [[token-info (global-get-token string)]]
                        (set string (second token-info))
                        (set current-tok next-tok)
                        (set next-tok (first token-info))
                        current-tok))]
               [CURRENT-TOKEN (lambda [] current-tok)]
               [NEXT-TOKEN (lambda [] next-tok)])]]
       (lambda [string]
          (let [[lex-obj (create-lexan-object string)]]
              (get-token lex-obj)                        ; initialize
              lex-obj))))

;;; Not dealt with by this code:
;;; 
;;;  -- strings
;;;  -- charats
;;;  -- character quotation (%)

;;; LEXICAL-ANALYSIS:
;;; =========

(define LEXICAL-ANALYSIS
   (lambda [string]
      (let [[a (lexan-object string)]]
         (letrec [[helper (lambda []
                              (let [[tok (get-token a)]]
                                  (if (= tok 'eot)
                                      []
                                      (cons tok (helper)))))]]
            (helper)))))


;;; ===============================================================
;;;          INTERNAL ROUTINES
;;; ===============================================================

;;; GLOBAL-GET-TOKEN  takes a STRING and returns a rail of:
;;; ================  a) the prefix of the string corresponding to the
;;;                      first token in the string
;;;                   b) the rest of the string after the prefix
;;; In case there are no tokens left in the string, returns the
;;; handle 'eot (end of tokens).
;;; 
;;; Used by GET-TOKEN (within INIT-LEXAN)

(define GLOBAL-GET-TOKEN   
   (lambda [string]
      (add-to-token "" (strip-leading-whitespace string))))

;;; ADD-TO-TOKEN  auxiliary function for GLOBAL-GET-TOKEN which 
;;; ============  adds characters to a token found so far (SO-FAR)
;;;               taking characters from a string STRING.
;;; 
;;; Uses information from global-variables:   *special-chars*
;;; defined by INIT-LEXAN:                    *delimiters*

(define ADD-TO-TOKEN
   (lambda [so-far string]
      (cond [(string-null string)
             [(if (string-null so-far) 'eot so-far) string]]
            [(and (string-null so-far)
                  (member (string-first string) *special-chars*))
             [(substring 1 1 string) (string-rest string)]]
            [(member (string-first string) *delimiters*)
             [so-far string]]
            [$true
             (add-to-token (string-append so-far
                                          (substring 1 1 string))
                           (string-rest string))])))

;;; STRIP-LEADING-WHITESPACE  removes all leading white-space and comments
;;; ========================  from a string.  White-space is defined as
;;;                           any character in the global variable
;;;                           *white-space-chars* (defined by INIT-LEXAN).
;;; Comments are any string of characters starting with the character
;;; bound to *comment-begin*, up through the character *comment-end*

(define STRIP-LEADING-WHITESPACE
   (lambda [string]
      (cond [(string-null string) string]
            [(member (string-first string) *white-space-chars*)
             (strip-leading-whitespace (string-rest string))]
            [(= (string-first string) *comment-begin*)
             (strip-leading-whitespace (strip-comment string))]
            [$true
             string])))

;;; STRIP-COMMENT  Removes one full comment prefix from a string.  A comment
;;; =============  is defined as any string of characters starting with the
;;;                globally bound *comment-begin* character, up through and
;;;                including *comment-end* (both defined by INIT-LEXAN).

(define STRIP-COMMENT
   (lambda [string]
      (cond [(string-null string) string]
            [(= (string-first string) *comment-end*)
             (string-rest string)]
            [$true
             (strip-comment (string-rest string))])))

;;; ===============================================================
;;;          SPECIAL TOKEN IDENTIFICATION PREDICATES
;;; ===============================================================

(define IDENTIFIER-EXPRESSION
   (lambda [token]
      (and (every-character
               (lambda [ch] (not (member ch *special-chars*)))
               token)
           (not (every-character
                   (lambda [ch] (member ch *digits*))
                   token)))))

(define NUMERAL-EXPRESSION
   (lambda [token]
      (every-character (lambda [ch] (member ch *digits*))
                       (if (member (nth-char 1 token) [#+ #-])
                           (string-rest token)
                           token))))

;;; ===============================================================
;;;          STRING MANIPULATION ROUTINES
;;; ===============================================================

(define STRING-NULL
   (lambda [string] (= string "")))

(define STRING-FIRST
   (lambda [string] (nth-char 1 string)))

(define STRING-REST
   (lambda [string] (substring 2 (string-length string) string)))

;;; (EVERY-CHARACTER predicate string)   True just in case predicate
;;; ==================================   is true of each character in
;;;                                      string.

(define EVERY-CHARACTER
   (lambda [predicate string]
      (cond [(string-null string) $true]
            [(predicate (string-first string))
             (every-character predicate (string-rest string))]
            [$true $false])))


(init-lexan)