module/language/cps/verify.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Commentary:
  20 ;;;
  21 ;;;
  22 ;;; Code:
  23
  24 (define-module (language cps verify)
  25   #:use-module (ice-9 match)
  26   #:use-module (srfi srfi-26)
  27   #:use-module (language cps)
  28   #:export (verify-cps))
  29
  30 (define (verify-cps fun)
  31   (define seen-gensyms (make-hash-table))
  32
  33   (define (add sym env)
  34     (if (hashq-ref seen-gensyms sym)
  35         (error "duplicate gensym" sym)
  36         (begin
  37           (hashq-set! seen-gensyms sym #t)
  38           (cons sym env))))
  39
  40   (define (add-env new env)
  41     (if (null? new)
  42         env
  43         (add-env (cdr new) (add (car new) env))))
  44
  45   (define (check-var sym env)
  46     (cond
  47      ((not (hashq-ref seen-gensyms sym))
  48       (error "unbound lexical" sym))
  49      ((not (memq sym env))
  50       (error "displaced lexical" sym))))
  51
  52   (define (check-src src)
  53     (if (and src (not (and (list? src) (and-map pair? src)
  54                            (and-map symbol? (map car src)))))
  55         (error "bad src")))
  56
  57   (define (visit-cont-body cont k-env v-env)
  58     (match cont
  59       (($ $kif kt kf)
  60        (check-var kt k-env)
  61        (check-var kf k-env))
  62       (($ $ktrunc ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k)
  63        (check-var k k-env))
  64       (($ $kargs ((? symbol? name) ...) ((? symbol? sym) ...) body)
  65        (unless (= (length name) (length sym))
  66          (error "name and sym lengths don't match" name sym))
  67        (visit-term body k-env (add-env sym v-env)))
  68       (_
  69        ;; $kclause, $kentry, and $ktail are only ever seen in $fun.
  70        (error "unexpected cont body" cont))))
  71
  72   (define (visit-clause clause k-env v-env)
  73     (match clause
  74       (($ $cont kclause src*
  75           ($ $kclause
  76              ($ $arity
  77                 ((? symbol? req) ...)
  78                 ((? symbol? opt) ...)
  79                 (and rest (or #f (? symbol?)))
  80                 (((? keyword? kw) (? symbol? kwname) (? symbol? kwsym)) ...)
  81                 (or #f #t))
  82              ($ $cont kbody src (and body ($ $kargs names syms _)))))
  83        (check-src src*)
  84        (check-src src)
  85        (for-each (lambda (sym)
  86                    (unless (memq sym syms)
  87                      (error "bad keyword sym" sym)))
  88                  kwsym)
  89        ;; FIXME: It is technically possible for kw syms to alias other
  90        ;; syms.
  91        (unless (equal? (append req opt (if rest (list rest) '()) kwname)
  92                        names)
  93          (error "clause body names do not match arity names" exp))
  94        (let ((k-env (add-env (list kclause kbody) k-env)))
  95          (visit-cont-body body k-env v-env)))
  96       (_
  97        (error "unexpected clause" clause))))
  98
  99   (define (visit-fun fun k-env v-env)
 100     (match fun
 101       (($ $fun meta ((? symbol? free) ...)
 102           ($ $cont kbody src
 103              ($ $kentry (? symbol? self) ($ $cont ktail _ ($ $ktail)) clauses)))
 104        (when (and meta (not (and (list? meta) (and-map pair? meta))))
 105          (error "meta should be alist" meta))
 106        (for-each (cut check-var <> v-env) free)
 107        (check-src src)
 108        ;; Reset the continuation environment, because Guile's
 109        ;; continuations are local.
 110        (let ((v-env (add-env (list self) v-env))
 111              (k-env (add-env (list ktail) '())))
 112          (for-each (cut visit-clause <> k-env v-env) clauses)))
 113       (_
 114        (error "unexpected $fun" fun))))
 115
 116   (define (visit-expression exp k-env v-env)
 117     (match exp
 118       (($ $var sym)
 119        (check-var sym v-env))
 120       (($ $void)
 121        #t)
 122       (($ $const val)
 123        #t)
 124       (($ $prim (? symbol? name))
 125        #t)
 126       (($ $fun)
 127        (visit-fun exp k-env v-env))
 128       (($ $call (? symbol? proc) ((? symbol? arg) ...))
 129        (check-var proc v-env)
 130        (for-each (cut check-var <> v-env) arg))
 131       (($ $primcall (? symbol? name) ((? symbol? arg) ...))
 132        (for-each (cut check-var <> v-env) arg))
 133       (($ $values ((? symbol? arg) ...))
 134        (for-each (cut check-var <> v-env) arg))
 135       (($ $prompt escape? tag handler)
 136        (unless (boolean? escape?) (error "escape? should be boolean" escape?))
 137        (check-var tag v-env)
 138        (check-var handler k-env))
 139       (_
 140        (error "unexpected expression" exp))))
 141
 142   (define (visit-term term k-env v-env)
 143     (match term
 144       (($ $letk (($ $cont (? symbol? k) src cont) ...) body)
 145        (let ((k-env (add-env k k-env)))
 146          (for-each check-src src)
 147          (for-each (cut visit-cont-body <> k-env v-env) cont)
 148          (visit-term body k-env v-env)))
 149
 150       (($ $letrec ((? symbol? name) ...) ((? symbol? sym) ...) (fun ...) body)
 151        (unless (= (length name) (length sym) (length fun))
 152          (error "letrec syms, names, and funs not same length" term))
 153        (let ((v-env (add-env sym v-env)))
 154          (for-each (cut visit-fun <> k-env v-env) fun)
 155          (visit-term body k-env v-env)))
 156
 157       (($ $continue k exp)
 158        (check-var k k-env)
 159        (visit-expression exp k-env v-env))
 160
 161       (_
 162        (error "unexpected term" term))))
 163
 164   (visit-fun fun '() '())
 165   fun)