suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Move eopl language to Racket.

Browse Source 
- 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 2013-02-20 14:28:14 -05:00 committed by Eli Barzilay
parent f6df93ed96
commit b265e260b2
7 changed files with 1964 additions and 1981 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
collects/eopl/datatype.rkt
View File

@ -1,10 +1,9 @@
;; NOTE: datatypes are currently transparent, for the sake of EoPL's ;; NOTE: datatypes are currently transparent, for the sake of EoPL's
;; use of `equal?' ;; 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 (define-syntax define-datatype
(lambda (stx) (lambda (stx)
@ -40,7 +39,7 @@
;; Count the fields for each variant: ;; Count the fields for each variant:
(with-syntax ([(variant-field-count ...) (with-syntax ([(variant-field-count ...)
(map (lambda (n) (map (lambda (n)
(datum->syntax-object (quote-syntax here) n #f)) (datum->syntax (quote-syntax here) n #f))
(map length (map length
(map (map
syntax->list syntax->list
@ -48,14 +47,14 @@
(syntax ((field-name ...) ...))))))] (syntax ((field-name ...) ...))))))]
[(variant? ...) [(variant? ...)
(map (lambda (vn) (map (lambda (vn)
(datum->syntax-object (datum->syntax
vn vn
(string->uninterned-symbol (string->uninterned-symbol
(format "~a?" (syntax-e vn))))) (format "~a?" (syntax-e vn)))))
variant-names)] variant-names)]
[(variant-accessor ...) [(variant-accessor ...)
(map (lambda (vn) (map (lambda (vn)
(datum->syntax-object (datum->syntax
vn vn
(string->uninterned-symbol (string->uninterned-symbol
(format "~a-accessor" (syntax-e vn))))) (format "~a-accessor" (syntax-e vn)))))
@ -68,7 +67,7 @@
(generate-temporaries variant-names)] (generate-temporaries variant-names)]
[(make-variant-name ...) [(make-variant-name ...)
(map (lambda (vn) (map (lambda (vn)
(datum->syntax-object (datum->syntax
vn vn
(string->symbol (string->symbol
(format "make-~a" (syntax-e vn))))) (format "make-~a" (syntax-e vn)))))
@ -101,7 +100,7 @@
variant-accessor variant-mutator) variant-accessor variant-mutator)
(make-struct-type 'variant-name struct:x variant-field-count 0 (make-struct-type 'variant-name struct:x variant-field-count 0
#f #f
`((,prop:print-convert-constructor-name . variant-name)) null
(make-inspector))] (make-inspector))]
...) ...)
;; User-available functions: ;; User-available functions:
@ -191,7 +190,7 @@
(values null null null #f)] (values null null null #f)]
[else [else
(let ([clause (car clauses)]) (let ([clause (car clauses)])
(syntax-case* clause (else) (syntax-case* clause ()
(lambda (a b) (lambda (a b)
(and (eq? (syntax-e b) 'else) (and (eq? (syntax-e b) 'else)
(not (identifier-binding b)))) (not (identifier-binding b))))
@ -200,7 +199,7 @@
[vt [vt
(ormap (lambda (dtv) (ormap (lambda (dtv)
(let ([vt-name (vt-name-stx dtv)]) (let ([vt-name (vt-name-stx dtv)])
(and (module-identifier=? variant vt-name) (and (free-identifier=? variant vt-name)
dtv))) dtv)))
(dt-variants dt))] (dt-variants dt))]
[orig-variant (and vt (vt-name-stx vt))]) [orig-variant (and vt (vt-name-stx vt))])
@ -208,7 +207,7 @@
(raise-syntax-error (raise-syntax-error
#f #f
(format "not a variant of `~a'" (format "not a variant of `~a'"
(syntax-object->datum (syntax datatype))) (syntax->datum (syntax datatype)))
stx stx
variant)) variant))
@ -228,8 +227,8 @@
#f #f
(format (format
"variant case `~a' for `~a' has wrong field count (expected ~a, found ~a)" "variant case `~a' for `~a' has wrong field count (expected ~a, found ~a)"
(syntax-object->datum variant) (syntax->datum variant)
(syntax-object->datum (syntax datatype)) (syntax->datum (syntax datatype))
(vt-field-count dtv) (vt-field-count dtv)
(length field-ids)) (length field-ids))
stx stx
@ -281,7 +280,7 @@
[missing (let loop ([l (dt-variants dt)]) [missing (let loop ([l (dt-variants dt)])
(cond (cond
[(null? l) ""] [(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))] (loop (cdr l))]
[else [else
(format " ~a~a" (format " ~a~a"

8
collects/eopl/eopl.rkt
View File

@ -3,8 +3,8 @@
(require "datatype.rkt" (require "datatype.rkt"
"private/sllgen.rkt" "private/sllgen.rkt"
racket/promise racket/promise
mzlib/trace racket/trace
mzlib/pretty) racket/pretty)
(require (for-syntax racket/base (require (for-syntax racket/base
"private/slldef.rkt")) "private/slldef.rkt"))
@ -153,8 +153,6 @@
parameterize parameterize
print-struct) print-struct)
(require mzlib/transcr)
(provide unquote unquote-splicing (provide unquote unquote-splicing
quote quasiquote if when unless quote quasiquote if when unless
lambda letrec define-syntax delay let let* let-syntax letrec-syntax lambda letrec define-syntax delay let let* let-syntax letrec-syntax
@ -179,7 +177,7 @@
exact->inexact inexact->exact number->string string->number exact->inexact inexact->exact number->string string->number
rationalize output-port? current-input-port current-output-port current-error-port rationalize output-port? current-input-port current-output-port current-error-port
open-input-file open-output-file close-input-port close-output-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-length string-ci<=? string-ci>=? string-append
string-fill! string-fill!
string->list list->string string->list list->string

27
collects/eopl/eopl.scrbl
View File

@ -1,10 +1,9 @@
#lang scribble/doc #lang scribble/doc
@(require scribble/manual @(require scribble/manual
scribble/struct scribble/struct
scheme/list racket/list
(for-label eopl/eopl (for-label eopl/eopl
scheme/contract racket/contract))
(only-in scheme printf pretty-print delay force)))
@(define-syntax-rule (def-rkt id) @(define-syntax-rule (def-rkt id)
(begin (begin
@ -14,24 +13,22 @@
@(define-syntax-rule (reprovide id ...) @(define-syntax-rule (reprovide id ...)
(*threecolumns (list (racket id) ... 'nbsp 'nbsp))) (*threecolumns (list (racket id) ... 'nbsp 'nbsp)))
@(define (*threecolumns l) @(define (*threecolumns l)
(let* ([len (length l)] (define len (length l))
[third (quotient len 3)] (define third (quotient len 3))
[a (take l third)] (define spacer (hspace 2))
[b (take (list-tail l third) third)] (define to-flow (compose make-flow list make-paragraph list))
[c (list-tail l (* 2 third))]
[spacer (hspace 2)]
[to-flow (compose make-flow list make-paragraph list)])
(make-table #f (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) (list (to-flow spacer)
(to-flow a) (to-flow a)
(to-flow spacer) (to-flow spacer)
(to-flow b) (to-flow b)
(to-flow spacer) (to-flow spacer)
(to-flow c))) (to-flow c)))))
a b c))))
@title{@italic{Essentials of Programming Languages} Language} @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 exact->inexact inexact->exact number->string string->number
rationalize output-port? current-input-port current-output-port current-error-port rationalize output-port? current-input-port current-output-port current-error-port
open-input-file open-output-file close-input-port close-output-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-length string-ci<=? string-ci>=? string-append
string-fill! string-fill!
string->list list->string string->list list->string

5
collects/eopl/private/sllboth.rkt
View File

@ -1,5 +1,4 @@
#lang racket
(module sllboth mzscheme
;; This is stuff that lives at both table-consruction time and ;; This is stuff that lives at both table-consruction time and
;; table-use time. That's ok because the data is all built on ;; table-use time. That's ok because the data is all built on
@ -68,4 +67,4 @@
(and (pair? v) (and (pair? v)
(eq? (car v) 'not) (eq? (car v) 'not)
(pair? (cdr v)) (pair? (cdr v))
(char? (cadr v))))))) (char? (cadr v))))))

6
collects/eopl/private/slldef.rkt
View File

@ -1,4 +1,4 @@
(module slldef mzscheme #lang racket
;; A compile-time table shared by eopl and sllgen: ;; A compile-time table shared by eopl and sllgen:
(define sllgen-def (make-hash-table)) (define sllgen-def (make-hasheq))
(provide sllgen-def)) (provide sllgen-def)

389
collects/eopl/private/sllgen.rkt
View File

@ -1,3 +1,4 @@
#lang racket
;;; sllgen -- Scheme LL(1) parser generator ;;; sllgen -- Scheme LL(1) parser generator
;; In this version, most of the sllgen: names are syntactic forms ;; 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 ;; been split, so that the grammar table, etc. is parsed at compile
;; time. ;; time.
(module sllgen mzscheme (require racket/pretty
(require mzlib/pretty racket/mpair
scheme/mpair
"../datatype.rkt" "../datatype.rkt"
"sllboth.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 (provide sllgen:make-string-parser
sllgen:make-string-parser
sllgen:make-stream-parser sllgen:make-stream-parser
sllgen:make-rep-loop sllgen:make-stream-scanner
sllgen:make-string-scanner
sllgen:make-define-datatypes sllgen:make-define-datatypes
sllgen:show-define-datatypes sllgen:show-define-datatypes
sllgen:list-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 (display (string-append
"sllgen.scm " "sllgen.scm "
(substring time-stamp 13 29) (substring time-stamp 13 29)
(string #\newline)))) (string #\newline))))
(define sllgen:make-rep-loop (define sllgen:make-rep-loop
(lambda (prompt eval-fn stream-parser) (lambda (prompt eval-fn stream-parser)
(lambda () (lambda ()
(display prompt) (flush-output) (display prompt) (flush-output)
@ -43,57 +44,50 @@
(loop stream)) (loop stream))
(lambda () #t)))))) (lambda () #t))))))
;; **************************************************************** ;; ****************************************************************
;; Table of contents: ;; Table of contents:
;; top.s top-level entries ;; top.s top-level entries
;; parser-gen.scm organization of parser generator ;; parser-gen.scm organization of parser generator
;; syntax.s concrete syntax for grammars, etc. ;; syntax.s concrete syntax for grammars, etc.
;; eliminate-arbno.s replaces (ARBNO lhs) items with new productions ;; eliminate-arbno.s replaces (ARBNO lhs) items with new productions
;; first-and-follow.s calculate first and follow sets ;; first-and-follow.s calculate first and follow sets
;; gen-table.s take list of productions, first and ;; gen-table.s take list of productions, first and
;; follow tables, and generate parsing table ;; follow tables, and generate parsing table
;; check-table.s take a parse table and check for conflicts ;; check-table.s take a parse table and check for conflicts
;; scan.s scanner using streams ;; scan.s scanner using streams
;; parse.s run the generated parser ;; parse.s run the generated parser
;; error handling ;; error handling
;; tests ;; tests
;; **************************************************************** ;; ****************************************************************
;; Mon Sep 25 11:48:13 2000 added scanner outcomes symbol, number, ;; Mon Sep 25 11:48:13 2000 added scanner outcomes symbol, number,
;; string to replace make-symbol, make-number, and make-string. ;; string to replace make-symbol, make-number, and make-string.
;; Wed Apr 12 14:15:24 2000 version intended to be R5RS-compliant, ;; Wed Apr 12 14:15:24 2000 version intended to be R5RS-compliant,
;; based on suggestions by Will Clinger. ;; based on suggestions by Will Clinger.
;; **************************************************************** ;; ****************************************************************
;; be sure to load compatibility files!! ;; be sure to load compatibility files!!
;; **************************************************************** ;; ****************************************************************
;; top.s ;; 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)
;; user-level entry points
(begin-for-syntax
;; Gets a table: maybe immediate, maybe from a top-level definition ;; Gets a table: maybe immediate, maybe from a top-level definition
(define (get-table srcstx t what) (define (get-table srcstx t what)
(let ([def (and (identifier? t) (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 (if def
(syntax-object->datum def) (syntax->datum def)
(syntax-case t (quote) (syntax-case t (quote)
[(quote v) [(quote v)
(syntax-object->datum (syntax v))] (syntax->datum (syntax v))]
[_else [_else
(raise-syntax-error #f (raise-syntax-error #f
(format "bad ~a specification" what) (format "bad ~a specification" what)
@ -119,7 +113,6 @@
scanner-spec)))) scanner-spec))))
(syntax (make-string-parser parser-maker scanner-maker))))) (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 (define sllgen:make-stream-parser-maker
(lambda (scanner-spec grammar srcstx) (lambda (scanner-spec grammar srcstx)
@ -131,7 +124,6 @@
scanner-spec)))) scanner-spec))))
(syntax (make-stream-parser parser-maker scanner-maker))))) (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 (define sllgen:make-stream-scanner-maker
(lambda (scanner-spec grammar srcstx) (lambda (scanner-spec grammar srcstx)
@ -141,8 +133,6 @@
grammar) grammar)
scanner-spec)))) scanner-spec))))
(define sllgen:make-stream-scanner/proc (make-one sllgen:make-stream-scanner-maker))
(define sllgen:make-string-scanner-maker (define sllgen:make-string-scanner-maker
(lambda (scanner-spec grammar srcstx) (lambda (scanner-spec grammar srcstx)
(with-syntax ((scanner-maker (sllgen:make-stream-scanner-maker scanner-spec grammar srcstx))) (with-syntax ((scanner-maker (sllgen:make-stream-scanner-maker scanner-spec grammar srcstx)))
@ -151,19 +141,15 @@
(sllgen:stream->list (sllgen:stream->list
(scanner (sllgen:string->stream string))))))))) (scanner (sllgen:string->stream string)))))))))
(define sllgen:make-string-scanner/proc (make-one sllgen:make-string-scanner-maker))
(define sllgen:make-define-datatypes-maker (define sllgen:make-define-datatypes-maker
(lambda (scanner-spec grammar srcstx) (lambda (scanner-spec grammar srcstx)
(with-syntax ((datatype-definitions (with-syntax ((datatype-definitions
(datum->syntax-object (datum->syntax
srcstx srcstx
(sllgen:build-define-datatype-definitions scanner-spec grammar) (sllgen:build-define-datatype-definitions scanner-spec grammar)
srcstx))) srcstx)))
(syntax (begin . datatype-definitions))))) (syntax (begin . datatype-definitions)))))
(define sllgen:make-define-datatypes/proc (make-one sllgen:make-define-datatypes-maker))
(define sllgen:show-define-datatypes-maker (define sllgen:show-define-datatypes-maker
(lambda (scanner-spec grammar srcstx) (lambda (scanner-spec grammar srcstx)
(with-syntax ((datatype-definitions (with-syntax ((datatype-definitions
@ -173,7 +159,7 @@
pretty-print pretty-print
'datatype-definitions)))))) 'datatype-definitions))))))
(define sllgen:show-define-datatypes/proc (make-one sllgen:show-define-datatypes-maker))
(define sllgen:list-define-datatypes-maker (define sllgen:list-define-datatypes-maker
(lambda (scanner-spec grammar srcstx) (lambda (scanner-spec grammar srcstx)
@ -181,7 +167,6 @@
(sllgen:build-define-datatype-definitions scanner-spec grammar))) (sllgen:build-define-datatype-definitions scanner-spec grammar)))
(syntax 'datatype-definitions)))) (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) (if (eq? (car act) 'reduce)
(list 'reduce (list 'reduce
(list 'unquote (list 'unquote
(datum->syntax-object (datum->syntax
srcstx srcstx
(cadr act)))) (cadr act))))
act)) act))
@ -552,7 +537,7 @@
(define sllgen:non-terminal-add! (define sllgen:non-terminal-add!
(lambda (sym) (lambda (sym)
(if (not (memv sym sllgen:non-terminal-table)) (when (not (memv sym sllgen:non-terminal-table))
(set! sllgen:non-terminal-table (set! sllgen:non-terminal-table
(cons sym sllgen:non-terminal-table))))) (cons sym sllgen:non-terminal-table)))))
@ -1358,12 +1343,19 @@
. ,(map . ,(map
(lambda (pred) (lambda (pred)
(list (sllgen:gensym (car entry)) 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) (lambda (char-stream)
(let ((stream (let ((stream
(sllgen:stream-add-sentinel-via-thunk (sllgen:stream-add-sentinel-via-thunk
@ -1387,7 +1379,7 @@
fn eos))))) fn eos)))))
fn eos)))))) fn eos))))))
(define (make-string-parser parser scanner) (define (make-string-parser parser scanner)
(lambda (string) (lambda (string)
(let* ((char-stream (sllgen:string->stream string)) (let* ((char-stream (sllgen:string->stream string))
(token-stream (scanner char-stream)) (token-stream (scanner char-stream))
@ -1399,7 +1391,7 @@
(sllgen:make-token 'end-marker #f (sllgen:make-token 'end-marker #f
(sllgen:char-stream->location char-stream)))) (sllgen:char-stream->location char-stream))))
(lambda (tree token token-stream) (lambda (tree token token-stream)
(if (null? token) (when (null? token)
(sllgen:stream-get! token-stream (sllgen:stream-get! token-stream
(lambda (tok1 str1) (lambda (tok1 str1)
(set! token tok1) (set! token tok1)
@ -1416,7 +1408,7 @@
(sllgen:token->data token)))))))) (sllgen:token->data token))))))))
(define sllgen:apply-tester (define sllgen:apply-tester
(lambda (tester ch) (lambda (tester ch)
(cond (cond
((char? tester) (char=? tester ch)) ((char? tester) (char=? tester ch))
@ -1435,19 +1427,19 @@
tester))))) tester)))))
;; actions ;; actions
;; action ::= (action-opcode . classname) ;; action ::= (action-opcode . classname)
;; action-opcode :: = skip | symbol | number | string ;; action-opcode :: = skip | symbol | number | string
;; make-symbol, make-number, and make-string are supported ;; make-symbol, make-number, and make-string are supported
;; alternates, but are deprecated. ;; 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 ;; if multiple actions are possible, do the one that appears here
;; first. make-string is first, so literal strings trump identifiers. ;; first. make-string is first, so literal strings trump identifiers.
(define sllgen:find-preferred-action (define sllgen:find-preferred-action
(lambda (action-opcodes) (lambda (action-opcodes)
(let loop ((preferences sllgen:action-preference-list)) (let loop ((preferences sllgen:action-preference-list))
(cond (cond
@ -1458,12 +1450,12 @@
(car preferences)) (car preferences))
(else (loop (cdr preferences))))))) (else (loop (cdr preferences)))))))
(define sllgen:is-all-skip? (define sllgen:is-all-skip?
(lambda (actions) (lambda (actions)
(let ((opcode (sllgen:find-preferred-action (map car actions)))) (let ((opcode (sllgen:find-preferred-action (map car actions))))
(eq? opcode 'skip)))) (eq? opcode 'skip))))
(define sllgen:cook-token (define sllgen:cook-token
(lambda (buffer actions loc) (lambda (buffer actions loc)
(let* ((opcode (sllgen:find-preferred-action (map car actions))) (let* ((opcode (sllgen:find-preferred-action (map car actions)))
(classname (cdr (assq opcode actions)))) (classname (cdr (assq opcode actions))))
@ -1488,35 +1480,35 @@
"unknown opcode selected from action list ~s" "unknown opcode selected from action list ~s"
actions)))))) actions))))))
; (define sllgen:cook-token ; (define sllgen:cook-token
; (lambda (buffer actions loc) ; (lambda (buffer actions loc)
; (let* ((opcode (sllgen:find-preferred-action (map car actions))) ; (let* ((opcode (sllgen:find-preferred-action (map car actions)))
; ;; (classname (cdr (assq opcode actions))) ; ;; (classname (cdr (assq opcode actions)))
; ) ; )
; (case opcode ; (case opcode
; ((skip) (sllgen:error 'sllgen:cook-token ; ((skip) (sllgen:error 'sllgen:cook-token
; "\nInternal error: skip should have been handled earlier ~s" ; "\nInternal error: skip should have been handled earlier ~s"
; actions)) ; actions))
; ((make-symbol identifier) ; ((make-symbol identifier)
; (sllgen:make-token 'identifier ; (sllgen:make-token 'identifier
; (string->symbol (list->string (reverse buffer))) ; (string->symbol (list->string (reverse buffer)))
; loc)) ; loc))
; ((make-number number) ; ((make-number number)
; (sllgen:make-token 'number ; (sllgen:make-token 'number
; (string->number (list->string (reverse buffer))) ; (string->number (list->string (reverse buffer)))
; loc)) ; loc))
; ((make-string string) ; ((make-string string)
; (sllgen:make-token 'string ; (sllgen:make-token 'string
; (list->string (reverse buffer)) ; (list->string (reverse buffer))
; loc)) ; loc))
; (else ; (else
; (sllgen:error 'scanning ; (sllgen:error 'scanning
; "\nUnknown opcode selected from action list ~s" ; "\nUnknown opcode selected from action list ~s"
; actions)))))) ; actions))))))
;; k = (actions * newstates * char * stream) -> val ;; k = (actions * newstates * char * stream) -> val
(define sllgen:scanner-inner-loop (define sllgen:scanner-inner-loop
(lambda (local-states stream k) (lambda (local-states stream k)
(let ((actions '()) (let ((actions '())
(newstates '()) (newstates '())
@ -1561,7 +1553,7 @@
(lambda (tester) (lambda (tester)
;; get a character if one hasn't been gotten and we ;; get a character if one hasn't been gotten and we
;; haven't discovered eos. ;; haven't discovered eos.
(if (and (null? char) (not eos-found?)) (when (and (null? char) (not eos-found?))
(sllgen:char-stream-get! stream (sllgen:char-stream-get! stream
(lambda (ch1) (lambda (ch1)
'(eopl:printf "read character ~s\n" ch1) '(eopl:printf "read character ~s\n" ch1)
@ -1569,7 +1561,7 @@
(lambda () (lambda ()
(set! eos-found? #t)))) (set! eos-found? #t))))
'(eopl:printf "applying tester ~s to ~s\n" tester char) '(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)) (sllgen:apply-tester tester char))
;; passed the test -- shift is possible ;; passed the test -- shift is possible
(set! newstates (cons (cdr state) newstates))) (set! newstates (cons (cdr state) newstates)))
@ -1608,9 +1600,9 @@
(append sequents (cdr state)) (append sequents (cdr state))
(cdr local-states))))))))))))) (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 (lambda (start-states input-stream) ; -> (token stream), same as before
(let (let
((states start-states) ; list of local-states ((states start-states) ; list of local-states
@ -1626,7 +1618,7 @@
(lambda () (lambda ()
(sllgen:scanner-inner-loop states stream (sllgen:scanner-inner-loop states stream
(lambda (new-actions new-states char new-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 ;; ok, the current buffer is a candidate token
(begin (begin
(set! success-buffer buffer) (set! success-buffer buffer)
@ -1649,7 +1641,7 @@
(lambda (char new-stream) (lambda (char new-stream)
;; first, push the lookahead character back on the ;; first, push the lookahead character back on the
;; stream. ;; stream.
(if (not (null? char)) (when (not (null? char))
(sllgen:char-stream-push-back! char new-stream)) (sllgen:char-stream-push-back! char new-stream))
(set! stream new-stream) (set! stream new-stream)
(if (null? buffer) (if (null? buffer)
@ -1696,71 +1688,71 @@
;; start by trying to absorb a character ;; start by trying to absorb a character
(process-stream))))) (process-stream)))))
;; Watch out for examples like: ;; Watch out for examples like:
;; ("a" | "b" | "c" | "abcdef") matched against "abc" should produce ;; ("a" | "b" | "c" | "abcdef") matched against "abc" should produce
;; 3 tokens before reaching eos. ;; 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:make-token list)
(define sllgen:token->class car) (define sllgen:token->class car)
(define sllgen:token->data cadr) (define sllgen:token->data cadr)
(define sllgen:token->location caddr) (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. ;; this is banged, because doing it on some streams may cause a side-effect.
(define sllgen:stream-get! (define sllgen:stream-get!
(lambda (str fcn eos-fcn) (lambda (str fcn eos-fcn)
(str fcn eos-fcn))) (str fcn eos-fcn)))
(define sllgen:empty-stream (define sllgen:empty-stream
(lambda (fcn eos-fcn) (lambda (fcn eos-fcn)
(eos-fcn))) (eos-fcn)))
(define sllgen:make-stream (define sllgen:make-stream
(lambda (tag char stream) (lambda (tag char stream)
;(eopl:printf "sllgen:make-stream: building stream at ~s with ~s\n" tag char) ;(eopl:printf "sllgen:make-stream: building stream at ~s with ~s\n" tag char)
(lambda (fcn eos-fcn) (lambda (fcn eos-fcn)
;(eopl:printf "sllgen:make-stream: emitting ~s\n" char) ;(eopl:printf "sllgen:make-stream: emitting ~s\n" char)
(fcn char stream)))) (fcn char stream))))
(define sllgen:list->stream (define sllgen:list->stream
(lambda (l) (lambda (l)
(if (null? l) sllgen:empty-stream (if (null? l) sllgen:empty-stream
(sllgen:make-stream 'sllgen:list->stream (car l) (sllgen:list->stream (cdr l)))))) (sllgen:make-stream 'sllgen:list->stream (car l) (sllgen:list->stream (cdr l))))))
; ;; brute force for now. ; ;; brute force for now.
; (define sllgen:string->stream ; (define sllgen:string->stream
; (lambda (string) (sllgen:list->stream (string->list string)))) ; (lambda (string) (sllgen:list->stream (string->list string))))
; ;; this one has state: ; ;; this one has state:
; (define sllgen:stdin-char-stream ; (define sllgen:stdin-char-stream
; (lambda (fcn eos-fcn) ; (lambda (fcn eos-fcn)
; (let ((char (read-char))) ; (let ((char (read-char)))
; (if (eof-object? char) ; (if (eof-object? char)
; (eos-fcn) ; (eos-fcn)
; (fcn char sllgen:stdin-char-stream))))) ; (fcn char sllgen:stdin-char-stream)))))
(define sllgen:stream->list (define sllgen:stream->list
(lambda (stream) (lambda (stream)
(sllgen:stream-get! stream (sllgen:stream-get! stream
(lambda (val stream) (lambda (val stream)
(cons val (sllgen:stream->list stream))) (cons val (sllgen:stream->list stream)))
(lambda () '())))) (lambda () '()))))
(define sllgen:constant-stream (define sllgen:constant-stream
(lambda (val) (lambda (val)
(lambda (fn eos) (lambda (fn eos)
(fn val (sllgen:constant-stream val))))) (fn val (sllgen:constant-stream val)))))
;; takes a stream and produces another stream that produces the ;; takes a stream and produces another stream that produces the
;; sentinel instead of an end-of-stream ;; sentinel instead of an end-of-stream
(define sllgen:stream-add-sentinel (define sllgen:stream-add-sentinel
(lambda (stream sentinel) (lambda (stream sentinel)
(lambda (fn eos) ; here's what to do on a get (lambda (fn eos) ; here's what to do on a get
(sllgen:stream-get! stream (sllgen:stream-get! stream
@ -1769,7 +1761,7 @@
(lambda () (lambda ()
(fn sentinel (sllgen:constant-stream sentinel))))))) (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 (stream sentinel-fcn)
(lambda (fn eos) ; here's what to do on a get (lambda (fn eos) ; here's what to do on a get
(sllgen:stream-get! stream (sllgen:stream-get! stream
@ -1781,59 +1773,59 @@
; (eopl:printf "~s\n" sentinel) ; (eopl:printf "~s\n" sentinel)
(fn sentinel (sllgen:constant-stream sentinel)))))))) (fn sentinel (sllgen:constant-stream sentinel))))))))
; no longer used ; no longer used
; (define sllgen:stream-get ; (define sllgen:stream-get
; (lambda (stream fcn) ; (lambda (stream fcn)
; (sllgen:stream-get! stream fcn ; (sllgen:stream-get! stream fcn
; (lambda () ; (lambda ()
; (sllgen:error 'sllgen:stream-get ; (sllgen:error 'sllgen:stream-get
; "internal error: old streams aren't supposed to produce eos"))))) ; "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:string->stream : string -> charstream
;; sllgen:stdin-char-stream : () -> charstream ;; sllgen:stdin-char-stream : () -> charstream
;; sllgen:char-stream-get! : !charstream * (char -> ans) * (() -> ans) ;; sllgen:char-stream-get! : !charstream * (char -> ans) * (() -> ans)
;; -> ans ;; -> ans
;; [modifies charstream] ;; [modifies charstream]
;; sllgen:char-stream-push-back! : char * !charstream -> () ;; sllgen:char-stream-push-back! : char * !charstream -> ()
;; sllgen:char-stream->location : charstream -> location ;; 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 ;; 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. ;; 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) (lambda (cstr sk th)
((vector-ref cstr 0) 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) (lambda (ch cstr)
((vector-ref cstr 1) ch cstr))) ((vector-ref cstr 1) ch cstr)))
(define sllgen:char-stream->location (define sllgen:char-stream->location
(lambda (cstr) (lambda (cstr)
(vector-ref cstr 2))) (vector-ref cstr 2)))
(define sllgen:set-location! (define sllgen:set-location!
(lambda (vec val) (lambda (vec val)
(vector-set! vec 2 val))) (vector-set! vec 2 val)))
;; for a string-built stream, the other stuff consists of an index ;; for a string-built stream, the other stuff consists of an index
;; into the string for the next unread character, and a string. ;; into the string for the next unread character, and a string.
(define sllgen:string->stream (define sllgen:string->stream
(lambda (string) (lambda (string)
(let ((len (string-length string))) (let ((len (string-length string)))
(vector (vector
@ -1863,10 +1855,10 @@
)))) ))))
;; for stdin-char-stream, we have ;; for stdin-char-stream, we have
;; [get-fn ; push-back-fn ; location ; push-back stack] ;; [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 ; line number
(lambda () (lambda ()
(vector (vector
@ -1899,14 +1891,14 @@
'() ; push-back is initially empty '() ; push-back is initially empty
))) )))
(define sllgen:char-stream->list (define sllgen:char-stream->list
(lambda (cstr) (lambda (cstr)
(let loop () (let loop ()
(sllgen:char-stream-get! cstr (sllgen:char-stream-get! cstr
(lambda (ch) (cons ch (loop))) (lambda (ch) (cons ch (loop)))
(lambda () '()))))) (lambda () '())))))
(define sllgen:char-stream->list2 (define sllgen:char-stream->list2
(lambda (cstr) (lambda (cstr)
(let loop () (let loop ()
(sllgen:char-stream-get! cstr (sllgen:char-stream-get! cstr
@ -1917,39 +1909,39 @@
(lambda () '()))))) (lambda () '())))))
(define sllgen:increment-location (define sllgen:increment-location
(lambda (ch n) (lambda (ch n)
(if (eqv? ch #\newline) (+ 1 n) n))) (if (eqv? ch #\newline) (+ 1 n) n)))
(define sllgen:decrement-location (define sllgen:decrement-location
(lambda (ch n) (lambda (ch n)
(if (eqv? ch #\newline) (- n 1) 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 ...) ...) ;; table ::= ((non-terminal alternative ...) ...)
;; alternative ::= (list-of-items action ...) ;; alternative ::= (list-of-items action ...)
;; action ::= (TERM symbol) | (NON-TERM symbol) | (GOTO symbol) ;; action ::= (TERM symbol) | (NON-TERM symbol) | (GOTO symbol)
;; | (EMIT-LIST) | (REDUCE proc) ;; | (EMIT-LIST) | (REDUCE proc)
;; The token register can either contain an token or '() -- the latter ;; The token register can either contain an token or '() -- the latter
;; signifying an empty buffer, to be filled when necessary. ;; 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) ...) ; k = (lambda (tree token stream) ...)
; token may be a token or nil. ; token may be a token or nil.
(define sllgen:find-production (define sllgen:find-production
(lambda (non-terminal parser buf token stream k) (lambda (non-terminal parser buf token stream k)
(if (null? token) (when (null? token)
(sllgen:stream-get! stream (sllgen:stream-get! stream
(lambda (next-token next-stream) (lambda (next-token next-stream)
; '(eopl:printf "find-production: filling token buffer with ~s\n" token) ; '(eopl:printf "find-production: filling token buffer with ~s\n" token)
@ -1981,7 +1973,7 @@
parser buf token stream k)) parser buf token stream k))
(else (loop (cdr alternatives))))))) (else (loop (cdr alternatives)))))))
(define sllgen:apply-actions (define sllgen:apply-actions
(lambda (lhs action-list parser buf token stream k) (lambda (lhs action-list parser buf token stream k)
(let loop ((actions action-list) (let loop ((actions action-list)
(buf buf) (buf buf)
@ -1989,7 +1981,7 @@
(stream stream)) (stream stream))
(let ((fill-token! ; fill-token! is a macro in mzscheme (let ((fill-token! ; fill-token! is a macro in mzscheme
(lambda () (lambda ()
(if (null? token) (when (null? token)
(sllgen:stream-get! stream (sllgen:stream-get! stream
(lambda (next-token next-stream) (lambda (next-token next-stream)
(set! token next-token) (set! token next-token)
@ -2068,7 +2060,7 @@
"internal error: unknown instruction ~s" "internal error: unknown instruction ~s"
action)))))))) action))))))))
(define sllgen:unzip-buffer (define sllgen:unzip-buffer
(lambda (trees n buf) (lambda (trees n buf)
(let ((ans (let consloop ((n n)) (let ((ans (let consloop ((n n))
(if (zero? n) (if (zero? n)
@ -2085,7 +2077,6 @@
(set-mcar! ptr (cons (car trees) (mcar ptr))) (set-mcar! ptr (cons (car trees) (mcar ptr)))
(loop (cdr trees) (mcdr ptr) (- ctr 1)))))))) (loop (cdr trees) (mcdr ptr) (- ctr 1))))))))
(define sllgen:apply-reduction (define sllgen:apply-reduction
(lambda (lhs opcode args) (lambda (lhs opcode args)
(apply opcode args))) (apply opcode args)))
)

15
collects/eopl/private/utils.rkt
View File

@ -1,18 +1,17 @@
#lang racket
(module utils mzscheme
;; Generative structure definitions: ;; Generative structure definitions:
(define-struct dt (pred-stx variants)) (define-struct dt (pred-stx variants) #:mutable)
(define-struct vt (name-stx predicate-stx accessor-stx field-count)) (define-struct vt (name-stx predicate-stx accessor-stx field-count) #:mutable)
;; Helper function: ;; Helper function:
(define (variant-assq name-stx variants) (define (variant-assq name-stx variants)
(let loop ([l variants]) (let loop ([l variants])
(if (module-identifier=? name-stx (if (free-identifier=? name-stx
(vt-name-stx (car l))) (vt-name-stx (car l)))
(car l) (car l)
(loop (cdr l))))) (loop (cdr l)))))
(provide (struct dt (pred-stx variants)) (provide (struct-out dt)
(struct vt (name-stx predicate-stx accessor-stx field-count)) (struct-out vt)
variant-assq)) variant-assq)