Skip to content

Commit 41395ca

Browse files
dvanhorndvanhorn
committed
Add iniquity-plus, which used to be in langs.
1 parent 1d146cb commit 41395ca

10 files changed

Lines changed: 1000 additions & 0 deletions

File tree

‎www/iniquity-plus/ast.rkt‎

Lines changed: 173 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,173 @@
1+
#lang racket
2+
(provide (all-defined-out))
3+
4+
;; type Prog = (Prog (Listof Defn) Expr)
5+
(struct Prog (ds e) #:prefab)
6+
7+
;; type Defn = (Defn Id Fun)
8+
(struct Defn (f fun) #:prefab)
9+
10+
;; type Fun = (FunPlain [Listof Id] Expr)
11+
;; | (FunRest [Listof Id] Id Expr)
12+
;; | (FunCase [Listof FunCaseClause])
13+
;; type FunCaseClause = (FunPlain [Listof Id] Expr)
14+
;; | (FunRest [Listof Id] Id Expr)
15+
(struct FunPlain (xs e) #:prefab)
16+
(struct FunRest (xs x e) #:prefab)
17+
(struct FunCase (cs) #:prefab)
18+
19+
;; type Expr = (Eof)
20+
;; | (Empty)
21+
;; | (Int Integer)
22+
;; | (Bool Boolean)
23+
;; | (Char Character)
24+
;; | (Str String)
25+
;; | (Prim0 Op0)
26+
;; | (Prim1 Op1 Expr)
27+
;; | (Prim2 Op2 Expr Expr)
28+
;; | (Prim3 Op3 Expr Expr Expr)
29+
;; | (If Expr Expr Expr)
30+
;; | (Begin Expr Expr)
31+
;; | (Let Id Expr Expr)
32+
;; | (Var Id)
33+
;; | (App Id (Listof Expr))
34+
;; | (Apply Id (Listof Expr) Expr)
35+
;; type Id = Symbol
36+
;; type Op0 = 'read-byte
37+
;; type Op1 = 'add1 | 'sub1 | 'zero?
38+
;; | 'char? | 'integer->char | 'char->integer
39+
;; | 'write-byte | 'eof-object?
40+
;; | 'box | 'car | 'cdr | 'unbox
41+
;; | 'empty? | 'cons? | 'box?
42+
;; | 'vector? | vector-length
43+
;; | 'string? | string-length
44+
;; type Op2 = '+ | '- | '< | '=
45+
;; | 'cons
46+
;; | 'make-vector | 'vector-ref
47+
;; | 'make-string | 'string-ref
48+
;; type Op3 = 'vector-set!
49+
(struct Eof () #:prefab)
50+
(struct Empty () #:prefab)
51+
(struct Int (i) #:prefab)
52+
(struct Bool (b) #:prefab)
53+
(struct Char (c) #:prefab)
54+
(struct Str (s) #:prefab)
55+
(struct Prim0 (p) #:prefab)
56+
(struct Prim1 (p e) #:prefab)
57+
(struct Prim2 (p e1 e2) #:prefab)
58+
(struct Prim3 (p e1 e2 e3) #:prefab)
59+
(struct If (e1 e2 e3) #:prefab)
60+
(struct Begin (e1 e2) #:prefab)
61+
(struct Let (x e1 e2) #:prefab)
62+
(struct Var (x) #:prefab)
63+
(struct App (f es) #:prefab)
64+
(struct Apply (f es e) #:prefab)
65+
66+
;; Prog -> Void
67+
(define (check-syntax p)
68+
(match p
69+
[(Prog ds e)
70+
(let ((dr (defined-ids ds)))
71+
(check-syntax-unique-defines ds)
72+
(check-syntax-defines ds dr)
73+
(check-syntax-e e dr '()))]))
74+
75+
;; [Listof Defn] -> [Listof Id]
76+
(define (defined-ids ds)
77+
(map (λ (d) (match d [(Defn f _) f]))
78+
ds))
79+
80+
;; [Listof Defn] -> Void
81+
(define (check-syntax-unique-defines ds)
82+
(unless (= (length ds)
83+
(length (remove-duplicates ds #:key Defn-f)))
84+
(error "duplicate definition for function")))
85+
86+
;; [Listof Defn] [Listof Id] -> Void
87+
(define (check-syntax-defines ds r)
88+
(for-each (λ (d) (check-syntax-define d r)) ds))
89+
90+
;; Defn [Listof Id] -> Void
91+
(define (check-syntax-define d dr)
92+
(match d
93+
[(Defn f (FunPlain xs e))
94+
(check-unique (cons f xs))
95+
(check-syntax-e e dr xs)]
96+
[(Defn f (FunRest xs x e))
97+
(check-unique (cons f (cons x xs)))
98+
(check-syntax-e e dr (cons x xs))]
99+
[(Defn f (FunCase '()))
100+
(void)]
101+
[(Defn f (FunCase (cons c cs)))
102+
(check-syntax-define (Defn f c) dr)
103+
(check-syntax-define (Defn f (FunCase cs)) dr)]))
104+
105+
;; [Listof Id] -> Void
106+
(define (check-unique xs)
107+
(unless (= (length xs) (length (remove-duplicates xs)))
108+
(error "duplicate identifier")))
109+
110+
;; Expr [Listof Id] [Listof Id] -> Void
111+
(define (check-syntax-e e dr r)
112+
(match e
113+
[(Eof) (void)]
114+
[(Empty) (void)]
115+
[(Int i) (void)]
116+
[(Bool b) (void)]
117+
[(Char c) (void)]
118+
[(Str s) (void)]
119+
[(Prim0 p) (void)]
120+
[(Prim1 p e) (check-syntax-e e dr r)]
121+
[(Prim2 p e1 e2)
122+
(check-syntax-e e1 dr r)
123+
(check-syntax-e e2 dr r)]
124+
[(Prim3 p e1 e2 e3)
125+
(check-syntax-e e1 dr r)
126+
(check-syntax-e e2 dr r)
127+
(check-syntax-e e3 dr r)]
128+
[(If e1 e2 e3)
129+
(check-syntax-e e1 dr r)
130+
(check-syntax-e e2 dr r)
131+
(check-syntax-e e3 dr r)]
132+
[(Begin e1 e2)
133+
(check-syntax-e e1 dr r)
134+
(check-syntax-e e2 dr r)]
135+
[(Let x e1 e2)
136+
(check-syntax-e e1 dr r)
137+
(check-syntax-e e2 dr (cons x r))]
138+
[(Var x)
139+
(unless (member x r)
140+
(error "unbound variable"))]
141+
[(App f es)
142+
(unless (member f dr)
143+
(error "undefined function"))
144+
(for-each (λ (e) (check-syntax-e e dr r)) es)]
145+
[(Apply f es e)
146+
(unless (member f dr)
147+
(error "undefined function"))
148+
(check-syntax-e e dr r)
149+
(for-each (λ (e) (check-syntax-e e dr r)) es)]))
150+
151+
(module+ test
152+
(require rackunit)
153+
(check-exn exn:fail? (λ () (check-syntax-e (Var 'x) '() '())))
154+
(check-exn exn:fail? (λ () (check-syntax-e (Var 'x) '(x) '())))
155+
(check-not-exn (λ () (check-syntax-e (Var 'x) '() '(x))))
156+
(check-not-exn (λ () (check-syntax-e (Let 'x (Int 1) (Var 'x)) '() '())))
157+
(check-not-exn (λ () (check-syntax-e (Let 'x (Int 1) (Let 'y (Int 2) (Var 'x))) '() '())))
158+
(check-not-exn (λ () (check-syntax-e (Let 'x (Int 1) (Let 'x (Int 2) (Var 'x))) '() '())))
159+
(check-not-exn (λ () (check-syntax-e (Let 'x (Int 1) (Let 'y (Int 2) (Var 'y))) '() '())))
160+
(check-exn exn:fail? (λ () (check-syntax (Prog (list (Defn 'f (FunPlain '() (Int 1)))) (Var 'f)))))
161+
(check-exn exn:fail? (λ () (check-syntax (Prog (list (Defn 'f (FunPlain '(f) (Int 1)))) (Int 1)))))
162+
(check-exn exn:fail? (λ () (check-syntax (Prog (list (Defn 'f (FunRest '(f) 'x (Int 1)))) (Int 1)))))
163+
(check-exn exn:fail? (λ () (check-syntax (Prog (list (Defn 'f (FunRest '() 'f (Int 1)))) (Int 1)))))
164+
(check-exn exn:fail? (λ () (check-syntax (Prog (list (Defn 'f (FunPlain '(x x) (Int 1)))) (Int 1)))))
165+
(check-exn exn:fail?
166+
(λ () (check-syntax
167+
(Prog (list (Defn 'f (FunPlain '(x) (Int 1)))
168+
(Defn 'f (FunPlain '(y) (Int 2))))
169+
(Int 1)))))
170+
(check-exn exn:fail? (λ () (check-syntax (Prog '() (App 'f '())))))
171+
(check-exn exn:fail? (λ () (check-syntax (Prog '() (Apply 'f '() (Int 1))))))
172+
(check-not-exn (λ () (check-syntax (Prog (list (Defn 'f (FunPlain '() (Int 1)))) (App 'f '())))))
173+
(check-not-exn (λ () (check-syntax (Prog (list (Defn 'f (FunPlain '() (Int 1)))) (Apply 'f '() (Int 1)))))))

‎www/iniquity-plus/env.rkt‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
#lang racket
2+
(provide lookup ext)
3+
4+
;; Env Variable -> Answer
5+
(define (lookup env x)
6+
(match env
7+
['() 'err]
8+
[(cons (list y i) env)
9+
(match (symbol=? x y)
10+
[#t i]
11+
[#f (lookup env x)])]))
12+
13+
;; Env Variable Value -> Value
14+
(define (ext r x i)
15+
(cons (list x i) r))

‎www/iniquity-plus/interp-io.rkt‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
#lang racket
2+
(provide interp/io)
3+
(require "interp.rkt")
4+
5+
;; Expr String -> (Cons Value String)
6+
;; Interpret e with given string as input,
7+
;; return value and collected output as string
8+
(define (interp/io e input)
9+
(parameterize ((current-output-port (open-output-string))
10+
(current-input-port (open-input-string input)))
11+
(cons (interp e)
12+
(get-output-string (current-output-port)))))

‎www/iniquity-plus/interp-prims.rkt‎

Lines changed: 68 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,68 @@
1+
#lang racket
2+
(require "ast.rkt")
3+
(provide interp-prim1 interp-prim2 interp-prim3)
4+
5+
;; Op1 Value -> Answer
6+
(define (interp-prim1 p1 v)
7+
(match (list p1 v)
8+
[(list 'add1 (? integer?)) (add1 v)]
9+
[(list 'sub1 (? integer?)) (sub1 v)]
10+
[(list 'zero? (? integer?)) (zero? v)]
11+
[(list 'char? v) (char? v)]
12+
[(list 'char->integer (? char?)) (char->integer v)]
13+
[(list 'integer->char (? codepoint?)) (integer->char v)]
14+
[(list 'eof-object? v) (eof-object? v)]
15+
[(list 'write-byte (? byte?)) (write-byte v)]
16+
[(list 'box v) (box v)]
17+
[(list 'unbox (? box?)) (unbox v)]
18+
[(list 'car (? pair?)) (car v)]
19+
[(list 'cdr (? pair?)) (cdr v)]
20+
[(list 'empty? v) (empty? v)]
21+
[(list 'cons? v) (cons? v)]
22+
[(list 'box? v) (box? v)]
23+
[(list 'vector? v) (vector? v)]
24+
[(list 'vector-length (? vector?)) (vector-length v)]
25+
[(list 'string? v) (string? v)]
26+
[(list 'string-length (? string?)) (string-length v)]
27+
[_ 'err]))
28+
29+
;; Op2 Value Value -> Answer
30+
(define (interp-prim2 p v1 v2)
31+
(match (list p v1 v2)
32+
[(list '+ (? integer?) (? integer?)) (+ v1 v2)]
33+
[(list '- (? integer?) (? integer?)) (- v1 v2)]
34+
[(list '< (? integer?) (? integer?)) (< v1 v2)]
35+
[(list '= (? integer?) (? integer?)) (= v1 v2)]
36+
[(list 'cons v1 v2) (cons v1 v2)]
37+
[(list 'make-vector (? integer?) _)
38+
(if (<= 0 v1)
39+
(make-vector v1 v2)
40+
'err)]
41+
[(list 'vector-ref (? vector?) (? integer?))
42+
(if (<= 0 v2 (sub1 (vector-length v1)))
43+
(vector-ref v1 v2)
44+
'err)]
45+
[(list 'make-string (? integer?) (? char?))
46+
(if (<= 0 v1)
47+
(make-string v1 v2)
48+
'err)]
49+
[(list 'string-ref (? string?) (? integer?))
50+
(if (<= 0 v2 (sub1 (string-length v1)))
51+
(string-ref v1 v2)
52+
'err)]
53+
[_ 'err]))
54+
55+
;; Op3 Value Value Value -> Answer
56+
(define (interp-prim3 p v1 v2 v3)
57+
(match (list p v1 v2 v3)
58+
[(list 'vector-set! (? vector?) (? integer?) _)
59+
(if (<= 0 v2 (sub1 (vector-length v1)))
60+
(vector-set! v1 v2 v3)
61+
'err)]
62+
[_ 'err]))
63+
64+
;; Any -> Boolean
65+
(define (codepoint? v)
66+
(and (integer? v)
67+
(or (<= 0 v 55295)
68+
(<= 57344 v 1114111))))

0 commit comments

Comments
 (0)