Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Add support for optional parameters to the universal backend
  • Loading branch information
feeley committed Feb 24, 2014
1 parent 182604e commit a3dd342
Show file tree
Hide file tree
Showing 4 changed files with 783 additions and 16 deletions.
97 changes: 83 additions & 14 deletions gsc/_t-univ.scm
Expand Up @@ -1586,20 +1586,7 @@
(^ (case (label-type gvm-instr)

((entry)
(^if (if (label-entry-rest? gvm-instr)
(^not (^call-prim
(^global-prim-function
(^prefix (univ-use-rtlib ctx 'build_rest)))
(- (label-entry-nb-parms gvm-instr) 1)))
(^!= (gvm-state-nargs-use ctx 'rd)
(label-entry-nb-parms gvm-instr)))
(univ-emit-return-call-prim
ctx
(^global-prim-function
(^prefix (univ-use-rtlib ctx 'wrong_nargs)))
(if (label-entry-closed? gvm-instr)
(^getreg (+ univ-nb-arg-regs 1))
id))))
(univ-label-entry ctx gvm-instr id))

(else
(^)))
Expand Down Expand Up @@ -1913,6 +1900,88 @@
(loop (cons (dump-proc (queue-get! proc-left))
rev-res))))))

(define (univ-label-entry ctx gvm-instr id)
(let* ((nb-parms (label-entry-nb-parms gvm-instr))
(opts (label-entry-opts gvm-instr))
(keys (label-entry-keys gvm-instr))
(rest? (label-entry-rest? gvm-instr))
(closed? (label-entry-closed? gvm-instr))
(nb-parms-except-rest
(- nb-parms (if rest? 1 0)))
(nb-keys
(if keys (length keys) 0))
(nb-req-and-opt
(- nb-parms-except-rest nb-keys))
(nb-opts
(length opts))
(nb-req
(- nb-req-and-opt nb-opts))
(defaults
(append opts (map cdr (or keys '())))))

(define (dispatch-on-nb-args nb-args)
(if (> nb-args (- nb-req-and-opt (if rest? 0 1)))

(if keys
(compiler-internal-error
"univ-label-entry, keyword parameters not supported")
(^if (if rest?
(^not (^call-prim
(^global-prim-function
(^prefix (univ-use-rtlib ctx 'build_rest)))
nb-parms-except-rest))
(^!= (gvm-state-nargs-use ctx 'rd)
nb-parms-except-rest))
(univ-emit-return-call-prim
ctx
(^global-prim-function
(^prefix (univ-use-rtlib ctx 'wrong_nargs)))
(if closed?
(^getreg (+ univ-nb-arg-regs 1))
id))))

(let ((nb-stacked (max 0 (- nb-args univ-nb-arg-regs)))
(nb-stacked* (max 0 (- nb-parms univ-nb-arg-regs))))

(define (setup-parameter i)
(if (<= i nb-parms)
(let* ((rest (setup-parameter (+ i 1)))
(src-reg (- i nb-stacked))
(src (cond ((<= i nb-args)
(^getreg src-reg))
((and rest? (= i nb-parms))
(^obj '()))
(else
(^obj
(obj-val (list-ref defaults (- i nb-req 1))))))))
(if (<= i nb-stacked*)
(^inc-by (begin
(gvm-state-sp-use ctx 'rd)
(gvm-state-sp-use ctx 'wr))
1
(lambda (x)
(^ (^expr-statement
(^assign
(^array-index
(gvm-state-stack-use ctx 'rd)
x)
src))
rest)))
(if (and (<= i nb-args) (= nb-stacked nb-stacked*))
rest
(let ((dst-reg (- i nb-stacked*)))
(^ (^setreg dst-reg src)
rest)))))
(^)))

(let ((x (setup-parameter (+ nb-stacked 1))))
(^if (^= (gvm-state-nargs-use ctx 'rd)
nb-args)
x
(dispatch-on-nb-args (+ nb-args 1)))))))

(dispatch-on-nb-args nb-req)))

(define closure-count 0)

#;
Expand Down
282 changes: 282 additions & 0 deletions gsc/tests/12-closure/opt1.scm
@@ -0,0 +1,282 @@
(declare (extended-bindings) (not constant-fold) (not safe))

(define (f00)
#f)

(define (f10 w)
(println w))

(define (f20 w x)
(println w)
(println x))

(define (f30 w x y)
(println w)
(println x)
(println y))

(define (f40 w x y z)
(println w)
(println x)
(println y)
(println z))

(define (f01 #!optional (a 11))
(println a))

(define (f11 w #!optional (a 11))
(println w)
(println a))

(define (f21 w x #!optional (a 11))
(println w)
(println x)
(println a))

(define (f31 w x y #!optional (a 11))
(println w)
(println x)
(println y)
(println a))

(define (f41 w x y z #!optional (a 11))
(println w)
(println x)
(println y)
(println z)
(println a))

(define (f02 #!optional (a 11) (b 22))
(println a)
(println b))

(define (f12 w #!optional (a 11) (b 22))
(println w)
(println a)
(println b))

(define (f22 w x #!optional (a 11) (b 22))
(println w)
(println x)
(println a)
(println b))

(define (f32 w x y #!optional (a 11) (b 22))
(println w)
(println x)
(println y)
(println a)
(println b))

(define (f42 w x y z #!optional (a 11) (b 22))
(println w)
(println x)
(println y)
(println z)
(println a)
(println b))

(define (f03 #!optional (a 11) (b 22) (c 33))
(println a)
(println b)
(println c))

(define (f13 w #!optional (a 11) (b 22) (c 33))
(println w)
(println a)
(println b)
(println c))

(define (f23 w x #!optional (a 11) (b 22) (c 33))
(println w)
(println x)
(println a)
(println b)
(println c))

(define (f33 w x y #!optional (a 11) (b 22) (c 33))
(println w)
(println x)
(println y)
(println a)
(println b)
(println c))

(define (f43 w x y z #!optional (a 11) (b 22) (c 33))
(println w)
(println x)
(println y)
(println z)
(println a)
(println b)
(println c))

(define (f04 #!optional (a 11) (b 22) (c 33) (d 44))
(println a)
(println b)
(println c)
(println d))

(define (f14 w #!optional (a 11) (b 22) (c 33) (d 44))
(println w)
(println a)
(println b)
(println c)
(println d))

(define (f24 w x #!optional (a 11) (b 22) (c 33) (d 44))
(println w)
(println x)
(println a)
(println b)
(println c)
(println d))

(define (f34 w x y #!optional (a 11) (b 22) (c 33) (d 44))
(println w)
(println x)
(println y)
(println a)
(println b)
(println c)
(println d))

(define (f44 w x y z #!optional (a 11) (b 22) (c 33) (d 44))
(println w)
(println x)
(println y)
(println z)
(println a)
(println b)
(println c)
(println d))


(println "f00")
(f00)

(println "f10")
(f10 1)

(println "f20")
(f20 1 2)

(println "f30")
(f30 1 2 3)

(println "f40")
(f40 1 2 3 4)


(println "f01")
(f01)
(f01 1)

(println "f11")
(f11 1)
(f11 1 2)

(println "f21")
(f21 1 2)
(f21 1 2 3)

(println "f31")
(f31 1 2 3)
(f31 1 2 3 4)

(println "f41")
(f41 1 2 3 4)
(f41 1 2 3 4 5)


(println "f02")
(f02)
(f02 1)
(f02 1 2)

(println "f12")
(f12 1)
(f12 1 2)
(f12 1 2 3)

(println "f22")
(f22 1 2)
(f22 1 2 3)
(f22 1 2 3 4)

(println "f32")
(f32 1 2 3)
(f32 1 2 3 4)
(f32 1 2 3 4 5)

(println "f42")
(f42 1 2 3 4)
(f42 1 2 3 4 5)
(f42 1 2 3 4 5 6)


(println "f03")
(f03)
(f03 1)
(f03 1 2)
(f03 1 2 3)

(println "f13")
(f13 1)
(f13 1 2)
(f13 1 2 3)
(f13 1 2 3 4)

(println "f23")
(f23 1 2)
(f23 1 2 3)
(f23 1 2 3 4)
(f23 1 2 3 4 5)

(println "f33")
(f33 1 2 3)
(f33 1 2 3 4)
(f33 1 2 3 4 5)
(f33 1 2 3 4 5 6)

(println "f43")
(f43 1 2 3 4)
(f43 1 2 3 4 5)
(f43 1 2 3 4 5 6)
(f43 1 2 3 4 5 6 7)


(println "f04")
(f04)
(f04 1)
(f04 1 2)
(f04 1 2 3)
(f04 1 2 3 4)

(println "f14")
(f14 1)
(f14 1 2)
(f14 1 2 3)
(f14 1 2 3 4)
(f14 1 2 3 4 5)

(println "f24")
(f24 1 2)
(f24 1 2 3)
(f24 1 2 3 4)
(f24 1 2 3 4 5)
(f24 1 2 3 4 5 6)

(println "f34")
(f34 1 2 3)
(f34 1 2 3 4)
(f34 1 2 3 4 5)
(f34 1 2 3 4 5 6)
(f34 1 2 3 4 5 6 7)

(println "f44")
(f44 1 2 3 4)
(f44 1 2 3 4 5)
(f44 1 2 3 4 5 6)
(f44 1 2 3 4 5 6 7)
(f44 1 2 3 4 5 6 7 8)

0 comments on commit a3dd342

Please sign in to comment.