module/language/tree-il/debug.scm

   1 ;;; Tree-IL verifier
   2
   3 ;; Copyright (C) 2011, 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 (define-module (language tree-il debug)
  20   #:use-module (language tree-il)
  21   #:use-module (ice-9 match)
  22   #:use-module (srfi srfi-1)
  23   #:use-module (srfi srfi-26)
  24   #:export (verify-tree-il))
  25
  26 (define (verify-tree-il exp)
  27   (define seen-gensyms (make-hash-table))
  28   (define (add sym env)
  29     (if (hashq-ref seen-gensyms sym)
  30         (error "duplicate gensym" sym)
  31         (begin
  32           (hashq-set! seen-gensyms sym #t)
  33           (cons sym env))))
  34   (define (add-env new env)
  35     (if (null? new)
  36         env
  37         (add-env (cdr new) (add (car new) env))))
  38
  39   (let visit ((exp exp)
  40               (env '()))
  41     (match exp
  42       (($ <lambda-case> src req opt rest kw inits gensyms body alt)
  43        (cond
  44         ((not (and (list? req) (and-map symbol? req)))
  45          (error "bad required args (should be list of symbols)" exp))
  46         ((and opt (not (and (list? opt) (and-map symbol? opt))))
  47          (error "bad optionals (should be #f or list of symbols)" exp))
  48         ((and rest (not (symbol? rest)))
  49          (error "bad required args (should be #f or symbol)" exp))
  50         ((and kw (not (match kw
  51                         ((aok . kwlist)
  52                          (and (list? kwlist)
  53                               (and-map
  54                                (lambda (x)
  55                                  (match x
  56                                    (((? keyword?) (? symbol?) (? symbol? sym))
  57                                     (memq sym gensyms))
  58                                    (_ #f)))
  59                                kwlist)))
  60                         (_ #f))))
  61          (error "bad keywords (should be #f or (aok (kw name sym) ...))" exp))
  62         ((not (and (list? gensyms) (and-map symbol? gensyms)))
  63          (error "bad gensyms (should be list of symbols)" exp))
  64         ((not (and (list? gensyms) (and-map symbol? gensyms)))
  65          (error "bad gensyms (should be list of symbols)" exp))
  66         ((not (= (length gensyms)
  67                  (+ (length req)
  68                     (if opt (length opt) 0)
  69                     ;; FIXME: technically possible for kw gensyms to
  70                     ;; alias other gensyms
  71                     (if rest 1 0)
  72                     (if kw (1- (length kw)) 0))))
  73          (error "unexpected gensyms length" exp))
  74         (else
  75          (let lp ((env (add-env (take gensyms (length req)) env))
  76                   (nopt (if opt (length opt) 0))
  77                   (inits inits)
  78                   (tail (drop gensyms (length req))))
  79            (if (zero? nopt)
  80                (let lp ((env (if rest (add (car tail) env) env))
  81                         (inits inits)
  82                         (tail (if rest (cdr tail) tail)))
  83                  (if (pair? inits)
  84                      (begin
  85                        (visit (car inits) env)
  86                        (lp (add (car tail) env) (cdr inits)
  87                            (cdr tail)))
  88                      (visit body env)))
  89                (begin
  90                  (visit (car inits) env)
  91                  (lp (add (car tail) env)
  92                      (1- nopt)
  93                      (cdr inits)
  94                      (cdr tail)))))
  95          (if alt (visit alt env)))))
  96       (($ <lexical-ref> src name gensym)
  97        (cond
  98         ((not (symbol? name))
  99          (error "name should be a symbol" name))
 100         ((not (hashq-ref seen-gensyms gensym))
 101          (error "unbound lexical" exp))
 102         ((not (memq gensym env))
 103          (error "displaced lexical" exp))))
 104       (($ <lexical-set> src name gensym exp)
 105        (cond
 106         ((not (symbol? name))
 107          (error "name should be a symbol" name))
 108         ((not (hashq-ref seen-gensyms gensym))
 109          (error "unbound lexical" exp))
 110         ((not (memq gensym env))
 111          (error "displaced lexical" exp))
 112         (else
 113          (visit exp env))))
 114       (($ <lambda> src meta body)
 115        (cond
 116         ((and meta (not (and (list? meta) (and-map pair? meta))))
 117          (error "meta should be alist" meta))
 118         ((and body (not (lambda-case? body)))
 119          (error "lambda body should be lambda-case" exp))
 120         (else
 121          (if body
 122              (visit body env)))))
 123       (($ <let> src names gensyms vals body)
 124        (cond
 125         ((not (and (list? names) (and-map symbol? names)))
 126          (error "names should be list of syms" exp))
 127         ((not (and (list? gensyms) (and-map symbol? gensyms)))
 128          (error "gensyms should be list of syms" exp))
 129         ((not (list? vals))
 130          (error "vals should be list" exp))
 131         ((not (= (length names) (length gensyms) (length vals)))
 132          (error "names, syms, vals should be same length" exp))
 133         (else
 134          (for-each (cut visit <> env) vals)
 135          (visit body (add-env gensyms env)))))
 136       (($ <letrec> src in-order? names gensyms vals body)
 137        (cond
 138         ((not (and (list? names) (and-map symbol? names)))
 139          (error "names should be list of syms" exp))
 140         ((not (and (list? gensyms) (and-map symbol? gensyms)))
 141          (error "gensyms should be list of syms" exp))
 142         ((not (list? vals))
 143          (error "vals should be list" exp))
 144         ((not (= (length names) (length gensyms) (length vals)))
 145          (error "names, syms, vals should be same length" exp))
 146         (else
 147          (let ((env (add-env gensyms env)))
 148            (for-each (cut visit <> env) vals)
 149            (visit body env)))))
 150       (($ <fix> src names gensyms vals body)
 151        (cond
 152         ((not (and (list? names) (and-map symbol? names)))
 153          (error "names should be list of syms" exp))
 154         ((not (and (list? gensyms) (and-map symbol? gensyms)))
 155          (error "gensyms should be list of syms" exp))
 156         ((not (list? vals))
 157          (error "vals should be list" exp))
 158         ((not (= (length names) (length gensyms) (length vals)))
 159          (error "names, syms, vals should be same length" exp))
 160         (else
 161          (let ((env (add-env gensyms env)))
 162            (for-each (cut visit <> env) vals)
 163            (visit body env)))))
 164       (($ <let-values> src exp body)
 165        (cond
 166         ((not (lambda-case? body))
 167          (error "let-values body should be lambda-case" exp))
 168         (else
 169          (visit exp env)
 170          (visit body env))))
 171       (($ <const> src val) #t)
 172       (($ <void> src) #t)
 173       (($ <toplevel-ref> src name)
 174        (cond
 175         ((not (symbol? name))
 176          (error "name should be a symbol" name))))
 177       (($ <module-ref> src mod name public?)
 178        (cond
 179         ((not (and (list? mod) (and-map symbol? mod)))
 180          (error "module name should be list of symbols" exp))
 181         ((not (symbol? name))
 182          (error "name should be symbol" exp))))
 183       (($ <primitive-ref> src name)
 184        (cond
 185         ((not (symbol? name))
 186          (error "name should be symbol" exp))))
 187       (($ <toplevel-set> src name exp)
 188        (cond
 189         ((not (symbol? name))
 190          (error "name should be a symbol" name))
 191         (else
 192          (visit exp env))))
 193       (($ <toplevel-define> src name exp)
 194        (cond
 195         ((not (symbol? name))
 196          (error "name should be a symbol" name))
 197         (else
 198          (visit exp env))))
 199       (($ <module-set> src mod name public? exp)
 200        (cond
 201         ((not (and (list? mod) (and-map symbol? mod)))
 202          (error "module name should be list of symbols" exp))
 203         ((not (symbol? name))
 204          (error "name should be symbol" exp))
 205         (else
 206          (visit exp env))))
 207       (($ <conditional> src condition subsequent alternate)
 208        (visit condition env)
 209        (visit subsequent env)
 210        (visit alternate env))
 211       (($ <primcall> src name args)
 212        (cond
 213         ((not (symbol? name))
 214          (error "expected symbolic operator" exp))
 215         ((not (list? args))
 216          (error "expected list of args" args))
 217         (else
 218          (for-each (cut visit <> env) args))))
 219       (($ <call> src proc args)
 220        (cond
 221         ((not (list? args))
 222          (error "expected list of args" args))
 223         (else
 224          (visit proc env)
 225          (for-each (cut visit <> env) args))))
 226       (($ <seq> src head tail)
 227        (visit head env)
 228        (visit tail env))
 229       (($ <prompt> src tag body handler)
 230        (visit tag env)
 231        (visit body env)
 232        (visit handler env))
 233       (($ <abort> src tag args tail)
 234        (visit tag env)
 235        (for-each (cut visit <> env) args)
 236        (visit tail env))
 237       (_
 238        (error "unexpected tree-il" exp)))
 239     (let ((src (tree-il-src exp)))
 240       (if (and src (not (and (list? src) (and-map pair? src)
 241                              (and-map symbol? (map car src)))))
 242           (error "bad src"))
 243       ;; Return it, why not.
 244       exp)))