aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/csc/cps-test.csc192
-rw-r--r--lib/csc/cps.csc148
-rw-r--r--lib/csc/ir1.csc7
-rw-r--r--lib/csc/macros-test.csc37
-rw-r--r--lib/csc/macros.csc32
5 files changed, 87 insertions, 329 deletions
diff --git a/lib/csc/cps-test.csc b/lib/csc/cps-test.csc
index ab92646..8bef0aa 100644
--- a/lib/csc/cps-test.csc
+++ b/lib/csc/cps-test.csc
@@ -139,18 +139,9 @@
(list
(make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
(make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))
- (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '()
- (make-primitive 'poke (list (make-constant 2) (test-ref 'generated-symbol) (make-constant 1)) '()
- (make-primitive 'poke (list (make-constant 10) (test-ref 'generated-symbol) (make-constant 2)) '()
- (make-primitive 'poke (list (make-constant 20) (test-ref 'generated-symbol) (make-constant 3)) '()
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))
- (make-primitive 'alloc (list (make-constant 4)) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))
+ (make-primitive 'cons (list (make-constant 20) (make-constant '())) (list (test-ref 'generated-symbol))
+ (make-primitive 'cons (list (make-constant 10) (test-ref 'generated-symbol)) (list (test-ref 'generated-symbol))
+ (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))
(ir1->ir2 (make-call (test-ref 'f) (list (make-constant 10) (make-constant 20)))
tail)
transform-ir2))
@@ -199,49 +190,13 @@
transform-ir2))
- ; It's pretty bad
- (test closure-rest
+ (test closure
(assert-equal
(make-fix
- (list (make-closure (test-ref 'generated-symbol)
- (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))
- (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol))
- (make-primitive 'lt (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol))
- (make-fix (list (make-closure (test-ref 'generated-symbol)
- (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-branch (test-ref 'generated-symbol)
- (make-fix (list (make-closure (test-ref 'generated-symbol)
- (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol)
- (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))
- (make-fix (list (make-closure (test-ref 'generated-symbol)
- (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'c))
- (make-apply (test-ref 'generated-symbol) (list (make-constant 5)))))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))
- (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '()
- (make-primitive 'poke (list (make-constant 2) (test-ref 'generated-symbol) (make-constant 1)) '()
- (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'generated-symbol) (make-constant 2)) '()
- (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 3)) '()
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-primitive 'peek (list *globals* (make-library-ref 'vector->list '(csc based))) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))))
- (make-primitive 'alloc (list (make-constant 4)) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))))))
+ (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'c))
+ (make-apply (test-ref 'generated-symbol) (list (make-constant 5)))))
(make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))
(ir1->ir2 (make-lambda
- '()
(test-ref 'c)
(make-constant 5))
tail)
@@ -254,44 +209,17 @@
(assert-equal
(make-fix
(list
- (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))
- (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol))
- (make-primitive 'eq (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-branch (test-ref 'generated-symbol)
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'x))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'x)))))
- (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 2)) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))))
+ (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'x))
+ (make-apply (test-ref 'generated-symbol) (list (test-ref 'x)))))
(make-fix
(list
(make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
(make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))
- (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '()
- (make-primitive 'poke (list (make-constant 1) (test-ref 'generated-symbol) (make-constant 1)) '()
- (make-primitive 'poke (list (make-constant 10) (test-ref 'generated-symbol) (make-constant 2)) '()
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))
- (make-primitive 'alloc (list (make-constant 3)) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))
+ (make-primitive 'cons (list (make-constant 10) (make-constant '())) (list (test-ref 'generated-symbol))
+ (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))
(ir1->ir2
(make-letrec #f '(f) (list f)
- (list (make-lambda (list x) #f x))
+ (list (make-lambda x x))
(make-call (make-lexical-ref 'f f) (list (make-constant 10))))
tail)
transform-ir2))
@@ -320,25 +248,15 @@
(test letrec-in-order-function
(assert-equal
(make-fix
- (list (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))
- (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol))
- (make-primitive 'eq (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-branch (test-ref 'generated-symbol)
- (make-apply (test-ref 'generated-symbol) (list (make-constant 5)))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))))
+ (list
+ (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'args))
+ (make-apply (test-ref 'generated-symbol) (list (make-constant 5)))))
(make-apply (test-ref 'tail) (list (make-constant 10))))
(ir1->ir2
(make-letrec #t
'(f)
(list (gensym))
- (list (make-lambda '() #f (make-constant 5)))
+ (list (make-lambda (test-ref 'args) (make-constant 5)))
(make-constant 10))
tail)
transform-ir2))
@@ -355,41 +273,21 @@
(make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'x))
(make-fix
(list
- (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))
- (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol))
- (make-primitive 'eq (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-branch (test-ref 'generated-symbol)
- (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))))
+ (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'args))
+ (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol))
+ (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))))
(make-fix
(list
(make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
(make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'x) (make-constant 0)) '()
(make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol))
(make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))))))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))
- (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '()
- (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 1)) '()
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))
- (make-primitive 'alloc (list (make-constant 2)) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))
+ (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (make-constant '()))))))
(ir1->ir2
(make-letrec #t
'(f x)
(list f x)
- (list (make-lambda '() #f (make-lexical-ref 'x x))
+ (list (make-lambda (test-ref 'args) (make-lexical-ref 'x x))
(make-call (make-lexical-ref 'f f) '()))
(make-lexical-ref 'x x))
tail)
@@ -401,37 +299,18 @@
(assert-equal
(make-fix
(list
- (make-closure (test-ref 'f) (list (test-ref 'generated-symbol)
- (test-ref 'generated-symbol))
- (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol))
- (make-primitive 'eq (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-branch (test-ref 'generated-symbol)
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))
- (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'x))
- (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'x) (make-constant 0)) '()
- (make-primitive 'poke (list (make-constant 10) (test-ref 'x) (make-constant 0)) '()
- (make-apply (test-ref 'generated-symbol) (list (make-constant #f))))))))
- (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 2)) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))))
+ (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))
+ (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'args))
+ (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'args) (make-constant 0)) '()
+ (make-primitive 'poke (list (make-constant 10) (test-ref 'args) (make-constant 0)) '()
+ (make-apply (test-ref 'generated-symbol) (list (make-constant #f))))))))
(make-apply (test-ref 'tail) (list (make-constant 5))))
(ir1->ir2 (make-letrec
#f
'(f)
(list (gensym))
- (list (make-lambda (list (make-lexical-ref 'x test-sym)) #f
- (make-lexical-set (make-lexical-ref 'x test-sym) (make-constant 10))))
+ (list (make-lambda (make-lexical-ref 'args test-sym)
+ (make-lexical-set (make-lexical-ref 'args test-sym) (make-constant 10))))
(make-constant 5))
tail)
transform-ir2))
@@ -441,19 +320,8 @@
(assert-equal
(make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'f))
(make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))
- (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol))
- (make-primitive 'eq (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-branch (test-ref 'generated-symbol)
- (make-apply (test-ref 'generated-symbol) (list (make-constant 10)))
- (make-fix
- (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
- (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol))
- (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))))
+ (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'args))
+ (make-apply (test-ref 'generated-symbol) (list (make-constant 10)))))
(make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'f) (make-constant 0)) '()
(make-primitive 'poke (list (make-constant 5) (test-ref 'f) (make-constant 0)) '()
(make-apply (test-ref 'tail) (list (make-constant #f)))))))
@@ -461,7 +329,7 @@
#f
'(f)
(list test-sym)
- (list (make-lambda '() #f (make-constant 10)))
+ (list (make-lambda (test-ref 'args) (make-constant 10)))
(make-lexical-set (make-lexical-ref 'f test-sym) (make-constant 5)))
tail)
transform-ir2))
diff --git a/lib/csc/cps.csc b/lib/csc/cps.csc
index ca6dbf4..1b8df9d 100644
--- a/lib/csc/cps.csc
+++ b/lib/csc/cps.csc
@@ -86,87 +86,6 @@
(make-lexical-ref 'generated-symbol (gensym)))
- ; Converts an IR1 expression to an equivalent expression where every
- ; procedure takes exactly one argument.
- (define (argument-conversion expr)
- (match expr
- (_ when (or (constant? expr)
- (lexical-ref? expr)
- (library-ref? expr))
- expr)
- ((% %lexical-set ref arg)
- (make-lexical-set ref (argument-conversion arg)))
- ((% %library-define ref arg)
- (make-library-define ref (argument-conversion arg)))
- ((% %define-syntax _ _) expr)
- ((% %if test consequent alternate)
- (make-if
- (argument-conversion test)
- (argument-conversion consequent)
- (argument-conversion alternate)))
- ((% %call proc args)
- (define argvec (new-ref))
- (define nargs (length args))
- (make-call
- (make-lambda (list argvec) #f
- (make-sequence
- (loop for arg in args
- for i from 2
- with expr = (make-sequence
- (make-call-builtin 'poke (list (make-constant 0) argvec (make-constant 0)))
- (make-call-builtin 'poke (list (make-constant nargs) argvec (make-constant 1))))
- do (set! expr (make-sequence
- expr
- (make-call-builtin 'poke (list (argument-conversion arg) argvec (make-constant i)))))
- finally (return expr))
- (make-call (argument-conversion proc) (list argvec))))
- (list (make-call-builtin 'alloc (list (make-constant (+ 2 nargs)))))))
- ((% %call-builtin op args)
- (make-call-builtin op (map argument-conversion args)))
- ((% %sequence head tail)
- (make-sequence
- (argument-conversion head)
- (argument-conversion tail)))
- ((% %lambda args rest body) when rest
- (define argvec (new-ref))
- (define nargs (length args))
- (make-lambda (list argvec) #f
- (make-if (make-call-builtin 'lt (list (make-call-builtin 'peek (list argvec (make-constant 1)))
- (make-constant nargs)))
- (make-call (make-library-ref 'wrong-number-of-arguments '(csc based)) (list argvec))
- (loop for arg in (reverse args)
- for i downfrom (+ 1 nargs)
- with expr = (make-call (make-lambda (list rest) #f
- (argument-conversion body))
- (list
- (argument-conversion
- (make-call (make-library-ref 'vector->list '(csc based))
- (list argvec (make-constant nargs))))))
- ; I'm relying on beta reduction here.
- do (set! expr (make-call (make-lambda (list arg) #f
- expr)
- (list (make-call-builtin 'peek (list argvec (make-constant i))))))
- finally (return expr)))))
- ((% %lambda args _ body)
- (define argvec (new-ref))
- (define nargs (length args))
- (make-lambda (list argvec) #f
- (make-if (make-call-builtin 'eq (list (make-call-builtin 'peek (list argvec (make-constant 1)))
- (make-constant nargs)))
- (loop for arg in (reverse args)
- for i downfrom (+ 1 nargs)
- with expr = (argument-conversion body)
- do (set! expr (make-call (make-lambda (list arg) #f
- expr)
- (list
- (make-call-builtin 'peek (list argvec (make-constant i))))))
- finally (return expr))
- (make-call (make-library-ref 'wrong-number-of-arguments '(csc based)) (list argvec)))))
- ((% %letrec in-order? names gensyms exprs body)
- (make-letrec in-order? names gensyms (map argument-conversion exprs) (argument-conversion body)))
- (_ (error "Unexpected form in argument-conversion" expr))))
-
-
; Update is a CPS expression that is used internally as part of
; CPS conversion.
; Update expressions are then removed by box-conversion.
@@ -188,11 +107,11 @@
for value in vals
if (lambda? value)
collect (match value
- ((% %lambda args _ body)
+ ((% %lambda args body)
(define continuation (new-ref))
(make-closure
(make-lexical-ref name gensym)
- (cons continuation args)
+ (list continuation args)
(to-cps
body
(lambda (z)
@@ -249,7 +168,7 @@
alternate
(lambda (result)
(make-apply continuation-ref (list result)))))))))
- ((% %call proc (arg))
+ ((% %call proc args)
(define return-address (new-ref))
(define result (new-ref))
(make-fix
@@ -258,29 +177,32 @@
proc
(lambda (f)
(to-cps
- arg
+ (loop for arg in (reverse args)
+ with arglist = (make-constant '())
+ do (set! arglist (make-call-builtin 'cons (list arg arglist)))
+ finally (return arglist))
(lambda (v)
(make-apply f (list return-address v))))))))
((% %call-builtin 'call-with-current-continuation (proc))
(define return-address (new-ref))
- (define result (new-ref))
- (define argvec (new-ref))
+ (define current-continuation (new-ref))
+ (define result1 (new-ref))
+ (define result2 (new-ref))
+ (define arglist (new-ref))
(make-fix
- (list (make-closure return-address (list result)
- (continuation result)))
- (make-primitive 'alloc (list (make-constant 3)) (list argvec)
- (make-primitive 'poke (list (make-constant 0) argvec (make-constant 0)) '()
- (make-primitive 'poke (list (make-constant 1) argvec (make-constant 1)) '()
- (make-primitive 'poke (list return-address argvec (make-constant 2)) '()
- (to-cps proc
- (lambda (f)
- (make-apply f (list return-address argvec))))))))))
+ (list (make-closure return-address (list result1)
+ (continuation result1))
+ (make-closure current-continuation (list k-unused result2)
+ (make-apply return-address (list result2))))
+ (make-primitive 'cons (list current-continuation (make-constant '())) (list arglist)
+ (to-cps proc
+ (lambda (f)
+ (make-apply f (list return-address arglist)))))))
((% %call-builtin 'call-with-values (producer consumer))
(define return-address (new-ref))
(define consumer-func (new-ref))
(define result (new-ref))
(define results (new-ref))
- (define argvec (new-ref))
(make-fix
(list (make-closure return-address (list result)
(continuation result))
@@ -288,14 +210,21 @@
(to-cps consumer
(lambda (c)
(make-apply c (list return-address results))))))
- (make-primitive 'alloc (list (make-constant 2)) (list argvec)
- (make-primitive 'poke (list (make-constant 0) argvec (make-constant 0)) '()
- (make-primitive 'poke (list (make-constant 0) argvec (make-constant 1)) '()
- (to-cps producer
- (lambda (p)
- (make-apply p (list consumer-func argvec)))))))))
+ (to-cps producer
+ (lambda (p)
+ (make-apply p (list consumer-func (make-constant '())))))))
((% %call-builtin 'apply (proc args))
- (to-cps (make-call proc (list args)) continuation))
+ (define return-address (new-ref))
+ (define result (new-ref))
+ (make-fix
+ (list (make-closure return-address (list result) (continuation result)))
+ (to-cps
+ proc
+ (lambda (f)
+ (to-cps
+ args
+ (lambda (l)
+ (make-apply f (list return-address l))))))))
((% %call-builtin op args)
(define returns-value? (not (memq op '(poke exit))))
(loop for arg in (reverse args)
@@ -320,12 +249,12 @@
(to-cps
tail
continuation))))
- ((% %lambda (arg) _ body)
+ ((% %lambda args body)
(define f (new-ref))
(define k (new-ref))
(make-fix
(list
- (make-closure f (list k arg)
+ (make-closure f (list k args)
(to-cps
body
(lambda (ret)
@@ -384,7 +313,8 @@
((% %fix funs body)
(loop with m = (get-boxed body)
for fun in funs
- do (set! m (merge m (get-boxed (closure-body fun))))
+ do (set! m (merge m (get-boxed
+ (closure-body fun))))
finally (return m)))
(_ (error "Unexpected form in get-boxed" expr))))
@@ -477,9 +407,7 @@
(define (ir1->ir2 expr continuation)
(box-conversion
- (to-cps
- (argument-conversion expr)
- continuation)))
+ (to-cps expr continuation)))
(define (hoist expr)
diff --git a/lib/csc/ir1.csc b/lib/csc/ir1.csc
index 5cc0bf0..c88123e 100644
--- a/lib/csc/ir1.csc
+++ b/lib/csc/ir1.csc
@@ -29,7 +29,6 @@
if?
lambda-arguments
lambda-body
- lambda-rest
lambda?
letrec-expression
letrec-gensyms
@@ -192,14 +191,12 @@
; <lambda> body
- ; A closure. Arguments is a list of lexical-refs.
- ; Rest is a lexical ref or #f if the lambda doesn't take a rest parameter.
+ ; A closure. Arguments is a lexical-ref.
(define-match-record-type <lambda>
- (make-lambda arguments rest body)
+ (make-lambda arguments body)
lambda?
%lambda
(arguments lambda-arguments)
- (rest lambda-rest)
(body lambda-body))
diff --git a/lib/csc/macros-test.csc b/lib/csc/macros-test.csc
index be573cb..ee4e295 100644
--- a/lib/csc/macros-test.csc
+++ b/lib/csc/macros-test.csc
@@ -242,12 +242,12 @@
(test builtin-syntax-rules-define
(assert-equal
(make-library-define (make-library-ref 'exit 'main)
- (make-lambda '() #f (make-sequence (make-constant #f) (make-call-builtin 'exit (list (make-library-ref 'code 'main))))))
+ (make-lambda (test-ref 'args) (make-sequence (make-constant #f) (make-call-builtin 'exit (list (make-library-ref 'code 'main))))))
(expand-body 'main
'((let-syntax
(define
(syntax-rules ()
- ((define (f . args) body ...)
+ ((define (f) body ...)
(builtin-define f (lambda args body ...)))))
(define (exit)
(call-builtin exit code))))
@@ -259,40 +259,25 @@
(make-lexical-ref sym (gensym)))
- (test builtin-lambda-rest
- (assert-equal
- (make-lambda (list
- (test-ref 'a)
- (test-ref 'b)
- (test-ref 'c))
- (test-ref 'd)
- (make-sequence (make-constant #f) (make-constant 5)))
- (expand-body 'main
- '((lambda
- (a b c . d) (quote 5)))
- builtins-environment)
- transform-ir1))
-
-
(test builtin-lambda-ref
(assert-equal
- (make-lambda (list (test-ref 'x)) #f
- (make-sequence (make-constant #f) (test-ref 'x)))
+ (make-lambda (test-ref 'args)
+ (make-sequence (make-constant #f) (test-ref 'args)))
(expand-body 'main
- '((lambda (x) x))
+ '((lambda args args))
builtins-environment)
transform-ir1))
(test builtin-case-lambda-defines
(assert-equal
- (make-lambda (list (test-ref 'x)) #f
+ (make-lambda (test-ref 'args)
(make-letrec #t '(a b) (list (gensym) (gensym))
(list (make-constant 6)
(test-ref 'a))
(make-sequence (make-constant #f) (make-constant 7))))
(expand-body 'main
- '((lambda (x)
+ '((lambda args
(builtin-define a (quote 6))
(builtin-define b a)
(quote 7)))
@@ -325,13 +310,13 @@
(test builtin-lexical-set
(assert-equal
- (make-lambda (list (test-ref 'x)) #f
+ (make-lambda (test-ref 'args)
(make-sequence
(make-constant #f)
- (make-lexical-set (test-ref 'x) (make-constant 5))))
+ (make-lexical-set (test-ref 'args) (make-constant 5))))
(expand-body 'main
- '((lambda (x)
- (set! x 5)))
+ '((lambda args
+ (set! args 5)))
builtins-environment)
transform-ir1))
diff --git a/lib/csc/macros.csc b/lib/csc/macros.csc
index 6278142..cf4549f 100644
--- a/lib/csc/macros.csc
+++ b/lib/csc/macros.csc
@@ -666,18 +666,6 @@
(_ (raise-syntax-error "unexpected form in let-syntax" (clean-syntax x)))))))
- (define (split-args-rest formals)
- (syntax-case formals
- ('()
- (values '() #f))
- ((var . vars) when (identifier? var)
- (let-values (((args rest) (split-args-rest vars)))
- (values (cons (identifier-name var) args) rest)))
- (var when (identifier? var)
- (values '() (identifier-name var)))
- (_ (raise-syntax-error "unexpected form in split-args-rest" (clean-syntax formals)))))
-
-
(define (expand-lambda-body-rest body env)
(let loop ((body body)
(expanded-body (make-constant #f)))
@@ -731,20 +719,12 @@
(make-macro-transformer
(lambda (x env)
(syntax-case x
- ((_ formals . body)
- (let-values (((args rest) (split-args-rest formals)))
- (define refs (map (lambda (name)
- (make-lexical-ref name (gensym)))
- args))
- (loop for ref in refs
- do (set! env (add-binding (lexical-ref-name ref) ref env)))
- (make-lambda
- refs
- (if rest
- (make-lexical-ref rest (gensym))
- #f)
- (expand-lambda-body body env))))
- (_ (raise-syntax-error "unexpected form in lambda" x))))))
+ ((_ args . body) when (identifier? args)
+ (define ref (make-lexical-ref (identifier-name args) (gensym)))
+ (set! env (add-binding args ref env))
+ (make-lambda
+ ref
+ (expand-lambda-body body env)))))))
(define builtin-define
generated by cgit v1.3.1 (git 2.54.0) at 2026-09-04 15:30:09 +0000