X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/cb8aaef4d08989aea2b7f088d298f71a03ecc1b2..a9ec16f9c5574d80f66c173b495285579f5894b4:/module/language/cps/verify.scm

diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 9da5037ba..e005594d3 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -28,27 +28,43 @@
   #:export (verify-cps))
 
 (define (verify-cps fun)
-  (define seen-gensyms (make-hash-table))
+  (define seen-labels (make-hash-table))
+  (define seen-vars (make-hash-table))
 
-  (define (add sym env)
-    (if (hashq-ref seen-gensyms sym)
-        (error "duplicate gensym" sym)
-        (begin
-          (hashq-set! seen-gensyms sym #t)
-          (cons sym env))))
+  (define (add sym seen env)
+    (when (hashq-ref seen sym)
+      (error "duplicate gensym" sym))
+    (hashq-set! seen sym #t)
+    (cons sym env))
 
-  (define (add-env new env)
+  (define (add-env new seen env)
     (if (null? new)
         env
-        (add-env (cdr new) (add (car new) env))))
+        (add-env (cdr new) seen (add (car new) seen env))))
 
-  (define (check-var sym env)
+  (define (add-vars new env)
+    (unless (and-map exact-integer? new)
+      (error "bad vars" new))
+    (add-env new seen-vars env))
+
+  (define (add-labels new env)
+    (unless (and-map exact-integer? new)
+      (error "bad labels" new))
+    (add-env new seen-labels env))
+
+  (define (check-ref sym seen env)
     (cond
-     ((not (hashq-ref seen-gensyms sym))
+     ((not (hashq-ref seen sym))
       (error "unbound lexical" sym))
      ((not (memq sym env))
       (error "displaced lexical" sym))))
 
+  (define (check-label sym env)
+    (check-ref sym seen-labels env))
+
+  (define (check-var sym env)
+    (check-ref sym seen-vars env))
+
   (define (check-src src)
     (if (and src (not (and (list? src) (and-map pair? src)
                            (and-map symbol? (map car src)))))
@@ -56,17 +72,14 @@
 
   (define (visit-cont-body cont k-env v-env)
     (match cont
-      (($ $kif kt kf)
-       (check-var kt k-env)
-       (check-var kf k-env))
       (($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k)
-       (check-var k k-env))
-      (($ $kargs ((? symbol? name) ...) ((? symbol? sym) ...) body)
+       (check-label k k-env))
+      (($ $kargs (name ...) (sym ...) body)
        (unless (= (length name) (length sym))
          (error "name and sym lengths don't match" name sym))
-       (visit-term body k-env (add-env sym v-env)))
+       (visit-term body k-env (add-vars sym v-env)))
       (_ 
-       ;; $kclause, $kentry, and $ktail are only ever seen in $fun.
+       ;; $kclause, $kfun, and $ktail are only ever seen in $fun.
        (error "unexpected cont body" cont))))
 
   (define (visit-clause clause k-env v-env)
@@ -77,9 +90,10 @@
                 ((? symbol? req) ...)
                 ((? symbol? opt) ...)
                 (and rest (or #f (? symbol?)))
-                (((? keyword? kw) (? symbol? kwname) (? symbol? kwsym)) ...)
+                (((? keyword? kw) (? symbol? kwname) kwsym) ...)
                 (or #f #t))
-             ($ $cont kbody (and body ($ $kargs names syms _)))))
+             ($ $cont kbody (and body ($ $kargs names syms _)))
+             alternate))
        (for-each (lambda (sym)
                    (unless (memq sym syms)
                      (error "bad keyword sym" sym)))
@@ -89,73 +103,94 @@
        (unless (equal? (append req opt (if rest (list rest) '()) kwname)
                        names)
          (error "clause body names do not match arity names" exp))
-       (let ((k-env (add-env (list kclause kbody) k-env)))
-         (visit-cont-body body k-env v-env)))
+       (let ((k-env (add-labels (list kclause kbody) k-env)))
+         (visit-cont-body body k-env v-env))
+       (when alternate
+         (visit-clause alternate k-env v-env)))
       (_
        (error "unexpected clause" clause))))
 
-  (define (visit-fun fun k-env v-env)
-    (match fun
-      (($ $fun src meta ((? symbol? free) ...)
-          ($ $cont kbody
-             ($ $kentry (? symbol? self) ($ $cont ktail ($ $ktail)) clauses)))
+  (define (visit-entry entry k-env v-env)
+    (match entry
+      (($ $cont kbody
+          ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
        (when (and meta (not (and (list? meta) (and-map pair? meta))))
          (error "meta should be alist" meta))
-       (for-each (cut check-var <> v-env) free)
        (check-src src)
        ;; Reset the continuation environment, because Guile's
        ;; continuations are local.
-       (let ((v-env (add-env (list self) v-env))
-             (k-env (add-env (list ktail) '())))
-         (for-each (cut visit-clause <> k-env v-env) clauses)))
+       (let ((v-env (add-vars (list self) v-env))
+             (k-env (add-labels (list ktail) '())))
+         (when clause
+           (visit-clause clause k-env v-env))))
+      (_ (error "unexpected $kfun" entry))))
+
+  (define (visit-fun fun k-env v-env)
+    (match fun
+      (($ $fun (free ...) entry)
+       (for-each (cut check-var <> v-env) free)
+       (visit-entry entry '() v-env))
       (_
        (error "unexpected $fun" fun))))
 
   (define (visit-expression exp k-env v-env)
     (match exp
-      (($ $void)
-       #t)
       (($ $const val)
        #t)
       (($ $prim (? symbol? name))
        #t)
+      (($ $closure kfun n)
+       #t)
       (($ $fun)
        (visit-fun exp k-env v-env))
-      (($ $call (? symbol? proc) ((? symbol? arg) ...))
+      (($ $call proc (arg ...))
        (check-var proc v-env)
        (for-each (cut check-var <> v-env) arg))
-      (($ $primcall (? symbol? name) ((? symbol? arg) ...))
+      (($ $callk k* proc (arg ...))
+       ;; We don't check that k* is in scope; it's actually inside some
+       ;; other function, probably.  We rely on the transformation that
+       ;; introduces the $callk to be correct, and the linker to resolve
+       ;; the reference.
+       (check-var proc v-env)
+       (for-each (cut check-var <> v-env) arg))
+      (($ $branch kt ($ $primcall (? symbol? name) (arg ...)))
+       (check-var kt k-env)
+       (for-each (cut check-var <> v-env) arg))
+      (($ $branch kt ($ $values (arg ...)))
+       (check-var kt k-env)
+       (for-each (cut check-var <> v-env) arg))
+      (($ $primcall (? symbol? name) (arg ...))
        (for-each (cut check-var <> v-env) arg))
-      (($ $values ((? symbol? arg) ...))
+      (($ $values (arg ...))
        (for-each (cut check-var <> v-env) arg))
       (($ $prompt escape? tag handler)
        (unless (boolean? escape?) (error "escape? should be boolean" escape?))
        (check-var tag v-env)
-       (check-var handler k-env))
+       (check-label handler k-env))
       (_
        (error "unexpected expression" exp))))
 
   (define (visit-term term k-env v-env)
     (match term
-      (($ $letk (($ $cont (? symbol? k) cont) ...) body)
-       (let ((k-env (add-env k k-env)))
+      (($ $letk (($ $cont k cont) ...) body)
+       (let ((k-env (add-labels k k-env)))
          (for-each (cut visit-cont-body <> k-env v-env) cont)
          (visit-term body k-env v-env)))
 
-      (($ $letrec ((? symbol? name) ...) ((? symbol? sym) ...) (fun ...) body)
+      (($ $letrec (name ...) (sym ...) (fun ...) body)
        (unless (= (length name) (length sym) (length fun))
          (error "letrec syms, names, and funs not same length" term))
-       (let ((v-env (add-env sym v-env)))
+       (let ((v-env (add-vars sym v-env)))
          (for-each (cut visit-fun <> k-env v-env) fun)
          (visit-term body k-env v-env)))
 
       (($ $continue k src exp)
-       (check-var k k-env)
+       (check-label k k-env)
        (check-src src)
        (visit-expression exp k-env v-env))
 
       (_
        (error "unexpected term" term))))
 
-  (visit-fun fun '() '())
+  (visit-entry fun '() '())
   fun)