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

8
collects/eopl/eopl.rkt
View File

@ -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

27
collects/eopl/eopl.scrbl
View File

@ -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

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

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

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:
(define sllgen-def (make-hash-table))
(provide sllgen-def))
(define sllgen-def (make-hasheq))
(provide sllgen-def)

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

@ -1,3 +1,4 @@
#lang racket
;;; sllgen -- Scheme LL(1) parser generator
;; 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
;; 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)
@ -77,23 +78,16 @@
;; 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)
(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,8 +1343,15 @@
. ,(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))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -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)
@ -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)))
@ -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)
@ -1949,7 +1941,7 @@
; 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)
@ -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)
@ -2088,4 +2080,3 @@
(define sllgen:apply-reduction
(lambda (lhs opcode args)
(apply opcode args)))
)

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

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