Skip to content

Commit 3af8777

Browse files
jsiekjsiek
committed
added interp-F
1 parent 2d0f118 commit 3af8777

File tree

5 files changed

+123
-42
lines changed

5 files changed

+123
-42
lines changed

‎functions.rkt

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -557,7 +557,7 @@
557557
("uniquify" ,(send compiler uniquify '())
558558
,(send interp interp-scheme '()))
559559
("reveal-functions" ,(send compiler reveal-functions '())
560-
,(send interp interp-scheme '()))
560+
,(send interp interp-F '()))
561561
("flatten" ,(send compiler flatten #f)
562562
,(send interp interp-C '()))
563563
("expose allocation"

‎interp.rkt

Lines changed: 115 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -366,7 +366,7 @@
366366
['Boolean (if val #t #f)]
367367
['Integer val]
368368
['Void (void)]
369-
['Any `(inject ,(arithmetic-shift val -2) Integer)]
369+
['Any `(tagged ,(arithmetic-shift val -2) Integer)]
370370
[else (error (format "don't know how to display type ~a" ty))]))
371371

372372
));; class interp-R1
@@ -685,7 +685,7 @@
685685
(define interp-R3
686686
(class interp-R2
687687
(super-new)
688-
(inherit primitives seq-C display-by-type)
688+
(inherit primitives seq-C display-by-type interp-op)
689689
(inherit-field result)
690690

691691
(define/public (non-apply-ast)
@@ -698,25 +698,72 @@
698698
(match ast
699699
[`(define (,f [,xs : ,ps] ...) : ,rt ,body)
700700
(cons f `(lambda ,xs ,body))]
701-
[`(function-ref ,f)
702-
(lookup f env)]
703-
[`(app ,f ,args ...)
704-
(define new-args (map (interp-scheme env) args))
705-
(let ([f-val ((interp-scheme env) f)])
706-
(match f-val
707-
[`(lambda (,xs ...) ,body)
708-
(define new-env (append (map cons xs new-args) env))
709-
((interp-scheme new-env) body)]
710-
[else (error "interp-scheme, expected function, not" f-val)]))]
711701
[`(program (type ,ty) ,ds ... ,body)
712702
((interp-scheme env) `(program ,@ds ,body))]
713703
[`(program ,ds ... ,body)
714704
(let ([top-level (map (interp-scheme '()) ds)])
715705
((interp-scheme top-level) body))]
716-
[`(,f ,args ...) #:when (not (set-member?
717-
(non-apply-ast) f))
718-
((interp-scheme env) `(app ,f ,@args))]
719-
[else ((super interp-scheme env) ast)])))
706+
[`(,fun ,args ...) #:when (not (set-member? (non-apply-ast) fun))
707+
(define new-args (map (interp-scheme env) args))
708+
(define fun-val ((interp-scheme env) fun))
709+
(match fun-val
710+
[`(lambda (,xs ...) ,body)
711+
(define new-env (append (map cons xs new-args) env))
712+
((interp-scheme new-env) body)]
713+
[else (error "interp-scheme, expected function, not" fun-val)])]
714+
[else ((super interp-scheme env) ast)]
715+
)))
716+
717+
(define/public (interp-F env)
718+
(lambda (ast)
719+
(verbose "R3/interp-F" ast)
720+
(define result
721+
(match ast
722+
;; For R3
723+
[`(define (,f [,xs : ,ps] ...) : ,rt ,body)
724+
(cons f `(lambda ,xs ,body))]
725+
[`(function-ref ,f)
726+
(lookup f env)]
727+
[`(app ,fun ,args ...)
728+
(define arg-vals (map (interp-F env) args))
729+
(define fun-val ((interp-F env) fun))
730+
(match fun-val
731+
[`(lambda (,xs ...) ,body)
732+
(define new-env (append (map cons xs arg-vals) env))
733+
((interp-F new-env) body)]
734+
[else (error "interp-F, expected function, not" fun-val)])]
735+
[`(program (type ,ty) ,ds ... ,body)
736+
((interp-F env) `(program ,@ds ,body))]
737+
[`(program ,ds ... ,body)
738+
(let ([top-level (map (interp-F '()) ds)])
739+
((interp-F top-level) body))]
740+
;; For R2
741+
[`(has-type ,e ,t) ((interp-F env) e)]
742+
[#t #t]
743+
[#f #f]
744+
[`(and ,e1 ,e2)
745+
(match ((interp-F env) e1)
746+
[#t (match ((interp-F env) e2)
747+
[#t #t] [#f #f])]
748+
[#f #f])]
749+
[`(if ,cnd ,thn ,els)
750+
(if ((interp-F env) cnd)
751+
((interp-F env) thn)
752+
((interp-F env) els))]
753+
;; For R1
754+
[(? symbol?)
755+
(lookup ast env)]
756+
[(? integer?) ast]
757+
[`(let ([,x ,e]) ,body)
758+
(let ([v ((interp-F env) e)])
759+
((interp-F (cons (cons x v) env)) body))]
760+
[`(program ,e) ((interp-F '()) e)]
761+
[`(,op ,args ...) #:when (set-member? (primitives) op)
762+
(apply (interp-op op) (map (interp-F env) args))]
763+
))
764+
(verbose "R3/interp-F" ast result)
765+
result
766+
))
720767

721768
(define/override (interp-C env)
722769
(lambda (ast)
@@ -727,11 +774,11 @@
727774
[`(function-ref ,f)
728775
(lookup f env)]
729776
[`(app ,f ,args ...)
730-
(define new-args (map (interp-C env) args))
777+
(define arg-vals (map (interp-C env) args))
731778
(define f-val ((interp-C env) f))
732779
(match f-val
733780
[`(lambda (,xs ...) ,ss ...)
734-
(define new-env (append (map cons xs new-args) env))
781+
(define new-env (append (map cons xs arg-vals) env))
735782
(define result-env ((seq-C new-env) ss))
736783
(lookup result result-env)]
737784
[else (error "interp-C, expected a funnction, not" f-val)])]
@@ -823,6 +870,7 @@
823870
(define interp-R4
824871
(class interp-R3
825872
(super-new)
873+
(inherit non-apply-ast)
826874
(inherit-field result)
827875

828876
(define/override (interp-scheme env)
@@ -831,14 +879,6 @@
831879
(match ast
832880
[`(lambda: ([,xs : ,Ts] ...) : ,rT ,body)
833881
`(lambda ,xs ,body ,env)]
834-
[`(app ,f ,args ...)
835-
(define new-args (map (interp-scheme env) args))
836-
(let ([f-val ((interp-scheme env) f)])
837-
(match f-val
838-
[`(lambda (,xs ...) ,body ,lam-env)
839-
(define new-env (append (map cons xs new-args) lam-env))
840-
((interp-scheme new-env) body)]
841-
[else (error "interp-scheme, expected function, not" f-val)]))]
842882
[`(define (,f [,xs : ,ps] ...) : ,rt ,body)
843883
(mcons f `(lambda ,xs ,body))]
844884
[`(program (type ,ty) ,ds ... ,body)
@@ -851,7 +891,47 @@
851891
[`(lambda ,xs ,body)
852892
`(lambda ,xs ,body ,top-level)])))
853893
((interp-scheme top-level) body))]
854-
[else ((super interp-scheme env) ast)]))))) ;; end interp-R4
894+
[`(,fun ,args ...) #:when (not (set-member? (non-apply-ast) fun))
895+
(define arg-vals (map (interp-scheme env) args))
896+
(define fun-val ((interp-scheme env) fun))
897+
(match fun-val
898+
[`(lambda (,xs ...) ,body ,lam-env)
899+
(define new-env (append (map cons xs arg-vals) lam-env))
900+
((interp-scheme new-env) body)]
901+
[else (error "interp-scheme, expected function, not" fun-val)])]
902+
[else ((super interp-scheme env) ast)]
903+
)))
904+
905+
(define/override (interp-F env)
906+
(lambda (ast)
907+
(verbose "R4/interp-F" ast)
908+
(match ast
909+
[`(lambda: ([,xs : ,Ts] ...) : ,rT ,body)
910+
`(lambda ,xs ,body ,env)]
911+
[`(define (,f [,xs : ,ps] ...) : ,rt ,body)
912+
(mcons f `(lambda ,xs ,body))]
913+
[`(program (type ,ty) ,ds ... ,body)
914+
((interp-F env) `(program ,@ds ,body))]
915+
[`(program ,ds ... ,body)
916+
(let ([top-level (map (interp-F '()) ds)])
917+
;; Use set-cdr! on define lambda's for mutual recursion
918+
(for/list ([b top-level])
919+
(set-mcdr! b (match (mcdr b)
920+
[`(lambda ,xs ,body)
921+
`(lambda ,xs ,body ,top-level)])))
922+
((interp-F top-level) body))]
923+
[`(app ,fun ,args ...)
924+
(define arg-vals (map (interp-F env) args))
925+
(define fun-val ((interp-F env) fun))
926+
(match fun-val
927+
[`(lambda (,xs ...) ,body ,lam-env)
928+
(define new-env (append (map cons xs arg-vals) lam-env))
929+
((interp-F new-env) body)]
930+
[else (error "interp-F, expected function, not" fun-val)])]
931+
[else ((super interp-F env) ast)]
932+
)))
933+
934+
)) ;; end interp-R4
855935

856936

857937
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -862,7 +942,6 @@
862942
(super-new)
863943
(inherit-field result)
864944

865-
866945
(define/override (primitives)
867946
(set-union (super primitives)
868947
(set 'boolean? 'integer? 'vector? 'procedure?)))
@@ -871,19 +950,19 @@
871950
(match op
872951
['boolean? (lambda (v)
873952
(match v
874-
[`(inject ,v1 Boolean) #t]
953+
[`(tagged ,v1 Boolean) #t]
875954
[else #f]))]
876955
['integer? (lambda (v)
877956
(match v
878-
[`(inject ,v1 Integer) #t]
957+
[`(tagged ,v1 Integer) #t]
879958
[else #f]))]
880959
['vector? (lambda (v)
881960
(match v
882-
[`(inject ,v1 (Vector ,ts ...)) #t]
961+
[`(tagged ,v1 (Vector ,ts ...)) #t]
883962
[else #f]))]
884963
['procedure? (lambda (v)
885964
(match v
886-
[`(inject ,v1 (,ts ... -> ,rt)) #t]
965+
[`(tagged ,v1 (,ts ... -> ,rt)) #t]
887966
[else #f]))]
888967
[else (super interp-op op)]
889968
))
@@ -893,11 +972,11 @@
893972
(verbose "R6/interp-scheme" ast)
894973
(match ast
895974
[`(inject ,e ,t)
896-
`(inject ,((interp-scheme env) e) ,t)]
975+
`(tagged ,((interp-scheme env) e) ,t)]
897976
[`(project ,e ,t2)
898977
(define v ((interp-scheme env) e))
899978
(match v
900-
[`(inject ,v1 ,t1)
979+
[`(tagged ,v1 ,t1)
901980
(cond [(equal? t1 t2)
902981
v1]
903982
[else
@@ -913,11 +992,11 @@
913992
(verbose "R6/interp-C" ast)
914993
(match ast
915994
[`(inject ,e ,t)
916-
`(inject ,((interp-C env) e) ,t)]
995+
`(tagged ,((interp-C env) e) ,t)]
917996
[`(project ,e ,t2)
918997
(define v ((interp-C env) e))
919998
(match v
920-
[`(inject ,v1 ,t1)
999+
[`(tagged ,v1 ,t1)
9211000
(cond [(equal? t1 t2)
9221001
v1]
9231002
[else

‎lambda.rkt

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -186,9 +186,9 @@
186186
("uniquify" ,(send compiler uniquify '())
187187
,(send interp interp-scheme '()))
188188
("reveal-functions" ,(send compiler reveal-functions '())
189-
,(send interp interp-scheme '()))
189+
,(send interp interp-F '()))
190190
("convert-to-closures" ,(send compiler convert-to-closures)
191-
,(send interp interp-scheme '()))
191+
,(send interp interp-F '()))
192192
("flatten" ,(send compiler flatten #f)
193193
,(send interp interp-C '()))
194194
("expose allocation"

‎tests/s1_21.rkt

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,3 @@
1-
(if (and (eq? (read) 0) (eq? (read) 0))
1+
(if (and (eq? (read) 0) (eq? (read) 1))
22
0
33
42)

‎utilities.rkt

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -245,11 +245,13 @@
245245
(match (car passes)
246246
[`(,pass-name ,pass ,interp)
247247
(let ([input p])
248-
(debug (string-append "running pass: " pass-name)
248+
(debug (string-append "running pass: " pass-name
249+
" on test: " test-name)
249250
input))
250251
(define new-p (pass p))
251252
(let ([output new-p])
252-
(trace (string-append "running pass: " pass-name)
253+
(trace (string-append "running pass: " pass-name
254+
" on test: " test-name)
253255
output))
254256
(cond [interp
255257
(let ([new-result

0 commit comments

Comments
 (0)