;;; 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)