Move eopl language to Racket.
- sllgen.rkt - use begin-for-syntax+define-syntax instead of define-syntax-set. - eopl.scrbl - rewrite *3-columns so that it no longer errors when 3 doesn't divide the number of reprovided lang forms. - Removal of mzscheme and mzlib requires. - Updated docs.
This commit is contained in:
Patrick Mahoney
Eli Barzilay
parent
f6df93ed96
commit
b265e260b2
|
|
@ -1,10 +1,9 @@
|
|||
;; NOTE: datatypes are currently transparent, for the sake of EoPL's
|
||||
;; use of `equal?'
|
||||
|
||||
#lang mzscheme
|
||||
#lang racket
|
||||
|
||||
(require mzlib/pconvert-prop)
|
||||
(require-for-syntax "private/utils.rkt")
|
||||
(require (for-syntax "private/utils.rkt"))
|
||||
|
||||
(define-syntax define-datatype
|
||||
(lambda (stx)
|
||||
|
|
@ -40,7 +39,7 @@
|
|||
;; Count the fields for each variant:
|
||||
(with-syntax ([(variant-field-count ...)
|
||||
(map (lambda (n)
|
||||
(datum->syntax-object (quote-syntax here) n #f))
|
||||
(datum->syntax (quote-syntax here) n #f))
|
||||
(map length
|
||||
(map
|
||||
syntax->list
|
||||
|
|
@ -48,14 +47,14 @@
|
|||
(syntax ((field-name ...) ...))))))]
|
||||
[(variant? ...)
|
||||
(map (lambda (vn)
|
||||
(datum->syntax-object
|
||||
(datum->syntax
|
||||
vn
|
||||
(string->uninterned-symbol
|
||||
(format "~a?" (syntax-e vn)))))
|
||||
variant-names)]
|
||||
[(variant-accessor ...)
|
||||
(map (lambda (vn)
|
||||
(datum->syntax-object
|
||||
(datum->syntax
|
||||
vn
|
||||
(string->uninterned-symbol
|
||||
(format "~a-accessor" (syntax-e vn)))))
|
||||
|
|
@ -68,7 +67,7 @@
|
|||
(generate-temporaries variant-names)]
|
||||
[(make-variant-name ...)
|
||||
(map (lambda (vn)
|
||||
(datum->syntax-object
|
||||
(datum->syntax
|
||||
vn
|
||||
(string->symbol
|
||||
(format "make-~a" (syntax-e vn)))))
|
||||
|
|
@ -101,7 +100,7 @@
|
|||
variant-accessor variant-mutator)
|
||||
(make-struct-type 'variant-name struct:x variant-field-count 0
|
||||
#f
|
||||
`((,prop:print-convert-constructor-name . variant-name))
|
||||
null
|
||||
(make-inspector))]
|
||||
...)
|
||||
;; User-available functions:
|
||||
|
|
@ -191,7 +190,7 @@
|
|||
(values null null null #f)]
|
||||
[else
|
||||
(let ([clause (car clauses)])
|
||||
(syntax-case* clause (else)
|
||||
(syntax-case* clause ()
|
||||
(lambda (a b)
|
||||
(and (eq? (syntax-e b) 'else)
|
||||
(not (identifier-binding b))))
|
||||
|
|
@ -200,7 +199,7 @@
|
|||
[vt
|
||||
(ormap (lambda (dtv)
|
||||
(let ([vt-name (vt-name-stx dtv)])
|
||||
(and (module-identifier=? variant vt-name)
|
||||
(and (free-identifier=? variant vt-name)
|
||||
dtv)))
|
||||
(dt-variants dt))]
|
||||
[orig-variant (and vt (vt-name-stx vt))])
|
||||
|
|
@ -208,7 +207,7 @@
|
|||
(raise-syntax-error
|
||||
#f
|
||||
(format "not a variant of `~a'"
|
||||
(syntax-object->datum (syntax datatype)))
|
||||
(syntax->datum (syntax datatype)))
|
||||
stx
|
||||
variant))
|
||||
|
||||
|
|
@ -228,8 +227,8 @@
|
|||
#f
|
||||
(format
|
||||
"variant case `~a' for `~a' has wrong field count (expected ~a, found ~a)"
|
||||
(syntax-object->datum variant)
|
||||
(syntax-object->datum (syntax datatype))
|
||||
(syntax->datum variant)
|
||||
(syntax->datum (syntax datatype))
|
||||
(vt-field-count dtv)
|
||||
(length field-ids))
|
||||
stx
|
||||
|
|
@ -281,7 +280,7 @@
|
|||
[missing (let loop ([l (dt-variants dt)])
|
||||
(cond
|
||||
[(null? l) ""]
|
||||
[(ormap (lambda (i) (module-identifier=? (vt-name-stx (car l)) i)) here)
|
||||
[(ormap (lambda (i) (free-identifier=? (vt-name-stx (car l)) i)) here)
|
||||
(loop (cdr l))]
|
||||
[else
|
||||
(format " ~a~a"
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@
|
|||
(require "datatype.rkt"
|
||||
"private/sllgen.rkt"
|
||||
racket/promise
|
||||
mzlib/trace
|
||||
mzlib/pretty)
|
||||
racket/trace
|
||||
racket/pretty)
|
||||
(require (for-syntax racket/base
|
||||
"private/slldef.rkt"))
|
||||
|
||||
|
|
@ -153,8 +153,6 @@
|
|||
parameterize
|
||||
print-struct)
|
||||
|
||||
(require mzlib/transcr)
|
||||
|
||||
(provide unquote unquote-splicing
|
||||
quote quasiquote if when unless
|
||||
lambda letrec define-syntax delay let let* let-syntax letrec-syntax
|
||||
|
|
@ -179,7 +177,7 @@
|
|||
exact->inexact inexact->exact number->string string->number
|
||||
rationalize output-port? current-input-port current-output-port current-error-port
|
||||
open-input-file open-output-file close-input-port close-output-port
|
||||
with-output-to-file transcript-on transcript-off flush-output
|
||||
with-output-to-file flush-output
|
||||
string-length string-ci<=? string-ci>=? string-append
|
||||
string-fill!
|
||||
string->list list->string
|
||||
|
|
|
|||
|
|
@ -1,10 +1,9 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual
|
||||
scribble/struct
|
||||
scheme/list
|
||||
racket/list
|
||||
(for-label eopl/eopl
|
||||
scheme/contract
|
||||
(only-in scheme printf pretty-print delay force)))
|
||||
racket/contract))
|
||||
|
||||
@(define-syntax-rule (def-rkt id)
|
||||
(begin
|
||||
|
|
@ -14,24 +13,22 @@
|
|||
|
||||
@(define-syntax-rule (reprovide id ...)
|
||||
(*threecolumns (list (racket id) ... 'nbsp 'nbsp)))
|
||||
|
||||
@(define (*threecolumns l)
|
||||
(let* ([len (length l)]
|
||||
[third (quotient len 3)]
|
||||
[a (take l third)]
|
||||
[b (take (list-tail l third) third)]
|
||||
[c (list-tail l (* 2 third))]
|
||||
[spacer (hspace 2)]
|
||||
[to-flow (compose make-flow list make-paragraph list)])
|
||||
(define len (length l))
|
||||
(define third (quotient len 3))
|
||||
(define spacer (hspace 2))
|
||||
(define to-flow (compose make-flow list make-paragraph list))
|
||||
(make-table #f
|
||||
(map (lambda (a b c)
|
||||
(for/list ([a (in-list (take l third))]
|
||||
[b (in-list (take (list-tail l third) third))]
|
||||
[c (in-list (list-tail l (* 2 third)))])
|
||||
(list (to-flow spacer)
|
||||
(to-flow a)
|
||||
(to-flow spacer)
|
||||
(to-flow b)
|
||||
(to-flow spacer)
|
||||
(to-flow c)))
|
||||
a b c))))
|
||||
|
||||
(to-flow c)))))
|
||||
|
||||
@title{@italic{Essentials of Programming Languages} Language}
|
||||
|
||||
|
|
@ -74,7 +71,7 @@ The following bindings are re-@racket[provide]d from
|
|||
exact->inexact inexact->exact number->string string->number
|
||||
rationalize output-port? current-input-port current-output-port current-error-port
|
||||
open-input-file open-output-file close-input-port close-output-port
|
||||
with-output-to-file transcript-on transcript-off flush-output
|
||||
with-output-to-file flush-output
|
||||
string-length string-ci<=? string-ci>=? string-append
|
||||
string-fill!
|
||||
string->list list->string
|
||||
|
|
|
|||
|
|
@ -1,5 +1,4 @@
|
|||
|
||||
(module sllboth mzscheme
|
||||
#lang racket
|
||||
|
||||
;; This is stuff that lives at both table-consruction time and
|
||||
;; table-use time. That's ok because the data is all built on
|
||||
|
|
@ -68,4 +67,4 @@
|
|||
(and (pair? v)
|
||||
(eq? (car v) 'not)
|
||||
(pair? (cdr v))
|
||||
(char? (cadr v)))))))
|
||||
(char? (cadr v))))))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(module slldef mzscheme
|
||||
#lang racket
|
||||
;; A compile-time table shared by eopl and sllgen:
|
||||
(define sllgen-def (make-hash-table))
|
||||
(provide sllgen-def))
|
||||
(define sllgen-def (make-hasheq))
|
||||
(provide sllgen-def)
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
#lang racket
|
||||
;;; sllgen -- Scheme LL(1) parser generator
|
||||
|
||||
;; In this version, most of the sllgen: names are syntactic forms
|
||||
|
|
@ -5,31 +6,31 @@
|
|||
;; been split, so that the grammar table, etc. is parsed at compile
|
||||
;; time.
|
||||
|
||||
(module sllgen mzscheme
|
||||
(require mzlib/pretty
|
||||
scheme/mpair
|
||||
(require racket/pretty
|
||||
racket/mpair
|
||||
"../datatype.rkt"
|
||||
"sllboth.rkt"
|
||||
mzlib/etc)
|
||||
"slldef.rkt"
|
||||
(for-syntax racket/base
|
||||
"sllboth.rkt"
|
||||
"slldef.rkt"))
|
||||
|
||||
(require-for-syntax "sllboth.rkt"
|
||||
"slldef.rkt")
|
||||
|
||||
(provide sllgen:make-string-scanner
|
||||
sllgen:make-string-parser
|
||||
(provide sllgen:make-string-parser
|
||||
sllgen:make-stream-parser
|
||||
sllgen:make-rep-loop
|
||||
sllgen:make-stream-scanner
|
||||
sllgen:make-string-scanner
|
||||
sllgen:make-define-datatypes
|
||||
sllgen:show-define-datatypes
|
||||
sllgen:list-define-datatypes)
|
||||
|
||||
'(let ((time-stamp "Time-stamp: <2000-09-25 11:48:47 wand>"))
|
||||
'(let ((time-stamp "Time-stamp: <2000-09-25 11:48:47 wand>"))
|
||||
(display (string-append
|
||||
"sllgen.scm "
|
||||
(substring time-stamp 13 29)
|
||||
(string #\newline))))
|
||||
|
||||
(define sllgen:make-rep-loop
|
||||
(define sllgen:make-rep-loop
|
||||
(lambda (prompt eval-fn stream-parser)
|
||||
(lambda ()
|
||||
(display prompt) (flush-output)
|
||||
|
|
@ -43,57 +44,50 @@
|
|||
(loop stream))
|
||||
(lambda () #t))))))
|
||||
|
||||
;; ****************************************************************
|
||||
;; ****************************************************************
|
||||
|
||||
;; Table of contents:
|
||||
;; Table of contents:
|
||||
|
||||
;; top.s top-level entries
|
||||
;; parser-gen.scm organization of parser generator
|
||||
;; syntax.s concrete syntax for grammars, etc.
|
||||
;; eliminate-arbno.s replaces (ARBNO lhs) items with new productions
|
||||
;; first-and-follow.s calculate first and follow sets
|
||||
;; gen-table.s take list of productions, first and
|
||||
;; follow tables, and generate parsing table
|
||||
;; check-table.s take a parse table and check for conflicts
|
||||
;; scan.s scanner using streams
|
||||
;; parse.s run the generated parser
|
||||
;; error handling
|
||||
;; tests
|
||||
;; top.s top-level entries
|
||||
;; parser-gen.scm organization of parser generator
|
||||
;; syntax.s concrete syntax for grammars, etc.
|
||||
;; eliminate-arbno.s replaces (ARBNO lhs) items with new productions
|
||||
;; first-and-follow.s calculate first and follow sets
|
||||
;; gen-table.s take list of productions, first and
|
||||
;; follow tables, and generate parsing table
|
||||
;; check-table.s take a parse table and check for conflicts
|
||||
;; scan.s scanner using streams
|
||||
;; parse.s run the generated parser
|
||||
;; error handling
|
||||
;; tests
|
||||
|
||||
;; ****************************************************************
|
||||
;; ****************************************************************
|
||||
|
||||
;; Mon Sep 25 11:48:13 2000 added scanner outcomes symbol, number,
|
||||
;; string to replace make-symbol, make-number, and make-string.
|
||||
;; Mon Sep 25 11:48:13 2000 added scanner outcomes symbol, number,
|
||||
;; string to replace make-symbol, make-number, and make-string.
|
||||
|
||||
;; Wed Apr 12 14:15:24 2000 version intended to be R5RS-compliant,
|
||||
;; based on suggestions by Will Clinger.
|
||||
;; Wed Apr 12 14:15:24 2000 version intended to be R5RS-compliant,
|
||||
;; based on suggestions by Will Clinger.
|
||||
|
||||
;; ****************************************************************
|
||||
;; ****************************************************************
|
||||
|
||||
;; be sure to load compatibility files!!
|
||||
;; be sure to load compatibility files!!
|
||||
|
||||
;; ****************************************************************
|
||||
;; ****************************************************************
|
||||
|
||||
;; top.s
|
||||
|
||||
;; user-level entry points
|
||||
|
||||
(define-syntax-set (sllgen:make-string-scanner
|
||||
sllgen:make-string-parser
|
||||
sllgen:make-stream-parser
|
||||
sllgen:make-define-datatypes
|
||||
sllgen:show-define-datatypes
|
||||
sllgen:list-define-datatypes)
|
||||
;; top.s
|
||||
|
||||
;; user-level entry points
|
||||
(begin-for-syntax
|
||||
;; Gets a table: maybe immediate, maybe from a top-level definition
|
||||
(define (get-table srcstx t what)
|
||||
(let ([def (and (identifier? t)
|
||||
(hash-table-get sllgen-def (syntax-e t) (lambda () #f)))])
|
||||
(hash-ref sllgen-def (syntax-e t) (lambda () #f)))])
|
||||
(if def
|
||||
(syntax-object->datum def)
|
||||
(syntax->datum def)
|
||||
(syntax-case t (quote)
|
||||
[(quote v)
|
||||
(syntax-object->datum (syntax v))]
|
||||
(syntax->datum (syntax v))]
|
||||
[_else
|
||||
(raise-syntax-error #f
|
||||
(format "bad ~a specification" what)
|
||||
|
|
@ -119,7 +113,6 @@
|
|||
scanner-spec))))
|
||||
(syntax (make-string-parser parser-maker scanner-maker)))))
|
||||
|
||||
(define sllgen:make-string-parser/proc (make-one sllgen:make-string-parser-maker))
|
||||
|
||||
(define sllgen:make-stream-parser-maker
|
||||
(lambda (scanner-spec grammar srcstx)
|
||||
|
|
@ -131,7 +124,6 @@
|
|||
scanner-spec))))
|
||||
(syntax (make-stream-parser parser-maker scanner-maker)))))
|
||||
|
||||
(define sllgen:make-stream-parser/proc (make-one sllgen:make-stream-parser-maker))
|
||||
|
||||
(define sllgen:make-stream-scanner-maker
|
||||
(lambda (scanner-spec grammar srcstx)
|
||||
|
|
@ -141,8 +133,6 @@
|
|||
grammar)
|
||||
scanner-spec))))
|
||||
|
||||
(define sllgen:make-stream-scanner/proc (make-one sllgen:make-stream-scanner-maker))
|
||||
|
||||
(define sllgen:make-string-scanner-maker
|
||||
(lambda (scanner-spec grammar srcstx)
|
||||
(with-syntax ((scanner-maker (sllgen:make-stream-scanner-maker scanner-spec grammar srcstx)))
|
||||
|
|
@ -151,19 +141,15 @@
|
|||
(sllgen:stream->list
|
||||
(scanner (sllgen:string->stream string)))))))))
|
||||
|
||||
(define sllgen:make-string-scanner/proc (make-one sllgen:make-string-scanner-maker))
|
||||
|
||||
(define sllgen:make-define-datatypes-maker
|
||||
(lambda (scanner-spec grammar srcstx)
|
||||
(with-syntax ((datatype-definitions
|
||||
(datum->syntax-object
|
||||
(datum->syntax
|
||||
srcstx
|
||||
(sllgen:build-define-datatype-definitions scanner-spec grammar)
|
||||
srcstx)))
|
||||
(syntax (begin . datatype-definitions)))))
|
||||
|
||||
(define sllgen:make-define-datatypes/proc (make-one sllgen:make-define-datatypes-maker))
|
||||
|
||||
(define sllgen:show-define-datatypes-maker
|
||||
(lambda (scanner-spec grammar srcstx)
|
||||
(with-syntax ((datatype-definitions
|
||||
|
|
@ -173,7 +159,7 @@
|
|||
pretty-print
|
||||
'datatype-definitions))))))
|
||||
|
||||
(define sllgen:show-define-datatypes/proc (make-one sllgen:show-define-datatypes-maker))
|
||||
|
||||
|
||||
(define sllgen:list-define-datatypes-maker
|
||||
(lambda (scanner-spec grammar srcstx)
|
||||
|
|
@ -181,7 +167,6 @@
|
|||
(sllgen:build-define-datatype-definitions scanner-spec grammar)))
|
||||
(syntax 'datatype-definitions))))
|
||||
|
||||
(define sllgen:list-define-datatypes/proc (make-one sllgen:list-define-datatypes-maker))
|
||||
|
||||
;; ****************************************************************
|
||||
;; ****************************************************************
|
||||
|
|
@ -214,7 +199,7 @@
|
|||
(if (eq? (car act) 'reduce)
|
||||
(list 'reduce
|
||||
(list 'unquote
|
||||
(datum->syntax-object
|
||||
(datum->syntax
|
||||
srcstx
|
||||
(cadr act))))
|
||||
act))
|
||||
|
|
@ -552,7 +537,7 @@
|
|||
|
||||
(define sllgen:non-terminal-add!
|
||||
(lambda (sym)
|
||||
(if (not (memv sym sllgen:non-terminal-table))
|
||||
(when (not (memv sym sllgen:non-terminal-table))
|
||||
(set! sllgen:non-terminal-table
|
||||
(cons sym sllgen:non-terminal-table)))))
|
||||
|
||||
|
|
@ -1358,12 +1343,19 @@
|
|||
. ,(map
|
||||
(lambda (pred)
|
||||
(list (sllgen:gensym (car entry)) pred))
|
||||
(cdr entry)))))
|
||||
)
|
||||
(cdr entry))))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define-syntax sllgen:make-string-parser (make-one sllgen:make-string-parser-maker))
|
||||
(define-syntax sllgen:make-stream-parser (make-one sllgen:make-stream-parser-maker))
|
||||
(define-syntax sllgen:make-stream-scanner (make-one sllgen:make-stream-scanner-maker))
|
||||
(define-syntax sllgen:make-string-scanner (make-one sllgen:make-string-scanner-maker))
|
||||
(define-syntax sllgen:make-define-datatypes (make-one sllgen:make-define-datatypes-maker))
|
||||
(define-syntax sllgen:show-define-datatypes (make-one sllgen:show-define-datatypes-maker))
|
||||
(define-syntax sllgen:list-define-datatypes (make-one sllgen:list-define-datatypes-maker))
|
||||
|
||||
(define (make-stream-parser parser scanner)
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (make-stream-parser parser scanner)
|
||||
(lambda (char-stream)
|
||||
(let ((stream
|
||||
(sllgen:stream-add-sentinel-via-thunk
|
||||
|
|
@ -1387,7 +1379,7 @@
|
|||
fn eos)))))
|
||||
fn eos))))))
|
||||
|
||||
(define (make-string-parser parser scanner)
|
||||
(define (make-string-parser parser scanner)
|
||||
(lambda (string)
|
||||
(let* ((char-stream (sllgen:string->stream string))
|
||||
(token-stream (scanner char-stream))
|
||||
|
|
@ -1399,7 +1391,7 @@
|
|||
(sllgen:make-token 'end-marker #f
|
||||
(sllgen:char-stream->location char-stream))))
|
||||
(lambda (tree token token-stream)
|
||||
(if (null? token)
|
||||
(when (null? token)
|
||||
(sllgen:stream-get! token-stream
|
||||
(lambda (tok1 str1)
|
||||
(set! token tok1)
|
||||
|
|
@ -1416,7 +1408,7 @@
|
|||
(sllgen:token->data token))))))))
|
||||
|
||||
|
||||
(define sllgen:apply-tester
|
||||
(define sllgen:apply-tester
|
||||
(lambda (tester ch)
|
||||
(cond
|
||||
((char? tester) (char=? tester ch))
|
||||
|
|
@ -1435,19 +1427,19 @@
|
|||
tester)))))
|
||||
|
||||
|
||||
;; actions
|
||||
;; action ::= (action-opcode . classname)
|
||||
;; action-opcode :: = skip | symbol | number | string
|
||||
;; actions
|
||||
;; action ::= (action-opcode . classname)
|
||||
;; action-opcode :: = skip | symbol | number | string
|
||||
|
||||
;; make-symbol, make-number, and make-string are supported
|
||||
;; alternates, but are deprecated.
|
||||
;; make-symbol, make-number, and make-string are supported
|
||||
;; alternates, but are deprecated.
|
||||
|
||||
;; the classname becomes the name of token.
|
||||
;; the classname becomes the name of token.
|
||||
|
||||
;; if multiple actions are possible, do the one that appears here
|
||||
;; first. make-string is first, so literal strings trump identifiers.
|
||||
;; if multiple actions are possible, do the one that appears here
|
||||
;; first. make-string is first, so literal strings trump identifiers.
|
||||
|
||||
(define sllgen:find-preferred-action
|
||||
(define sllgen:find-preferred-action
|
||||
(lambda (action-opcodes)
|
||||
(let loop ((preferences sllgen:action-preference-list))
|
||||
(cond
|
||||
|
|
@ -1458,12 +1450,12 @@
|
|||
(car preferences))
|
||||
(else (loop (cdr preferences)))))))
|
||||
|
||||
(define sllgen:is-all-skip?
|
||||
(define sllgen:is-all-skip?
|
||||
(lambda (actions)
|
||||
(let ((opcode (sllgen:find-preferred-action (map car actions))))
|
||||
(eq? opcode 'skip))))
|
||||
|
||||
(define sllgen:cook-token
|
||||
(define sllgen:cook-token
|
||||
(lambda (buffer actions loc)
|
||||
(let* ((opcode (sllgen:find-preferred-action (map car actions)))
|
||||
(classname (cdr (assq opcode actions))))
|
||||
|
|
@ -1488,35 +1480,35 @@
|
|||
"unknown opcode selected from action list ~s"
|
||||
actions))))))
|
||||
|
||||
; (define sllgen:cook-token
|
||||
; (lambda (buffer actions loc)
|
||||
; (let* ((opcode (sllgen:find-preferred-action (map car actions)))
|
||||
; ;; (classname (cdr (assq opcode actions)))
|
||||
; )
|
||||
; (case opcode
|
||||
; ((skip) (sllgen:error 'sllgen:cook-token
|
||||
; "\nInternal error: skip should have been handled earlier ~s"
|
||||
; actions))
|
||||
; ((make-symbol identifier)
|
||||
; (sllgen:make-token 'identifier
|
||||
; (string->symbol (list->string (reverse buffer)))
|
||||
; loc))
|
||||
; ((make-number number)
|
||||
; (sllgen:make-token 'number
|
||||
; (string->number (list->string (reverse buffer)))
|
||||
; loc))
|
||||
; ((make-string string)
|
||||
; (sllgen:make-token 'string
|
||||
; (list->string (reverse buffer))
|
||||
; loc))
|
||||
; (else
|
||||
; (sllgen:error 'scanning
|
||||
; "\nUnknown opcode selected from action list ~s"
|
||||
; actions))))))
|
||||
; (define sllgen:cook-token
|
||||
; (lambda (buffer actions loc)
|
||||
; (let* ((opcode (sllgen:find-preferred-action (map car actions)))
|
||||
; ;; (classname (cdr (assq opcode actions)))
|
||||
; )
|
||||
; (case opcode
|
||||
; ((skip) (sllgen:error 'sllgen:cook-token
|
||||
; "\nInternal error: skip should have been handled earlier ~s"
|
||||
; actions))
|
||||
; ((make-symbol identifier)
|
||||
; (sllgen:make-token 'identifier
|
||||
; (string->symbol (list->string (reverse buffer)))
|
||||
; loc))
|
||||
; ((make-number number)
|
||||
; (sllgen:make-token 'number
|
||||
; (string->number (list->string (reverse buffer)))
|
||||
; loc))
|
||||
; ((make-string string)
|
||||
; (sllgen:make-token 'string
|
||||
; (list->string (reverse buffer))
|
||||
; loc))
|
||||
; (else
|
||||
; (sllgen:error 'scanning
|
||||
; "\nUnknown opcode selected from action list ~s"
|
||||
; actions))))))
|
||||
|
||||
|
||||
;; k = (actions * newstates * char * stream) -> val
|
||||
(define sllgen:scanner-inner-loop
|
||||
;; k = (actions * newstates * char * stream) -> val
|
||||
(define sllgen:scanner-inner-loop
|
||||
(lambda (local-states stream k)
|
||||
(let ((actions '())
|
||||
(newstates '())
|
||||
|
|
@ -1561,7 +1553,7 @@
|
|||
(lambda (tester)
|
||||
;; get a character if one hasn't been gotten and we
|
||||
;; haven't discovered eos.
|
||||
(if (and (null? char) (not eos-found?))
|
||||
(when (and (null? char) (not eos-found?))
|
||||
(sllgen:char-stream-get! stream
|
||||
(lambda (ch1)
|
||||
'(eopl:printf "read character ~s\n" ch1)
|
||||
|
|
@ -1569,7 +1561,7 @@
|
|||
(lambda ()
|
||||
(set! eos-found? #t))))
|
||||
'(eopl:printf "applying tester ~s to ~s\n" tester char)
|
||||
(if (and (not (null? char))
|
||||
(when (and (not (null? char))
|
||||
(sllgen:apply-tester tester char))
|
||||
;; passed the test -- shift is possible
|
||||
(set! newstates (cons (cdr state) newstates)))
|
||||
|
|
@ -1608,9 +1600,9 @@
|
|||
(append sequents (cdr state))
|
||||
(cdr local-states)))))))))))))
|
||||
|
||||
(define sllgen:xapply (lambda (x) (lambda (y) (y x))))
|
||||
(define sllgen:xapply (lambda (x) (lambda (y) (y x))))
|
||||
|
||||
(define sllgen:scanner-outer-loop
|
||||
(define sllgen:scanner-outer-loop
|
||||
(lambda (start-states input-stream) ; -> (token stream), same as before
|
||||
(let
|
||||
((states start-states) ; list of local-states
|
||||
|
|
@ -1626,7 +1618,7 @@
|
|||
(lambda ()
|
||||
(sllgen:scanner-inner-loop states stream
|
||||
(lambda (new-actions new-states char new-stream)
|
||||
(if (not (null? new-actions))
|
||||
(when (not (null? new-actions))
|
||||
;; ok, the current buffer is a candidate token
|
||||
(begin
|
||||
(set! success-buffer buffer)
|
||||
|
|
@ -1649,7 +1641,7 @@
|
|||
(lambda (char new-stream)
|
||||
;; first, push the lookahead character back on the
|
||||
;; stream.
|
||||
(if (not (null? char))
|
||||
(when (not (null? char))
|
||||
(sllgen:char-stream-push-back! char new-stream))
|
||||
(set! stream new-stream)
|
||||
(if (null? buffer)
|
||||
|
|
@ -1696,71 +1688,71 @@
|
|||
;; start by trying to absorb a character
|
||||
(process-stream)))))
|
||||
|
||||
;; Watch out for examples like:
|
||||
;; ("a" | "b" | "c" | "abcdef") matched against "abc" should produce
|
||||
;; 3 tokens before reaching eos.
|
||||
;; Watch out for examples like:
|
||||
;; ("a" | "b" | "c" | "abcdef") matched against "abc" should produce
|
||||
;; 3 tokens before reaching eos.
|
||||
|
||||
;; tokens
|
||||
;; tokens
|
||||
|
||||
; (define-record token (symbol? (lambda (v) #t)))
|
||||
; (define-record token (symbol? (lambda (v) #t)))
|
||||
|
||||
(define sllgen:make-token list)
|
||||
(define sllgen:token->class car)
|
||||
(define sllgen:token->data cadr)
|
||||
(define sllgen:token->location caddr)
|
||||
(define sllgen:make-token list)
|
||||
(define sllgen:token->class car)
|
||||
(define sllgen:token->data cadr)
|
||||
(define sllgen:token->location caddr)
|
||||
|
||||
;; streams
|
||||
;; streams
|
||||
|
||||
;; (sllgen:stream-get! (sllgen:make-stream tag char stream) fcn eos-fcn) = (fcn char stream)
|
||||
;; (sllgen:stream-get! (sllgen:make-stream tag char stream) fcn eos-fcn) = (fcn char stream)
|
||||
|
||||
;; this is banged, because doing it on some streams may cause a side-effect.
|
||||
(define sllgen:stream-get!
|
||||
;; this is banged, because doing it on some streams may cause a side-effect.
|
||||
(define sllgen:stream-get!
|
||||
(lambda (str fcn eos-fcn)
|
||||
(str fcn eos-fcn)))
|
||||
|
||||
(define sllgen:empty-stream
|
||||
(define sllgen:empty-stream
|
||||
(lambda (fcn eos-fcn)
|
||||
(eos-fcn)))
|
||||
|
||||
(define sllgen:make-stream
|
||||
(define sllgen:make-stream
|
||||
(lambda (tag char stream)
|
||||
;(eopl:printf "sllgen:make-stream: building stream at ~s with ~s\n" tag char)
|
||||
(lambda (fcn eos-fcn)
|
||||
;(eopl:printf "sllgen:make-stream: emitting ~s\n" char)
|
||||
(fcn char stream))))
|
||||
|
||||
(define sllgen:list->stream
|
||||
(define sllgen:list->stream
|
||||
(lambda (l)
|
||||
(if (null? l) sllgen:empty-stream
|
||||
(sllgen:make-stream 'sllgen:list->stream (car l) (sllgen:list->stream (cdr l))))))
|
||||
|
||||
; ;; brute force for now.
|
||||
; (define sllgen:string->stream
|
||||
; (lambda (string) (sllgen:list->stream (string->list string))))
|
||||
; ;; brute force for now.
|
||||
; (define sllgen:string->stream
|
||||
; (lambda (string) (sllgen:list->stream (string->list string))))
|
||||
|
||||
; ;; this one has state:
|
||||
; (define sllgen:stdin-char-stream
|
||||
; (lambda (fcn eos-fcn)
|
||||
; (let ((char (read-char)))
|
||||
; (if (eof-object? char)
|
||||
; (eos-fcn)
|
||||
; (fcn char sllgen:stdin-char-stream)))))
|
||||
; ;; this one has state:
|
||||
; (define sllgen:stdin-char-stream
|
||||
; (lambda (fcn eos-fcn)
|
||||
; (let ((char (read-char)))
|
||||
; (if (eof-object? char)
|
||||
; (eos-fcn)
|
||||
; (fcn char sllgen:stdin-char-stream)))))
|
||||
|
||||
(define sllgen:stream->list
|
||||
(define sllgen:stream->list
|
||||
(lambda (stream)
|
||||
(sllgen:stream-get! stream
|
||||
(lambda (val stream)
|
||||
(cons val (sllgen:stream->list stream)))
|
||||
(lambda () '()))))
|
||||
|
||||
(define sllgen:constant-stream
|
||||
(define sllgen:constant-stream
|
||||
(lambda (val)
|
||||
(lambda (fn eos)
|
||||
(fn val (sllgen:constant-stream val)))))
|
||||
|
||||
;; takes a stream and produces another stream that produces the
|
||||
;; sentinel instead of an end-of-stream
|
||||
(define sllgen:stream-add-sentinel
|
||||
;; takes a stream and produces another stream that produces the
|
||||
;; sentinel instead of an end-of-stream
|
||||
(define sllgen:stream-add-sentinel
|
||||
(lambda (stream sentinel)
|
||||
(lambda (fn eos) ; here's what to do on a get
|
||||
(sllgen:stream-get! stream
|
||||
|
|
@ -1769,7 +1761,7 @@
|
|||
(lambda ()
|
||||
(fn sentinel (sllgen:constant-stream sentinel)))))))
|
||||
|
||||
(define sllgen:stream-add-sentinel-via-thunk
|
||||
(define sllgen:stream-add-sentinel-via-thunk
|
||||
(lambda (stream sentinel-fcn)
|
||||
(lambda (fn eos) ; here's what to do on a get
|
||||
(sllgen:stream-get! stream
|
||||
|
|
@ -1781,59 +1773,59 @@
|
|||
; (eopl:printf "~s\n" sentinel)
|
||||
(fn sentinel (sllgen:constant-stream sentinel))))))))
|
||||
|
||||
; no longer used
|
||||
; (define sllgen:stream-get
|
||||
; (lambda (stream fcn)
|
||||
; (sllgen:stream-get! stream fcn
|
||||
; (lambda ()
|
||||
; (sllgen:error 'sllgen:stream-get
|
||||
; "internal error: old streams aren't supposed to produce eos")))))
|
||||
; no longer used
|
||||
; (define sllgen:stream-get
|
||||
; (lambda (stream fcn)
|
||||
; (sllgen:stream-get! stream fcn
|
||||
; (lambda ()
|
||||
; (sllgen:error 'sllgen:stream-get
|
||||
; "internal error: old streams aren't supposed to produce eos")))))
|
||||
|
||||
|
||||
;; ****************************************************************
|
||||
;; ****************************************************************
|
||||
|
||||
;; imperative character streams Tue Apr 11 12:09:32 2000
|
||||
;; imperative character streams Tue Apr 11 12:09:32 2000
|
||||
|
||||
;; interface:
|
||||
;; interface:
|
||||
|
||||
;; sllgen:string->stream : string -> charstream
|
||||
;; sllgen:stdin-char-stream : () -> charstream
|
||||
;; sllgen:string->stream : string -> charstream
|
||||
;; sllgen:stdin-char-stream : () -> charstream
|
||||
|
||||
;; sllgen:char-stream-get! : !charstream * (char -> ans) * (() -> ans)
|
||||
;; -> ans
|
||||
;; [modifies charstream]
|
||||
;; sllgen:char-stream-push-back! : char * !charstream -> ()
|
||||
;; sllgen:char-stream->location : charstream -> location
|
||||
;; sllgen:char-stream-get! : !charstream * (char -> ans) * (() -> ans)
|
||||
;; -> ans
|
||||
;; [modifies charstream]
|
||||
;; sllgen:char-stream-push-back! : char * !charstream -> ()
|
||||
;; sllgen:char-stream->location : charstream -> location
|
||||
|
||||
;; for the moment, a location is a line number
|
||||
;; for the moment, a location is a line number
|
||||
|
||||
;; we have two kinds of streams-- those built by string->stream and
|
||||
;; those built by stdin-char-stream. We'll use a little OO here.
|
||||
;; we have two kinds of streams-- those built by string->stream and
|
||||
;; those built by stdin-char-stream. We'll use a little OO here.
|
||||
|
||||
;; represent by a vector
|
||||
;; represent by a vector
|
||||
|
||||
;; [get-fn ; push-back-fn ; location ; other stuff]
|
||||
;; [get-fn ; push-back-fn ; location ; other stuff]
|
||||
|
||||
(define sllgen:char-stream-get!
|
||||
(define sllgen:char-stream-get!
|
||||
(lambda (cstr sk th)
|
||||
((vector-ref cstr 0) cstr sk th)))
|
||||
|
||||
(define sllgen:char-stream-push-back!
|
||||
(define sllgen:char-stream-push-back!
|
||||
(lambda (ch cstr)
|
||||
((vector-ref cstr 1) ch cstr)))
|
||||
|
||||
(define sllgen:char-stream->location
|
||||
(define sllgen:char-stream->location
|
||||
(lambda (cstr)
|
||||
(vector-ref cstr 2)))
|
||||
|
||||
(define sllgen:set-location!
|
||||
(define sllgen:set-location!
|
||||
(lambda (vec val)
|
||||
(vector-set! vec 2 val)))
|
||||
|
||||
;; for a string-built stream, the other stuff consists of an index
|
||||
;; into the string for the next unread character, and a string.
|
||||
;; for a string-built stream, the other stuff consists of an index
|
||||
;; into the string for the next unread character, and a string.
|
||||
|
||||
(define sllgen:string->stream
|
||||
(define sllgen:string->stream
|
||||
(lambda (string)
|
||||
(let ((len (string-length string)))
|
||||
(vector
|
||||
|
|
@ -1863,10 +1855,10 @@
|
|||
))))
|
||||
|
||||
|
||||
;; for stdin-char-stream, we have
|
||||
;; [get-fn ; push-back-fn ; location ; push-back stack]
|
||||
;; for stdin-char-stream, we have
|
||||
;; [get-fn ; push-back-fn ; location ; push-back stack]
|
||||
|
||||
(define sllgen:stdin-char-stream ; this must be a thunk to reset the
|
||||
(define sllgen:stdin-char-stream ; this must be a thunk to reset the
|
||||
; line number
|
||||
(lambda ()
|
||||
(vector
|
||||
|
|
@ -1899,14 +1891,14 @@
|
|||
'() ; push-back is initially empty
|
||||
)))
|
||||
|
||||
(define sllgen:char-stream->list
|
||||
(define sllgen:char-stream->list
|
||||
(lambda (cstr)
|
||||
(let loop ()
|
||||
(sllgen:char-stream-get! cstr
|
||||
(lambda (ch) (cons ch (loop)))
|
||||
(lambda () '())))))
|
||||
|
||||
(define sllgen:char-stream->list2
|
||||
(define sllgen:char-stream->list2
|
||||
(lambda (cstr)
|
||||
(let loop ()
|
||||
(sllgen:char-stream-get! cstr
|
||||
|
|
@ -1917,39 +1909,39 @@
|
|||
(lambda () '())))))
|
||||
|
||||
|
||||
(define sllgen:increment-location
|
||||
(define sllgen:increment-location
|
||||
(lambda (ch n)
|
||||
(if (eqv? ch #\newline) (+ 1 n) n)))
|
||||
|
||||
(define sllgen:decrement-location
|
||||
(define sllgen:decrement-location
|
||||
(lambda (ch n)
|
||||
(if (eqv? ch #\newline) (- n 1) n)))
|
||||
|
||||
;; see tests.s for examples.
|
||||
;; see tests.s for examples.
|
||||
|
||||
;; ****************************************************************
|
||||
;; ****************************************************************
|
||||
|
||||
;; parse.s
|
||||
;; parse.s
|
||||
|
||||
;; parse.s -- run the generated parser
|
||||
;; parse.s -- run the generated parser
|
||||
|
||||
;; parsing table is of following form:
|
||||
;; parsing table is of following form:
|
||||
|
||||
;; table ::= ((non-terminal alternative ...) ...)
|
||||
;; alternative ::= (list-of-items action ...)
|
||||
;; action ::= (TERM symbol) | (NON-TERM symbol) | (GOTO symbol)
|
||||
;; | (EMIT-LIST) | (REDUCE proc)
|
||||
;; table ::= ((non-terminal alternative ...) ...)
|
||||
;; alternative ::= (list-of-items action ...)
|
||||
;; action ::= (TERM symbol) | (NON-TERM symbol) | (GOTO symbol)
|
||||
;; | (EMIT-LIST) | (REDUCE proc)
|
||||
|
||||
;; The token register can either contain an token or '() -- the latter
|
||||
;; signifying an empty buffer, to be filled when necessary.
|
||||
;; The token register can either contain an token or '() -- the latter
|
||||
;; signifying an empty buffer, to be filled when necessary.
|
||||
|
||||
; (define-record sllgen:parser-result (tree token stream))
|
||||
; (define-record sllgen:parser-result (tree token stream))
|
||||
|
||||
; k = (lambda (tree token stream) ...)
|
||||
; token may be a token or nil.
|
||||
(define sllgen:find-production
|
||||
; k = (lambda (tree token stream) ...)
|
||||
; token may be a token or nil.
|
||||
(define sllgen:find-production
|
||||
(lambda (non-terminal parser buf token stream k)
|
||||
(if (null? token)
|
||||
(when (null? token)
|
||||
(sllgen:stream-get! stream
|
||||
(lambda (next-token next-stream)
|
||||
; '(eopl:printf "find-production: filling token buffer with ~s\n" token)
|
||||
|
|
@ -1981,7 +1973,7 @@
|
|||
parser buf token stream k))
|
||||
(else (loop (cdr alternatives)))))))
|
||||
|
||||
(define sllgen:apply-actions
|
||||
(define sllgen:apply-actions
|
||||
(lambda (lhs action-list parser buf token stream k)
|
||||
(let loop ((actions action-list)
|
||||
(buf buf)
|
||||
|
|
@ -1989,7 +1981,7 @@
|
|||
(stream stream))
|
||||
(let ((fill-token! ; fill-token! is a macro in mzscheme
|
||||
(lambda ()
|
||||
(if (null? token)
|
||||
(when (null? token)
|
||||
(sllgen:stream-get! stream
|
||||
(lambda (next-token next-stream)
|
||||
(set! token next-token)
|
||||
|
|
@ -2068,7 +2060,7 @@
|
|||
"internal error: unknown instruction ~s"
|
||||
action))))))))
|
||||
|
||||
(define sllgen:unzip-buffer
|
||||
(define sllgen:unzip-buffer
|
||||
(lambda (trees n buf)
|
||||
(let ((ans (let consloop ((n n))
|
||||
(if (zero? n)
|
||||
|
|
@ -2085,7 +2077,6 @@
|
|||
(set-mcar! ptr (cons (car trees) (mcar ptr)))
|
||||
(loop (cdr trees) (mcdr ptr) (- ctr 1))))))))
|
||||
|
||||
(define sllgen:apply-reduction
|
||||
(define sllgen:apply-reduction
|
||||
(lambda (lhs opcode args)
|
||||
(apply opcode args)))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,18 +1,17 @@
|
|||
|
||||
(module utils mzscheme
|
||||
#lang racket
|
||||
|
||||
;; Generative structure definitions:
|
||||
(define-struct dt (pred-stx variants))
|
||||
(define-struct vt (name-stx predicate-stx accessor-stx field-count))
|
||||
(define-struct dt (pred-stx variants) #:mutable)
|
||||
(define-struct vt (name-stx predicate-stx accessor-stx field-count) #:mutable)
|
||||
|
||||
;; Helper function:
|
||||
(define (variant-assq name-stx variants)
|
||||
(let loop ([l variants])
|
||||
(if (module-identifier=? name-stx
|
||||
(if (free-identifier=? name-stx
|
||||
(vt-name-stx (car l)))
|
||||
(car l)
|
||||
(loop (cdr l)))))
|
||||
|
||||
(provide (struct dt (pred-stx variants))
|
||||
(struct vt (name-stx predicate-stx accessor-stx field-count))
|
||||
variant-assq))
|
||||
(provide (struct-out dt)
|
||||
(struct-out vt)
|
||||
variant-assq)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user