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"

16
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"))
@ -144,17 +144,15 @@
trace untrace ;; debugging trace untrace ;; debugging
require module ;; we allow full use of modules require module ;; we allow full use of modules
only-in only-in
prefix-in prefix-in
provide ;; in case someone wants to use a module provide ;; in case someone wants to use a module
all-defined-out all-defined-out
all-from-out ;; surely some subforms are missing all-from-out ;; surely some subforms are missing
rename-out rename-out
make-parameter make-parameter
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
@ -214,4 +212,4 @@
#| #|
scheme-report-environment null-environment interaction-environment scheme-report-environment null-environment interaction-environment
|# |#
) )

43
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)
(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)])
(make-table #f
(map (lambda (a b c)
(list (to-flow spacer)
(to-flow a)
(to-flow spacer)
(to-flow b)
(to-flow spacer)
(to-flow c)))
a b c))))
@(define (*threecolumns l)
(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
(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)))))
@title{@italic{Essentials of Programming Languages} Language} @title{@italic{Essentials of Programming Languages} Language}
@ -55,10 +52,10 @@ The following bindings are re-@racket[provide]d from
quote quasiquote if quote quasiquote if
lambda letrec define-syntax delay let let* let-syntax letrec-syntax lambda letrec define-syntax delay let let* let-syntax letrec-syntax
and or cond case do and or cond case do
begin set! begin set!
#%module-begin #%module-begin
#%app #%datum #%top #%top-interaction #%app #%datum #%top #%top-interaction
#%require #%provide #%expression #%require #%provide #%expression
syntax-rules ... syntax-rules ...
@ -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)

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

File diff suppressed because it is too large Load Diff

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)