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)

77
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,20 +6,20 @@
;; 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)
@ -77,23 +78,16 @@
;; top.s ;; top.s
;; user-level entry points ;; user-level entry points
(begin-for-syntax
(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)
;; 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,8 +1343,15 @@
. ,(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))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -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)
@ -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)))
@ -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)
@ -1949,7 +1941,7 @@
; 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)
@ -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)
@ -2088,4 +2080,3 @@
(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)