; Soft Scheme -- Copyright (C) 1993, 1994 Andrew K. Wright ; ; This program is free software; you can redistribute it and/or modify ; it under the terms of the GNU General Public License as published by ; the Free Software Foundation; either version 2 of the License, or ; (at your option) any later version. ; ; This program is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; GNU General Public License for more details. ; ; You should have received a copy of the GNU General Public License ; along with this program; if not, write to the Free Software ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ; ; Packaged as a single file for Larceny by Lars T Hansen. ; Modified 2000-02-15 by lth. ; ; Compilation notes. ; ; The macro definitions for MATCH in this file depend on the presence of ; certain helper functions in the compilation environment, eg. match:andmap. ; (That is not a problem when loading this file, but it is an issue when ; compiling it.) The easiest way to provide the helper functions during ; compilation is to load match.sch into the compilation environment before ; compiling. ; ; Once compiled, this program is self-contained. ; The SoftScheme benchmark performs soft typing on a program and prints ; a diagnostic report. All screen output is captured in an output ; string port, which is subsequently discarded. (There is a moderate ; amount of output). No file I/O occurs while the program is running. (define (softscheme-benchmark) (let ((expr `(begin ,@(readfile "ss-input.scm"))) (out (open-output-string))) (run-benchmark "softscheme" (lambda () (with-output-to-port out (lambda () (soft-def expr #f))))) (newline) (display (string-length (get-output-string out))) (display " characters of output written.") (newline))) ;;; Define defmacro, macro?, and macroexpand-1. (define *macros* '()) (define-syntax defmacro (transformer (lambda (exp rename compare) (define (arglist? x) (or (symbol? x) (null? x) (and (pair? x) (symbol? (car x)) (arglist? (cdr x))))) (if (not (and (list? exp) (>= (length exp) 4) (symbol? (cadr exp)) (arglist? (caddr exp)))) (error "Bad macro definition: " exp)) (let ((name (cadr exp)) (args (caddr exp)) (body (cdddr exp))) `(begin (define-syntax ,name (transformer (lambda (_defmacro_exp _defmacro_rename _defmacro_compare) (apply (lambda ,args ,@body) (cdr _defmacro_exp))))) (set! *macros* (cons (cons ',name (lambda (_exp) (apply (lambda ,args ,@body) (cdr _exp)))) *macros*)) ))))) (define (macroexpand-1 exp) (cond ((pair? exp) (let ((probe (assq (car exp) *macros*))) (if probe ((cdr probe) exp) exp))) (else exp))) (define (macro? keyword) (and (symbol? keyword) (assq keyword *macros*))) ;;; Other compatibility hacks (define slib:error error) (define force-output flush-output-port) (define format (let ((format format)) (lambda (port . rest) (if (not port) (let ((s (open-output-string))) (apply format s rest) (get-output-string s)) (apply format port rest))))) (define gentemp (let ((gensym gensym)) (lambda () (gensym "G")))) (define getenv (let ((getenv getenv)) (lambda (x) (or (getenv x) (if (string=? x "HOME") "Ertevann:Desktop folder:" #f))))) ;;; The rest of the file should be more or less portable. (define match-file #f) (define installation-directory #f) (define customization-file #f) (define fastlibrary-file #f) (define st:version "Larceny Version 0.18, April 21, 1995") (define match:version "Version 1.18, July 17, 1995") (define match:error (lambda (val . args) (for-each pretty-print args) (slib:error "no matching clause for " val))) (define match:andmap (lambda (f l) (if (null? l) (and) (and (f (car l)) (match:andmap f (cdr l)))))) (define match:syntax-err (lambda (obj msg) (slib:error msg obj))) (define match:disjoint-structure-tags '()) (define match:make-structure-tag (lambda (name) (if (or (eq? match:structure-control 'disjoint) match:runtime-structures) (let ((tag (gentemp))) (set! match:disjoint-structure-tags (cons tag match:disjoint-structure-tags)) tag) (string->symbol (string-append "<" (symbol->string name) ">"))))) (define match:structure? (lambda (tag) (memq tag match:disjoint-structure-tags))) (define match:structure-control 'vector) (define match:set-structure-control (lambda (v) (set! match:structure-control v))) (define match:set-error (lambda (v) (set! match:error v))) (define match:error-control 'error) (define match:set-error-control (lambda (v) (set! match:error-control v))) (define match:disjoint-predicates (cons 'null '(pair? symbol? boolean? number? string? char? procedure? vector?))) (define match:vector-structures '()) (define match:expanders (letrec ((genmatch (lambda (x clauses match-expr) (let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (blist (car eb-errf)) (plist (map (lambda (c) (let* ((x (bound (validate-pattern (car c)))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (fail (and (pair? (cdr c)) (pair? (cadr c)) (eq? (caadr c) '=>) (symbol? (cadadr c)) (pair? (cdadr c)) (null? (cddadr c)) (pair? (cddr c)) (cadadr c))) (bv2 (if fail (cons fail bv) bv)) (body (if fail (cddr c) (cdr c)))) (set! blist (cons `(,code (lambda ,bv2 ,@body)) (append bindings blist))) (list p code bv (and fail (gentemp)) #f))) clauses)) (code (gen x '() plist (cdr eb-errf) length>= (gentemp)))) (unreachable plist match-expr) (inline-let `(let ((,length>= (lambda (n) (lambda (l) (>= (length l) n)))) ,@blist) ,code))))) (genletrec (lambda (pat exp body match-expr) (let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (plist (list (list p code bv #f #f))) (x (gentemp)) (m (gen x '() plist (cdr eb-errf) length>= (gentemp))) (gs (map (lambda (_) (gentemp)) bv))) (unreachable plist match-expr) `(letrec ((,length>= (lambda (n) (lambda (l) (>= (length l) n)))) ,@(map (lambda (v) `(,v #f)) bv) (,x ,exp) (,code (lambda ,gs ,@(map (lambda (v g) `(set! ,v ,g)) bv gs) ,@body)) ,@bindings ,@(car eb-errf)) ,m)))) (gendefine (lambda (pat exp match-expr) (let* ((length>= (gentemp)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gentemp)) (plist (list (list p code bv #f #f))) (x (gentemp)) (m (gen x '() plist (cdr eb-errf) length>= (gentemp))) (gs (map (lambda (_) (gentemp)) bv))) (unreachable plist match-expr) `(begin ,@(map (lambda (v) `(define ,v #f)) bv) ,(inline-let `(let ((,length>= (lambda (n) (lambda (l) (>= (length l) n)))) (,x ,exp) (,code (lambda ,gs ,@(map (lambda (v g) `(set! ,v ,g)) bv gs) (cond (#f #f)))) ,@bindings ,@(car eb-errf)) ,m)))))) (pattern-var? (lambda (x) (and (symbol? x) (not (dot-dot-k? x)) (not (memq x '(quasiquote quote unquote unquote-splicing ? _ $ = and or not set! get! ... ___)))))) (dot-dot-k? (lambda (s) (and (symbol? s) (if (memq s '(... ___)) 0 (let* ((s (symbol->string s)) (n (string-length s))) (and (<= 3 n) (memq (string-ref s 0) '(#\. #\_)) (memq (string-ref s 1) '(#\. #\_)) (match:andmap char-numeric? (string->list (substring s 2 n))) (string->number (substring s 2 n)))))))) (error-maker (lambda (match-expr) (cond ((eq? match:error-control 'unspecified) (cons '() (lambda (x) `(cond (#f #f))))) ((memq match:error-control '(error fail)) (cons '() (lambda (x) `(match:error ,x)))) ((eq? match:error-control 'match) (let ((errf (gentemp)) (arg (gentemp))) (cons `((,errf (lambda (,arg) (match:error ,arg ',match-expr)))) (lambda (x) `(,errf ,x))))) (else (match:syntax-err '(unspecified error fail match) "invalid value for match:error-control, legal values are"))))) (unreachable (lambda (plist match-expr) (for-each (lambda (x) (if (not (car (cddddr x))) (begin (display "Warning: unreachable pattern ") (display (car x)) (display " in ") (display match-expr) (newline)))) plist))) (validate-pattern (lambda (pattern) (letrec ((simple? (lambda (x) (or (string? x) (boolean? x) (char? x) (number? x) (null? x)))) (ordinary (lambda (p) (let ((g88 (lambda (x y) (cons (ordinary x) (ordinary y))))) (if (simple? p) ((lambda (p) p) p) (if (equal? p '_) ((lambda () '_)) (if (pattern-var? p) ((lambda (p) p) p) (if (pair? p) (if (equal? (car p) 'quasiquote) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (quasi p)) (cadr p)) (g88 (car p) (cdr p))) (if (equal? (car p) 'quote) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) p) p) (g88 (car p) (cdr p))) (if (equal? (car p) '?) (if (and (pair? (cdr p)) (list? (cddr p))) ((lambda (pred ps) `(? ,pred ,@(map ordinary ps))) (cadr p) (cddr p)) (g88 (car p) (cdr p))) (if (equal? (car p) '=) (if (and (pair? (cdr p)) (pair? (cddr p)) (null? (cdddr p))) ((lambda (sel p) `(= ,sel ,(ordinary p))) (cadr p) (caddr p)) (g88 (car p) (cdr p))) (if (equal? (car p) 'and) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) `(and ,@(map ordinary ps))) (cdr p)) (g88 (car p) (cdr p))) (if (equal? (car p) 'or) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) `(or ,@(map ordinary ps))) (cdr p)) (g88 (car p) (cdr p))) (if (equal? (car p) 'not) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) `(not ,@(map ordinary ps))) (cdr p)) (g88 (car p) (cdr p))) (if (equal? (car p) '$) (if (and (pair? (cdr p)) (symbol? (cadr p)) (list? (cddr p))) ((lambda (r ps) `($ ,r ,@(map ordinary ps))) (cadr p) (cddr p)) (g88 (car p) (cdr p))) (if (equal? (car p) 'set!) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g88 (car p) (cdr p))) (if (equal? (car p) 'get!) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g88 (car p) (cdr p))) (if (equal? (car p) 'unquote) (g88 (car p) (cdr p)) (if (equal? (car p) 'unquote-splicing) (g88 (car p) (cdr p)) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) `(,(ordinary p) ,ddk)) (car p) (cadr p)) (g88 (car p) (cdr p))))))))))))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (and (not (null? rpl)) (dot-dot-k? (car rpl))) (reverse (cons (car rpl) (map ordinary (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern"))))))))))) (quasi (lambda (p) (let ((g109 (lambda (x y) (cons (quasi x) (quasi y))))) (if (simple? p) ((lambda (p) p) p) (if (symbol? p) ((lambda (p) `',p) p) (if (pair? p) (if (equal? (car p) 'unquote) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (ordinary p)) (cadr p)) (g109 (car p) (cdr p))) (if (and (pair? (car p)) (equal? (caar p) 'unquote-splicing) (pair? (cdar p)) (null? (cddar p))) (if (null? (cdr p)) ((lambda (p) (ordinary p)) (cadar p)) ((lambda (p y) (append (ordlist p) (quasi y))) (cadar p) (cdr p))) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) `(,(quasi p) ,ddk)) (car p) (cadr p)) (g109 (car p) (cdr p))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (dot-dot-k? (car rpl)) (reverse (cons (car rpl) (map quasi (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern")))))))))) (ordlist (lambda (p) (cond ((null? p) '()) ((pair? p) (cons (ordinary (car p)) (ordlist (cdr p)))) (else (match:syntax-err pattern "invalid use of unquote-splicing in pattern")))))) (ordinary pattern)))) (bound (lambda (pattern) (letrec ((pred-bodies '()) (bound (lambda (p a k) (cond ((eq? '_ p) (k p a)) ((symbol? p) (if (memq p a) (match:syntax-err pattern "duplicate variable in pattern")) (k p (cons p a))) ((and (pair? p) (eq? 'quote (car p))) (k p a)) ((and (pair? p) (eq? '? (car p))) (cond ((not (null? (cddr p))) (bound `(and (? ,(cadr p)) ,@(cddr p)) a k)) ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gentemp))) (set! pred-bodies (cons `(,g ,(cadr p)) pred-bodies)) (k `(? ,g) a))) (else (k p a)))) ((and (pair? p) (eq? '= (car p))) (cond ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gentemp))) (set! pred-bodies (cons `(,g ,(cadr p)) pred-bodies)) (bound `(= ,g ,(caddr p)) a k))) (else (bound (caddr p) a (lambda (p2 a) (k `(= ,(cadr p) ,p2) a)))))) ((and (pair? p) (eq? 'and (car p))) (bound* (cdr p) a (lambda (p a) (k `(and ,@p) a)))) ((and (pair? p) (eq? 'or (car p))) (bound (cadr p) a (lambda (first-p first-a) (let or* ((plist (cddr p)) (k (lambda (plist) (k `(or ,first-p ,@plist) first-a)))) (if (null? plist) (k plist) (bound (car plist) a (lambda (car-p car-a) (if (not (permutation car-a first-a)) (match:syntax-err pattern "variables of or-pattern differ in")) (or* (cdr plist) (lambda (cdr-p) (k (cons car-p cdr-p))))))))))) ((and (pair? p) (eq? 'not (car p))) (cond ((not (null? (cddr p))) (bound `(not (or ,@(cdr p))) a k)) (else (bound (cadr p) a (lambda (p2 a2) (if (not (permutation a a2)) (match:syntax-err p "no variables allowed in")) (k `(not ,p2) a)))))) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (bound (car p) a (lambda (q b) (let ((bvars (find-prefix b a))) (k `(,q ,(cadr p) ,bvars ,(gentemp) ,(gentemp) ,(map (lambda (_) (gentemp)) bvars)) b))))) ((and (pair? p) (eq? '$ (car p))) (bound* (cddr p) a (lambda (p1 a) (k `($ ,(cadr p) ,@p1) a)))) ((and (pair? p) (eq? 'set! (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((and (pair? p) (eq? 'get! (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((pair? p) (bound (car p) a (lambda (car-p a) (bound (cdr p) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) ((vector? p) (boundv (vector->list p) a (lambda (pl a) (k (list->vector pl) a)))) (else (k p a))))) (boundv (lambda (plist a k) (let ((g115 (lambda () (k plist a)))) (if (pair? plist) (if (and (pair? (cdr plist)) (dot-dot-k? (cadr plist)) (null? (cddr plist))) ((lambda () (bound plist a k))) (if (null? plist) (g115) ((lambda (x y) (bound x a (lambda (car-p a) (boundv y a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) (car plist) (cdr plist)))) (if (null? plist) (g115) (match:error plist)))))) (bound* (lambda (plist a k) (if (null? plist) (k plist a) (bound (car plist) a (lambda (car-p a) (bound* (cdr plist) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))))) (find-prefix (lambda (b a) (if (eq? b a) '() (cons (car b) (find-prefix (cdr b) a))))) (permutation (lambda (p1 p2) (and (= (length p1) (length p2)) (match:andmap (lambda (x1) (memq x1 p2)) p1))))) (bound pattern '() (lambda (p a) (list p (reverse a) pred-bodies)))))) (inline-let (lambda (let-exp) (letrec ((occ (lambda (x e) (let loop ((e e)) (cond ((pair? e) (+ (loop (car e)) (loop (cdr e)))) ((eq? x e) 1) (else 0))))) (subst (lambda (e old new) (let loop ((e e)) (cond ((pair? e) (cons (loop (car e)) (loop (cdr e)))) ((eq? old e) new) (else e))))) (const? (lambda (sexp) (or (symbol? sexp) (boolean? sexp) (string? sexp) (char? sexp) (number? sexp) (null? sexp) (and (pair? sexp) (eq? (car sexp) 'quote) (pair? (cdr sexp)) (symbol? (cadr sexp)) (null? (cddr sexp)))))) (isval? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (memq (car sexp) '(lambda quote match-lambda match-lambda*)))))) (small? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (eq? (car sexp) 'lambda) (pair? (cdr sexp)) (pair? (cddr sexp)) (const? (caddr sexp)) (null? (cdddr sexp))))))) (let loop ((b (cadr let-exp)) (new-b '()) (e (caddr let-exp))) (cond ((null? b) (if (null? new-b) e `(let ,(reverse new-b) ,e))) ((isval? (cadr (car b))) (let* ((x (caar b)) (n (occ x e))) (cond ((= 0 n) (loop (cdr b) new-b e)) ((or (= 1 n) (small? (cadr (car b)))) (loop (cdr b) new-b (subst e x (cadr (car b))))) (else (loop (cdr b) (cons (car b) new-b) e))))) (else (loop (cdr b) (cons (car b) new-b) e))))))) (gen (lambda (x sf plist erract length>= eta) (if (null? plist) (erract x) (let* ((v '()) (val (lambda (x) (cdr (assq x v)))) (fail (lambda (sf) (gen x sf (cdr plist) erract length>= eta))) (success (lambda (sf) (set-car! (cddddr (car plist)) #t) (let* ((code (cadr (car plist))) (bv (caddr (car plist))) (fail-sym (cadddr (car plist)))) (if fail-sym (let ((ap `(,code ,fail-sym ,@(map val bv)))) `(call-with-current-continuation (lambda (,fail-sym) (let ((,fail-sym (lambda () (,fail-sym ,(fail sf))))) ,ap)))) `(,code ,@(map val bv))))))) (let next ((p (caar plist)) (e x) (sf sf) (kf fail) (ks success)) (cond ((eq? '_ p) (ks sf)) ((symbol? p) (set! v (cons (cons p e) v)) (ks sf)) ((null? p) (emit `(null? ,e) sf kf ks)) ((equal? p ''()) (emit `(null? ,e) sf kf ks)) ((string? p) (emit `(equal? ,e ,p) sf kf ks)) ((boolean? p) (emit `(equal? ,e ,p) sf kf ks)) ((char? p) (emit `(equal? ,e ,p) sf kf ks)) ((number? p) (emit `(equal? ,e ,p) sf kf ks)) ((and (pair? p) (eq? 'quote (car p))) (emit `(equal? ,e ,p) sf kf ks)) ((and (pair? p) (eq? '? (car p))) (let ((tst `(,(cadr p) ,e))) (emit tst sf kf ks))) ((and (pair? p) (eq? '= (car p))) (next (caddr p) `(,(cadr p) ,e) sf kf ks)) ((and (pair? p) (eq? 'and (car p))) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (ks sf) (next (car p) e sf kf (lambda (sf) (loop (cdr p) sf)))))) ((and (pair? p) (eq? 'or (car p))) (let ((or-v v)) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (kf sf) (begin (set! v or-v) (next (car p) e sf (lambda (sf) (loop (cdr p) sf)) ks)))))) ((and (pair? p) (eq? 'not (car p))) (next (cadr p) e sf ks kf)) ((and (pair? p) (eq? '$ (car p))) (let* ((tag (cadr p)) (fields (cdr p)) (rlen (length fields)) (tst `(,(symbol-append tag '?) ,e))) (emit tst sf kf (let rloop ((n 1)) (lambda (sf) (if (= n rlen) (ks sf) (next (list-ref fields n) `(,(symbol-append tag '- n) ,e) sf kf (rloop (+ 1 n))))))))) ((and (pair? p) (eq? 'set! (car p))) (set! v (cons (cons (cadr p) (setter e p)) v)) (ks sf)) ((and (pair? p) (eq? 'get! (car p))) (set! v (cons (cons (cadr p) (getter e p)) v)) (ks sf)) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (emit `(list? ,e) sf kf (lambda (sf) (let* ((k (dot-dot-k? (cadr p))) (ks (lambda (sf) (let ((bound (list-ref p 2))) (cond ((eq? (car p) '_) (ks sf)) ((null? bound) (let* ((ptst (next (car p) eta sf (lambda (sf) #f) (lambda (sf) #t))) (tst (if (and (pair? ptst) (symbol? (car ptst)) (pair? (cdr ptst)) (eq? eta (cadr ptst)) (null? (cddr ptst))) (car ptst) `(lambda (,eta) ,ptst)))) (assm `(match:andmap ,tst ,e) (kf sf) (ks sf)))) ((and (symbol? (car p)) (equal? (list (car p)) bound)) (next (car p) e sf kf ks)) (else (let* ((gloop (list-ref p 3)) (ge (list-ref p 4)) (fresh (list-ref p 5)) (p1 (next (car p) `(car ,ge) sf kf (lambda (sf) `(,gloop (cdr ,ge) ,@(map (lambda (b f) `(cons ,(val b) ,f)) bound fresh)))))) (set! v (append (map cons bound (map (lambda (x) `(reverse ,x)) fresh)) v)) `(let ,gloop ((,ge ,e) ,@(map (lambda (x) `(,x '())) fresh)) (if (null? ,ge) ,(ks sf) ,p1))))))))) (case k ((0) (ks sf)) ((1) (emit `(pair? ,e) sf kf ks)) (else (emit `((,length>= ,k) ,e) sf kf ks))))))) ((pair? p) (emit `(pair? ,e) sf kf (lambda (sf) (next (car p) (add-a e) sf kf (lambda (sf) (next (cdr p) (add-d e) sf kf ks)))))) ((and (vector? p) (>= (vector-length p) 6) (dot-dot-k? (vector-ref p (- (vector-length p) 5)))) (let* ((vlen (- (vector-length p) 6)) (k (dot-dot-k? (vector-ref p (+ vlen 1)))) (minlen (+ vlen k)) (bound (vector-ref p (+ vlen 2)))) (emit `(vector? ,e) sf kf (lambda (sf) (assm `(>= (vector-length ,e) ,minlen) (kf sf) ((let vloop ((n 0)) (lambda (sf) (cond ((not (= n vlen)) (next (vector-ref p n) `(vector-ref ,e ,n) sf kf (vloop (+ 1 n)))) ((eq? (vector-ref p vlen) '_) (ks sf)) (else (let* ((gloop (vector-ref p (+ vlen 3))) (ind (vector-ref p (+ vlen 4))) (fresh (vector-ref p (+ vlen 5))) (p1 (next (vector-ref p vlen) `(vector-ref ,e ,ind) sf kf (lambda (sf) `(,gloop (- ,ind 1) ,@(map (lambda (b f) `(cons ,(val b) ,f)) bound fresh)))))) (set! v (append (map cons bound fresh) v)) `(let ,gloop ((,ind (- (vector-length ,e) 1)) ,@(map (lambda (x) `(,x '())) fresh)) (if (> ,minlen ,ind) ,(ks sf) ,p1))))))) sf)))))) ((vector? p) (let ((vlen (vector-length p))) (emit `(vector? ,e) sf kf (lambda (sf) (emit `(equal? (vector-length ,e) ,vlen) sf kf (let vloop ((n 0)) (lambda (sf) (if (= n vlen) (ks sf) (next (vector-ref p n) `(vector-ref ,e ,n) sf kf (vloop (+ 1 n))))))))))) (else (display "FATAL ERROR IN PATTERN MATCHER") (newline) (error #f "THIS NEVER HAPPENS")))))))) (emit (lambda (tst sf kf ks) (cond ((in tst sf) (ks sf)) ((in `(not ,tst) sf) (kf sf)) (else (let* ((e (cadr tst)) (implied (cond ((eq? (car tst) 'equal?) (let ((p (caddr tst))) (cond ((string? p) `((string? ,e))) ((boolean? p) `((boolean? ,e))) ((char? p) `((char? ,e))) ((number? p) `((number? ,e))) ((and (pair? p) (eq? 'quote (car p))) `((symbol? ,e))) (else '())))) ((eq? (car tst) 'null?) `((list? ,e))) ((vec-structure? tst) `((vector? ,e))) (else '()))) (not-imp (case (car tst) ((list?) `((not (null? ,e)))) (else '()))) (s (ks (cons tst (append implied sf)))) (k (kf (cons `(not ,tst) (append not-imp sf))))) (assm tst k s)))))) (assm (lambda (tst f s) (cond ((equal? s f) s) ((and (eq? s #t) (eq? f #f)) tst) ((and (eq? (car tst) 'pair?) (memq match:error-control '(unspecified fail)) (memq (car f) '(cond match:error)) (guarantees s (cadr tst))) s) ((and (pair? s) (eq? (car s) 'if) (equal? (cadddr s) f)) (if (eq? (car (cadr s)) 'and) `(if (and ,tst ,@(cdr (cadr s))) ,(caddr s) ,f) `(if (and ,tst ,(cadr s)) ,(caddr s) ,f))) ((and (pair? s) (equal? (car s) 'call-with-current-continuation) (pair? (cdr s)) (pair? (cadr s)) (equal? (caadr s) 'lambda) (pair? (cdadr s)) (pair? (cadadr s)) (null? (cdr (cadadr s))) (pair? (cddadr s)) (pair? (car (cddadr s))) (equal? (caar (cddadr s)) 'let) (pair? (cdar (cddadr s))) (pair? (cadar (cddadr s))) (pair? (caadar (cddadr s))) (pair? (cdr (caadar (cddadr s)))) (pair? (cadr (caadar (cddadr s)))) (equal? (caadr (caadar (cddadr s))) 'lambda) (pair? (cdadr (caadar (cddadr s)))) (null? (cadadr (caadar (cddadr s)))) (pair? (cddadr (caadar (cddadr s)))) (pair? (car (cddadr (caadar (cddadr s))))) (pair? (cdar (cddadr (caadar (cddadr s))))) (null? (cddar (cddadr (caadar (cddadr s))))) (null? (cdr (cddadr (caadar (cddadr s))))) (null? (cddr (caadar (cddadr s)))) (null? (cdadar (cddadr s))) (pair? (cddar (cddadr s))) (null? (cdddar (cddadr s))) (null? (cdr (cddadr s))) (null? (cddr s)) (equal? f (cadar (cddadr (caadar (cddadr s)))))) (let ((k (car (cadadr s))) (fail (car (caadar (cddadr s)))) (s2 (caddar (cddadr s)))) `(call-with-current-continuation (lambda (,k) (let ((,fail (lambda () (,k ,f)))) ,(assm tst `(,fail) s2)))))) ((and #f (pair? s) (equal? (car s) 'let) (pair? (cdr s)) (pair? (cadr s)) (pair? (caadr s)) (pair? (cdaadr s)) (pair? (car (cdaadr s))) (equal? (caar (cdaadr s)) 'lambda) (pair? (cdar (cdaadr s))) (null? (cadar (cdaadr s))) (pair? (cddar (cdaadr s))) (null? (cdddar (cdaadr s))) (null? (cdr (cdaadr s))) (null? (cdadr s)) (pair? (cddr s)) (null? (cdddr s)) (equal? (caddar (cdaadr s)) f)) (let ((fail (caaadr s)) (s2 (caddr s))) `(let ((,fail (lambda () ,f))) ,(assm tst `(,fail) s2)))) (else `(if ,tst ,s ,f))))) (guarantees (lambda (code x) (let ((a (add-a x)) (d (add-d x))) (let loop ((code code)) (cond ((not (pair? code)) #f) ((memq (car code) '(cond match:error)) #t) ((or (equal? code a) (equal? code d)) #t) ((eq? (car code) 'if) (or (loop (cadr code)) (and (loop (caddr code)) (loop (cadddr code))))) ((eq? (car code) 'lambda) #f) ((and (eq? (car code) 'let) (symbol? (cadr code))) #f) (else (or (loop (car code)) (loop (cdr code))))))))) (in (lambda (e l) (or (member e l) (and (eq? (car e) 'list?) (or (member `(null? ,(cadr e)) l) (member `(pair? ,(cadr e)) l))) (and (eq? (car e) 'not) (let* ((srch (cadr e)) (const-class (equal-test? srch))) (cond (const-class (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? const-class (car x)))) (equal? x `(not (,const-class ,(cadr srch)))) (and (equal? (cadr x) (cadr srch)) (equal-test? x) (not (equal? (caddr srch) (caddr x)))) (mem (cdr l))))))) ((disjoint? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? (car x) (car srch)))) (mem (cdr l))))))) ((eq? (car srch) 'list?) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (memq (car x) '(list? pair? null?)))) (mem (cdr l))))))) ((vec-structure? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (or (disjoint? x) (vec-structure? x)) (not (equal? (car x) 'vector?)) (not (equal? (car x) (car srch)))) (equal? x `(not (vector? ,(cadr srch)))) (mem (cdr l))))))) (else #f))))))) (equal-test? (lambda (tst) (and (eq? (car tst) 'equal?) (let ((p (caddr tst))) (cond ((string? p) 'string?) ((boolean? p) 'boolean?) ((char? p) 'char?) ((number? p) 'number?) ((and (pair? p) (pair? (cdr p)) (null? (cddr p)) (eq? 'quote (car p)) (symbol? (cadr p))) 'symbol?) (else #f)))))) (disjoint? (lambda (tst) (memq (car tst) match:disjoint-predicates))) (vec-structure? (lambda (tst) (memq (car tst) match:vector-structures))) (add-a (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cadr new) (cdr a)) `(car ,a))))) (add-d (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cddr new) (cdr a)) `(cdr ,a))))) (c---rs '((car caar . cdar) (cdr cadr . cddr) (caar caaar . cdaar) (cadr caadr . cdadr) (cdar cadar . cddar) (cddr caddr . cdddr) (caaar caaaar . cdaaar) (caadr caaadr . cdaadr) (cadar caadar . cdadar) (caddr caaddr . cdaddr) (cdaar cadaar . cddaar) (cdadr cadadr . cddadr) (cddar caddar . cdddar) (cdddr cadddr . cddddr))) (setter (lambda (e p) (let ((mk-setter (lambda (s) (symbol-append 'set- s '!)))) (cond ((not (pair? e)) (match:syntax-err p "unnested set! pattern")) ((eq? (car e) 'vector-ref) `(let ((x ,(cadr e))) (lambda (y) (vector-set! x ,(caddr e) y)))) ((eq? (car e) 'unbox) `(let ((x ,(cadr e))) (lambda (y) (set-box! x y)))) ((eq? (car e) 'car) `(let ((x ,(cadr e))) (lambda (y) (set-car! x y)))) ((eq? (car e) 'cdr) `(let ((x ,(cadr e))) (lambda (y) (set-cdr! x y)))) ((let ((a (assq (car e) get-c---rs))) (and a `(let ((x (,(cadr a) ,(cadr e)))) (lambda (y) (,(mk-setter (cddr a)) x y)))))) (else `(let ((x ,(cadr e))) (lambda (y) (,(mk-setter (car e)) x y)))))))) (getter (lambda (e p) (cond ((not (pair? e)) (match:syntax-err p "unnested get! pattern")) ((eq? (car e) 'vector-ref) `(let ((x ,(cadr e))) (lambda () (vector-ref x ,(caddr e))))) ((eq? (car e) 'unbox) `(let ((x ,(cadr e))) (lambda () (unbox x)))) ((eq? (car e) 'car) `(let ((x ,(cadr e))) (lambda () (car x)))) ((eq? (car e) 'cdr) `(let ((x ,(cadr e))) (lambda () (cdr x)))) ((let ((a (assq (car e) get-c---rs))) (and a `(let ((x (,(cadr a) ,(cadr e)))) (lambda () (,(cddr a) x)))))) (else `(let ((x ,(cadr e))) (lambda () (,(car e) x))))))) (get-c---rs '((caar car . car) (cadr cdr . car) (cdar car . cdr) (cddr cdr . cdr) (caaar caar . car) (caadr cadr . car) (cadar cdar . car) (caddr cddr . car) (cdaar caar . cdr) (cdadr cadr . cdr) (cddar cdar . cdr) (cdddr cddr . cdr) (caaaar caaar . car) (caaadr caadr . car) (caadar cadar . car) (caaddr caddr . car) (cadaar cdaar . car) (cadadr cdadr . car) (caddar cddar . car) (cadddr cdddr . car) (cdaaar caaar . cdr) (cdaadr caadr . cdr) (cdadar cadar . cdr) (cdaddr caddr . cdr) (cddaar cdaar . cdr) (cddadr cdadr . cdr) (cdddar cddar . cdr) (cddddr cdddr . cdr))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l))))) (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l))))) (rdc (lambda (l) (if (null? (cdr l)) '() (cons (car l) (rdc (cdr l))))))) (list genmatch genletrec gendefine pattern-var?))) (defmacro match args (cond ((and (list? args) (<= 1 (length args)) (match:andmap (lambda (y) (and (list? y) (<= 2 (length y)))) (cdr args))) (let* ((exp (car args)) (clauses (cdr args)) (e (if (symbol? exp) exp (gentemp)))) (if (symbol? exp) ((car match:expanders) e clauses `(match ,@args)) `(let ((,e ,exp)) ,((car match:expanders) e clauses `(match ,@args)))))) (else (match:syntax-err `(match ,@args) "syntax error in")))) (defmacro match-lambda args (if (and (list? args) (match:andmap (lambda (g126) (if (and (pair? g126) (list? (cdr g126))) (pair? (cdr g126)) #f)) args)) ((lambda () (let ((e (gentemp))) `(lambda (,e) (match ,e ,@args))))) ((lambda () (match:syntax-err `(match-lambda ,@args) "syntax error in"))))) (defmacro match-lambda* args (if (and (list? args) (match:andmap (lambda (g134) (if (and (pair? g134) (list? (cdr g134))) (pair? (cdr g134)) #f)) args)) ((lambda () (let ((e (gentemp))) `(lambda ,e (match ,e ,@args))))) ((lambda () (match:syntax-err `(match-lambda* ,@args) "syntax error in"))))) (defmacro match-let args (let ((g158 (lambda (pat exp body) `(match ,exp (,pat ,@body)))) (g154 (lambda (pat exp body) (let ((g (map (lambda (x) (gentemp)) pat)) (vpattern (list->vector pat))) `(let ,(map list g exp) (match (vector ,@g) (,vpattern ,@body)))))) (g146 (lambda () (match:syntax-err `(match-let ,@args) "syntax error in"))) (g145 (lambda (p1 e1 p2 e2 body) (let ((g1 (gentemp)) (g2 (gentemp))) `(let ((,g1 ,e1) (,g2 ,e2)) (match (cons ,g1 ,g2) ((,p1 unquote p2) ,@body)))))) (g136 (cadddr match:expanders))) (if (pair? args) (if (symbol? (car args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g161 ((g162 (cadr args)) (g160 '()) (g159 '())) (if (null? g162) (if (and (list? (cddr args)) (pair? (cddr args))) ((lambda (name pat exp body) (if (match:andmap (cadddr match:expanders) pat) `(let ,@args) `(letrec ((,name (match-lambda* (,pat ,@body)))) (,name ,@exp)))) (car args) (reverse g159) (reverse g160) (cddr args)) (g146)) (if (and (pair? (car g162)) (pair? (cdar g162)) (null? (cddar g162))) (g161 (cdr g162) (cons (cadar g162) g160) (cons (caar g162) g159)) (g146)))) (g146)) (if (list? (car args)) (if (match:andmap (lambda (g167) (if (and (pair? g167) (g136 (car g167)) (pair? (cdr g167))) (null? (cddr g167)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () `(let ,@args))) (let g149 ((g150 (car args)) (g148 '()) (g147 '())) (if (null? g150) (g146) (if (and (pair? (car g150)) (pair? (cdar g150)) (null? (cddar g150))) (g149 (cdr g150) (cons (cadar g150) g148) (cons (caar g150) g147)) (g146))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g158 (caaar args) (cadaar args) (cdr args)) (let g149 ((g150 (car args)) (g148 '()) (g147 '())) (if (null? g150) (g146) (if (and (pair? (car g150)) (pair? (cdar g150)) (null? (cddar g150))) (g149 (cdr g150) (cons (cadar g150) g148) (cons (caar g150) g147)) (g146))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g145 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g149 ((g150 (car args)) (g148 '()) (g147 '())) (if (null? g150) (g146) (if (and (pair? (car g150)) (pair? (cdar g150)) (null? (cddar g150))) (g149 (cdr g150) (cons (cadar g150) g148) (cons (caar g150) g147)) (g146))))) (let g149 ((g150 (car args)) (g148 '()) (g147 '())) (if (null? g150) (if (and (list? (cdr args)) (pair? (cdr args))) (g154 (reverse g147) (reverse g148) (cdr args)) (g146)) (if (and (pair? (car g150)) (pair? (cdar g150)) (null? (cddar g150))) (g149 (cdr g150) (cons (cadar g150) g148) (cons (caar g150) g147)) (g146)))))) (let g149 ((g150 (car args)) (g148 '()) (g147 '())) (if (null? g150) (if (and (list? (cdr args)) (pair? (cdr args))) (g154 (reverse g147) (reverse g148) (cdr args)) (g146)) (if (and (pair? (car g150)) (pair? (cdar g150)) (null? (cddar g150))) (g149 (cdr g150) (cons (cadar g150) g148) (cons (caar g150) g147)) (g146)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g158 (caaar args) (cadaar args) (cdr args)) (let g149 ((g150 (car args)) (g148 '()) (g147 '())) (if (null? g150) (g146) (if (and (pair? (car g150)) (pair? (cdar g150)) (null? (cddar g150))) (g149 (cdr g150) (cons (cadar g150) g148) (cons (caar g150) g147)) (g146))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g145 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g149 ((g150 (car args)) (g148 '()) (g147 '())) (if (null? g150) (g146) (if (and (pair? (car g150)) (pair? (cdar g150)) (null? (cddar g150))) (g149 (cdr g150) (cons (cadar g150) g148) (cons (caar g150) g147)) (g146))))) (let g149 ((g150 (car args)) (g148 '()) (g147 '())) (if (null? g150) (if (and (list? (cdr args)) (pair? (cdr args))) (g154 (reverse g147) (reverse g148) (cdr args)) (g146)) (if (and (pair? (car g150)) (pair? (cdar g150)) (null? (cddar g150))) (g149 (cdr g150) (cons (cadar g150) g148) (cons (caar g150) g147)) (g146)))))) (let g149 ((g150 (car args)) (g148 '()) (g147 '())) (if (null? g150) (if (and (list? (cdr args)) (pair? (cdr args))) (g154 (reverse g147) (reverse g148) (cdr args)) (g146)) (if (and (pair? (car g150)) (pair? (cdar g150)) (null? (cddar g150))) (g149 (cdr g150) (cons (cadar g150) g148) (cons (caar g150) g147)) (g146))))) (g146)))) (g146)))) (defmacro match-let* args (let ((g176 (lambda () (match:syntax-err `(match-let* ,@args) "syntax error in")))) (if (pair? args) (if (null? (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda (body) `(let* ,@args)) (cdr args)) (g176)) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args)) (list? (cdar args)) (list? (cdr args)) (pair? (cdr args))) ((lambda (pat exp rest body) (if ((cadddr match:expanders) pat) `(let ((,pat ,exp)) (match-let* ,rest ,@body)) `(match ,exp (,pat (match-let* ,rest ,@body))))) (caaar args) (cadaar args) (cdar args) (cdr args)) (g176))) (g176)))) (defmacro match-letrec args (let ((g200 (cadddr match:expanders)) (g199 (lambda (p1 e1 p2 e2 body) `(match-letrec (((,p1 unquote p2) (cons ,e1 ,e2))) ,@body))) (g195 (lambda () (match:syntax-err `(match-letrec ,@args) "syntax error in"))) (g194 (lambda (pat exp body) `(match-letrec ((,(list->vector pat) (vector ,@exp))) ,@body))) (g186 (lambda (pat exp body) ((cadr match:expanders) pat exp body `(match-letrec ((,pat ,exp)) ,@body))))) (if (pair? args) (if (list? (car args)) (if (match:andmap (lambda (g206) (if (and (pair? g206) (g200 (car g206)) (pair? (cdr g206))) (null? (cddr g206)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () `(letrec ,@args))) (let g189 ((g190 (car args)) (g188 '()) (g187 '())) (if (null? g190) (g195) (if (and (pair? (car g190)) (pair? (cdar g190)) (null? (cddar g190))) (g189 (cdr g190) (cons (cadar g190) g188) (cons (caar g190) g187)) (g195))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g186 (caaar args) (cadaar args) (cdr args)) (let g189 ((g190 (car args)) (g188 '()) (g187 '())) (if (null? g190) (g195) (if (and (pair? (car g190)) (pair? (cdar g190)) (null? (cddar g190))) (g189 (cdr g190) (cons (cadar g190) g188) (cons (caar g190) g187)) (g195))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g199 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g189 ((g190 (car args)) (g188 '()) (g187 '())) (if (null? g190) (g195) (if (and (pair? (car g190)) (pair? (cdar g190)) (null? (cddar g190))) (g189 (cdr g190) (cons (cadar g190) g188) (cons (caar g190) g187)) (g195))))) (let g189 ((g190 (car args)) (g188 '()) (g187 '())) (if (null? g190) (if (and (list? (cdr args)) (pair? (cdr args))) (g194 (reverse g187) (reverse g188) (cdr args)) (g195)) (if (and (pair? (car g190)) (pair? (cdar g190)) (null? (cddar g190))) (g189 (cdr g190) (cons (cadar g190) g188) (cons (caar g190) g187)) (g195)))))) (let g189 ((g190 (car args)) (g188 '()) (g187 '())) (if (null? g190) (if (and (list? (cdr args)) (pair? (cdr args))) (g194 (reverse g187) (reverse g188) (cdr args)) (g195)) (if (and (pair? (car g190)) (pair? (cdar g190)) (null? (cddar g190))) (g189 (cdr g190) (cons (cadar g190) g188) (cons (caar g190) g187)) (g195)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g186 (caaar args) (cadaar args) (cdr args)) (let g189 ((g190 (car args)) (g188 '()) (g187 '())) (if (null? g190) (g195) (if (and (pair? (car g190)) (pair? (cdar g190)) (null? (cddar g190))) (g189 (cdr g190) (cons (cadar g190) g188) (cons (caar g190) g187)) (g195))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g199 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g189 ((g190 (car args)) (g188 '()) (g187 '())) (if (null? g190) (g195) (if (and (pair? (car g190)) (pair? (cdar g190)) (null? (cddar g190))) (g189 (cdr g190) (cons (cadar g190) g188) (cons (caar g190) g187)) (g195))))) (let g189 ((g190 (car args)) (g188 '()) (g187 '())) (if (null? g190) (if (and (list? (cdr args)) (pair? (cdr args))) (g194 (reverse g187) (reverse g188) (cdr args)) (g195)) (if (and (pair? (car g190)) (pair? (cdar g190)) (null? (cddar g190))) (g189 (cdr g190) (cons (cadar g190) g188) (cons (caar g190) g187)) (g195)))))) (let g189 ((g190 (car args)) (g188 '()) (g187 '())) (if (null? g190) (if (and (list? (cdr args)) (pair? (cdr args))) (g194 (reverse g187) (reverse g188) (cdr args)) (g195)) (if (and (pair? (car g190)) (pair? (cdar g190)) (null? (cddar g190))) (g189 (cdr g190) (cons (cadar g190) g188) (cons (caar g190) g187)) (g195))))) (g195))) (g195)))) (defmacro match-define args (let ((g210 (cadddr match:expanders)) (g209 (lambda () (match:syntax-err `(match-define ,@args) "syntax error in")))) (if (pair? args) (if (g210 (car args)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda () `(begin (define ,@args)))) (g209)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda (pat exp) ((caddr match:expanders) pat exp `(match-define ,@args))) (car args) (cadr args)) (g209))) (g209)))) (define match:runtime-structures #f) (define match:set-runtime-structures (lambda (v) (set! match:runtime-structures v))) (define match:primitive-vector? vector?) (defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) '()) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g227 (lambda () (match:syntax-err `(defstruct ,@args) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g229 ((g230 (cdddr args)) (g228 '())) (if (null? g230) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gentemp) `',(match:make-structure-tag name))) (vectorp (cond ((eq? match:structure-control 'disjoint) 'match:primitive-vector?) ((eq? match:structure-control 'vector) 'vector?)))) (cond ((eq? match:structure-control 'disjoint) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control 'vector) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err '(vector disjoint) "invalid value for match:structure-control, legal values are"))) `(begin ,@(if match:runtime-structures `((define ,tag (match:make-structure-tag ',name))) '()) (define ,constructor (lambda ,selectors (vector ,tag ,@selectors))) (define ,predicate (lambda (obj) (and (,vectorp obj) (= (vector-length obj) ,(+ 1 (length selectors))) (eq? (vector-ref obj 0) ,tag)))) ,@(filter-map-with-index (lambda (n i) `(define ,n (lambda (obj) (vector-ref obj ,i)))) selectors) ,@(filter-map-with-index (lambda (n i) (and n `(define ,n (lambda (obj newval) (vector-set! obj ,i newval))))) mutators)))) (car args) (cadr args) (caddr args) (reverse g228)) (if (field? (car g230)) (g229 (cdr g230) (cons (car g230) g228)) (g227)))) (g227))))) (defmacro define-structure args (let ((g242 (lambda () (match:syntax-err `(define-structure ,@args) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) `(define-structure (,name ,@id1) ())) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g239 ((g240 (cadr args)) (g238 '()) (g237 '())) (if (null? g240) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) '@) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () `(! ,id))))))) `(define-const-structure (,name ,@(map mk-id id1)) ,(map (lambda (id v) `(,(mk-id id) ,v)) id2 val)))) (caar args) (cdar args) (reverse g237) (reverse g238)) (g242)) (if (and (pair? (car g240)) (pair? (cdar g240)) (null? (cddar g240))) (g239 (cdr g240) (cons (cadar g240) g238) (cons (caar g240) g237)) (g242)))) (g242))) (g242)))) (defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) '!) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) '()) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g266 (lambda () (match:syntax-err `(define-const-structure ,@args) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) `(define-const-structure (,name ,@id1) ())) (caar args) (cdar args)) (if (symbol? (caar args)) (let g259 ((g260 (cdar args)) (g258 '())) (if (null? g260) (if (and (pair? (cdr args)) (list? (cadr args))) (let g263 ((g264 (cadr args)) (g262 '()) (g261 '())) (if (null? g264) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append 'make-raw- name)) (constructor (symbol-append 'make- name)) (predicate (symbol-append name '?))) `(begin (defstruct ,name ,raw-constructor ,predicate ,@(filter-map-with-index (lambda (arg i) (if (has-mutator? arg) `(,(symbol-append name '- i) ,(symbol-append 'set- name '- i '!)) (symbol-append name '- i))) id1id2)) ,(let* ((make-fresh (lambda (x) (if (eq? '_ x) (gentemp) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) `(define ,constructor (lambda ,names1 (let* ,(map list names2 val) (,raw-constructor ,@names1 ,@names2))))) ,@(filter-map-with-index (lambda (field i) (if (eq? (field-name field) '_) #f `(define (unquote (symbol-append name '- (field-name field))) ,(symbol-append name '- i)))) id1id2) ,@(filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) '_) (not (has-mutator? field))) #f `(define (unquote (symbol-append 'set- name '- (field-name field) '!)) ,(symbol-append 'set- name '- i '!)))) id1id2)))) (caar args) (reverse g258) (reverse g261) (reverse g262)) (g266)) (if (and (pair? (car g264)) (field? (caar g264)) (pair? (cdar g264)) (null? (cddar g264))) (g263 (cdr g264) (cons (cadar g264) g262) (cons (caar g264) g261)) (g266)))) (g266)) (if (field? (car g260)) (g259 (cdr g260) (cons (car g260) g258)) (g266)))) (g266))) (g266))))) (define home-directory (or (getenv "HOME") (error "environment variable HOME is not defined"))) (defmacro recur args `(let ,@args)) (defmacro rec args (match args (((? symbol? x) v) `(letrec ((,x ,v)) ,x)))) (defmacro parameterize args (match args ((bindings exp ...) `(begin ,@exp)))) (define gensym gentemp) (define expand-once macroexpand-1) (defmacro check-increment-counter args #f) (define symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (format #f "~a" x)) l))))) (define gensym gentemp) (define andmap (lambda (f . lists) (cond ((null? (car lists)) (and)) ((null? (cdr (car lists))) (apply f (map car lists))) (else (and (apply f (map car lists)) (apply andmap f (map cdr lists))))))) (define true-object? (lambda (x) (eq? #t x))) (define false-object? (lambda (x) (eq? #f x))) (define void (lambda () (cond (#f #f)))) (defmacro when args (match args ((tst body __1) `(if ,tst (begin ,@body (void)) (void))))) (defmacro unless args (match args ((tst body __1) `(if ,tst (void) (begin ,@body (void)))))) (define should-never-reach (lambda (form) (slib:error "fell off end of " form))) (define make-cvector make-vector) (define cvector vector) (define cvector-length vector-length) (define cvector-ref vector-ref) (define cvector->list vector->list) (define list->cvector list->vector) (define-const-structure (record _)) (defmacro record args (match args ((((? symbol? id) exp) ...) `(make-record (list ,@(map (lambda (i x) `(cons ',i ,x)) id exp)))) (_ (slib:error "syntax error at " `(record ,@args))))) (defmacro field args (match args (((? symbol? id) exp) `(match ,exp (($ record x) (match (assq ',id x) (#f (slib:error "no field " ,id 'in (cons 'record (map car x)))) ((_ . x) x))) (_ (slib:error "not a record: " '(field ,id _))))) (_ (slib:error "syntax error at " `(field ,@args))))) (define-const-structure (module _)) (defmacro module args (match args (((i ...) defs ...) `(let () ,@defs (make-module (record ,@(map (lambda (x) (list x x)) i))))) (_ (slib:error "syntax error at " `(module ,@args))))) (defmacro import args (match args ((((mod defs ...) ...) body __1) (let* ((m (map (lambda (_) (gentemp)) mod)) (newdefs (let loop ((mod-names m) (l-defs defs)) (if (null? mod-names) '() (append (let ((m (car mod-names))) (map (match-lambda ((? symbol? x) `(,x (field ,x ,m))) (((? symbol? i) (? symbol? e)) `(,i (field ,e ,m))) (x (slib:error "ill-formed definition: " x))) (car l-defs))) (loop (cdr mod-names) (cdr l-defs))))))) `(let (unquote (map (lambda (m mod) `(,m (match ,mod (($ module x) x)))) m mod)) (let ,newdefs body ...)))))) (define raise (lambda vals (slib:error "Unhandled exception " vals))) (defmacro fluid-let args (match args ((((x val) ...) body __1) (let ((old-x (map (lambda (_) (gentemp)) x)) (swap-x (map (lambda (_) (gentemp)) x)) (swap (gentemp))) `(let ,(map list old-x val) (let ((,swap (lambda () (let ,(map list swap-x old-x) ,@(map (lambda (old x) `(set! ,old ,x)) old-x x) ,@(map (lambda (x swap) `(set! ,x ,swap)) x swap-x))))) (dynamic-wind ,swap (lambda () ,@body) ,swap))))) (_ (slib:error "syntax error at " `(fluid-let ,@args))))) (defmacro handle args (match args ((e h) (let ((k (gentemp)) (exn (gentemp))) `((call-with-current-continuation (lambda (k) (fluid-let ((raise (lambda ,exn (k (lambda () (apply ,h ,exn)))))) (let ((v ,e)) (lambda () v)))))))) (_ (slib:error "syntax error in " `(handle ,@args))))) (defmacro : args (match args ((typeexp exp) exp))) (defmacro module: args (match args ((((i type) ...) defs ...) `(let () ,@defs (make-module (record ,@(map (lambda (i type) `(,i (: ,type ,i))) i type))))))) (defmacro define: args (match args ((name type exp) `(define ,name (: ,type ,exp))))) (define st:failure (lambda (chk fmt . args) (slib:error (apply format #f (string-append "~a : " fmt) chk args)))) (defmacro check-bound args (match args ((var) var) (x (st:failure `(check-bound ,@x) "syntax-error")))) (defmacro clash args (match args ((name info ...) name) (x (st:failure `(clash ,@x) "syntax error")))) (defmacro check-lambda args (match args (((id info ...) (? symbol? args) body __1) `(lambda ,args (check-increment-counter ,id) ,@body)) (((id info ...) args body __1) (let* ((n 0) (chk (let loop ((a args) (nargs 0)) (cond ((pair? a) (loop (cdr a) (+ 1 nargs))) ((null? a) (set! n nargs) `(= ,nargs (length args))) (else (set! n nargs) `(<= ,nargs (length args)))))) (incr (if (number? id) `(check-increment-counter ,id) #f))) `(let ((lam (lambda ,args ,@body))) (lambda args ,incr (if ,chk (apply lam args) ,(if (eq? '= (car chk)) `(st:failure '(check-lambda ,id ,@info) "requires ~a arguments, passed: ~a" ,n args) `(st:failure '(check-lambda ,id ,@info) "requires >= ~a arguments, passed: ~a" ,n args))))))) (x (st:failure `(check-lambda ,@x) "syntax error")))) (defmacro check-ap args (match args (((id info ...) (? symbol? f) args ...) `(begin (check-increment-counter ,id) (if (procedure? ,f) (,f ,@args) (st:failure '(check-ap ,id ,@info) "not a procedure: ~a" ,f)))) (((id info ...) f args ...) `((lambda (proc . args) (check-increment-counter ,id) (if (procedure? proc) (apply proc args) (st:failure '(check-ap ,id ,@info) "not a procedure: ~a" proc))) ,f ,@args)) (x (st:failure `(check-ap ,@x) "syntax error")))) (defmacro check-field args (match args (((id info ...) (? symbol? f) exp) `(match ,exp (($ record x) (match (assq ',f x) (#f (st:failure '(check-field ,id ,@info) "no ~a field in (record ~a)" ',f (map car x))) ((_ . x) x))) (v (st:failure '(check-field ,id ,@info) "not a record: ~a" v)))) (x (st:failure `(check-field ,@x) "syntax error")))) (defmacro check-match args (match args (((id info ...) exp (and clause (pat _ __1)) ...) (letrec ((last (lambda (pl) (if (null? (cdr pl)) (car pl) (last (cdr pl)))))) (if (match (last pat) ((? symbol?) #t) (('and subp ...) (andmap symbol? subp)) (_ #f)) `(begin (check-increment-counter ,id) (match ,exp ,@clause)) `(begin (check-increment-counter ,id) (match ,exp ,@clause (x (st:failure '(check-match ,id ,@info) "no matching clause for ~a" x))))))) (x (st:failure `(check-match ,@x) "syntax error")))) (defmacro check-: args (match args (((id info ...) typeexp exp) `(st:failure '(check-: ,id ,@info) "static type annotation reached")) (x (st:failure `(check-: ,@x) "syntax error")))) (defmacro make-check-typed args (match args ((prim) (let ((chkprim (symbol-append 'check- prim))) (list 'defmacro chkprim 'id (list 'quasiquote `(lambda a (check-increment-counter (,'unquote (car id))) (if (null? a) (,prim) (st:failure (cons ',chkprim '(,'unquote id)) "invalid arguments: ~a" a))))))) ((prim '_) (let ((chkprim (symbol-append 'check- prim))) (list 'defmacro chkprim 'id (list 'quasiquote `(lambda a (check-increment-counter (,'unquote (car id))) (if (= 1 (length a)) (,prim (car a)) (st:failure (cons ',chkprim '(,'unquote id)) "invalid arguments: ~a" a))))))) ((prim type1) (let ((chkprim (symbol-append 'check- prim))) (list 'defmacro chkprim 'id (list 'quasiquote `(lambda a (check-increment-counter (,'unquote (car id))) (if (and (= 1 (length a)) (,type1 (car a))) (,prim (car a)) (st:failure (cons ',chkprim '(,'unquote id)) "invalid arguments: ~a" a))))))) ((prim '_ '_) (let ((chkprim (symbol-append 'check- prim))) (list 'defmacro chkprim 'id (list 'quasiquote `(lambda a (check-increment-counter (,'unquote (car id))) (if (= 2 (length a)) (,prim (car a) (cadr a)) (st:failure (cons ',chkprim '(,'unquote id)) "invalid arguments: ~a" a))))))) ((prim '_ type2) (let ((chkprim (symbol-append 'check- prim))) (list 'defmacro chkprim 'id (list 'quasiquote `(lambda a (check-increment-counter (,'unquote (car id))) (if (and (= 2 (length a)) (,type2 (cadr a))) (,prim (car a) (cadr a)) (st:failure (cons ',chkprim '(,'unquote id)) "invalid arguments: ~a" a))))))) ((prim type1 '_) (let ((chkprim (symbol-append 'check- prim))) (list 'defmacro chkprim 'id (list 'quasiquote `(lambda a (check-increment-counter (,'unquote (car id))) (if (and (= 2 (length a)) (,type1 (car a))) (,prim (car a) (cadr a)) (st:failure (cons ',chkprim '(,'unquote id)) "invalid arguments: ~a" a))))))) ((prim type1 type2) (let ((chkprim (symbol-append 'check- prim))) (list 'defmacro chkprim 'id (list 'quasiquote `(lambda a (check-increment-counter (,'unquote (car id))) (if (and (= 2 (length a)) (,type1 (car a)) (,type2 (cadr a))) (,prim (car a) (cadr a)) (st:failure (cons ',chkprim '(,'unquote id)) "invalid arguments: ~a" a))))))) ((prim types ...) (let ((nargs (length types)) (chkprim (symbol-append 'check- prim)) (types (map (match-lambda ('_ '(lambda (_) #t)) (x x)) types))) (list 'defmacro chkprim 'id (list 'quasiquote `(lambda a (check-increment-counter (,'unquote (car id))) (if (and (= ,nargs (length a)) (andmap (lambda (f a) (f a)) (list ,@types) a)) (apply ,prim a) (st:failure (cons ',chkprim '(,'unquote id)) "invalid arguments: ~a" a))))))))) (defmacro make-check-selector args (match args ((prim pat) (let ((chkprim (symbol-append 'check- prim))) (list 'defmacro chkprim 'id (list 'quasiquote `(lambda a (check-increment-counter (,'unquote (car id))) (match a ((,pat) x) (_ (st:failure (cons ',chkprim '(,'unquote id)) "invalid arguments: ~a" a)))))))))) (make-check-typed number? _) (make-check-typed null? _) (make-check-typed char? _) (make-check-typed symbol? _) (make-check-typed string? _) (make-check-typed vector? _) (make-check-typed box? _) (make-check-typed pair? _) (make-check-typed procedure? _) (make-check-typed eof-object? _) (make-check-typed input-port? _) (make-check-typed output-port? _) (make-check-typed true-object? _) (make-check-typed false-object? _) (make-check-typed boolean? _) (make-check-typed list? _) (make-check-typed not _) (make-check-typed eqv? _ _) (make-check-typed eq? _ _) (make-check-typed equal? _ _) (make-check-typed cons _ _) (make-check-selector car (x . _)) (make-check-selector cdr (_ . x)) (make-check-selector caar ((x . _) . _)) (make-check-selector cadr (_ x . _)) (make-check-selector cdar ((_ . x) . _)) (make-check-selector cddr (_ _ . x)) (make-check-selector caaar (((x . _) . _) . _)) (make-check-selector caadr (_ (x . _) . _)) (make-check-selector cadar ((_ x . _) . _)) (make-check-selector caddr (_ _ x . _)) (make-check-selector cdaar (((_ . x) . _) . _)) (make-check-selector cdadr (_ (_ . x) . _)) (make-check-selector cddar ((_ _ . x) . _)) (make-check-selector cdddr (_ _ _ . x)) (make-check-selector caaaar ((((x . _) . _) . _) . _)) (make-check-selector caaadr (_ ((x . _) . _) . _)) (make-check-selector caadar ((_ (x . _) . _) . _)) (make-check-selector caaddr (_ _ (x . _) . _)) (make-check-selector cadaar (((_ x . _) . _) . _)) (make-check-selector cadadr (_ (_ x . _) . _)) (make-check-selector caddar ((_ _ x . _) . _)) (make-check-selector cadddr (_ _ _ x . _)) (make-check-selector cdaaar ((((_ . x) . _) . _) . _)) (make-check-selector cdaadr (_ ((_ . x) . _) . _)) (make-check-selector cdadar ((_ (_ . x) . _) . _)) (make-check-selector cdaddr (_ _ (_ . x) . _)) (make-check-selector cddaar (((_ _ . x) . _) . _)) (make-check-selector cddadr (_ (_ _ . x) . _)) (make-check-selector cdddar ((_ _ _ . x) . _)) (make-check-selector cddddr (_ _ _ _ . x)) (make-check-typed set-car! pair? _) (make-check-typed set-cdr! pair? _) (defmacro check-list id `(lambda a (check-increment-counter ,(car id)) (apply list a))) (make-check-typed length list?) (defmacro check-append id `(lambda a (check-increment-counter ,(car id)) (let loop ((b a)) (match b (() #t) ((l) #t) (((? list?) . y) (loop y)) (_ (st:failure (cons 'check-append ',id) "invalid arguments: ~a" a)))) (apply append a))) (make-check-typed reverse list?) (make-check-typed list-tail list? number?) (make-check-typed list-ref list? number?) (make-check-typed memq _ list?) (make-check-typed memv _ list?) (make-check-typed member _ list?) (defmacro check-assq id `(lambda a (check-increment-counter ,(car id)) (if (and (= 2 (length a)) (list? (cadr a)) (andmap pair? (cadr a))) (assq (car a) (cadr a)) (st:failure (cons 'check-assq ',id) "invalid arguments: ~a" a)))) (defmacro check-assv id `(lambda a (check-increment-counter ,(car id)) (if (and (= 2 (length a)) (list? (cadr a)) (andmap pair? (cadr a))) (assv (car a) (cadr a)) (st:failure (cons 'check-assv ',id) "invalid arguments: ~a" a)))) (defmacro check-assoc id `(lambda a (check-increment-counter ,(car id)) (if (and (= 2 (length a)) (list? (cadr a)) (andmap pair? (cadr a))) (assoc (car a) (cadr a)) (st:failure (cons 'check-assoc ',id) "invalid arguments: ~a" a)))) (make-check-typed symbol->string symbol?) (make-check-typed string->symbol string?) (make-check-typed complex? _) (make-check-typed real? _) (make-check-typed rational? _) (make-check-typed integer? _) (make-check-typed exact? number?) (make-check-typed inexact? number?) (defmacro check-= id `(lambda a (check-increment-counter ,(car id)) (if (and (<= 2 (length a)) (andmap number? a)) (apply = a) (st:failure (cons 'check-= ',id) "invalid arguments: ~a" a)))) (defmacro check-< id `(lambda a (check-increment-counter ,(car id)) (if (and (<= 2 (length a)) (andmap number? a)) (apply < a) (st:failure (cons 'check-< ',id) "invalid arguments: ~a" a)))) (defmacro check-> id `(lambda a (check-increment-counter ,(car id)) (if (and (<= 2 (length a)) (andmap number? a)) (apply > a) (st:failure (cons 'check-> ',id) "invalid arguments: ~a" a)))) (defmacro check-<= id `(lambda a (check-increment-counter ,(car id)) (if (and (<= 2 (length a)) (andmap number? a)) (apply <= a) (st:failure (cons 'check-<= ',id) "invalid arguments: ~a" a)))) (defmacro check->= id `(lambda a (check-increment-counter ,(car id)) (if (and (<= 2 (length a)) (andmap number? a)) (apply >= a) (st:failure (cons 'check->= ',id) "invalid arguments: ~a" a)))) (make-check-typed zero? number?) (make-check-typed positive? number?) (make-check-typed negative? number?) (make-check-typed odd? number?) (make-check-typed even? number?) (defmacro check-max id `(lambda a (check-increment-counter ,(car id)) (if (and (<= 1 (length a)) (andmap number? a)) (apply max a) (st:failure (cons 'check-max ',id) "invalid arguments: ~a" a)))) (defmacro check-min id `(lambda a (check-increment-counter ,(car id)) (if (and (<= 1 (length a)) (andmap number? a)) (apply min a) (st:failure (cons 'check-min ',id) "invalid arguments: ~a" a)))) (defmacro check-+ id `(lambda a (check-increment-counter ,(car id)) (if (andmap number? a) (apply + a) (st:failure (cons 'check-+ ',id) "invalid arguments: ~a" a)))) (defmacro check-* id `(lambda a (check-increment-counter ,(car id)) (if (andmap number? a) (apply * a) (st:failure (cons 'check-* ',id) "invalid arguments: ~a" a)))) (defmacro check-- id `(lambda a (check-increment-counter ,(car id)) (if (and (<= 1 (length a)) (andmap number? a)) (apply - a) (st:failure (cons 'check-- ',id) "invalid arguments: ~a" a)))) (defmacro check-/ id `(lambda a (check-increment-counter ,(car id)) (if (and (<= 1 (length a)) (andmap number? a)) (apply / a) (st:failure (cons 'check-/ ',id) "invalid arguments: ~a" a)))) (make-check-typed abs number?) (make-check-typed quotient number? number?) (make-check-typed remainder number? number?) (make-check-typed modulo number? number?) (defmacro check-gcd id `(lambda a (check-increment-counter ,(car id)) (if (andmap number? a) (apply gcd a) (st:failure (cons 'check-gcd ',id) "invalid arguments: ~a" a)))) (defmacro check-lcm id `(lambda a (check-increment-counter ,(car id)) (if (andmap number? a) (apply lcm a) (st:failure (cons 'check-lcm ',id) "invalid arguments: ~a" a)))) (make-check-typed numerator number?) (make-check-typed denominator number?) (make-check-typed floor number?) (make-check-typed ceiling number?) (make-check-typed truncate number?) (make-check-typed round number?) (make-check-typed rationalize number? number?) (make-check-typed exp number?) (make-check-typed log number?) (make-check-typed sin number?) (make-check-typed cos number?) (make-check-typed tan number?) (make-check-typed asin number?) (make-check-typed acos number?) (defmacro check-atan id `(lambda a (check-increment-counter ,(car id)) (if (and (andmap number? a) (pair? a) (>= 2 (length a))) (apply atan a) (st:failure (cons 'check-atan ',id) "invalid arguments: ~a" a)))) (make-check-typed sqrt number?) (make-check-typed expt number? number?) (make-check-typed make-rectangular number? number?) (make-check-typed make-polar number? number?) (make-check-typed real-part number?) (make-check-typed imag-part number?) (make-check-typed magnitude number?) (make-check-typed angle number?) (make-check-typed exact->inexact number?) (make-check-typed inexact->exact number?) (defmacro check-number->string id `(lambda a (check-increment-counter ,(car id)) (if (and (andmap number? a) (pair? a) (>= 2 (length a))) (apply number->string a) (st:failure (cons 'check-number->string ',id) "invalid arguments: ~a" a)))) (defmacro check-string->number id `(lambda a (check-increment-counter ,(car id)) (if (and (pair? a) (string? (car a)) (>= 2 (length a)) (or (null? (cdr a)) (number? (cadr a)))) (apply string->number a) (st:failure (cons 'check-string->number ',id) "invalid arguments: ~a" a)))) (make-check-typed char=? char? char?) (make-check-typed char? char? char?) (make-check-typed char<=? char? char?) (make-check-typed char>=? char? char?) (make-check-typed char-ci=? char? char?) (make-check-typed char-ci? char? char?) (make-check-typed char-ci<=? char? char?) (make-check-typed char-ci>=? char? char?) (make-check-typed char-alphabetic? char?) (make-check-typed char-numeric? char?) (make-check-typed char-whitespace? char?) (make-check-typed char-upper-case? char?) (make-check-typed char-lower-case? char?) (make-check-typed char->integer char?) (make-check-typed integer->char number?) (make-check-typed char-upcase char?) (make-check-typed char-downcase char?) (defmacro check-make-string id `(lambda a (check-increment-counter ,(car id)) (if (and (pair? a) (number? (car a)) (>= 2 (length a)) (or (null? (cdr a)) (char? (cadr a)))) (apply make-string a) (st:failure (cons 'check-make-string ',id) "invalid arguments: ~a" a)))) (defmacro check-string id `(lambda a (check-increment-counter ,(car id)) (if (andmap char? a) (apply string a) (st:failure (cons 'check-string ',id) "invalid arguments: ~a" a)))) (make-check-typed string-length string?) (make-check-typed string-ref string? number?) (make-check-typed string-set! string? number? char?) (make-check-typed string=? string? string?) (make-check-typed string? string? string?) (make-check-typed string<=? string? string?) (make-check-typed string>=? string? string?) (make-check-typed string-ci=? string? string?) (make-check-typed string-ci? string? string?) (make-check-typed string-ci<=? string? string?) (make-check-typed string-ci>=? string? string?) (make-check-typed substring string? number? number?) (defmacro check-string-append id `(lambda a (check-increment-counter ,(car id)) (if (andmap string? a) (apply string-append a) (st:failure (cons 'check-string-append ',id) "invalid arguments: ~a" a)))) (make-check-typed string->list string?) (defmacro check-list->string id `(lambda a (check-increment-counter ,(car id)) (if (and (= 1 (length a)) (list? (car a)) (andmap char? (car a))) (list->string (car a)) (st:failure (cons 'check-list->string ',id) "invalid arguments: ~a" a)))) (make-check-typed string-copy string?) (make-check-typed string-fill! string? char?) (make-check-typed make-vector number? _) (defmacro check-vector id `(lambda a (check-increment-counter ,(car id)) (apply vector a))) (make-check-typed vector-length vector?) (make-check-typed vector-ref vector? number?) (make-check-typed vector-set! vector? number? _) (make-check-typed vector->list vector?) (make-check-typed list->vector list?) (make-check-typed vector-fill! vector? _) (defmacro check-apply id `(lambda a (check-increment-counter ,(car id)) (if (pair? a) (let loop ((arg (cdr a))) (match arg (((? list?)) (apply apply a)) ((_ . y) (loop y)) (_ (st:failure (cons 'check-apply ',id) "invalid arguments: ~a" a)))) (st:failure `(check-apply ,@id) "invalid arguments: ~a" a)))) (defmacro check-map id `(lambda a (check-increment-counter ,(car id)) (if (and (<= 2 (length a)) (procedure? (car a)) (andmap list? (cdr a))) (apply map a) (st:failure (cons 'check-map ',id) "invalid arguments: ~a" a)))) (defmacro check-for-each id `(lambda a (check-increment-counter ,(car id)) (if (and (<= 2 (length a)) (procedure? (car a)) (andmap list? (cdr a))) (apply for-each a) (st:failure (cons 'check-for-each ',id) "invalid arguments: ~a" a)))) (make-check-typed force procedure?) (defmacro check-call-with-current-continuation id `(lambda a (check-increment-counter ,(car id)) (if (and (= 1 (length a)) (procedure? (car a))) (call-with-current-continuation (lambda (k) ((car a) (check-lambda (continuation) (x) (k x))))) (st:failure (cons 'check-call-with-current-continuation ',id) "invalid arguments: ~a" a)))) (make-check-typed call-with-input-file string? procedure?) (make-check-typed call-with-output-file string? procedure?) (make-check-typed input-port? _) (make-check-typed output-port? _) (make-check-typed current-input-port) (make-check-typed current-output-port) (make-check-typed with-input-from-file string? procedure?) (make-check-typed with-output-to-file string? procedure?) (make-check-typed open-input-file string?) (make-check-typed open-output-file string?) (make-check-typed close-input-port input-port?) (make-check-typed close-output-port output-port?) (defmacro check-read id `(lambda a (check-increment-counter ,(car id)) (if (or (null? a) (and (= 1 (length a)) (input-port? (car a)))) (apply read a) (st:failure (cons 'check-read ',id) "invalid arguments: ~a" a)))) (defmacro check-read-char id `(lambda a (check-increment-counter ,(car id)) (if (or (null? a) (and (= 1 (length a)) (input-port? (car a)))) (apply read-char a) (st:failure (cons 'check-read-char ',id) "invalid arguments: ~a" a)))) (defmacro check-peek-char id `(lambda a (check-increment-counter ,(car id)) (if (or (null? a) (and (= 1 (length a)) (input-port? (car a)))) (apply peek-char a) (st:failure (cons 'check-peek-char ',id) "invalid arguments: ~a" a)))) (defmacro check-char-ready? id `(lambda a (check-increment-counter ,(car id)) (if (or (null? a) (and (= 1 (length a)) (input-port? (car a)))) (apply char-ready? a) (st:failure (cons 'check-char-ready? ',id) "invalid arguments: ~a" a)))) (defmacro check-write id `(lambda a (check-increment-counter ,(car id)) (if (and (pair? a) (or (null? (cdr a)) (output-port? (cadr a)))) (apply write a) (st:failure (cons 'check-write ',id) "invalid arguments: ~a" a)))) (defmacro check-display id `(lambda a (check-increment-counter ,(car id)) (if (and (pair? a) (or (null? (cdr a)) (output-port? (cadr a)))) (apply display a) (st:failure (cons 'check-display ',id) "invalid arguments: ~a" a)))) (defmacro check-newline id `(lambda a (check-increment-counter ,(car id)) (if (or (null? a) (output-port? (car a))) (apply newline a) (st:failure (cons 'check-newline ',id) "invalid arguments: ~a" a)))) (defmacro check-write-char id `(lambda a (check-increment-counter ,(car id)) (if (and (pair? a) (char? (car a)) (or (null? (cdr a)) (output-port? (cadr a)))) (apply write-char a) (st:failure (cons 'check-write-char ',id) "invalid arguments: ~a" a)))) (make-check-typed load string?) (make-check-typed transcript-on string?) (make-check-typed transcript-off) (defmacro check-symbol-append id `(lambda a (check-increment-counter ,(car id)) (apply symbol-append a))) (make-check-typed box _) (make-check-typed unbox box?) (make-check-typed set-box! box? _) (make-check-typed void) (make-check-typed make-module _) (defmacro check-match:error id `(lambda a (check-increment-counter ,(car id)) (if (pair? a) (apply match:error a) (st:failure (cons 'check-match:error ',id) "invalid arguments: ~a" a)))) (make-check-typed should-never-reach symbol?) (defmacro check-make-cvector id `(lambda a (check-increment-counter ,(car id)) (if (and (pair? a) (number? (car a)) (= 2 (length a))) (apply make-cvector a) (st:failure (cons 'check-make-cvector ',id) "invalid arguments: ~a" a)))) (defmacro check-cvector id `(lambda a (check-increment-counter ,(car id)) (apply cvector a))) (make-check-typed cvector-length cvector?) (make-check-typed cvector-ref cvector? number?) (make-check-typed cvector->list cvector?) (make-check-typed list->cvector list?) (defmacro check-define-const-structure args (let ((field? (lambda (x) (or (symbol? x) (and (pair? x) (equal? (car x) '!) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x)))))) (arg-name (lambda (x) (if (symbol? x) x (cadr x)))) (with-mutator? (lambda (x) (not (symbol? x))))) (match args ((((? symbol? name) (? field? id1) ...)) (let ((constructor (symbol-append 'make- name)) (check-constructor (symbol-append 'check-make- name)) (predicate (symbol-append name '?)) (access (let loop ((l id1)) (cond ((null? l) '()) ((eq? '_ (arg-name (car l))) (loop (cdr l))) (else (cons (symbol-append name '- (arg-name (car l))) (loop (cdr l))))))) (assign (let loop ((l id1)) (cond ((null? l) '()) ((eq? '_ (arg-name (car l))) (loop (cdr l))) ((not (with-mutator? (car l))) (loop (cdr l))) (else (cons (symbol-append 'set- name '- (arg-name (car l)) '!) (loop (cdr l))))))) (nargs (length id1))) `(begin (define-const-structure (,name ,@id1) ()) (defmacro ,check-constructor id (lambda a (check-increment-counter (,'unquote (car id))) (if (= ,nargs (length a)) (apply ,constructor a) (st:failure (cons ',check-constructor '(,'unquote id)) "invalid arguments: ~a" a)))) (make-check-typed ,predicate _) ,@(map (lambda (a) `(make-check-typed ,a ,predicate)) access) ,@(map (lambda (a) `(make-check-typed ,a ,predicate _)) assign)))) (x (st:failure `(check-define-const-structure ,@x) "syntax error"))))) (if (equal? '(match 1) (macroexpand-1 '(match 1))) (load "/home/wright/scheme/match/match-slib.scm")) (define sprintf (lambda args (apply format #f args))) (define printf (lambda args (apply format #t args))) (define disaster (lambda (context fmt . args) (slib:error (apply sprintf (string-append "in ~a: " fmt) context args)))) (define use-error (lambda (fmt . args) (slib:error (apply sprintf fmt args)))) (define syntax-err (lambda (context fmt . args) (newline) (if context (pretty-print context)) (slib:error (apply sprintf (string-append "in syntax: " fmt) args)))) (define flush-output force-output) (define print-context (lambda (obj depth) (pretty-print (recur loop ((obj obj) (n 0)) (if (pair? obj) (if (< n depth) (cons (loop (car obj) (+ 1 n)) (loop (cdr obj) n)) '(...)) obj))))) (define *box-tag* (gensym)) (define box (lambda (a) (cons *box-tag* a))) (define box? (lambda (b) (and (pair? b) (eq? (car b) *box-tag*)))) (define unbox cdr) (define box-1 cdr) (define set-box! set-cdr!) (define sort-list sort) (define expand-once-if-macro (lambda (e) (and (macro? (car e)) (macroexpand-1 e)))) (define ormap (lambda (f . lists) (if (null? (car lists)) (or) (or (apply f (map car lists)) (apply ormap f (map cdr lists)))))) (define call/cc call-with-current-continuation) (define (cpu-time) 0) (define (pretty-print x) (display x) (newline)) (define clock-granularity 1.0e-3) (define set-vector! vector-set!) (define set-string! string-set!) (define maplr (lambda (f l) (match l (() '()) ((x . y) (let ((v (f x))) (cons v (maplr f y))))))) (define maprl (lambda (f l) (match l (() '()) ((x . y) (let ((v (maprl f y))) (cons (f x) v)))))) (define foldl (lambda (f i l) (recur loop ((l l) (acc i)) (match l (() acc) ((x . y) (loop y (f x acc))))))) (define foldr (lambda (f i l) (recur loop ((l l)) (match l (() i) ((x . y) (f x (loop y))))))) (define filter (lambda (p l) (match l (() '()) ((x . y) (if (p x) (cons x (filter p y)) (filter p y)))))) (define filter-map (lambda (p l) (match l (() '()) ((x . y) (match (p x) (#f (filter-map p y)) (x (cons x (filter-map p y)))))))) (define rac (lambda (l) (match l ((last) last) ((_ . rest) (rac rest))))) (define rdc (lambda (l) (match l ((_) '()) ((x . rest) (cons x (rdc rest)))))) (define map-with-n (lambda (f l) (recur loop ((l l) (n 0)) (match l (() '()) ((x . y) (let ((v (f x n))) (cons v (loop y (+ 1 n))))))))) (define readfile (lambda (f) (with-input-from-file f (letrec ((rf (lambda () (match (read) ((? eof-object?) '()) (sexp (cons sexp (rf))))))) rf)))) (define map2 (lambda (f a b) (match (cons a b) ((()) '()) (((ax . ay) bx . by) (let ((v (f ax bx))) (cons v (map2 f ay by)))) (else (error 'map2 "lists differ in length"))))) (define for-each2 (lambda (f a b) (match (cons a b) ((()) (void)) (((ax . ay) bx . by) (f ax bx) (for-each2 f ay by)) (else (error 'for-each2 "lists differ in length"))))) (define andmap2 (lambda (f a b) (match (cons a b) ((()) (and)) (((ax) bx) (f ax bx)) (((ax . ay) bx . by) (and (f ax bx) (andmap2 f ay by))) (else (error 'andmap2 "lists differ in length"))))) (define ormap2 (lambda (f a b) (match (cons a b) ((()) (or)) (((ax) bx) (f ax bx)) (((ax . ay) bx . by) (or (f ax bx) (ormap2 f ay by))) (else (error 'ormap2 "lists differ in length"))))) (define empty-set '()) (define empty-set? null?) (define set (lambda l (list->set l))) (define list->set (match-lambda (() '()) ((x . y) (if (memq x y) (list->set y) (cons x (list->set y)))))) (define element-of? (lambda (x set) (and (memq x set) #t))) (define cardinality length) (define set<= (lambda (a b) (foldr (lambda (a-elt acc) (and acc (memq a-elt b) #t)) (and) a))) (define set-eq? (lambda (a b) (and (= (cardinality a) (cardinality b)) (set<= a b)))) (define union2 (lambda (a b) (if (null? b) a (foldr (lambda (x b) (if (memq x b) b (cons x b))) b a)))) (define union (lambda l (foldr union2 '() l))) (define setdiff2 (lambda (a b) (if (null? b) a (foldr (lambda (x c) (if (memq x b) c (cons x c))) '() a)))) (define setdiff (lambda l (if (null? l) '() (setdiff2 (car l) (foldr union2 '() (cdr l)))))) (define intersect2 (lambda (a b) (if (null? b) a (foldr (lambda (x c) (if (memq x b) (cons x c) c)) '() a)))) (define intersect (lambda l (if (null? l) '() (foldl intersect2 (car l) l)))) (define-const-structure (some _)) (define-const-structure (none)) (define none (make-none)) (define some make-some) (define-const-structure (and exps)) (define-const-structure (app exp exps)) (define-const-structure (begin exps)) (define-const-structure (const val pred)) (define-const-structure (if exp1 exp2 exp3)) (define-const-structure (lam names body)) (define-const-structure (let binds body)) (define-const-structure (let* binds body)) (define-const-structure (letr binds body)) (define-const-structure (or exps)) (define-const-structure (prim name)) (define-const-structure (delay exp)) (define-const-structure (set! (! name) exp)) (define-const-structure (var (! name))) (define-const-structure (vlam names name body)) (define-const-structure (match exp mclauses)) (define-const-structure (record binds)) (define-const-structure (field name exp)) (define-const-structure (cast type exp)) (define-const-structure (body defs exps)) (define-const-structure (bind name exp)) (define-const-structure (mclause pat body fail)) (define-const-structure (pvar name)) (define-const-structure (pany)) (define-const-structure (pelse)) (define-const-structure (pconst name pred)) (define-const-structure (pobj name pats)) (define-const-structure (ppred name)) (define-const-structure (pand pats)) (define-const-structure (pnot pat)) (define-const-structure (define name (! exp))) (define-const-structure (defstruct tag args make pred get set getn setn mutable)) (define-const-structure (datatype _)) (define-const-structure (variant con pred arg-types)) (define-structure (name name ty timestamp occ mutated gdef primitive struct pure predicate variant selector)) (define-structure (type ty exp)) (define-const-structure (shape _ _)) (define-const-structure (check _ _)) (define parse-def (lambda (def) (let ((parse-name (match-lambda ((? symbol? s) (if (keyword? s) (syntax-err def "invalid use of keyword ~a" s) s)) (n (syntax-err def "invalid variable at ~a" n))))) (match def (('extend-syntax ((? symbol? name) . _) . _) (printf "Note: installing but _not_ checking (extend-syntax (~a) ...)~%" name) (eval def) '()) (('extend-syntax . _) (syntax-err def "invalid syntax")) (('defmacro (? symbol? name) . _) (printf "Note: installing but _not_ checking (defmacro ~a ...)~%" name) (eval def) '()) (('defmacro . _) (syntax-err def "invalid syntax")) (('define (? symbol? n) e) (list (make-define (parse-name n) (parse-exp e)))) (('define (n . args) . body) (list (make-define (parse-name n) (parse-exp `(lambda ,args ,@body))))) (('define . _) (syntax-err def "at define")) (('begin . defs) (foldr append '() (smap parse-def defs))) (('define-structure (n . args)) (parse-def `(define-structure (,n ,@args) ()))) (('define-structure (n . args) inits) (let ((m-args (smap (lambda (x) `(! ,x)) args)) (m-inits (smap (match-lambda ((x e) `((! ,x) ,e)) (_ (syntax-err def "invalid structure initializer"))) inits))) (parse-def `(define-const-structure (,n ,@m-args) ,m-inits)))) (('define-const-structure ((? symbol? n) . args)) (parse-def `(define-const-structure (,n ,@args) ()))) (('define-const-structure ((? symbol? n) . args) ()) (letrec ((smap-with-n (lambda (f l) (recur loop ((l l) (n 0)) (match l (() '()) ((x . y) (let ((v (f x n))) (cons v (loop y (+ 1 n))))) (_ (syntax-err l "invalid list")))))) (parse-arg (lambda (a index) (match a (('! '_) (list none none (some (symbol-append n '- (+ index 1))) (some (symbol-append 'set- n '- (+ index 1) '!)) #t)) (('! a) (let ((a (parse-name a))) (list (some (symbol-append n '- a)) (some (symbol-append 'set- n '- a '!)) (some (symbol-append n '- (+ index 1))) (some (symbol-append 'set- n '- (+ index 1) '!)) #t))) ('_ (list none none (some (symbol-append n '- (+ index 1))) none #f)) (a (let ((a (parse-name a))) (list (some (symbol-append n '- a)) none (some (symbol-append n '- (+ index 1))) none #f))))))) (let* ((arg-info (smap-with-n parse-arg args)) (get (map car arg-info)) (set (map cadr arg-info)) (getn (map caddr arg-info)) (setn (map cadddr arg-info)) (mutable (map (lambda (x) (car (cddddr x))) arg-info))) (list (make-defstruct n (cons n args) (symbol-append 'make- n) (symbol-append n '?) get set getn setn mutable))))) (('define-const-structure ((? symbol? n) . args) inits) (syntax-err def "sorry, structure initializers are not supported")) (('datatype . d) (let* ((parse-variant (match-lambda (((? symbol? con) ? list? args) (let ((n (parse-name con))) (make-variant (symbol-append 'make- n) (symbol-append n '?) (cons con args)))) (_ (syntax-err def "invalid datatype syntax")))) (parse-dt (match-lambda (((? symbol? type) . variants) (cons (list (parse-name type)) (smap parse-variant variants))) ((((? symbol? type) ? list? targs) . variants) (cons (cons (parse-name type) (smap parse-name targs)) (smap parse-variant variants))) (_ (syntax-err def "invalid datatype syntax"))))) (list (make-datatype (smap parse-dt d))))) (((? symbol? k) . _) (cond ((and (not (keyword? k)) (expand-once-if-macro def)) => parse-def) (else (list (make-define #f (parse-exp def)))))) (_ (list (make-define #f (parse-exp def)))))))) (define keep-match #t) (define parse-exp (lambda (expression) (letrec ((n-primitive (string->symbol "#primitive")) (parse-exp (match-lambda (('quote (? symbol? s)) (make-const s 'symbol?)) ((and m ('quote _)) (parse-exp (quote-tf m))) ((and m ('quasiquote _)) (parse-exp (quasiquote-tf m))) ((and m (? box?)) (parse-exp (quote-tf m))) ((and m (? vector?)) (parse-exp (quote-tf m))) ((and m ('cond . _)) (parse-exp (cond-tf m))) ((and m ('case . _)) (parse-exp (case-tf m))) ((and m ('do . _)) (parse-exp (do-tf m))) ((? symbol? s) (make-var (parse-name s))) (#t (make-const #t 'true-object?)) (#f (make-const #f 'false-object?)) ((? null? c) (make-const c 'null?)) ((? number? c) (make-const c 'number?)) ((? char? c) (make-const c 'char?)) ((? string? c) (make-const c 'string?)) ((': ty e1) (make-cast ty (parse-exp e1))) ((and exp ('record . bind)) (let ((bindings (smap parse-bind bind))) (no-repeats (map bind-name bindings) exp) (make-record bindings))) ((and exp ('field name e1)) (make-field (parse-name name) (parse-exp e1))) ((and exp ('match e clause0 . clauses)) (=> fail) (if keep-match (let* ((e2 (parse-exp e)) (parse-clause (match-lambda ((p ('=> (? symbol? failsym)) . body) (make-mclause (parse-pat p expression) (parse-body `((let ((,failsym (lambda () (,failsym)))) ,@body))) failsym)) ((p . body) (make-mclause (parse-pat p expression) (parse-body body) #f)) (_ (syntax-err exp "invalid match clause"))))) (make-match e2 (smap parse-clause (cons clause0 clauses)))) (fail))) ((and exp ('lambda bind . body)) (recur loop ((b bind) (names '())) (match b ((? symbol? n) (let ((rest (parse-name n))) (no-repeats (cons rest names) exp) (make-vlam (reverse names) rest (parse-body body)))) (() (no-repeats names exp) (make-lam (reverse names) (parse-body body))) ((n . x) (loop x (cons (parse-name n) names))) (_ (syntax-err exp "invalid lambda expression"))))) (('if e1 e2 e3) (make-if (parse-exp e1) (parse-exp e2) (parse-exp e3))) ((and if-expr ('if e1 e2)) (printf "Note: one-armed if: ") (print-context if-expr 2) (make-if (parse-exp e1) (parse-exp e2) (parse-exp '(void)))) (('delay e) (make-delay (parse-exp e))) (('set! n e) (make-set! (parse-name n) (parse-exp e))) (('and . args) (make-and (smap parse-exp args))) (('or . args) (make-or (smap parse-exp args))) ((and exp ('let (? symbol? n) bind . body)) (let* ((nb (parse-name n)) (bindings (smap parse-bind bind))) (no-repeats (map bind-name bindings) exp) (make-app (make-letr (list (make-bind nb (make-lam (map bind-name bindings) (parse-body body)))) (make-body '() (list (make-var nb)))) (map bind-exp bindings)))) ((and exp ('let bind . body)) (let ((bindings (smap parse-bind bind))) (no-repeats (map bind-name bindings) exp) (make-let bindings (parse-body body)))) (('let* bind . body) (make-let* (smap parse-bind bind) (parse-body body))) ((and exp ('letrec bind . body)) (let ((bindings (smap parse-bind bind))) (no-repeats (map bind-name bindings) exp) (make-letr bindings (parse-body body)))) (('begin e1 . rest) (make-begin (smap parse-exp (cons e1 rest)))) (('define . _) (syntax-err expression "invalid context for internal define")) (('define-structure . _) (syntax-err expression "invalid context for internal define-structure")) (('define-const-structure . _) (syntax-err expression "invalid context for internal define-const-structure")) ((and m (f . args)) (cond ((and (eq? f n-primitive) (match args (((? symbol? p)) (make-prim p)) (_ #f)))) ((and (symbol? f) (not (keyword? f)) (expand-once-if-macro m)) => parse-exp) (else (make-app (parse-exp f) (smap parse-exp args))))) (x (syntax-err expression "invalid expression at ~a" x)))) (parse-name (match-lambda ((? symbol? s) (when (keyword? s) (syntax-err expression "invalid use of keyword ~a" s)) s) (n (syntax-err expression "invalid variable at ~a" n)))) (parse-bind (match-lambda ((x e) (make-bind (parse-name x) (parse-exp e))) (b (syntax-err expression "invalid binding at ~a" b)))) (parse-body (lambda (body) (recur loop ((b body) (defs '())) (match b (((and d ('define . _)) . rest) (loop rest (append defs (parse-def d)))) (((and d ('define-structure . _)) . rest) (loop rest (append defs (parse-def d)))) (((and d ('define-const-structure . _)) . rest) (loop rest (append defs (parse-def d)))) ((('begin) . rest) (loop rest defs)) (((and beg ('begin ('define . _) . _)) . rest) (loop rest (append defs (parse-def beg)))) (((and beg ('begin ('define-structure . _) . _)) . rest) (loop rest (append defs (parse-def beg)))) (((and beg ('begin ('define-const-structure . _) . _)) . rest) (loop rest (append defs (parse-def beg)))) ((_ . _) (make-body defs (smap parse-exp b))) (_ (syntax-err expression "invalid body at ~a" b)))))) (no-repeats (lambda (l exp) (match l (() #f) ((_) #f) ((x . l) (if (memq x l) (syntax-err exp "name ~a repeated" x) (no-repeats l exp))))))) (parse-exp expression)))) (define parse-pat (lambda (pat expression) (letrec ((parse-pat (match-lambda (#f (make-ppred 'false-object?)) (#t (make-ppred 'true-object?)) (() (make-ppred 'null?)) ((? number? c) (make-pconst c 'number?)) ((? char? c) (make-pconst c 'char?)) ((? string? c) (make-pconst c 'string?)) (('quote x) (parse-quote x)) ('_ (make-pany)) ('else (make-pelse)) ((? symbol? n) (make-pvar (parse-pname n))) (('not . pats) (syntax-err expression "not patterns are not supported")) (('or . pats) (syntax-err expression "or patterns are not supported")) (('get! . pats) (syntax-err expression "get! patterns are not supported")) (('set! . pats) (syntax-err expression "set! patterns are not supported")) (('and . pats) (let* ((pats (smap parse-pat pats)) (p (make-flat-pand pats)) (non-var? (match-lambda ((? pvar?) #f) ((? pany?) #f) (_ #t)))) (match p (($ pand pats) (when (< 1 (length (filter non-var? pats))) (syntax-err expression "~a has conflicting subpatterns" (ppat p)))) (_ #f)) p)) (('? (? symbol? pred) p) (parse-pat `(and (? ,pred) ,p))) (('? (? symbol? pred)) (if (keyword? pred) (syntax-err expression "invalid use of keyword ~a" pred) (make-ppred pred))) (('$ (? symbol? c) . args) (if (memq c '(? _ $)) (syntax-err expression "invalid use of pattern keyword ~a" c) (make-pobj (symbol-append c '?) (smap parse-pat args)))) ((? box? cb) (make-pobj 'box? (list (parse-pat (unbox cb))))) ((x . y) (make-pobj 'pair? (list (parse-pat x) (parse-pat y)))) ((? vector? v) (make-pobj 'vector? (map parse-pat (vector->list v)))) (m (syntax-err expression "invalid pattern at ~a" m)))) (parse-quote (match-lambda (#f (make-pobj 'false-object? '())) (#t (make-pobj 'true-object? '())) (() (make-pobj 'null? '())) ((? number? c) (make-pconst c 'number?)) ((? char? c) (make-pconst c 'char?)) ((? string? c) (make-pconst c 'string?)) ((? symbol? s) (make-pconst s 'symbol?)) ((? box? cb) (make-pobj 'box? (list (parse-quote (unbox cb))))) ((x . y) (make-pobj 'pair? (list (parse-quote x) (parse-quote y)))) ((? vector? v) (make-pobj 'vector? (map parse-quote (vector->list v)))) (m (syntax-err expression "invalid pattern at ~a" m)))) (parse-pname (match-lambda ((? symbol? s) (cond ((keyword? s) (syntax-err expression "invalid use of keyword ~a" s)) ((memq s '(? _ else $ and or not set! get! ...)) (syntax-err expression "invalid use of pattern keyword ~a" s)) (else s))) (n (syntax-err expression "invalid pattern variable at ~a" n))))) (parse-pat pat)))) (define smap (lambda (f l) (match l (() '()) ((x . r) (let ((v (f x))) (cons v (smap f r)))) (_ (syntax-err l "invalid list"))))) (define primitive (lambda (p) (list (string->symbol "#primitive") p))) (define keyword? (lambda (s) (or (memq s '(=> and begin case cond do define delay if lambda let let* letrec or quasiquote quote set! unquote unquote-splicing define-structure define-const-structure record field : datatype)) (and keep-match (eq? s 'match))))) (define make-flat-pand (lambda (pats) (let* ((l (foldr (lambda (p plist) (match p (($ pand pats) (append pats plist)) (_ (cons p plist)))) '() pats)) (concrete? (match-lambda ((? pconst?) #t) ((? pobj?) #t) ((? ppred?) #t) (_ #f))) (sorted (append (filter concrete? l) (filter (lambda (x) (not (concrete? x))) l)))) (match sorted ((p) p) (_ (make-pand sorted)))))) (define never-counter 0) (define reinit-macros! (lambda () (set! never-counter 0))) (define cond-tf (lambda (cond-expr) (recur loop ((e (cdr cond-expr))) (match e (() (begin (set! never-counter (+ 1 never-counter)) `(,(primitive 'should-never-reach) '(cond ,never-counter)))) ((('else b1 . body)) `(begin ,b1 ,@body)) ((('else . _) . _) (syntax-err cond-expr "invalid cond expression")) (((test '=> proc) . rest) (let ((g (gensym))) `(let ((,g ,test)) (if ,g (,proc ,g) ,(loop rest))))) (((#t b1 . body)) `(begin ,b1 ,@body)) (((test) . rest) `(or ,test ,(loop rest))) (((test . body) . rest) `(if ,test (begin ,@body) ,(loop rest))) (_ (syntax-err cond-expr "invalid cond expression")))))) (define scheme-cond-tf (lambda (cond-expr) (recur loop ((e (cdr cond-expr))) (match e (() `(,(primitive 'void))) ((('else b1 . body)) `(begin ,b1 ,@body)) ((('else . _) . _) (syntax-err cond-expr "invalid cond expression")) (((test '=> proc) . rest) (let ((g (gensym))) `(let ((,g ,test)) (if ,g (,proc ,g) ,(loop rest))))) (((#t b1 . body)) `(begin ,b1 ,@body)) (((test) . rest) `(or ,test ,(loop rest))) (((test . body) . rest) `(if ,test (begin ,@body) ,(loop rest))) (_ (syntax-err cond-expr "invalid cond expression")))))) (define case-tf (lambda (case-expr) (recur loop ((e (cdr case-expr))) (match e ((exp) `(begin ,exp (,(primitive 'void)))) ((exp ('else b1 . body)) `(begin ,b1 ,@body)) ((exp ('else . _) . _) (syntax-err case-expr "invalid case expression")) (((? symbol? exp) ((? list? test) b1 . body) . rest) `(if (,(primitive 'memv) ,exp ',test) (begin ,b1 ,@body) ,(loop (cons exp rest)))) (((? symbol? exp) (test b1 . body) . rest) `(if (,(primitive 'memv) ,exp '(,test)) (begin ,b1 ,@body) ,(loop (cons exp rest)))) ((exp . rest) (if (not (symbol? exp)) (let ((g (gensym))) `(let ((,g ,exp)) ,(loop (cons g rest)))) (syntax-err case-expr "invalid case expression"))) (_ (syntax-err case-expr "invalid case expression")))))) (define conslimit 8) (define quote-tf (lambda (exp) (letrec ((qloop (match-lambda ((? box? q) `(,(primitive qbox) ,(qloop (unbox q)))) ((? symbol? q) `',q) ((? null? q) q) ((? list? q) (if (< (length q) conslimit) `(,(primitive qcons) ,(qloop (car q)) ,(qloop (cdr q))) `(,(primitive qlist) ,@(map qloop q)))) ((x . y) `(,(primitive qcons) ,(qloop x) ,(qloop y))) ((? vector? q) `(,(primitive qvector) ,@(map qloop (vector->list q)))) ((? boolean? q) q) ((? number? q) q) ((? char? q) q) ((? string? q) q) (q (syntax-err exp "invalid quote expression at ~a" q))))) (match exp (('quote q) (qloop q)) ((? vector? q) (qloop q)) ((? box? q) (qloop q)))))) (define quasiquote-tf (lambda (exp) (letrec ((make-cons (lambda (x y) (cond ((null? y) `(,(primitive 'list) ,x)) ((and (pair? y) (equal? (car y) (primitive 'list))) (cons (car y) (cons x (cdr y)))) (else `(,(primitive 'cons) ,x ,y))))) (qloop (lambda (e n) (match e (('quasiquote e) (make-cons 'quasiquote (qloop `(,e) (+ 1 n)))) (('unquote e) (if (zero? n) e (make-cons 'unquote (qloop `(,e) (- n 1))))) (('unquote-splicing e) (if (zero? n) e (make-cons 'unquote-splicing (qloop `(,e) (- n 1))))) ((('unquote-splicing e) . y) (=> fail) (if (zero? n) (if (null? y) e `(,(primitive 'append) ,e ,(qloop y n))) (fail))) ((? box? q) `(,(primitive 'box) ,(qloop (unbox q) n))) ((? symbol? q) (if (memq q '(quasiquote unquote unquote-splicing)) (syntax-err exp "invalid use of ~a inside quasiquote" q) `',q)) ((? null? q) q) ((x . y) (make-cons (qloop x n) (qloop y n))) ((? vector? q) `(,(primitive 'vector) ,@(map (lambda (z) (qloop z n)) (vector->list q)))) ((? boolean? q) q) ((? number? q) q) ((? char? q) q) ((? string? q) q) (q (syntax-err exp "invalid quasiquote expression at ~a" q)))))) (match exp (('quasiquote q) (qloop q 0)))))) (define do-tf (lambda (do-expr) (recur loop ((e (cdr do-expr))) (match e (((? list? vis) (e0 ? list? e1) ? list? c) (if (andmap (match-lambda ((_ _ . _) #t) (_ #f)) vis) (let* ((var (map car vis)) (init (map cadr vis)) (step (map cddr vis)) (step (map (lambda (v s) (match s (() v) ((e) e) (_ (syntax-err do-expr "invalid do expression")))) var step))) (let ((doloop (gensym))) (match e1 (() `(let ,doloop ,(map list var init) (if (not ,e0) (begin ,@c (,doloop ,@step) (void)) (void)))) ((body0 ? list? body) `(let ,doloop ,(map list var init) (if ,e0 (begin ,body0 ,@body) (begin ,@c (,doloop ,@step))))) (_ (syntax-err do-expr "invalid do expression"))))) (syntax-err do-expr "invalid do expression"))) (_ (syntax-err do-expr "invalid do expression")))))) (define empty-env '()) (define lookup (lambda (env x) (match (assq x env) (#f (disaster 'lookup "no binding for ~a" x)) ((_ . b) b)))) (define lookup? (lambda (env x) (match (assq x env) (#f #f) ((_ . b) b)))) (define bound? (lambda (env x) (match (assq x env) (#f #f) (_ #t)))) (define extend-env (lambda (env x v) (cons (cons x v) env))) (define extend-env* (lambda (env xs vs) (append (map2 cons xs vs) env))) (define join-env (lambda (env newenv) (append newenv env))) (define populated #t) (define pseudo #f) (define global-error #f) (define share #f) (define matchst #f) (define fullsharing #t) (define dump-depths #f) (define flags #t) (define-structure (c depth kind fsym pres args next)) (define-structure (v depth kind name vis split inst)) (define-structure (ts type n-gen)) (define-structure (k name order args)) (define top (box 'top)) (define bot (box 'bot)) (define generic? (lambda (d) (< d 0))) (define new-type (lambda (s d) (let ((t (box s))) (vector-set! types d (cons t (vector-ref types d))) t))) (define generate-counter (lambda () (let ((n 0)) (lambda () (set! n (+ 1 n)) n)))) (define var-counter (generate-counter)) (define make-raw-tvar (lambda (d k) (make-v d k var-counter #t #f #f))) (define make-tvar (lambda (d k) (new-type (make-raw-tvar d k) d))) (define ord? (lambda (k) (eq? 'ord k))) (define abs? (lambda (k) (eq? 'abs k))) (define pre? (lambda (k) (eq? 'pre k))) (define ord-depth 2) (define depth ord-depth) (define types (make-vector 16 '())) (define reset-types! (lambda () (set! depth ord-depth) (set! types (make-vector 16 '())))) (define push-level (lambda () (set! depth (+ depth 1)) (when (< (vector-length types) (+ 1 depth)) (set! types (let ((l (vector->list types))) (list->vector (append l (map (lambda (_) '()) l)))))))) (define pop-level (lambda () (vector-set! types depth '()) (set! depth (- depth 1)))) (define v-ord (lambda () (make-tvar depth 'ord))) (define v-abs (lambda () (make-tvar depth 'abs))) (define v-pre (lambda () (make-tvar depth 'pre))) (define tvar v-ord) (define out1tvar (lambda () (make-tvar (- depth 1) 'ord))) (define monotvar (lambda () (make-tvar ord-depth 'ord))) (define pvar (match-lambda (($ box (and x ($ v d k _ vis _ _))) (unless (number? (v-name x)) (set-v-name! x ((v-name x)))) (string->symbol (sprintf "~a~a~a" (match k ('ord (if (generic? d) (if vis "X" "x") (if vis "Z" "z"))) ('abs (if vis "A" "a")) ('pre (if vis "P" "p"))) (v-name x) (if dump-depths (sprintf ".~a" d) "")))))) (define make-tvar-like (match-lambda (($ box ($ v d k _ _ _ _)) (make-tvar d k)))) (define ind* (lambda (t) (match (unbox t) ((? box? u) (let ((v (ind* u))) (set-box! t v) v)) (_ t)))) (define type-check? (match-lambda ((abs def inexhaust once _) (cond (((if once check-abs1? check-abs?) abs) (if (and def (definite? def)) 'def #t)) (inexhaust 'inexhaust) (else #f))))) (define type-check1? (match-lambda ((abs def inexhaust _ _) (cond ((check-abs1? abs) (if (and def (definite? def)) 'def #t)) (inexhaust 'inexhaust) (else #f))))) (define check-abs? (lambda (vlist) (letrec ((seen '()) (labs? (lambda (t) (match t (($ box ($ v _ _ _ _ _ inst)) (and inst (not (memq t seen)) (begin (set! seen (cons t seen)) (ormap (match-lambda ((t . _) (labs? t))) inst)))) (($ box ($ c _ _ _ p _ n)) (or (labs? p) (labs? n))) (($ box (? symbol?)) #t) (($ box i) (labs? i)))))) (ormap labs? vlist)))) (define check-abs1? (lambda (vlist) (letrec ((labs1? (lambda (t) (match t (($ box (? v?)) #f) (($ box ($ c _ _ _ p _ n)) (or (labs1? p) (labs1? n))) (($ box (? symbol?)) #t) (($ box i) (labs1? i)))))) (ormap labs1? vlist)))) (define check-sources (lambda (info) (letrec ((seen '()) (lsrcs (lambda (t source) (match t (($ box ($ v _ k _ _ _ inst)) (union (if (and inst (not (memq t seen))) (begin (set! seen (cons t seen)) (foldr union empty-set (map (match-lambda ((t . s) (lsrcs t s))) inst))) empty-set))) (($ box ($ c _ _ _ p _ n)) (union (lsrcs p source) (lsrcs n source))) (($ box (? symbol?)) (if source (set source) empty-set)) (($ box i) (lsrcs i source)))))) (match-let (((abs _ _ _ _) info)) (if (eq? #t abs) empty-set (foldr union empty-set (map (lambda (t) (lsrcs t #f)) abs))))))) (define check-local-sources (match-lambda ((_ _ _ _ component) component))) (define mk-definite-prim (match-lambda (($ box ($ c _ _ x p a n)) (if (eq? (k-name x) '?->) (let ((seen '())) (recur lprim ((t (car a))) (match t (($ box ($ c _ _ x p a n)) (if (memq t seen) '() (begin (set! seen (cons t seen)) (match (k-name x) ('noarg (cons p (lprim n))) ('arg (let ((args (recur argloop ((a (car a))) (match a (($ box ($ c _ _ _ p _ n)) (cons p (argloop n))) (($ box ($ v _ k _ _ _ _)) (if (ord? k) (list a) '())) (($ box (? symbol?)) '()) (($ box i) (argloop i)))))) (cons (list p args (lprim (cadr a))) (lprim n)))))))) (($ box ($ v _ k _ _ _ _)) (if (ord? k) (list t) '())) (($ box (? symbol?)) '()) (($ box i) (lprim i))))) (mk-definite-prim n))) (($ box (? v?)) '()) (($ box (? symbol?)) '()) (($ box i) (mk-definite-prim i)))) (define mk-definite-app (match-lambda (($ box ($ c _ _ _ p _ _)) (list p)))) (define mk-definite-lam (match-lambda (($ box ($ c _ _ x p a n)) (if (eq? (k-name x) '?->) (let ((seen '())) (recur llam ((t (car a))) (match t (($ box ($ c _ _ x p a n)) (if (memq t seen) '() (begin (set! seen (cons t seen)) (match (k-name x) ('noarg (cons p (llam n))) ('arg (let ((args (list top))) (cons (list p args (llam (cadr a))) (llam n)))))))) (($ box ($ v _ k _ _ _ _)) (if (ord? k) (list t) '())) (($ box (? symbol?)) '()) (($ box i) (llam i))))) (mk-definite-lam n))) (($ box (? v?)) '()) (($ box (? symbol?)) '()) (($ box i) (mk-definite-lam i)))) (define definite? (lambda (def-info) (letrec ((non-empty? (lambda (t) (let ((seen '())) (recur ldef ((t t)) (match t (($ box ($ c _ _ _ p _ n)) (or (ldef p) (ldef n))) (($ box ($ v d k _ _ _ inst)) (if (or global-error (abs? k)) (and inst (generic? d) (not (memq t seen)) (begin (set! seen (cons t seen)) (ormap (match-lambda ((t . _) (ldef t))) inst))) (generic? d))) (($ box 'top) #t) (($ box 'bot) #f) (($ box i) (ldef i))))))) (ok (lambda (l) (ormap (match-lambda ((? box? t) (non-empty? t)) ((p arg rest) (and (non-empty? p) (ormap non-empty? arg) (ok rest)))) l)))) (not (ok def-info))))) (define close (lambda (t-list) (close-type t-list #f))) (define closeall (lambda (t) (car (close-type (list t) #t)))) (define for (lambda (from to f) (cond ((= from to) (f from)) ((< from to) (begin (f from) (for (+ from 1) to f))) (else #f)))) (define close-type (lambda (t-list all?) (let* ((sorted (make-vector (+ depth 1) '())) (sort (lambda (t) (match t (($ box ($ c d _ _ _ _ _)) (vector-set! sorted d (cons t (vector-ref sorted d)))) (($ box ($ v d _ _ _ _ _)) (vector-set! sorted d (cons t (vector-ref sorted d)))) (_ #f)))) (prop-d (lambda (down) (letrec ((pr (match-lambda (($ box (and x ($ v d _ _ _ _ _))) (when (< down d) (set-v-depth! x down))) (($ box (and x ($ c d _ _ p a n))) (when (< down d) (set-c-depth! x down) (pr p) (for-each pr a) (pr n))) (($ box (? symbol?)) #f) (z (pr (ind* z)))))) (match-lambda (($ box (and x ($ c d _ _ p a n))) (when (<= down d) (pr p) (for-each pr a) (pr n))) (_ #f))))) (prop-k (lambda (t) (let ((pk (lambda (kind) (rec pr (match-lambda (($ box (and x ($ v _ k _ _ _ _))) (when (kind< kind k) (set-v-kind! x kind))) (($ box (and x ($ c _ k _ p a n))) (when (kind< kind k) (set-c-kind! x kind) (pr p) (unless populated (for-each pr a)) (pr n))) (($ box (? symbol?)) #f) (z (pr (ind* z)))))))) (match t (($ box (and x ($ c _ k _ p a n))) (when (not (ord? k)) (let ((prop (pk k))) (prop p) (unless populated (for-each prop a)) (prop n)))) (_ #f))))) (might-be-generalized? (match-lambda (($ box ($ v d k _ _ _ _)) (and (<= depth d) (or populated (ord? k) all?))) (($ box ($ c d k _ _ _ _)) (and (<= depth d) (or populated (ord? k) all?))) (($ box (? symbol?)) #f))) (leaves '()) (depth-of (match-lambda (($ box ($ v d _ _ _ _ _)) d) (($ box ($ c d _ _ _ _ _)) d))) (vector-grow (lambda (v) (let* ((n (vector-length v)) (v2 (make-vector (* n 2) '()))) (recur loop ((i 0)) (when (< i n) (vector-set! v2 i (vector-ref v i)) (loop (+ 1 i)))) v2))) (parents (make-vector 64 '())) (parent-index 0) (parents-of (lambda (t) (let ((d (depth-of t))) (if (< depth d) (vector-ref parents (- (- d depth) 1)) '())))) (xtnd-parents! (lambda (t parent) (match t (($ box (and x ($ v d _ _ _ _ _))) (when (= d depth) (set! parent-index (+ 1 parent-index)) (set-v-depth! x (+ depth parent-index)) (when (< (vector-length parents) parent-index) (set! parents (vector-grow parents))) (set! d (+ depth parent-index))) (vector-set! parents (- (- d depth) 1) (cons parent (vector-ref parents (- (- d depth) 1))))) (($ box (and x ($ c d _ _ _ _ _))) (when (= d depth) (set! parent-index (+ 1 parent-index)) (set-c-depth! x (+ depth parent-index)) (when (< (vector-length parents) parent-index) (set! parents (vector-grow parents))) (set! d (+ depth parent-index))) (vector-set! parents (- (- d depth) 1) (cons parent (vector-ref parents (- (- d depth) 1)))))))) (needs-cleanup '()) (revtype (rec revtype (lambda (parent t) (let ((t (ind* t))) (cond ((not (might-be-generalized? t)) #f) ((null? (parents-of t)) (xtnd-parents! t parent) (set! needs-cleanup (cons t needs-cleanup)) (match t (($ box (? v?)) (set! leaves (cons t leaves))) (($ box ($ c _ _ _ p a n)) (let ((rev (lambda (q) (revtype t q)))) (rev p) (for-each rev a) (rev n))))) ((not (memq parent (parents-of t))) (xtnd-parents! t parent)) (else #f)))))) (generic-index 0) (gen (rec gen (lambda (t) (let ((t (ind* t))) (when (might-be-generalized? t) (set! generic-index (- generic-index 1)) (let ((parents (parents-of t))) (match t (($ box (and x ($ v _ k _ _ _ _))) (set-v-depth! x generic-index) (when (and populated (or global-error (abs? k) (pre? k)) (not all?)) (set-v-inst! x '()))) (($ box (? c? x)) (set-c-depth! x generic-index))) (for-each gen parents))))))) (cleanup (match-lambda (($ box (and x ($ v d _ _ _ _ _))) (unless (< d 0) (set-v-depth! x (- depth 1)))) (($ box (and x ($ c d _ _ _ _ _))) (unless (< d 0) (set-c-depth! x (- depth 1)))))) (gen2 (rec gen (lambda (t) (let ((t (ind* t))) (when (might-be-generalized? t) (set! generic-index (- generic-index 1)) (match t (($ box (and x ($ v _ k _ _ _ _))) (set-v-depth! x generic-index) (when (and populated (or global-error (abs? k) (pre? k)) (not all?)) (set-v-inst! x '()))) (($ box (and x ($ c _ _ _ p a n))) (set-c-depth! x generic-index) (gen p) (for-each gen a) (gen n)))))))) (upd (lambda (t) (let ((d (depth-of t))) (when (< 0 d) (vector-set! types d (cons t (vector-ref types d)))))))) (for-each sort (vector-ref types depth)) (for 0 (- depth 1) (lambda (i) (for-each (prop-d i) (vector-ref sorted i)))) (for-each prop-k (vector-ref types depth)) (vector-set! types depth '()) (if fullsharing (begin (for-each (lambda (t) (revtype t t)) t-list) (for-each gen leaves) (for-each cleanup needs-cleanup)) (for-each gen2 t-list)) (for 0 depth (lambda (i) (for-each upd (vector-ref sorted i)))) (if (null? t-list) '() (match-let* ((n-gen (- generic-index)) ((t-list n-gen) (if (and pseudo flags (not all?)) (pseudo t-list n-gen) (list t-list n-gen)))) (visible t-list n-gen) (map (lambda (t) (make-ts t n-gen)) t-list)))))) (define visible-time 0) (define visible (lambda (t-list n-gen) (let* ((before (cpu-time)) (valences (make-vector n-gen '())) (namer (generate-counter)) (lvis (rec lvis (lambda (t pos rcd) (match t (($ box ($ c d _ x p a n)) (when (and (generic? d) (not (element-of? pos (vector-ref valences (- (- d) 1))))) (let ((u (union (vector-ref valences (- (- d) 1)) (set pos)))) (vector-set! valences (- (- d) 1) u)) (lvis p pos rcd) (match (k-name x) ('?-> (lvis (car a) (not pos) #f) (lvis (cadr a) pos #f)) ('record (lvis (car a) pos #t)) (_ (for-each (lambda (x) (lvis x pos #f)) a))) (lvis n pos rcd))) (($ box (and x ($ v d k _ _ _ _))) (when (and (generic? d) (not (element-of? pos (vector-ref valences (- (- d) 1))))) (let ((u (union (vector-ref valences (- (- d) 1)) (set pos)))) (vector-set! valences (- (- d) 1) u) (set-v-name! x namer) (cond ((abs? k) #f) ((= 2 (cardinality u)) (set-v-split! x #t) (set-v-vis! x #t)) ((eq? pos rcd) (set-v-vis! x #t)) (else (set-v-vis! x #f)))))) (($ box (? symbol?)) #f) (($ box i) (lvis i pos rcd))))))) (for-each (lambda (t) (lvis t #t #f)) t-list) (set! visible-time (+ visible-time (- (cpu-time) before)))))) (define visible? (match-lambda (($ box ($ v _ k _ vis _ _)) (or (pre? k) (and vis (not (abs? k))))) (($ box 'top) #t) (($ box 'bot) #f) (($ box i) (visible? i)))) (define instantiate (lambda (ts syntax) (match ts (($ ts t n-gen) (let* ((absv '()) (seen (make-vector n-gen #f)) (t2 (recur linst ((t t)) (match t (($ box (and y ($ v d k _ _ _ inst))) (cond ((not (generic? d)) t) ((vector-ref seen (- (- d) 1))) (else (let ((u (make-tvar depth k))) (vector-set! seen (- (- d) 1) u) (when inst (set-v-inst! y (cons (cons u syntax) inst))) (when (or (abs? k) (pre? k)) (set! absv (cons u absv))) u)))) (($ box ($ c d _ x p a n)) (cond ((not (generic? d)) t) ((vector-ref seen (- (- d) 1))) (else (let ((u (new-type '**fix** depth))) (vector-set! seen (- (- d) 1) u) (set-box! u (make-c depth 'ord x (if flags (linst p) top) (map linst a) (linst n))) u)))) (($ box (? symbol?)) t) (($ box i) (linst i)))))) (list t2 absv)))))) (define pseudo-subtype (lambda (t-list n-gen) (let* ((valences (make-vector n-gen '())) (valence-of (lambda (d) (vector-ref valences (- (- d) 1)))) (set-valence (lambda (d v) (vector-set! valences (- (- d) 1) v))) (find (rec find (lambda (t pos mutable) (match t (($ box ($ v d _ _ _ _ _)) (when (generic? d) (cond (mutable (set-valence d (set #t #f))) ((not (element-of? pos (valence-of d))) (set-valence d (union (valence-of d) (set pos)))) (else #f)))) (($ box ($ c d _ x p a n)) (when (generic? d) (cond ((= 2 (cardinality (valence-of d))) #f) (mutable (set-valence d (set #t #f)) (for-each2 (lambda (t m) (find t pos mutable)) a (k-args x)) (find n pos mutable)) ((not (element-of? pos (valence-of d))) (set-valence d (union (valence-of d) (set pos))) (if (eq? '?-> (k-name x)) (begin (find (car a) (not pos) mutable) (find (cadr a) pos mutable)) (for-each2 (lambda (t m) (find t pos (or m mutable))) a (k-args x))) (find n pos mutable)) (else #f)))) (($ box (? symbol?)) #f) (($ box i) (find i pos mutable)))))) (seen (make-vector n-gen #f)) (new-generic-var (lambda () (set! n-gen (+ 1 n-gen)) (box (make-raw-tvar (- n-gen) 'ord)))) (copy (rec copy (lambda (t) (match t (($ box ($ v d k _ _ _ _)) (if (generic? d) (or (vector-ref seen (- (- d) 1)) (let ((u (if (and (abs? k) (equal? (valence-of d) '(#t))) (new-generic-var) t))) (vector-set! seen (- (- d) 1) u) u)) t)) (($ box ($ c d k x p a n)) (if (generic? d) (or (vector-ref seen (- (- d) 1)) (let* ((u (box '**fix**)) (_ (vector-set! seen (- (- d) 1) u)) (new-p (if (and (eq? (ind* p) top) (equal? (valence-of d) '(#f))) (new-generic-var) (copy p))) (new-a (map copy a)) (new-n (copy n))) (set-box! u (make-c d 'ord x new-p new-a new-n)) u)) t)) (($ box (? symbol?)) t) (($ box i) (copy i)))))) (t-list (map (lambda (t) (find t #t #f) (copy t)) t-list))) (list t-list n-gen)))) (set! pseudo pseudo-subtype) (define unify (letrec ((uni (lambda (u v) (unless (eq? u v) (match (cons u v) ((($ box (and us ($ c ud uk ux up ua un))) $ box (and vs ($ c vd vk vx vp va vn))) (if (eq? ux vx) (begin (if (< ud vd) (begin (set-box! v u) (when (kind< vk uk) (set-c-kind! us vk))) (begin (set-box! u v) (when (kind< uk vk) (set-c-kind! vs uk)))) (uni un vn) (for-each2 uni ua va) (uni up vp)) (let* ((next (tvar)) (k (if (kind< uk vk) uk vk))) (if (< ud vd) (begin (when (< vd ud) (set-c-depth! us vd)) (when (kind< vk uk) (set-c-kind! us vk)) (set-box! v u)) (begin (when (< ud vd) (set-c-depth! vs ud)) (when (kind< uk vk) (set-c-kind! vs uk)) (set-box! u v))) (uni (new-type (make-c depth k ux up ua next) depth) vn) (uni un (new-type (make-c depth k vx vp va next) depth))))) ((($ box (and x ($ v ud uk _ _ _ _))) $ box ($ v vd vk _ _ _ _)) (set-v-depth! x (min ud vd)) (set-v-kind! x (if (kind< uk vk) uk vk)) (set-box! v u)) ((($ box ($ v ud uk _ _ _ _)) $ box (and x ($ c vd vk _ _ _ _))) (when (< ud vd) (set-c-depth! x ud)) (when (kind< uk vk) (set-c-kind! x uk)) (set-box! u v)) ((($ box (and x ($ c ud uk _ _ _ _))) $ box ($ v vd vk _ _ _ _)) (when (< vd ud) (set-c-depth! x vd)) (when (kind< vk uk) (set-c-kind! x vk)) (set-box! v u)) ((($ box ($ v _ _ _ _ _ _)) $ box (? symbol?)) (set-box! u v)) ((($ box (? symbol?)) $ box ($ v _ _ _ _ _ _)) (set-box! v u)) ((($ box 'bot) $ box ($ c _ _ _ p _ n)) (set-box! v u) (uni u p) (uni u n)) ((($ box ($ c _ _ _ p _ n)) $ box 'bot) (set-box! u v) (uni v p) (uni v n)) (_ (uni (ind* u) (ind* v)))))))) uni)) (define kind< (lambda (k1 k2) (and (ord? k2) (not (ord? k1))))) (define r+- (lambda (flag+ flag- tail+- absent- pos env type) (letrec ((absent+ v-ord) (tvars '()) (fvars '()) (absv '()) (make-flag (lambda (pos) (cond ((not flags) top) (pos (flag+)) (else (flag-))))) (typevar? (lambda (v) (and (symbol? v) (not (bound? env v)) (not (memq v '(_ bool mu list &list &optional &rest arglist + not rec *tidy)))))) (parse-type (lambda (t pos) (match t (('mu a t) (unless (typevar? a) (raise 'type "invalid type syntax at ~a" t)) (when (assq a tvars) (raise 'type "~a is defined more than once" a)) (let* ((fix (new-type '**fix** depth)) (_ (set! tvars (cons (list a fix '()) tvars))) (t (parse-type t pos))) (when (eq? t fix) (raise 'type "recursive type is not contractive")) (set-box! fix t) (ind* t))) (('rec (? list? bind) t2) (for-each (match-lambda ((a _) (unless (typevar? a) (raise 'type "invalid type syntax at ~a" t)) (when (assq a tvars) (raise 'type "~a is defined more than once" a)) (set! tvars (cons (list a (new-type '**fix** depth) '()) tvars))) (_ (raise 'type "invalid type syntax at ~a" t))) bind) (for-each (match-lambda ((a t) (match (assq a tvars) ((_ fix _) (let ((t (parse-type t '?))) (when (eq? t fix) (raise 'type "type is not contractive")) (set-box! fix t)))))) bind) (parse-type t2 pos)) ('bool (parse-type '(+ false true) pos)) ('s-exp (let ((v (gensym))) (parse-type `(mu ,v (+ num nil false true char sym str (vec ,v) (box ,v) (cons ,v ,v))) pos))) (('list t) (let ((u (gensym))) (parse-type `(mu ,u (+ nil (cons ,t ,u))) pos))) (('arglist t) (let ((u (gensym))) (parse-type `(mu ,u (+ noarg (arg ,t ,u))) pos))) (('+ ? list? union) (parse-union union pos)) (t (parse-union (list t) pos))))) (parse-union (lambda (t pos) (letrec ((sort-cs (lambda (cs) (sort-list cs (lambda (x y) (k< (c-fsym x) (c-fsym y)))))) (link (lambda (c t) (set-c-next! c t) (new-type c depth)))) (recur loop ((t t) (cs '())) (match t (() (foldr link (if pos (absent+) (let ((v (absent-))) (set! absv (cons v absv)) v)) (sort-cs cs))) (((? box? t)) (foldr link t (sort-cs cs))) (('_) (foldr link (tail+-) (sort-cs cs))) (((? symbol? a)) (=> fail) (unless (typevar? a) (fail)) (let* ((cs (sort-cs cs)) (ks (map c-fsym cs))) (foldr link (match (assq a tvars) ((_ f aks) (unless (equal? ks aks) (raise 'type "variable ~a is not tidy" a)) f) (#f (let ((v (tail+-))) (set! tvars (cons (list a v ks) tvars)) v))) cs))) ((k . rest) (loop rest (cons (parse-k k pos) cs)))))))) (parse-k (lambda (k pos) (cond ((and (list? k) (let ((n (length k))) (and (<= 2 n) (eq? '-> (list-ref k (- n 2)))))) (let* ((rk (reverse k)) (arg (reverse (cddr rk))) (res (car rk))) (letrec ((mkargs (match-lambda (() 'noarg) ((('&rest x)) x) ((('&list x)) (let ((u (gensym))) `(mu ,u (+ noarg (arg ,x ,u))))) ((('&optional x)) `(+ noarg (arg ,x noarg))) ((x . y) `(arg ,x ,(mkargs y))) (_ (raise 'type "invalid type syntax"))))) (make-c depth 'ord (lookup env '?->) (make-flag pos) (let ((a (parse-type (mkargs arg) (flip pos))) (r (parse-type res pos))) (list a r)) '**fix**)))) (else (match k ((arg '?-> res) (make-c depth 'ord (lookup env '?->) (make-flag pos) (let ((a (parse-type arg (flip pos))) (r (parse-type res pos))) (list a r)) '**fix**)) (('record ? list? fields) (make-c depth 'ord (lookup env 'record) (make-flag pos) (list (recur loop ((fields fields)) (match fields (() (if pos bot (v-ord))) ((((? symbol? f) ftype) . rest) (new-type (make-c depth 'ord (new-field! f) (if pos (v-ord) (let ((v (v-pre))) (set! absv (cons v absv)) v)) (list (parse-type ftype pos)) (loop rest)) depth))))) '**fix**)) (('not (? k? k)) (make-c depth 'ord k (if pos (absent+) (let ((v (absent-))) (set! absv (cons v absv)) v)) (map (lambda (x) (tail+-)) (k-args k)) '**fix**)) (('not c) (unless (bound? env c) (raise 'type "invalid type syntax at ~a" k)) (let ((k (lookup env c))) (make-c depth 'ord k (if pos (absent+) (let ((v (absent-))) (set! absv (cons v absv)) v)) (map (lambda (x) (tail+-)) (k-args k)) '**fix**))) (('*tidy c (? symbol? f)) (unless (bound? env c) (raise 'type "invalid type syntax at ~a" k)) (let ((k (lookup env c))) (make-c depth 'ord k (match (assq f fvars) ((_ . f) f) (#f (let ((v (tail+-))) (set! fvars (cons (cons f v) fvars)) v))) (map (lambda (x) (parse-type '(+) pos)) (k-args k)) '**fix**))) (((? k? k) ? list? arg) (unless (= (length arg) (length (k-args k))) (raise 'type "~a requires ~a arguments" (k-name k) (length (k-args k)))) (make-c depth 'ord k (make-flag pos) (smap (lambda (x) (parse-type x pos)) arg) '**fix**)) ((c ? list? arg) (unless (bound? env c) (raise 'type "invalid type syntax at ~a" k)) (let ((k (lookup env c))) (unless (= (length arg) (length (k-args k))) (raise 'type "~a requires ~a arguments" c (length (k-args k)))) (make-c depth 'ord k (make-flag pos) (smap (lambda (x) (parse-type x pos)) arg) '**fix**))) (c (unless (bound? env c) (raise 'type "invalid type syntax at ~a" k)) (let ((k (lookup env c))) (unless (= 0 (length (k-args k))) (raise 'type "~a requires ~a arguments" c (length (k-args k)))) (make-c depth 'ord k (make-flag pos) '() '**fix**)))))))) (flip (match-lambda ('? '?) (#t #f) (#f #t)))) (let ((t (parse-type type pos))) (list t absv))))) (define v-top (lambda () top)) (define r+ (lambda (env t) (car (r+- v-top v-ord v-ord v-abs #t env t)))) (define r- (lambda (env t) (car (r+- v-top v-ord v-ord v-abs #f env t)))) (define r++ (lambda (env t) (car (r+- v-top v-ord v-ord v-ord #t env t)))) (define r+collect (lambda (env t) (r+- v-top v-ord v-ord v-abs #t env t))) (define r-collect (lambda (env t) (r+- v-top v-ord v-ord v-abs #f env t))) (define r (lambda (t) (r+ initial-type-env t))) (define r-match (lambda (t) (close '()) '(pretty-print `(fixing ,(ptype t))) (fix-pat-abs! t) (list t (collect-abs t)))) (define collect-abs (lambda (t) (let ((seen '())) (recur loop ((t t)) (match t (($ box ($ v _ k _ _ _ _)) (if (abs? k) (set t) empty-set)) (($ box ($ c _ _ _ p a n)) (if (memq t seen) empty-set (begin (set! seen (cons t seen)) (foldr union (union (loop p) (loop n)) (map loop a))))) (($ box (? symbol?)) empty-set) (($ box i) (loop i))))))) (define fix-pat-abs! (lambda (t) (let ((seen '())) (recur loop ((t t)) (match t (($ box (and x ($ v d _ _ _ _ _))) (when (= d depth) (set-v-kind! x 'abs))) (($ box (and c ($ c _ _ _ p a n))) (unless (memq t seen) (set! seen (cons t seen)) (loop p) (when (and matchst flags (eq? (ind* p) top)) (set-c-pres! c (v-ord))) (for-each loop a) (loop n))) (($ box (? symbol?)) t) (($ box i) (loop i))))))) (define pat-var-bind (lambda (t) (let ((seen '())) (recur loop ((t t)) (match t (($ box ($ v d _ _ _ _ _)) (if (< d depth) t (match (assq t seen) ((_ . new) new) (#f (let* ((new (v-ord))) (set! seen (cons (cons t new) seen)) new))))) (($ box ($ c d k x p a n)) (match (assq t seen) ((_ . new) new) (#f (let* ((fix (new-type '**fix** depth)) (fixbox (box fix)) (_ (set! seen (cons (cons t fixbox) seen))) (new-p (if flags (loop p) top)) (new-a (map2 (lambda (mutable a) (if mutable a (loop a))) (k-args x) a)) (new-n (loop n))) (if (and (eq? new-p p) (eq? new-n n) (andmap eq? new-a a)) (begin (set-box! fixbox t) t) (begin (set-box! fix (make-c d k x new-p new-a new-n)) fix)))))) (($ box (? symbol?)) t) (($ box i) (loop i))))))) (define fields '()) (define new-field! (lambda (x) (match (assq x fields) (#f (let ((k (make-k x (+ 1 (length fields)) '(#f)))) (set! fields (cons (cons x k) fields)) k)) ((_ . k) k)))) (define k< (lambda (x y) (< (k-order x) (k-order y)))) (define k-counter 0) (define bind-tycon (lambda (x args covers fail-thunk) (when (memq x '(_ bool mu list &list &optional &rest arglist + not rec *tidy)) (fail-thunk "invalid type constructor ~a" x)) (set! k-counter (+ 1 k-counter)) (make-k (if covers (symbol-append x "." (- k-counter 100)) x) k-counter args))) (define initial-type-env '()) (define init-types! (lambda () (set! k-counter 0) (set! var-counter (generate-counter)) (set! initial-type-env (foldl (lambda (l env) (extend-env env (car l) (bind-tycon (car l) (cdr l) #f (lambda x (apply disaster 'init x))))) empty-env initial-type-info)) (set! k-counter 100) (reset-types!))) (define reinit-types! (lambda () (set! var-counter (generate-counter)) (set! k-counter 100) (set! fields '()) (set-cons-mutability! #t) (reset-types!))) (define deftype (lambda (tag mutability) (set! initial-type-env (extend-env initial-type-env tag (make-k tag (+ 1 (length initial-type-env)) mutability))))) (define initial-type-info '((?-> #f #f) (arg #f #f) (noarg) (num) (nil) (false) (true) (char) (sym) (str) (void) (iport) (oport) (eof) (vec #t) (box #t) (cons #t #t) (cvec #f) (promise #t) (record #f) (module #f))) (define cons-is-mutable #f) (define set-cons-mutability! (lambda (m) (set! cons-is-mutable m) (set-k-args! (lookup initial-type-env 'cons) (list m m)))) (define tidy? (lambda (t) (let ((seen '())) (recur loop ((t t) (label '())) (match t (($ box (? v?)) (match (assq t seen) (#f (set! seen (cons (cons t label) seen)) #t) ((_ . l2) (equal? label l2)))) (($ box ($ c _ _ x _ a n)) (match (assq t seen) ((_ . l2) (equal? label l2)) (#f (set! seen (cons (cons t label) seen)) (and (loop n (sort-list (cons x label) k<)) (andmap (lambda (t) (loop t '())) a))))) (($ box (? symbol?)) #t) (($ box i) (loop i label))))))) (define tidy (match-lambda (($ ts t _) (tidy-print t print-union assemble-union #f)) (t (tidy-print t print-union assemble-union #f)))) (define ptype (match-lambda (($ ts t _) (tidy-print t print-raw-union assemble-raw-union #t)) (t (tidy-print t print-raw-union assemble-raw-union #t)))) (define tidy-print (lambda (t print assemble top) (let* ((share (shared-unions t top)) (bindings (map-with-n (lambda (t n) (list t (box #f) (box #f) (symbol-append "Y" (+ 1 n)))) share)) (body (print t (print-binding bindings))) (let-bindings (filter-map (match-lambda ((_ _ ($ box #f) _) #f) ((_ ($ box t) ($ box x) _) (list x t))) bindings))) (assemble let-bindings body)))) (define print-binding (lambda (bindings) (lambda (ty share-wrapper var-wrapper render) (match (assq ty bindings) (#f (render)) ((_ box-tprint box-name nprint) (var-wrapper (or (unbox box-name) (begin (set-box! box-name nprint) (set-box! box-tprint (share-wrapper (render))) nprint)))))))) (define shared-unions (lambda (t all) (let ((seen '())) (recur loop ((t t) (top #t)) (match t (($ box (? v?)) #f) (($ box ($ c _ _ _ _ a n)) (match (and top (assq t seen)) (#f (set! seen (cons (cons t (box 1)) seen)) (for-each (lambda (x) (loop x #t)) a) (loop n all)) ((_ . b) (set-box! b (+ 1 (unbox b)))))) (($ box (? symbol?)) #f) (($ box i) (loop i top)))) (reverse (filter-map (match-lambda ((_ $ box 1) #f) ((t . _) t)) seen))))) (define print-raw-union (lambda (t print-share) (recur loop ((t t)) (match t (($ box ($ v _ _ _ _ split _)) (if (and share split) (string->symbol (sprintf "~a#" (pvar t))) (pvar t))) (($ box ($ c d k x p a n)) (print-share t (lambda (x) x) (lambda (x) x) (lambda () (let* ((name (if (abs? k) (symbol-append '~ (k-name x)) (k-name x))) (name (if dump-depths (symbol-append d '! name) name)) (pr-x `(,name ,@(maplr loop (cons p a))))) (cons pr-x (loop n)))))) (($ box 'top) '+) (($ box 'bot) '-) (($ box i) (loop i)))))) (define assemble-raw-union (lambda (bindings body) (if (null? bindings) body `(rec ,bindings ,body)))) (define print-union (lambda (t print-share) (add-+ (recur loop ((t t) (tailvis (visible? (tailvar t)))) (match t (($ box (? v?)) (if (visible? t) (list (pvar t)) '())) (($ box ($ c _ _ x p a n)) (print-share t add-+ list (lambda () (cond ((visible? p) (let* ((split-flag (and share (match (ind* p) (($ box ($ v _ _ _ _ split _)) split) (_ #f)))) (kname (if split-flag (string->symbol (sprintf "~a#~a" (k-name x) (pvar p))) (k-name x)))) (cons (cond ((null? a) kname) ((eq? '?-> (k-name x)) (let ((arg (add-+ (loop (car a) (visible? (tailvar (car a)))))) (res (add-+ (loop (cadr a) (visible? (tailvar (cadr a))))))) (decode-arrow kname (lambda () (if split-flag (string->symbol (sprintf "->#~a" (pvar p))) '->)) arg res))) ((eq? 'record (k-name x)) `(,kname ,@(loop (car a) #f))) (else `(,kname ,@(maplr (lambda (x) (add-+ (loop x (visible? (tailvar x))))) a)))) (loop n tailvis)))) ((not tailvis) (loop n tailvis)) (else (cons `(not ,(k-name x)) (loop n tailvis))))))) (($ box 'bot) '()) (($ box i) (loop i tailvis))))))) (define assemble-union (lambda (bindings body) (subst-small-type (map clean-binding bindings) body))) (define add-+ (match-lambda (() 'empty) ((t) t) (x (cons '+ x)))) (define tailvar (lambda (t) (match t (($ box (? v?)) t) (($ box ($ c _ _ _ _ _ n)) (tailvar n)) (($ box 'bot) t) (($ box i) (tailvar i))))) (define decode-arrow (lambda (kname thunk-> arg res) (let ((args (recur loop ((l arg)) (match l ('noarg '()) (('arg a b) `(,a ,@(loop b))) (('+ ('arg a b) 'noarg . _) `((&optional ,a) ,@(loop b))) (('+ 'noarg ('arg a b) . _) `((&optional ,a) ,@(loop b))) ((? symbol? z) (if (rectypevar? z) `(,z) `((&rest ,z)))) (('+ 'noarg z) (loop z)) (('+ ('arg a b) z) (loop `(+ (arg ,a ,b) noarg ,z))))))) `(,@args ,(thunk->) ,res)))) (define rectypevar? (lambda (s) (memq (string-ref (symbol->string s) 0) '(#\Y)))) (define typevar? (lambda (s) (memq (string-ref (symbol->string s) 0) '(#\X #\Z)))) (define clean-binding (lambda (binding) (match binding ((u ('+ 'nil ('cons a v))) (if (and (equal? u v) (not (memq* u a))) (list u `(list ,a)) binding)) ((u ('+ ('cons a v) 'nil)) (if (and (equal? u v) (not (memq* u a))) (list u `(list ,a)) binding)) ((u ('+ 'nil ('cons a v) (? symbol? z))) (if (and (equal? u v) (not (memq* u a)) (typevar? z)) (list u `(list* ,a ,z)) binding)) ((u ('+ ('cons a v) 'nil (? symbol? z))) (if (and (equal? u v) (not (memq* u a)) (typevar? z)) (list u `(list* ,a ,z)) binding)) ((u ('+ 'noarg ('arg a v))) (if (and (equal? u v) (not (memq* u a))) (list u `(&list ,a)) binding)) ((u ('+ ('arg a v) 'noarg)) (if (and (equal? u v) (not (memq* u a))) (list u `(&list ,a)) binding)) (x x)))) (define memq* (lambda (v t) (recur loop ((t t)) (match t ((x . y) (or (loop x) (loop y))) (_ (eq? v t)))))) (define subst-type (lambda (new old t) (match new (('list elem) (subst-list elem old t)) (_ (subst* new old t))))) (define subst-list (lambda (elem old t) (match t ((? symbol?) (if (eq? old t) `(list ,elem) t)) (('+ 'nil ('cons a (? symbol? b))) (if (and (eq? b old) (equal? elem a)) `(list ,elem) `(+ nil (cons ,(subst-list elem old a) ,b)))) (('+ ('cons a (? symbol? b)) 'nil) (if (and (eq? b old) (equal? elem a)) `(list ,elem) `(+ nil (cons ,(subst-list elem old a) ,b)))) ((a . b) (cons (subst-list elem old a) (subst-list elem old b))) (z z)))) (define subst* (lambda (new old t) (cond ((eq? old t) new) ((pair? t) (cons (subst* new old (car t)) (subst* new old (cdr t)))) (else t)))) (define subst-small-type (lambda (bindings body) (recur loop ((bindings bindings) (newb '()) (body body)) (match bindings (() (let ((newb (filter (match-lambda ((name type) (not (equal? name type)))) newb))) (if (null? newb) body `(rec ,(reverse newb) ,body)))) (((and b (name type)) . rest) (if (and (not (memq* name type)) (small-type? type)) (loop (subst-type type name rest) (subst-type type name newb) (subst-type type name body)) (loop rest (cons b newb) body))))))) (define small-type? (lambda (t) (>= 8 (recur loop ((t t)) (match t ('+ 0) ((? symbol? s) 1) ((? number? n) 0) ((x . y) (+ (loop x) (loop y))) (() 0)))))) (define qop (lambda (s) (string->symbol (string-append "# " s)))) (define qcons (qop "cons")) (define qbox (qop "box")) (define qlist (qop "list")) (define qvector (qop "vector")) (define initial-info `((not (a -> bool)) (eqv? (a a -> bool)) (eq? (a a -> bool)) (equal? (a a -> bool)) (cons (a b -> (cons a b)) (ic)) (car ((cons a b) -> a) (s (x . _))) (cdr ((cons b a) -> a) (s (_ . x))) (caar ((cons (cons a b) c) -> a) (s ((x . _) . _))) (cadr ((cons c (cons a b)) -> a) (s (_ x . _))) (cdar ((cons (cons b a) c) -> a) (s ((_ . x) . _))) (cddr ((cons c (cons b a)) -> a) (s (_ _ . x))) (caaar ((cons (cons (cons a b) c) d) -> a) (s (((x . _) . _) . _))) (caadr ((cons d (cons (cons a b) c)) -> a) (s (_ (x . _) . _))) (cadar ((cons (cons c (cons a b)) d) -> a) (s ((_ x . _) . _))) (caddr ((cons d (cons c (cons a b))) -> a) (s (_ _ x . _))) (cdaar ((cons (cons (cons b a) c) d) -> a) (s (((_ . x) . _) . _))) (cdadr ((cons d (cons (cons b a) c)) -> a) (s (_ (_ . x) . _))) (cddar ((cons (cons c (cons b a)) d) -> a) (s ((_ _ . x) . _))) (cdddr ((cons d (cons c (cons b a))) -> a) (s (_ _ _ . x))) (caaaar ((cons (cons (cons (cons a b) c) d) e) -> a) (s ((((x . _) . _) . _) . _))) (caaadr ((cons e (cons (cons (cons a b) c) d)) -> a) (s (_ ((x . _) . _) . _))) (caadar ((cons (cons d (cons (cons a b) c)) e) -> a) (s ((_ (x . _) . _) . _))) (caaddr ((cons e (cons d (cons (cons a b) c))) -> a) (s (_ _ (x . _) . _))) (cadaar ((cons (cons (cons c (cons a b)) d) e) -> a) (s (((_ x . _) . _) . _))) (cadadr ((cons e (cons (cons c (cons a b)) d)) -> a) (s (_ (_ x . _) . _))) (caddar ((cons (cons d (cons c (cons a b))) e) -> a) (s ((_ _ x . _) . _))) (cadddr ((cons e (cons d (cons c (cons a b)))) -> a) (s (_ _ _ x . _))) (cdaaar ((cons (cons (cons (cons b a) c) d) e) -> a) (s ((((_ . x) . _) . _) . _))) (cdaadr ((cons e (cons (cons (cons b a) c) d)) -> a) (s (_ ((_ . x) . _) . _))) (cdadar ((cons (cons d (cons (cons b a) c)) e) -> a) (s ((_ (_ . x) . _) . _))) (cdaddr ((cons e (cons d (cons (cons b a) c))) -> a) (s (_ _ (_ . x) . _))) (cddaar ((cons (cons (cons c (cons b a)) d) e) -> a) (s (((_ _ . x) . _) . _))) (cddadr ((cons e (cons (cons c (cons b a)) d)) -> a) (s (_ (_ _ . x) . _))) (cdddar ((cons (cons d (cons c (cons b a))) e) -> a) (s ((_ _ _ . x) . _))) (cddddr ((cons e (cons d (cons c (cons b a)))) -> a) (s (_ _ _ _ . x))) (set-car! ((cons a b) a -> void)) (set-cdr! ((cons a b) b -> void)) (list ((&list a) -> (list a)) (ic)) (length ((list a) -> num)) (append ((&list (list a)) -> (list a)) (ic) (d)) (reverse ((list a) -> (list a)) (ic)) (list-tail ((list a) num -> (list a)) (c)) (list-ref ((list a) num -> a) (c)) (memq (a (list a) -> (+ false (cons a (list a))))) (memv (a (list a) -> (+ false (cons a (list a))))) (member (a (list a) -> (+ false (cons a (list a))))) (assq (a (list (cons a c)) -> (+ false (cons a c)))) (assv (a (list (cons a c)) -> (+ false (cons a c)))) (assoc (a (list (cons a c)) -> (+ false (cons a c)))) (symbol->string (sym -> str)) (string->symbol (str -> sym)) (complex? (a -> bool)) (real? (a -> bool)) (rational? (a -> bool)) (integer? (a -> bool)) (exact? (num -> bool)) (inexact? (num -> bool)) (= (num num (&list num) -> bool)) (< (num num (&list num) -> bool)) (> (num num (&list num) -> bool)) (<= (num num (&list num) -> bool)) (>= (num num (&list num) -> bool)) (zero? (num -> bool)) (positive? (num -> bool)) (negative? (num -> bool)) (odd? (num -> bool)) (even? (num -> bool)) (max (num (&list num) -> num)) (min (num (&list num) -> num)) (+ ((&list num) -> num)) (* ((&list num) -> num)) (- (num (&list num) -> num)) (/ (num (&list num) -> num)) (abs (num -> num)) (quotient (num num -> num)) (remainder (num num -> num)) (modulo (num num -> num)) (gcd ((&list num) -> num)) (lcm ((&list num) -> num)) (numerator (num -> num)) (denominator (num -> num)) (floor (num -> num)) (ceiling (num -> num)) (truncate (num -> num)) (round (num -> num)) (rationalize (num num -> num)) (exp (num -> num)) (log (num -> num)) (sin (num -> num)) (cos (num -> num)) (tan (num -> num)) (asin (num -> num)) (acos (num -> num)) (atan (num (&optional num) -> num)) (sqrt (num -> num)) (expt (num num -> num)) (make-rectangular (num num -> num)) (make-polar (num num -> num)) (real-part (num -> num)) (imag-part (num -> num)) (magnitude (num -> num)) (angle (num -> num)) (exact->inexact (num -> num)) (inexact->exact (num -> num)) (number->string (num (&optional num) -> str)) (string->number (str (&optional num) -> num)) (char=? (char char -> bool)) (char bool)) (char>? (char char -> bool)) (char<=? (char char -> bool)) (char>=? (char char -> bool)) (char-ci=? (char char -> bool)) (char-ci bool)) (char-ci>? (char char -> bool)) (char-ci<=? (char char -> bool)) (char-ci>=? (char char -> bool)) (char-alphabetic? (char -> bool)) (char-numeric? (char -> bool)) (char-whitespace? (char -> bool)) (char-upper-case? (char -> bool)) (char-lower-case? (char -> bool)) (char->integer (char -> num)) (integer->char (num -> char)) (char-upcase (char -> char)) (char-downcase (char -> char)) (make-string (num (&optional char) -> str)) (string ((&list char) -> str)) (string-length (str -> num)) (string-ref (str num -> char)) (string-set! (str num char -> void)) (string=? (str str -> bool)) (string bool)) (string>? (str str -> bool)) (string<=? (str str -> bool)) (string>=? (str str -> bool)) (string-ci=? (str str -> bool)) (string-ci bool)) (string-ci>? (str str -> bool)) (string-ci<=? (str str -> bool)) (string-ci>=? (str str -> bool)) (substring (str num num -> str)) (string-append ((&list str) -> str)) (string->list (str -> (list char)) (ic)) (list->string ((list char) -> str)) (string-copy (str -> str)) (string-fill! (str char -> void)) (make-vector (num a -> (vec a)) (i)) (vector ((&list a) -> (vec a)) (i)) (vector-length ((vec a) -> num)) (vector-ref ((vec a) num -> a)) (vector-set! ((vec a) num a -> void)) (vector->list ((vec a) -> (list a)) (ic)) (list->vector ((list a) -> (vec a)) (i)) (vector-fill! ((vec a) a -> void)) (apply (((&list a) -> b) (list a) -> b) (i) (d)) (map ((a -> b) (list a) -> (list b)) (i) (d)) (for-each ((a -> b) (list a) -> void) (i) (d)) (force ((promise a) -> a) (i)) (call-with-current-continuation (((a -> b) -> a) -> a) (i)) (call-with-input-file (str (iport -> a) -> a) (i)) (call-with-output-file (str (oport -> a) -> a) (i)) (input-port? (a -> bool)) (output-port? (a -> bool)) (current-input-port (-> iport)) (current-output-port (-> oport)) (with-input-from-file (str (-> a) -> a) (i)) (with-output-to-file (str (-> a) -> a) (i)) (open-input-file (str -> iport)) (open-output-file (str -> oport)) (close-input-port (iport -> void)) (close-output-port (oport -> void)) (read ((&optional iport) -> (+ eof num nil false true char sym str (box (mu sexp (+ num nil false true char sym str (vec sexp) (cons sexp sexp) (box sexp)))) (cons sexp sexp) (vec sexp))) (i)) (read-char ((&optional iport) -> (+ char eof)) (i)) (peek-char ((&optional iport) -> (+ char eof)) (i)) (char-ready? ((&optional iport) -> bool) (i)) (write (a (&optional oport) -> void) (i)) (display (a (&optional oport) -> void) (i)) (newline ((&optional oport) -> void) (i)) (write-char (char (&optional oport) -> void) (i)) (load (str -> void)) (transcript-on (str -> void)) (transcript-off (-> void)) (symbol-append ((&rest a) -> sym)) (box (a -> (box a)) (i)) (unbox ((box a) -> a) (s boxx)) (set-box! ((box a) a -> void)) (void (-> void)) (make-module (a -> (module a))) (raise ((&rest a) -> b)) (match:error (a (&rest b) -> c)) (should-never-reach (a -> b)) (make-cvector (num a -> (cvec a))) (cvector ((&list a) -> (cvec a))) (cvector-length ((cvec a) -> num)) (cvector-ref ((cvec a) num -> a)) (cvector->list ((cvec a) -> (list a)) (ic)) (list->cvector ((list a) -> (cvec a))) (,qcons (a b -> (cons a b)) (ic) (n)) (,qvector ((&list a) -> (vec a)) (i) (n)) (,qbox (a -> (box a)) (i) (n)) (,qlist ((&list a) -> (list a)) (ic) (n)) (number? ((+ num x) -> bool) (p (num))) (null? ((+ nil x) -> bool) (p (nil))) (char? ((+ char x) -> bool) (p (char))) (symbol? ((+ sym x) -> bool) (p (sym))) (string? ((+ str x) -> bool) (p (str))) (vector? ((+ (vec a) x) -> bool) (p (vec a))) (cvector? ((+ (cvec a) x) -> bool) (p (cvec a))) (box? ((+ (box a) x) -> bool) (p (box a))) (pair? ((+ (cons a b) x) -> bool) (p (cons a b))) (procedure? ((+ ((&rest a) -> b) x) -> bool) (p (?-> a b))) (eof-object? ((+ eof x) -> bool) (p (eof))) (input-port? ((+ iport x) -> bool) (p (iport))) (output-port? ((+ oport x) -> bool) (p (oport))) (true-object? ((+ true x) -> bool) (p (true))) (false-object? ((+ false x) -> bool) (p (false))) (module? ((+ (module a) x) -> bool) (p (module a))) (boolean? ((+ true false x) -> bool) (p #t)) (list? ((mu u (+ nil (cons y u) x)) -> bool) (p #t)))) (define initial-env '()) (define init-env! (lambda () (set! initial-env (foldr init-prim empty-env initial-info)))) (define init-prim (lambda (l env) (letrec ((build-selector (match-lambda ('x (lambda (x) x)) ('_ (lambda (x) (make-pany))) ('boxx (let ((c (lookup env 'box?))) (lambda (x) (make-pobj c (list x))))) ((x . y) (let ((c (lookup env 'pair?)) (lx (build-selector x)) (ly (build-selector y))) (lambda (x) (make-pobj c (list (lx x) (ly x))))))))) (match l ((name type . attr) (let* ((pure (cond ((assq 'i attr) #f) ((assq 'ic attr) 'cons) (else #t))) (def (assq 'd attr)) (check (assq 'c attr)) (nocheck (assq 'n attr)) (pred (match (assq 'p attr) (#f #f) ((_ #t) #t) ((_ (tag . args)) (cons (lookup initial-type-env tag) args)))) (sel (match (assq 's attr) (#f #f) ((_ s) (build-selector s)))) (env1 (extend-env env name (make-name name (closeall (r+ initial-type-env type)) #f 0 #f #f (cond (nocheck 'nocheck) (check 'check) (def 'imprecise) (else #t)) #f pure pred #f sel))) (env2 (extend-env env1 (symbol-append 'check- name) (make-name (symbol-append 'check- name) (closeall (r++ initial-type-env type)) #f 0 #f #f #t #f pure pred #f sel)))) env2)))))) (define defprim (lambda (name type mode) (handle (r+ initial-type-env type) (match-lambda* (('type . args) (apply syntax-err type args)) (x (apply raise x)))) (let* ((attr (match mode ('impure '((i))) ('pure '()) ('pure-if-cons-is '((ic))) ('mutates-cons (set! cons-mutators (cons name cons-mutators)) '()) (x (use-error "invalid attribute ~a for st:defprim" x)))) (info `(,name ,type ,@attr))) (unless (equal? info (assq name initial-info)) (set! initial-info (cons info initial-info)) (set! initial-env (init-prim info initial-env)))))) (init-types!) (init-env!) (define %not (lookup initial-env 'not)) (define %list (lookup initial-env 'list)) (define %cons (lookup initial-env 'cons)) (define %should-never-reach (lookup initial-env 'should-never-reach)) (define %false-object? (lookup initial-env 'false-object?)) (define %eq? (lookup initial-env 'eq?)) (define %eqv? (lookup initial-env 'eqv?)) (define %equal? (lookup initial-env 'equal?)) (define %null? (lookup initial-env 'null?)) (define %vector? (lookup initial-env 'vector?)) (define %cvector? (lookup initial-env 'cvector?)) (define %list? (lookup initial-env 'list?)) (define %boolean? (lookup initial-env 'boolean?)) (define %procedure? (lookup initial-env 'procedure?)) (define n-unbound 0) (define bind-defs (lambda (defs env0 tenv0 old-unbound timestamp) (letrec ((cons-mutable #f) (unbound '()) (use-var (lambda (x env context mk-node) (match (lookup? env x) (#f (let* ((b (bind-var x)) (n (mk-node b))) (set-name-timestamp! b context) (set! unbound (cons n unbound)) n)) (b (when (and (name-primitive b) (memq x cons-mutators)) (set! cons-mutable #t)) (set-name-occ! b (+ 1 (name-occ b))) (mk-node b))))) (bind-var (lambda (x) (make-name x #f timestamp 0 #f #f #f #f #f #f #f #f))) (bind (lambda (e env tenv context) (let ((bind-cur (lambda (x) (bind x env tenv context)))) (match e (($ var x) (use-var x env context make-var)) (($ prim x) (use-var x initial-env context make-var)) (($ const c pred) (use-var pred initial-env context (lambda (p) (make-const c p)))) (($ lam args e2) (let* ((b-args (map bind-var args)) (newenv (extend-env* env args b-args))) (make-lam b-args (bind e2 newenv tenv context)))) (($ vlam args rest e2) (let* ((b-args (map bind-var args)) (b-rest (bind-var rest)) (newenv (extend-env* env (cons rest args) (cons b-rest b-args)))) (make-vlam b-args b-rest (bind e2 newenv tenv context)))) (($ match e1 clauses) (make-match (bind-cur e1) (map (lambda (x) (bind-mclause x env tenv context)) clauses))) (($ app e1 args) (make-app (bind-cur e1) (map bind-cur args))) (($ begin exps) (make-begin (map bind-cur exps))) (($ and exps) (make-and (map bind-cur exps))) (($ or exps) (make-or (map bind-cur exps))) (($ if test then els) (make-if (bind-cur test) (bind-cur then) (bind-cur els))) (($ delay e2) (make-delay (bind-cur e2))) (($ set! x e2) (use-var x env context (lambda (b) (when (name-struct b) (syntax-err (pexpr e) "define-structure identifier ~a may not be assigned" x)) (when (name-primitive b) (syntax-err (pexpr e) "(set! ~a ...) requires (define ~a ...)" x x)) (when (and (not (name-mutated b)) (not (= (name-timestamp b) timestamp))) (syntax-err (pexpr e) "(set! ~a ...) missing from compilation unit defining ~a" x x)) (set-name-mutated! b #t) (make-set! b (bind-cur e2))))) (($ let args e2) (let* ((b-args (map (match-lambda (($ bind x e) (make-bind (bind-var x) (bind-cur e)))) args)) (newenv (extend-env* env (map bind-name args) (map bind-name b-args)))) (make-let b-args (bind e2 newenv tenv context)))) (($ let* args e2) (recur loop ((args args) (b-args '()) (env env)) (match args ((($ bind x e) . rest) (let ((b (bind-var x))) (loop rest (cons (make-bind b (bind e env tenv context)) b-args) (extend-env env x b)))) (() (make-let* (reverse b-args) (bind e2 env tenv context)))))) (($ letr args e2) (let* ((b-args (map (match-lambda (($ bind x e) (make-bind (bind-var x) e))) args)) (newenv (extend-env* env (map bind-name args) (map bind-name b-args))) (b-args (map (match-lambda (($ bind b e) (let* ((n (name-occ b)) (e2 (bind e newenv tenv context))) (set-name-occ! b n) (make-bind b e2)))) b-args))) (make-letr b-args (bind e2 newenv tenv context)))) (($ body defs exps) (match-let* (((defs newenv newtenv) (bind-defn defs env tenv #f))) (make-body defs (map (lambda (x) (bind x newenv newtenv context)) exps)))) (($ record args) (make-record (map (match-lambda (($ bind x e) (new-field! x) (make-bind x (bind-cur e)))) args))) (($ field x e2) (new-field! x) (make-field x (bind-cur e2))) (($ cast ty e2) (match-let (((t absv) (handle (r+collect tenv (match ty (('rec bind ty2) `(rec ,bind (,ty2 -> ,ty2))) (_ `(,ty -> ,ty)))) (match-lambda* (('type . args) (apply syntax-err ty args)) (x (apply raise x)))))) (make-cast (list ty t absv) (bind-cur e2)))))))) (bind-mclause (lambda (clause env tenv context) (match-let* ((($ mclause pattern body failsym) clause) (patenv empty-env) (bp (recur loop ((p pattern)) (match p (($ pvar x) (when (bound? patenv x) (syntax-err (ppat pattern) "pattern variable ~a repeated" x)) (let ((b (bind-var x))) (set! patenv (extend-env patenv x b)) (make-pvar b))) (($ pobj c args) (use-var c env context (lambda (b) (cond ((boolean? (name-predicate b)) (syntax-err (ppat pattern) "~a is not a predicate" c)) ((and (not (eq? b %vector?)) (not (eq? b %cvector?)) (not (= (length (cdr (name-predicate b))) (length args)))) (syntax-err (ppat pattern) "~a requires ~a sub-patterns" c (length (cdr (name-predicate b))))) (else (make-pobj b (map loop args))))))) (($ pand pats) (make-pand (map loop pats))) (($ pnot pat) (make-pnot (loop pat))) (($ ppred pred) (use-var pred env context (lambda (b) (unless (name-predicate b) (syntax-err (ppat pattern) "~a is not a predicate" pred)) (make-ppred b)))) (($ pany) p) (($ pelse) p) (($ pconst c pred) (use-var pred initial-env context (lambda (p) (make-pconst c p)))))))) (if failsym (let ((b (bind-var failsym))) (when (bound? patenv failsym) (syntax-err (ppat pattern) "fail symbol ~a repeated" failsym)) (set! patenv (extend-env patenv failsym b)) (make-mclause bp (bind body (join-env env patenv) tenv context) b)) (make-mclause bp (bind body (join-env env patenv) tenv context) #f))))) (bind-defn (lambda (defs env tenv glob) (let* ((newenv empty-env) (newtenv empty-env) (struct-def (lambda (x pure) (when (or (bound? newenv x) (and glob (bound? initial-env x))) (syntax-err #f "~a defined more than once" x)) (let ((b (bind-var x))) (set-name-primitive! b #t) (set-name-struct! b #t) (set-name-pure! b pure) (set! newenv (extend-env newenv x b)) b))) (bind1 (match-lambda ((and z ($ define x e)) (cond ((not x) z) ((bound? newenv x) (if glob (make-define #f (make-set! x e)) (syntax-err #f "~a defined more than once" x))) (else (let ((b (bind-var x))) (set-name-gdef! b glob) (set! newenv (extend-env newenv x b)) (make-define b e))))) ((and d ($ defstruct tag args make pred get set getn setn mutable)) (let* ((make (struct-def make (map not mutable))) (pred (struct-def pred #t)) (bind-get (lambda (name n) (match name (($ some x) (let ((b (struct-def x #t))) (set-name-selector! b (lambda (x) (make-pobj pred (map-with-n (lambda (_ m) (if (= m n) x (make-pany))) get)))) (some b))) (none none)))) (bind-set (match-lambda (($ some x) (some (struct-def x #t))) (none none))) (get (map-with-n bind-get get)) (getn (map-with-n bind-get getn)) (set (map bind-set set)) (setn (map bind-set setn)) (_ (when (bound? newtenv tag) (syntax-err (pdef d) "type constructor ~a defined more than once" tag))) (tc (bind-tycon tag mutable (bound? tenv tag) (lambda args (apply syntax-err (cons (pdef d) args)))))) (set! newtenv (extend-env newtenv tag tc)) (set-name-predicate! pred `(,tc ,@(map (lambda (_) (gensym)) get))) (make-defstruct tc args make pred get set getn setn mutable))) ((and d ($ datatype dt)) (make-datatype (maplr (match-lambda (((tag . args) . bindings) (when (bound? newtenv tag) (syntax-err (pdef d) "type constructor ~a defined more than once" tag)) (let ((tc (bind-tycon tag (map (lambda (_) #f) args) (bound? tenv tag) (lambda args (apply syntax-err (cons (pdef d) args)))))) (set! newtenv (extend-env newtenv tag tc)) (cons (cons tc args) (maplr (match-lambda (($ variant con pred arg-types) (let ((make (struct-def con #t)) (pred (struct-def pred #t))) (set-name-predicate! pred (cons tc args)) (set-name-variant! pred arg-types) (make-variant make pred arg-types)))) bindings))))) dt))))) (defs2 (maplr bind1 defs)) (newenv2 (join-env env newenv)) (newtenv2 (join-env tenv newtenv)) (bind2 (match-lambda ((and ($ define (? name? x) ($ var y))) (=> fail) (if (eq? (name-name x) y) (if (bound? initial-env y) (make-define x (make-var (lookup initial-env y))) (begin (printf "Warning: (define ~a ~a) but ~a is not a primitive~%" y y y) (fail))) (fail))) ((and ($ define x e2) context) (when (and glob (name? x) (bound? initial-env (name-name x))) (printf "Note: (define ~a ...) hides primitive ~a~%" (name-name x) (name-name x))) (make-define (or x (let ((b (bind-var x))) (set-name-gdef! b glob) b)) (bind e2 newenv2 newtenv2 context))) (d d)))) (list (maplr bind2 defs2) newenv2 newtenv2)))) (bind-old (lambda (e env) (match e (($ var x) (match (lookup? env (name-name x)) (#f (set! unbound (cons e unbound))) (b (when (and (name-primitive b) (memq x cons-mutators)) (set! cons-mutable #t)) (set-name-occ! b (+ 1 (name-occ b))) (set-var-name! e b)))) (($ set! x _) (match (lookup? env (name-name x)) (#f (set! unbound (cons e unbound))) (b (when (name-struct b) (syntax-err (pexpr e) "define-structure identifier ~a may not be assigned" x)) (when (name-primitive b) (syntax-err (pexpr e) "(set! ~a ...) requires (define ~a ...)" x x)) (when (and (not (name-mutated b)) (not (= (name-timestamp b) timestamp))) (syntax-err (pexpr e) "(set! ~a ...) missing from compilation unit defining ~a" x x)) (set-name-mutated! b #t) (set-name-occ! b (+ 1 (name-occ b))) (set-set!-name! e b)))))))) (match-let (((defs env tenv) (bind-defn defs env0 tenv0 #t))) (for-each (lambda (x) (bind-old x env)) old-unbound) (set-cons-mutability! cons-mutable) (set! n-unbound (length unbound)) (list defs env tenv unbound))))) (define rebind-var (lambda (b) (make-name (name-name b) (name-ty b) (name-timestamp b) (name-occ b) (name-mutated b) #f #f #f #f #f #f #f))) (define warn-unbound (lambda (l) (let* ((names '()) (node->name (match-lambda (($ var x) x) (($ set! x _) x) (($ pobj x _) x) (($ ppred x) x))) (warn (lambda (b) (unless (memq (name-name b) names) (set! names (cons (name-name b) names)) (printf "Warning: ~a is unbound in " (name-name b)) (print-context (pexpr (name-timestamp b)) 2))))) (for-each (lambda (x) (warn (node->name x))) l)))) (define name-unbound? (lambda (x) (not (number? (name-timestamp x))))) (define improve-defs (lambda (defs) (map (match-lambda (($ define x e2) (make-define x (improve e2))) (x x)) defs))) (define improve (match-lambda (($ match e clauses) (improve-match e clauses)) (($ if tst thn els) (improve-if tst thn els)) ((? var? e) e) ((? const? e) e) (($ lam args e2) (make-lam args (improve e2))) (($ vlam args rest e2) (make-vlam args rest (improve e2))) (($ app (and e1 ($ var x)) args) (let ((args (map improve args))) (if (and (eq? x %list) (< (length args) conslimit)) (foldr (lambda (a rest) (make-app (make-var %cons) (list a rest))) (make-const '() %null?) args) (make-app e1 args)))) (($ app e1 args) (make-app (improve e1) (map improve args))) (($ begin exps) (make-begin (map improve exps))) (($ and exps) (make-and (map improve exps))) (($ or exps) (make-or (map improve exps))) (($ delay e2) (make-delay (improve e2))) (($ set! x e2) (make-set! x (improve e2))) (($ let args e2) (let ((args (map (match-lambda (($ bind x e) (make-bind x (improve e)))) args))) (make-let args (improve e2)))) (($ let* args e2) (let ((args (map (match-lambda (($ bind x e) (make-bind x (improve e)))) args))) (make-let* args (improve e2)))) (($ letr args e2) (let ((args (map (match-lambda (($ bind x e) (make-bind x (improve e)))) args))) (make-letr args (improve e2)))) (($ body defs exps) (let ((defs (improve-defs defs))) (make-body defs (map improve exps)))) (($ record args) (make-record (map (match-lambda (($ bind x e) (make-bind x (improve e)))) args))) (($ field x e2) (make-field x (improve e2))) (($ cast ty e2) (make-cast ty (improve e2))))) (define improve-if (lambda (tst thn els) (let ((if->match (lambda (x p mk-s thn els) (let ((else-pat (match els (($ app ($ var q) _) (if (eq? q %should-never-reach) (make-pelse) (make-pany))) (_ (make-pany))))) (make-match (make-var x) (list (make-mclause (mk-s (make-ppred p)) (make-body '() (list thn)) #f) (make-mclause (mk-s else-pat) (make-body '() (list els)) #f))))))) (match tst (($ app ($ var v) (e)) (=> fail) (if (eq? v %not) (improve-if e els thn) (fail))) (($ app ($ var eq) (($ const #f _) val)) (=> fail) (if (or (eq? eq %eq?) (eq? eq %eqv?) (eq? eq %equal?)) (improve-if val els thn) (fail))) (($ app ($ var eq) (val ($ const #f _))) (=> fail) (if (or (eq? eq %eq?) (eq? eq %eqv?) (eq? eq %equal?)) (improve-if val els thn) (fail))) (($ app ($ var v) (($ var x))) (=> fail) (if (and (name-predicate v) (not (name-mutated x))) (improve (if->match x v (lambda (x) x) thn els)) (fail))) (($ app ($ var v) (($ app ($ var s) (($ var x))))) (=> fail) (if (and (name-predicate v) (name-selector s) (not (name-mutated x))) (improve (if->match x v (name-selector s) thn els)) (fail))) (($ app ($ var v) (($ var x))) (=> fail) (if (and (name-selector v) (not (name-mutated x))) (improve (if->match x %false-object? (name-selector v) els thn)) (fail))) (($ var v) (=> fail) (if (not (name-mutated v)) (improve (if->match v %false-object? (lambda (x) x) els thn)) (fail))) (_ (make-if (improve tst) (improve thn) (improve els))))))) (define improve-match (lambda (e clauses) (let ((clauses (map (match-lambda (($ mclause p body fail) (make-mclause p (improve body) fail))) clauses))) (match e (($ var x) (if (not (name-mutated x)) (let ((fix-clause (match-lambda ((and c ($ mclause p e fail)) (if (not (uses-x? e x)) c (let ((y (rebind-var x))) (make-mclause (make-flat-pand (list p (make-pvar y))) (sub e x y) fail))))))) (make-match e (map fix-clause clauses))) (make-match e clauses))) (_ (make-match (improve e) clauses)))))) (define uses-x? (lambda (e x) (recur loop ((e e)) (match e (($ and exps) (ormap loop exps)) (($ app fun args) (or (loop fun) (ormap loop args))) (($ begin exps) (ormap loop exps)) (($ if e1 e2 e3) (or (loop e1) (loop e2) (loop e3))) (($ lam names body) (loop body)) (($ let bindings body) (or (ormap (match-lambda (($ bind _ b) (loop b))) bindings) (loop body))) (($ let* bindings body) (or (ormap (match-lambda (($ bind _ b) (loop b))) bindings) (loop body))) (($ letr bindings body) (or (ormap (match-lambda (($ bind _ b) (loop b))) bindings) (loop body))) (($ or exps) (ormap loop exps)) (($ delay e2) (loop e2)) (($ set! name exp) (or (eq? x name) (loop exp))) (($ var name) (eq? x name)) (($ vlam names name body) (loop body)) (($ match exp clauses) (or (loop exp) (ormap (match-lambda (($ mclause p b _) (or (loop p) (loop b)))) clauses))) (($ body defs exps) (or (ormap loop defs) (ormap loop exps))) (($ record bindings) (ormap (match-lambda (($ bind _ b) (loop b))) bindings)) (($ field _ e) (loop e)) (($ cast _ e) (loop e)) (($ define _ e) (loop e)) ((? defstruct?) #f) ((? datatype?) #f) (($ pand pats) (ormap loop pats)) (($ pnot pat) (loop pat)) (($ pobj c args) (ormap loop args)) (($ ppred pred) (eq? x pred)) (_ #f))))) (define sub (lambda (e x to) (let ((dos (lambda (y) (if (eq? x y) to y)))) (recur sub ((e e)) (match e (($ define x e) (make-define x (sub e))) ((? defstruct?) e) ((? datatype?) e) (($ match e clauses) (let ((clauses (map (match-lambda (($ mclause p e fail) (make-mclause p (sub e) fail))) clauses))) (make-match (sub e) clauses))) (($ if tst thn els) (make-if (sub tst) (sub thn) (sub els))) (($ var x) (make-var (dos x))) ((? const? e) e) (($ lam args e2) (make-lam args (sub e2))) (($ vlam args rest e2) (make-vlam args rest (sub e2))) (($ app e1 args) (make-app (sub e1) (map sub args))) (($ begin exps) (make-begin (map sub exps))) (($ and exps) (make-and (map sub exps))) (($ or exps) (make-or (map sub exps))) (($ delay e2) (make-delay (sub e2))) (($ set! x e2) (make-set! (dos x) (sub e2))) (($ let args e2) (let ((args (map (match-lambda (($ bind x e) (make-bind x (sub e)))) args))) (make-let args (sub e2)))) (($ let* args e2) (let ((args (map (match-lambda (($ bind x e) (make-bind x (sub e)))) args))) (make-let* args (sub e2)))) (($ letr args e2) (let ((args (map (match-lambda (($ bind x e) (make-bind x (sub e)))) args))) (make-letr args (sub e2)))) (($ body defs exps) (make-body (map sub defs) (map sub exps))) (($ record args) (make-record (map (match-lambda (($ bind x e) (make-bind x (sub e)))) args))) (($ field x e) (make-field x (sub e))) (($ cast ty e) (make-cast ty (sub e)))))))) (define improve-clauses (lambda (clauses) (recur loop ((clauses clauses)) (match clauses (() '()) ((_) clauses) (((and m1 ($ mclause p _ fail)) . rest) (cons m1 (if fail (loop rest) (recur loop2 ((clauses (loop rest))) (match clauses (() '()) (((and m ($ mclause p2 body2 fail2)) . r) (match (improve-by-pattern p2 p) (('stop . p) (cons (make-mclause p body2 fail2) r)) (('redundant . p) (unless (null? r) (printf "Warning: redundant pattern ~a~%" (ppat p2))) (cons (make-mclause p body2 fail2) r)) (('continue . p) (cons (make-mclause p body2 fail2) (loop2 r)))))))))))))) (define improve-by-pattern (lambda (p2 p1) (call-with-current-continuation (lambda (k) (let* ((reject (lambda () (k (cons 'continue p2)))) (p1covers #t) (p2covers #t) (p3 (recur m ((p1 p1) (p2 p2)) '(printf "(M ~a ~a)~%" (ppat p1) (ppat p2)) (match (cons p1 p2) ((($ pand (a . _)) . p2) (m a p2)) ((p1 $ pand (a . b)) (make-flat-pand (cons (m p1 a) b))) ((($ pvar _) . _) (unless (or (pvar? p2) (pany? p2)) (set! p2covers #f)) p2) ((($ pany) . _) (unless (or (pvar? p2) (pany? p2)) (set! p2covers #f)) p2) ((($ pelse) . _) '(unless (or (pvar? p2) (pany? p2)) (set! p2covers #f)) p2) ((_ $ pvar _) (unless p1covers (reject)) (set! p1covers #f) (make-flat-pand (list p2 (make-pnot p1)))) ((_ $ pany) (unless p1covers (reject)) (set! p1covers #f) (make-flat-pand (list p2 (make-pnot p1)))) ((_ $ pelse) (unless p1covers (reject)) (set! p1covers #f) (make-flat-pand (list p2 (make-pnot p1)))) ((($ pconst a _) $ pconst b _) (unless (equal? a b) (reject)) p2) ((($ pobj tag1 a) $ pobj tag2 b) (unless (eq? tag1 tag2) (reject)) (make-pobj tag1 (map2 m a b))) ((($ ppred tag1) $ ppred tag2) (unless (eq? tag1 tag2) (reject)) p2) ((($ ppred tag1) $ pobj tag2 _) (unless (eq? tag1 tag2) (reject)) (set! p2covers #f) p2) ((($ ppred tag1) $ pconst c tag2) (unless (eq? tag1 tag2) (reject)) (set! p2covers #f) p2) (_ (reject)))))) (cond (p1covers (cons 'redundant p2)) (p2covers (cons 'stop p3)) (else (cons 'continue p3)))))))) (define improve-by-noisily (lambda (p2 p1) (let ((r (improve-by-pattern p2 p1))) (printf "~a by ~a returns ~a ~a~%" (ppat p2) (ppat p1) (car r) (ppat (cdr r)))))) (define make-components (lambda (d) (let* ((structs (filter-map (match-lambda ((? define?) #f) (x x)) d)) (defs (filter-map (match-lambda ((? define? x) x) (_ #f)) d)) (name-of (match-lambda (($ define x _) x))) (ref-of (match-lambda (($ define _ e) (references e name-gdef)))) (comp (top-sort defs name-of ref-of))) (when #f (printf "Components:~%") (pretty-print (map (lambda (c) (map (match-lambda (($ define x _) (and x (name-name x)))) c)) comp))) (append structs comp)))) (define make-body-components (lambda (d) (let* ((structs (filter-map (match-lambda ((? define?) #f) (x x)) d)) (defs (filter-map (match-lambda ((? define? x) x) (_ #f)) d)) (name-of (match-lambda (($ define x _) x))) (bound (map name-of defs)) (ref-of (match-lambda (($ define _ e) (references e (lambda (x) (memq x bound)))))) (comp (top-sort defs name-of ref-of))) (when #f (printf "Components:~%") (pretty-print (map (lambda (c) (map (match-lambda (($ define x _) (and x (name-name x)))) c)) comp))) (append structs comp)))) (define make-letrec-components (lambda (bindings) (let* ((name-of bind-name) (bound (map name-of bindings)) (ref-of (match-lambda (($ bind _ e) (references e (lambda (x) (memq x bound)))))) (comp (top-sort bindings name-of ref-of))) (when #f (printf "Letrec Components:~%") (pretty-print (map (lambda (c) (map (match-lambda (($ bind x _) (pname x))) c)) comp))) comp))) (define references (lambda (e ref?) (recur loop ((e e)) (match e (($ define x e) (if (and x (name-mutated x)) (union (set x) (loop e)) (loop e))) ((? defstruct?) empty-set) ((? datatype?) empty-set) ((? const?) empty-set) (($ var x) (if (ref? x) (set x) empty-set)) (($ lam _ e1) (loop e1)) (($ vlam _ _ e1) (loop e1)) (($ app e0 args) (foldr union2 (loop e0) (map loop args))) (($ let b e2) (let ((do-bind (match-lambda (($ bind _ e) (loop e))))) (foldr union2 (loop e2) (map do-bind b)))) (($ let* b e2) (let ((do-bind (match-lambda (($ bind _ e) (loop e))))) (foldr union2 (loop e2) (map do-bind b)))) (($ letr b e2) (let ((do-bind (match-lambda (($ bind _ e) (loop e))))) (foldr union2 (loop e2) (map do-bind b)))) (($ body defs exps) (foldr union2 empty-set (map loop (append defs exps)))) (($ record b) (let ((do-bind (match-lambda (($ bind _ e) (loop e))))) (foldr union2 empty-set (map do-bind b)))) (($ field _ e) (loop e)) (($ cast _ e) (loop e)) (($ and exps) (foldr union2 empty-set (map loop exps))) (($ or exps) (foldr union2 empty-set (map loop exps))) (($ begin exps) (foldr union2 empty-set (map loop exps))) (($ if test then els) (union (loop test) (loop then) (loop els))) (($ delay e) (loop e)) (($ set! x body) (union (if (ref? x) (set x) empty-set) (loop body))) (($ match exp clauses) (foldr union2 (loop exp) (map (match-lambda (($ mclause _ exp _) (loop exp))) clauses))))))) (define top-sort (lambda (graph name-of references-of) (let* ((adj assq) (g (map (lambda (x) (list (name-of x) (box (references-of x)) (box #f) x)) graph)) (gt (let ((gt (map (match-lambda ((n _ _ name) (list n (box empty-set) (box #f) n))) g))) (for-each (match-lambda ((n nay _ _) (for-each (lambda (v) (match (adj v gt) (#f #f) ((_ b _ _) (set-box! b (cons n (unbox b)))))) (unbox nay)))) g) gt)) (visit (lambda (vg) (letrec ((visit (lambda (g l) (match g (#f l) ((n nay mark name) (if (unbox mark) l (begin (set-box! mark #t) (cons name (foldr (lambda (v l) (visit (adj v vg) l)) l (unbox nay)))))))))) visit))) (visit-gt (visit gt)) (visit-g (visit g)) (post (foldr visit-gt '() gt)) (pre (foldl (lambda (gg l) (match (visit-g (adj gg g) '()) (() l) (c (cons c l)))) '() post))) (reverse pre)))) (define genlet #t) (define genmatch #t) (define letonce #f) (define type-defs (lambda (d) (for-each (match-lambda ((? defstruct? b) (type-structure b)) ((? datatype? b) (type-structure b)) (c (type-component c #t))) (make-components d)) (close '()))) (define type-structure (match-lambda (($ defstruct x _ make pred get set getn setn mutable) (let* ((vars (map (lambda (_) (gensym)) get)) (make-get-type (lambda (getter v) (match getter (($ some b) (set-name-ty! b (closeall (r+ initial-type-env `((,x ,@vars) -> ,v))))) (_ #f)))) (make-set-type (lambda (setter v) (match setter (($ some b) (set-name-ty! b (closeall (r+ initial-type-env `((,x ,@vars) ,v -> void))))) (_ #f))))) (set-name-ty! make (closeall (r+ initial-type-env `(,@vars -> (,x ,@vars))))) (set-name-ty! pred (closeall (r+ initial-type-env `((+ (,x ,@vars) y) -> bool)))) (for-each2 make-get-type get vars) (for-each2 make-set-type set vars) (for-each2 make-get-type getn vars) (for-each2 make-set-type setn vars))) (($ datatype dt) (for-each (match-lambda ((type . variants) (for-each (match-lambda (($ variant con pred arg-types) (set-name-ty! con (closeall (r+ initial-type-env `(,@(cdr arg-types) -> ,type)))) (set-name-ty! pred (closeall (r+ initial-type-env `((+ ,(name-predicate pred) x) -> bool)))))) variants))) dt)))) (define type-component (lambda (component top) (when verbose (let ((cnames (filter-map (match-lambda (($ define b _) (name-name b))) component))) (unless (null? cnames) (printf "Typing ~a~%" cnames)))) (let* ((f (match-lambda (($ define b e) (make-bind b e)))) (bindings (map f component)) (names (map (match-lambda (($ define b _) (pname b))) component)) (f1 (match-lambda (($ define b _) (set-name-ty! b (tvar))))) (f2 (match-lambda ((and d ($ define b e)) (set-define-exp! d (w e names))))) (f3 (match-lambda (($ define b e) (unify (name-ty b) (typeof e))))) (f4 (match-lambda (($ define b _) (name-ty b)))) (f5 (lambda (d ts) (match d (($ define b _) (set-name-ty! b ts)))))) (push-level) (for-each f1 component) (for-each f2 component) (for-each f3 component) (for-each limit-expansive component) (for-each f5 component (close (map f4 component))) (pop-level)))) (define w (lambda (e component) (match e (($ const _ pred) (make-type (r+ initial-type-env (name-predicate pred)) e)) (($ var x) (unless (name-ty x) (set-name-ty! x (if (name-mutated x) (monotvar) (let* ((_1 (push-level)) (t (closeall (tvar))) (_2 (pop-level))) t)))) (if (ts? (name-ty x)) (match-let* ((tynode (make-type #f #f)) ((t absv) (instantiate (name-ty x) tynode))) (set-type-ty! tynode t) (set-type-exp! tynode (match (name-primitive x) ('imprecise (make-check (list absv #f #f #f component) e)) ('check (make-check (list (cons top absv) #f #f #f component) e)) ('nocheck e) (#t (make-check (list absv (mk-definite-prim t) #f #f component) e)) (#f (make-check (list absv #f #f #t component) e)))) tynode) e)) (($ lam x e1) (for-each (lambda (b) (set-name-ty! b (tvar))) x) (match-let* ((body (w e1 component)) ((t absv) (r+collect initial-type-env `(,@(map name-ty x) -> ,(typeof body))))) (make-type t (make-check (list absv (mk-definite-lam t) #f #f component) (make-lam x body))))) (($ vlam x rest e1) (for-each (lambda (b) (set-name-ty! b (tvar))) x) (match-let* ((z (tvar)) (_ (set-name-ty! rest (r+ initial-type-env `(list ,z)))) (body (w e1 component)) ((t absv) (r+collect initial-type-env `(,@(map name-ty x) (&list ,z) -> ,(typeof body))))) (make-type t (make-check (list absv (mk-definite-lam t) #f #f component) (make-vlam x rest body))))) (($ app e0 args) (match-let* ((t0 (w e0 component)) (targs (maplr (lambda (e) (w e component)) args)) (a* (map (lambda (_) (tvar)) args)) (b (tvar)) ((t absv) (r-collect initial-type-env `(,@a* -> ,b))) (definf (mk-definite-app t))) (unify (typeof t0) t) (for-each2 unify (map typeof targs) a*) (if (syntactically-a-procedure? t0) (make-type b (make-app t0 targs)) (make-type b (make-check (list absv definf #f #f component) (make-app t0 targs)))))) (($ let b e2) (let* ((do-bind (match-lambda (($ bind b e) (if genlet (let* ((_ (push-level)) (e (w e (list (pname b)))) (bind (make-bind b e))) (limit-expansive bind) (set-name-ty! b (car (close (list (typeof e))))) (pop-level) bind) (let ((e (w e component))) (set-name-ty! b (typeof e)) (make-bind b e)))))) (tb (map do-bind b)) (body (w e2 component))) (make-let tb body))) (($ let* b e2) (let* ((do-bind (match-lambda (($ bind b e) (if genlet (let* ((_ (push-level)) (e (w e (list (pname b)))) (bind (make-bind b e))) (limit-expansive bind) (set-name-ty! b (car (close (list (typeof e))))) (pop-level) bind) (let ((e (w e component))) (set-name-ty! b (typeof e)) (make-bind b e)))))) (tb (maplr do-bind b)) (body (w e2 component))) (make-let* tb body))) (($ letr b e2) (let* ((do-comp (lambda (b) (if genlet (let* ((f1 (match-lambda (($ bind b _) (set-name-ty! b (tvar))))) (names (map (match-lambda (($ bind b _) (pname b))) b)) (f2 (match-lambda (($ bind b e) (make-bind b (w e names))))) (f3 (match-lambda (($ bind b e) (unify (name-ty b) (typeof e)) (name-ty b)))) (f4 (lambda (bind ts) (match bind (($ bind b _) (set-name-ty! b ts))))) (_1 (push-level)) (_2 (for-each f1 b)) (tb (maplr f2 b)) (_3 (for-each limit-expansive tb)) (ts-list (close (maplr f3 tb)))) (pop-level) (for-each2 f4 tb ts-list) tb) (let* ((f1 (match-lambda (($ bind b _) (set-name-ty! b (tvar))))) (f2 (match-lambda (($ bind b e) (make-bind b (w e component))))) (f3 (match-lambda (($ bind b e) (unify (name-ty b) (typeof e))))) (_1 (for-each f1 b)) (tb (maplr f2 b))) (for-each f3 tb) tb)))) (comps (make-letrec-components b)) (tb (foldr append '() (maplr do-comp comps)))) (make-letr tb (w e2 component)))) (($ body defs exps) (for-each (match-lambda ((? defstruct? b) (type-structure b)) ((? datatype? b) (type-structure b)) (c (type-component c #f))) (make-body-components defs)) (let ((texps (maplr (lambda (x) (w x component)) exps))) (make-body defs texps))) (($ and exps) (let* ((texps (maplr (lambda (x) (w x component)) exps)) (t (match texps (() (r+ initial-type-env 'true)) ((e) (typeof e)) (_ (let ((a (r+ initial-type-env 'false))) (unify (typeof (rac texps)) a) a))))) (make-type t (make-and texps)))) (($ or exps) (let* ((texps (maplr (lambda (x) (w x component)) exps)) (t (match texps (() (r+ initial-type-env 'false)) ((e) (typeof e)) (_ (let* ((t-last (typeof (rac texps))) (but-last (rdc texps)) (a (tvar))) (for-each (lambda (e) (unify (typeof e) (r+ initial-type-env `(+ (not false) ,a)))) but-last) (unify t-last (r+ initial-type-env `(+ (not false) ,a))) t-last))))) (make-type t (make-or texps)))) (($ begin exps) (let ((texps (maplr (lambda (x) (w x component)) exps))) (make-begin texps))) (($ if test then els) (let ((ttest (w test component)) (tthen (w then component)) (tels (w els component)) (a (tvar))) (unify (typeof tthen) a) (unify (typeof tels) a) (make-type a (make-if ttest tthen tels)))) (($ delay e2) (let ((texp (w e2 component))) (make-type (r+ initial-type-env `(promise ,(typeof texp))) (make-delay texp)))) (($ set! x body) (unless (name-ty x) (set-name-ty! x (monotvar))) (let* ((body (w body component)) (t (if (ts? (name-ty x)) (car (instantiate (name-ty x) #f)) (name-ty x)))) (unify t (typeof body)) (make-type (r+ initial-type-env 'void) (make-set! x body)))) (($ record bind) (let* ((tbind (map (match-lambda (($ bind name exp) (make-bind name (w exp component)))) bind)) (t (r+ initial-type-env `(record ,@(map (match-lambda (($ bind name exp) (list name (typeof exp)))) tbind))))) (make-type t (make-record tbind)))) (($ field name exp) (match-let* ((texp (w exp component)) (a (tvar)) ((t absv) (r-collect initial-type-env `(record (,name ,a))))) (unify (typeof texp) t) (make-type a (make-check (list absv #f #f #f component) (make-field name texp))))) (($ cast (ty t absv) exp) (let ((texp (w exp component)) (a (tvar))) (unify (r+ initial-type-env `(,(typeof texp) -> ,a)) t) (make-type a (make-check (list absv #f #f #f component) (make-cast (list ty t absv) texp))))) (($ match exp clauses) (for-each (match-lambda (($ mclause p _ (? name? fail)) (set-name-ty! fail (r+ initial-type-env '(a ?-> b)))) (_ #f)) clauses) (match-let* ((iclauses (improve-clauses (append clauses (list (make-mclause (make-pelse) #f #f))))) ((tmatch absv precise) (w-match (rdc iclauses) (rac iclauses))) (texp (w exp component)) (_ (unify (typeof texp) tmatch)) (tclauses (maplr (match-lambda (($ mclause p e fail) (make-mclause p (w e component) fail))) clauses)) (a (tvar))) (for-each (match-lambda (($ mclause _ e _) (unify (typeof e) a))) tclauses) (make-type a (make-check (list absv #f (not precise) #f component) (make-match texp tclauses)))))))) (define w-match (lambda (clauses last) (letrec ((bindings '()) (encode (match-lambda (($ pand pats) (encode* pats)) (x (encode* (list x))))) (encode* (lambda (pats) (let* ((concrete? (lambda (p) (or (pconst? p) (pobj? p) (ppred? p) (pelse? p)))) (var? (lambda (p) (or (pvar? p) (pany? p)))) (not-var? (lambda (p) (and (not (pvar? p)) (not (pany? p))))) (t (match (filter concrete? pats) ((p) (r+ initial-type-env (match (template p) ((x) x) (x `(+ ,@x))))) (() (r+ initial-type-env `(+ ,@(apply append (map template (filter not-var? pats))) ,@(if (null? (filter var? pats)) '() (list (out1tvar))))))))) (for-each (match-lambda (($ pvar b) (set! bindings (cons b bindings)) (set-name-ty! b (pat-var-bind t)))) (filter pvar? pats)) t))) (template (match-lambda ((? pelse?) '()) (($ pconst _ pred) (list (name-predicate pred))) ((and pat ($ pobj c args)) (list (cond ((or (eq? %vector? c) (eq? %cvector? c)) (cons (if (eq? %vector? c) 'vec 'cvec) (match (maplr encode args) (() (list (out1tvar))) ((first . rest) (list (foldr (lambda (x y) (unify x y) y) first rest)))))) (else (cons (car (name-predicate c)) (maplr encode args)))))) (($ ppred pred) (cond ((eq? pred %boolean?) (list 'true 'false)) ((eq? pred %list?) (list `(list ,(out1tvar)))) (else (list (cons (car (name-predicate pred)) (maplr (lambda (_) (out1tvar)) (cdr (name-predicate pred)))))))) (($ pnot (? pconst?)) '()) (($ pnot ($ ppred pred)) (cond ((eq? pred %boolean?) '((not true) (not false))) ((eq? pred %procedure?) '((not ?->))) ((eq? pred %list?) '()) (else `((not ,(car (name-predicate pred))))))) (($ pnot ($ pobj pred pats)) (let ((m (foldr + 0 (map non-triv pats)))) (case m ((0) `((not ,(car (name-predicate pred))))) ((1) `((,(car (name-predicate pred)) ,@(map (match-lambda (($ pobj pred _) `(+ (not ,(car (name-predicate pred))) ,(out1tvar))) (($ ppred pred) `(+ (not ,(car (name-predicate pred))) ,(out1tvar))) (_ (out1tvar))) pats)))) (else '())))))) (non-triv (match-lambda ((? pvar?) 0) ((? pany?) 0) ((? pelse?) 0) ((? pconst?) 2) (($ pobj _ pats) (foldr + 1 (map non-triv pats))) (_ 1))) (precise (match-lambda ((? pconst?) #f) (($ pand pats) (andmap precise pats)) (($ pnot pat) (precise pat)) (($ pobj pred pats) (let ((m (foldr + 0 (map non-triv pats)))) (case m ((0) #t) ((1) (andmap precise pats)) (else #f)))) (($ ppred pred) (not (eq? pred %list?))) (_ #t)))) (push-level) (match-let* ((precise-match (and (andmap (match-lambda (($ mclause _ _ fail) (not fail))) clauses) (match last (($ mclause p _ _) (precise p))))) (types (maplr (match-lambda (($ mclause p _ _) (encode p))) clauses)) ((t absv) (r-match (foldr (lambda (x y) (unify x y) y) (tvar) types)))) (unify (out1tvar) t) (for-each limit-name bindings) (for-each2 set-name-ty! bindings (close (map name-ty bindings))) (pop-level) '(pretty-print `(match-input ,@(map (match-lambda (($ mclause p _ _) (ppat p))) clauses))) '(pretty-print `(match-type ,(ptype t) ,@(map (lambda (b) (list (pname b) (ptype (name-ty b)))) bindings))) (list t absv precise-match))))) (define syntactically-a-procedure? (match-lambda (($ type _ e) (syntactically-a-procedure? e)) (($ check _ e) (syntactically-a-procedure? e)) (($ var x) (name-primitive x)) ((? lam?) #t) ((? vlam?) #t) (($ let _ body) (syntactically-a-procedure? body)) (($ let* _ body) (syntactically-a-procedure? body)) (($ letr _ body) (syntactically-a-procedure? body)) (($ if _ e2 e3) (and (syntactically-a-procedure? e2) (syntactically-a-procedure? e3))) (($ begin exps) (syntactically-a-procedure? (rac exps))) (($ body _ exps) (syntactically-a-procedure? (rac exps))) (_ #f))) (define typeof (match-lambda (($ type t _) t) (($ check _ e) (typeof e)) (($ let _ body) (typeof body)) (($ let* _ body) (typeof body)) (($ letr _ body) (typeof body)) (($ body _ exps) (typeof (rac exps))) (($ begin exps) (typeof (rac exps))) (($ var x) (name-ty x)))) (define limit-name (lambda (n) (when (name-mutated n) (unify (name-ty n) (out1tvar))))) (define limit-expansive (letrec ((limit! (lambda (t) (unify t (out1tvar)))) (expansive-pattern? (match-lambda ((? pconst?) #f) (($ pvar x) (name-mutated x)) (($ pobj _ pats) (ormap expansive-pattern? pats)) ((? pany?) #f) ((? pelse?) #f) (($ pand pats) (ormap expansive-pattern? pats)) (($ ppred x) (name-mutated x)) (($ pnot pat) (expansive-pattern? pat)))) (limit-expr (match-lambda (($ bind b e) (if (name-mutated b) (limit! (typeof e)) (limit-expr e))) ((? defstruct?) #f) ((? datatype?) #f) (($ define x e) (if (and x (name-mutated x)) (limit! (typeof e)) (limit-expr e))) (($ type t ($ app ($ type _ ($ check _ ($ var x))) exps)) (cond ((list? (name-pure x)) (if (= (length (name-pure x)) (length exps)) (for-each2 (lambda (pure e) (if pure (limit-expr e) (limit! (typeof e)))) (name-pure x) exps) (limit! t))) ((or (eq? #t (name-pure x)) (and (eq? 'cons (name-pure x)) (not cons-is-mutable))) (for-each limit-expr exps)) (else (limit! t)))) (($ type t ($ app _ _)) (limit! t)) (($ type t ($ check _ ($ app _ _))) (limit! t)) (($ delay _) #f) (($ type t ($ set! _ _)) (limit! t)) (($ var _) #f) ((? const?) #f) (($ lam _ _) #f) (($ vlam _ _ _) #f) (($ let bind body) (limit-expr body) (for-each limit-expr bind)) (($ let* bind body) (limit-expr body) (for-each limit-expr bind)) (($ letr bind body) (limit-expr body) (for-each limit-expr bind)) (($ body defs exps) (for-each limit-expr defs) (for-each limit-expr exps)) (($ and exps) (for-each limit-expr exps)) (($ or exps) (for-each limit-expr exps)) (($ begin exps) (for-each limit-expr exps)) (($ if e1 e2 e3) (limit-expr e1) (limit-expr e2) (limit-expr e3)) (($ record bind) (for-each (match-lambda (($ bind _ e) (limit-expr e))) bind)) (($ field _ exp) (limit-expr exp)) (($ cast _ exp) (limit-expr exp)) (($ match exp clauses) (limit-expr exp) (for-each (match-lambda (($ mclause pat body fail) (if (or (and fail (name-mutated fail)) (expansive-pattern? pat)) (limit! (typeof body)) (limit-expr body)))) clauses)) (($ type _ e1) (limit-expr e1)) (($ check _ e1) (limit-expr e1))))) limit-expr)) (define unparse (lambda (e check-action) (letrec ((pbind (match-lambda (($ bind n e) (list (pname n) (pexpr e))))) (pexpr (match-lambda ((and x ($ type _ (? check?))) (check-action x pexpr)) (($ type _ exp) (pexpr exp)) (($ shape t exp) (pexpr exp)) (($ define x e) (if (or (not x) (and (name? x) (not (name-name x)))) (pexpr e) `(define ,(pname x) ,(pexpr e)))) (($ defstruct _ args _ _ _ _ _ _ _) `(check-define-const-structure ,args)) (($ datatype d) `(datatype ,@(map (match-lambda (((tag . args) . bindings) (cons (cons (ptag tag) args) (map (match-lambda (($ variant _ _ types) types)) bindings)))) d))) (($ and exps) `(and ,@(maplr pexpr exps))) (($ or exps) `(or ,@(maplr pexpr exps))) (($ begin exps) `(begin ,@(maplr pexpr exps))) (($ var x) (pname x)) (($ prim x) (pname x)) (($ const x _) (pconst x)) (($ lam x e1) `(lambda ,(maplr pname x) ,@(pexpr e1))) (($ vlam x rest e1) `(lambda ,(append (maplr pname x) (pname rest)) ,@(pexpr e1))) (($ match e1 clauses) (let* ((pclause (match-lambda (($ mclause p #f #f) `(,(ppat p) )) (($ mclause p exp fail) (if fail `(,(ppat p) (=> ,(pname fail)) ,@(pexpr exp)) `(,(ppat p) ,@(pexpr exp)))))) (p1 (pexpr e1))) `(match ,p1 ,@(maplr pclause clauses)))) (($ app e1 args) (let* ((p1 (pexpr e1)) (pargs (maplr pexpr args)) (unkwote (match-lambda (('quote x) x) ((? boolean? x) x) ((? number? x) x) ((? char? x) x) ((? string? x) x) ((? null? x) x) ((? box? x) x) ((? vector? x) x)))) (cond ((eq? p1 qlist) `',(maplr unkwote pargs)) ((eq? p1 qcons) (let ((unq (maplr unkwote pargs))) `',(cons (car unq) (cadr unq)))) ((eq? p1 qbox) (box (unkwote (car pargs)))) ((eq? p1 qvector) (list->vector (maplr unkwote pargs))) (else (cons p1 pargs))))) (($ let b e2) (let ((pb (maplr pbind b))) `(let ,pb ,@(pexpr e2)))) (($ let* b e2) (let ((pb (maplr pbind b))) `(let* ,pb ,@(pexpr e2)))) (($ letr b e2) (let ((pb (maplr pbind b))) `(letrec ,pb ,@(pexpr e2)))) (($ body defs exps) (let ((pdefs (maplr pexpr defs))) (append pdefs (maplr pexpr exps)))) (($ if e1 e2 e3) (let* ((p1 (pexpr e1)) (p2 (pexpr e2)) (p3 (pexpr e3))) `(if ,p1 ,p2 ,p3))) (($ record bindings) `(record ,@(maplr pbind bindings))) (($ field x e2) `(field ,x ,(pexpr e2))) (($ cast (ty . _) e2) `(: ,ty ,(pexpr e2))) (($ delay e) `(delay ,(pexpr e))) (($ set! x e) `(set! ,(pname x) ,(pexpr e)))))) (pexpr e)))) (define pexpr (lambda (ex) (unparse ex (lambda (e pexpr) (match e (($ type _ ($ check _ exp)) (pexpr exp))))))) (define pdef pexpr) (define ppat (match-lambda (($ pconst x _) (pconst x)) (($ pvar x) (pname x)) (($ pany) '_) (($ pelse) 'else) (($ pnot pat) `(not ,(ppat pat))) (($ pand pats) `(and ,@(maplr ppat pats))) (($ ppred pred) (match (pname pred) ('false-object? #f) ('true-object? #t) ('null? '()) (x `(? ,x)))) (($ pobj tag args) (match (cons (pname tag) args) (('box? x) (box (ppat x))) (('pair? x y) (cons (ppat x) (ppat y))) (('vector? . x) (list->vector (maplr ppat x))) ((tg . _) `($ ,(strip-? tg) ,@(maplr ppat args))))))) (define strip-? (lambda (s) (let* ((str (symbol->string s)) (n (string-length str))) (if (or (zero? n) (not (char=? #\? (string-ref str (- n 1))))) s (string->symbol (substring str 0 (- n 1))))))) (define pname (match-lambda ((? name? x) (or (name-name x) ')) ((? symbol? x) x))) (define ptag (match-lambda ((? k? k) (k-name k)) ((? symbol? x) x))) (define pconst (match-lambda ((? symbol? x) `',x) ((? boolean? x) x) ((? number? x) x) ((? char? x) x) ((? string? x) x) ((? null? x) `',x))) (define check (lambda (file) (output-checked file '() type-check?))) (define profcheck (lambda (file) (output-checked #f '() type-check?) (output-checked #f (make-counters total-possible) type-check?))) (define fullcheck (lambda (file) (let ((check? (lambda (_) #t))) (output-checked #f '() check?) (output-checked #f (make-counters total-possible) check?)))) (define make-counters (lambda (n) (let* ((init `(define check-counters (make-vector ,n 0))) (sum '(define check-total (lambda () (let ((foldr (lambda (f i l) (recur loop ((l l)) (match l (() i) ((x . y) (f x (loop y)))))))) (foldr + 0 (vector->list check-counters)))))) (incr '(extend-syntax (check-increment-counter) ((check-increment-counter c) (vector-set! check-counters c (+ 1 (vector-ref check-counters c))))))) (list init sum incr)))) (define output-checked (lambda (file header check-test) (set! summary '()) (set! total-possible 0) (set! total-cast 0) (set! total-err 0) (set! total-any 0) (let ((doit (lambda () (when (string? file) (printf ";; Generated by Soft Scheme ~a~%" st:version) (printf ";; (st:control") (for-each (lambda (x) (printf " '~a" x)) (show-controls)) (printf ")~%") (unless (= 0 n-unbound) (printf ";; CAUTION: ~a unbound references, this code is not safe~%" n-unbound)) (printf "~%") (for-each pretty-print header)) (for-each (lambda (exp) (match exp (($ define x _) (set! n-possible 0) (set! n-clash 0) (set! n-err 0) (set! n-match 0) (set! n-inexhaust 0) (set! n-prim 0) (set! n-lam 0) (set! n-app 0) (set! n-field 0) (set! n-cast 0) (if file (pretty-print (pcheck exp check-test)) (pcheck exp check-test)) (make-summary-line x) (set! total-possible (+ total-possible n-possible)) (set! total-cast (+ total-cast n-cast)) (set! total-err (+ total-err n-err)) (set! total-any (+ total-any n-match n-inexhaust n-prim n-lam n-app n-field n-cast))) (_ (when file (pretty-print (pcheck exp check-test)))))) tree) (when (string? file) (newline) (newline) (print-summary "; "))))) (if (string? file) (begin (delete-file file) (with-output-to-file file doit)) (doit))))) (define total-possible 0) (define total-err 0) (define total-cast 0) (define total-any 0) (define n-possible 0) (define n-clash 0) (define n-err 0) (define n-match 0) (define n-inexhaust 0) (define n-prim 0) (define n-lam 0) (define n-app 0) (define n-field 0) (define n-cast 0) (define summary '()) (define make-summary-line (lambda (x) (let ((total (+ n-match n-inexhaust n-prim n-lam n-app n-field n-cast))) (unless (= 0 total) (let* ((s (sprintf "~a~a " (padr (pname x) 16) (padl total 2))) (s (cond ((< 0 n-inexhaust) (sprintf "~a (~a match ~a inexhaust)" s n-match n-inexhaust)) ((< 0 n-match) (sprintf "~a (~a match)" s n-match)) (else s))) (s (if (< 0 n-prim) (sprintf "~a (~a prim)" s n-prim) s)) (s (if (< 0 n-field) (sprintf "~a (~a field)" s n-field) s)) (s (if (< 0 n-lam) (sprintf "~a (~a lambda)" s n-lam) s)) (s (if (< 0 n-app) (sprintf "~a (~a ap)" s n-app) s)) (s (if (< 0 n-err) (sprintf "~a (~a ERROR)" s n-err) s)) (s (if (< 0 n-cast) (sprintf "~a (~a TYPE)" s n-cast) s))) (set! summary (cons s summary))))))) (define print-summary (lambda (hdr) (for-each (lambda (s) (printf "~a~a~%" hdr s)) (reverse summary)) (printf "~a~a~a " hdr (padr "TOTAL CHECKS" 16) (padl total-any 2)) (printf " (of ~s is ~s%)" total-possible (if (= 0 total-possible) 0 (string->number (chop-number (exact->inexact (* (/ total-any total-possible) 100)) 4)))) (when (< 0 total-err) (printf " (~s ERROR)" total-err)) (when (< 0 total-cast) (printf " (~s TYPE)" total-cast)) (printf "~%"))) (define padl (lambda (arg n) (let ((s (sprintf "~a" arg))) (recur loop ((s s)) (if (< (string-length s) n) (loop (string-append " " s)) s))))) (define padr (lambda (arg n) (let ((s (sprintf "~a" arg))) (recur loop ((s s)) (if (< (string-length s) n) (loop (string-append s " ")) s))))) (define chop-number (lambda (x n) (substring (sprintf "~s00000000000000000000" x) 0 (- n 1)))) (define pcheck (lambda (ex check-test) (unparse ex (lambda (e pexpr) (match e ((and z ($ type _ ($ check inf ($ var x)))) (cond ((name-primitive x) (set! n-possible (+ 1 n-possible)) (match (check-test inf) (#f (pname x)) ('def (set! n-err (+ 1 n-err)) (set! n-prim (+ 1 n-prim)) `(,(symbol-append "CHECK-" (pname x)) ,(tree-index z) ',(string->symbol "ERROR"))) (_ (set! n-prim (+ 1 n-prim)) `(,(symbol-append "CHECK-" (pname x)) ,(tree-index z))))) ((name-unbound? x) `(check-bound ,(pname x))) (else (if (check-test inf) (begin (set! n-clash (+ 1 n-clash)) `(,(string->symbol "CLASH") ,(pname x) ,(tree-index z))) (pname x))))) ((and z ($ type _ ($ check inf (and m ($ lam x e1))))) (set! n-possible (+ 1 n-possible)) (match (check-test inf) (#f (pexpr m)) ('def (set! n-err (+ 1 n-err)) (set! n-lam (+ 1 n-lam)) `(,(string->symbol "CHECK-lambda") (,(tree-index z) ',(string->symbol "ERROR")) ,(map pname x) ,@(pexpr e1))) (_ (set! n-lam (+ 1 n-lam)) `(,(string->symbol "CHECK-lambda") (,(tree-index z)) ,(map pname x) ,@(pexpr e1))))) ((and z ($ type _ ($ check inf (and m ($ vlam x rest e1))))) (set! n-possible (+ 1 n-possible)) (match (check-test inf) (#f (pexpr m)) ('def (set! n-err (+ 1 n-err)) (set! n-lam (+ 1 n-lam)) `(,(string->symbol "CHECK-lambda") (,(tree-index z) ',(string->symbol "ERROR")) ,(append (map pname x) (pname rest)) ,@(pexpr e1))) (_ (set! n-lam (+ 1 n-lam)) `(,(string->symbol "CHECK-lambda") (,(tree-index z)) ,(append (map pname x) (pname rest)) ,@(pexpr e1))))) ((and z ($ type _ ($ check inf (and m ($ app e1 args))))) (set! n-possible (+ 1 n-possible)) (match (check-test inf) (#f (pexpr m)) ('def (set! n-err (+ 1 n-err)) (set! n-app (+ 1 n-app)) `(,(string->symbol "CHECK-ap") (,(tree-index z) ',(string->symbol "ERROR")) ,(pexpr e1) ,@(map pexpr args))) (_ (set! n-app (+ 1 n-app)) (let ((p1 (pexpr e1))) `(,(string->symbol "CHECK-ap") (,(tree-index z)) ,p1 ,@(map pexpr args)))))) ((and z ($ type _ ($ check inf (and m ($ field x e1))))) (set! n-possible (+ 1 n-possible)) (match (check-test inf) (#f (pexpr m)) ('def (set! n-err (+ 1 n-err)) (set! n-field (+ 1 n-field)) `(,(string->symbol "CHECK-field") (,(tree-index z) ',(string->symbol "ERROR")) ,x ,(pexpr e1))) (_ (set! n-field (+ 1 n-field)) `(,(string->symbol "CHECK-field") (,(tree-index z)) ,x ,(pexpr e1))))) ((and z ($ type _ ($ check inf (and m ($ cast (x . _) e1))))) (set! n-possible (+ 1 n-possible)) (match (check-test inf) (#f (pexpr m)) (_ (set! n-cast (+ 1 n-cast)) `(,(string->symbol "CHECK-:") (,(tree-index z)) ,x ,(pexpr e1))))) ((and z ($ type _ ($ check inf (and m ($ match e1 clauses))))) (set! n-possible (+ 1 n-possible)) (match (check-test inf) (#f (pexpr m)) (inx (let* ((pclause (match-lambda (($ mclause p exp fail) (if fail `(,(ppat p) (=> ,(pname fail)) ,@(pexpr exp)) `(,(ppat p) ,@(pexpr exp)))))) (p1 (pexpr e1))) (if (eq? 'inexhaust inx) (begin (set! n-inexhaust (+ 1 n-inexhaust)) `(,(string->symbol "CHECK-match") (,(tree-index z) ,(string->symbol "INEXHAUST")) ,p1 ,@(maplr pclause clauses))) (begin (set! n-match (+ 1 n-match)) `(,(string->symbol "CHECK-match") (,(tree-index z)) ,p1 ,@(maplr pclause clauses))))))))))))) (define tree-index-list '()) (define reinit-output! (lambda () (set! tree-index-list '()))) (define tree-index (lambda (syntax) (match (assq syntax tree-index-list) (#f (let ((n (length tree-index-list))) (set! tree-index-list (cons (cons syntax n) tree-index-list)) n)) ((_ . n) n)))) (define tree-unindex (lambda (n) (let ((max (length tree-index-list))) (when (<= max n) (use-error "Invalid CHECK number ~a" n)) (car (list-ref tree-index-list (- (- max 1) n)))))) (define cause (lambda () (for-each (lambda (def) (for-each pretty-print (exp-cause def))) tree))) (define cause* (lambda names (if (null? names) (for-each (lambda (def) (for-each pretty-print (exp-cause def))) tree) (for-each (match-lambda ((? symbol? dname) (for-each pretty-print (exp-cause (find-global dname))))) names)))) (define exp-cause (let ((sum (lambda (exps) (foldr (lambda (x y) (append (exp-cause x) y)) '() exps))) (src (lambda (inf) (let ((nonlocal (map tree-index (check-sources inf)))) (if (type-check1? inf) (cons (check-local-sources inf) nonlocal) nonlocal))))) (match-lambda ((and z ($ type ty ($ check inf ($ var x)))) (if (name-primitive x) (if (type-check? inf) (list `((,(symbol-append 'check- (pname x)) ,(tree-index z)) ,@(src inf))) '()) (if (type-check1? inf) (list `((clash ,(pname x) ,(tree-index z)) ,@(src inf))) '()))) ((and z ($ type ty ($ check inf ($ lam x e1)))) (append (if (type-check? inf) (list `((check-lambda ,(tree-index z) ,(map pname x) ...) ,@(src inf))) '()) (exp-cause e1))) ((and z ($ type ty ($ check inf ($ vlam x rest e1)))) (append (if (type-check? inf) (list `((check-lambda ,(tree-index z) ,(append (map pname x) (pname rest)) ...) ,@(src inf))) '()) (exp-cause e1))) ((and z ($ type _ ($ check inf ($ app e1 args)))) (append (if (type-check? inf) (list `((check-ap ,(tree-index z)) ,@(src inf))) '()) (exp-cause e1) (sum args))) ((and z ($ type _ ($ check inf ($ field x e1)))) (append (if (type-check? inf) (list `((check-field ,(tree-index z) ,x ...) ,@(src inf))) '()) (exp-cause e1))) ((and z ($ type _ ($ check inf ($ cast (x . _) e1)))) (append (if (type-check? inf) (list `((check-: ,(tree-index z) ,x ...) ,@(src inf))) '()) (exp-cause e1))) ((and z ($ type _ ($ check inf (and m ($ match e1 clauses))))) (append (if (type-check? inf) (list `((check-match ,(tree-index z) ...) ,@(src inf))) '()) (exp-cause m))) (($ define _ e) (exp-cause e)) ((? defstruct?) '()) ((? datatype?) '()) (($ app e1 args) (sum (cons e1 args))) (($ match exp clauses) (foldr (lambda (x y) (append (match x (($ mclause _ e _) (exp-cause e))) y)) (exp-cause exp) clauses)) (($ var _) '()) (($ and exps) (sum exps)) (($ begin exps) (sum exps)) ((? const?) '()) (($ if test then els) (append (exp-cause test) (exp-cause then) (exp-cause els))) (($ let bindings body) (foldr (lambda (x y) (append (match x (($ bind _ e) (exp-cause e))) y)) (exp-cause body) bindings)) (($ let* bindings body) (foldr (lambda (x y) (append (match x (($ bind _ e) (exp-cause e))) y)) (exp-cause body) bindings)) (($ letr bindings body) (foldr (lambda (x y) (append (match x (($ bind _ e) (exp-cause e))) y)) (exp-cause body) bindings)) (($ body defs exps) (sum (append defs exps))) (($ or exps) (sum exps)) (($ delay e) (exp-cause e)) (($ set! var body) (exp-cause body)) (($ record bindings) (foldr (lambda (x y) (append (match x (($ bind _ e) (exp-cause e))) y)) '() bindings)) (($ type _ exp) (exp-cause exp))))) (define display-type tidy) (define type (lambda names (if (null? names) (for-each globaldef tree) (for-each (match-lambda ((? symbol? x) (match (lookup? global-env x) (#f (use-error "~a is not defined" x)) (ty (pretty-print `(,x : ,(display-type (name-ty ty))))))) ((? number? n) (let* ((ty (check-type (tree-unindex n))) (type (display-type ty))) (pretty-print `(,n : ,type)))) (_ (use-error "arguments must be identifiers or CHECK numbers"))) names)))) (define localtype (lambda names (if (null? names) (for-each localdef tree) (for-each (lambda (x) (localdef (find-global x))) names)))) (define find-global (lambda (name) (let ((d (ormap (match-lambda ((and d ($ define x _)) (and (eq? name (name-name x)) d)) (_ #f)) tree))) (unless d (use-error "~a is not defined" name)) d))) (define globaldef (lambda (e) (match e (($ define x _) (let ((type (display-type (name-ty x)))) (pretty-print `(,(pname x) : ,type)))) (_ #f)))) (define localdef (lambda (e) (pretty-print (expdef e)))) (define expdef (let* ((show (lambda (x) `(,(pname x) : ,(display-type (name-ty x))))) (pbind (match-lambda (($ bind x e) `(,(show x) ,(expdef e)))))) (match-lambda (($ define x e) (if (or (not x) (and (name? x) (not (name-name x)))) (expdef e) `(define ,(show x) ,(expdef e)))) ((? defstruct? d) (pdef d)) ((? datatype? d) (pdef d)) (($ and exps) `(and ,@(maplr expdef exps))) (($ app fun args) `(,(expdef fun) ,@(maplr expdef args))) (($ begin exps) `(begin ,@(maplr expdef exps))) (($ const c _) (pconst c)) (($ if test then els) `(if ,(expdef test) ,(expdef then) ,(expdef els))) (($ lam params body) `(lambda ,(map show params) ,@(expdef body))) (($ vlam params rest body) `(lambda ,(append (map show params) (show rest)) ,@(expdef body))) (($ let bindings body) `(let ,(map pbind bindings) ,@(expdef body))) (($ let* bindings body) `(let* ,(map pbind bindings) ,@(expdef body))) (($ letr bindings body) `(letrec ,(map pbind bindings) ,@(expdef body))) (($ body defs exps) (let ((pdefs (maplr expdef defs))) (append pdefs (maplr expdef exps)))) (($ record bindings) `(record ,@(maplr pbind bindings))) (($ field x e) `(field ,x ,(expdef e))) (($ cast (ty . _) e) `(: ,ty ,(expdef e))) (($ or exps) `(or ,@(maplr expdef exps))) (($ delay e) `(delay ,(expdef e))) (($ set! x body) `(set! ,(pname x) ,(expdef body))) (($ var x) (pname x)) (($ match e1 clauses) (let* ((pclause (match-lambda (($ mclause p exp fail) (if fail `(,(expdef p) (=> ,(pname fail)) ,@(expdef exp)) `(,(expdef p) ,@(expdef exp)))))) (p1 (expdef e1))) `(match ,p1 ,@(maplr pclause clauses)))) (($ pconst x _) (pconst x)) (($ pvar x) (show x)) (($ pany) '_) (($ pelse) 'else) (($ pnot pat) `(not ,(expdef pat))) (($ pand pats) `(and ,@(maplr expdef pats))) (($ ppred pred) (match (pname pred) ('false-object? #f) ('true-object? #t) ('null? '()) (x `(? ,x)))) (($ pobj tag args) (match (cons (pname tag) args) (('pair? x y) (cons (expdef x) (expdef y))) (('box? x) (box (expdef x))) (('vector? . x) (list->vector (maplr expdef x))) ((tg . _) `($ ,(strip-? tg) ,@(maplr expdef args))))) (($ type _ exp) (expdef exp)) (($ check _ exp) (expdef exp))))) (define check-type (match-lambda (($ type ty ($ check inf ($ var x))) ty) (($ type ty ($ check inf ($ lam x e1))) ty) (($ type ty ($ check inf ($ vlam x rest e1))) ty) (($ type _ ($ check inf ($ app e1 args))) (typeof e1)) (($ type _ ($ check inf ($ field x e1))) (typeof e1)) (($ type _ ($ check inf ($ cast (x . _) e1))) (typeof e1)) (($ type _ ($ check inf ($ match e1 clauses))) (typeof e1)))) (define tree '()) (define global-env empty-env) (define verbose #f) (define times #t) (define benchmarking #f) (define cons-mutators '(set-car! set-cdr!)) (define st:check (lambda args (parameterize ((print-level #f) (print-length #f) (pretty-maximum-lines #f)) (let ((output (apply do-soft args))) (when output (printf "Typed program written to file ~a~%" output)))))) (define st:run (lambda (file) (parameterize ((optimize-level 3)) (when benchmarking (printf "Reloading slow CHECKs...~%") (load (string-append installation-directory "checklib.scm")) (set! benchmarking #f)) (load file)))) (define st:bench (lambda (file) (parameterize ((optimize-level 3)) (unless benchmarking (unless fastlibrary-file (use-error "No benchmarking mode in this version")) (printf "Reloading fast CHECKs...~%") (load (string-append installation-directory fastlibrary-file)) (set! benchmarking #t)) (load file)))) (define st: (lambda args (parameterize ((print-level #f) (print-length #f) (pretty-maximum-lines #f)) (let ((output (apply do-soft args))) (cond ((not output) (use-error "Output file name required to run")) ((= 0 n-unbound) (printf "Typed program written to file ~a, executing ...~%" output) (flush-output) (st:run output)) (else (printf "Typed program written to file ~a, not executing (unbound refs)~%" output))))))) (define do-soft (match-lambda* ((input (? string? output)) (when (strip-suffix output) (use-error "output file name cannot end in .ss or .scm")) (cond ((string? input) (soft-files (list input) output) output) ((and (list? input) (andmap string? input)) (soft-files input output) output) (else (soft-def input output) output))) ((input #f) (cond ((string? input) (soft-files (list input) #f) #f) ((and (list? input) (andmap string? input)) (soft-files input #f) #f) (else (soft-def input #f) #f))) ((input) (cond ((string? input) (let ((o (string-append (or (strip-suffix input) input) ".soft"))) (soft-files (list input) o) o)) ((and (list? input) (andmap string? input)) (use-error "Output file name required")) (else (soft-def input #t) #f))) (else (use-error "Input must be a file name or list of file names")))) (define rawmode #f) (define st:control (lambda args (let ((dbg (match-lambda ('raw (set! display-type ptype) (set! rawmode #t)) ('!raw (set! display-type tidy) (set! rawmode #f)) ('verbose (set! verbose #t)) ('!verbose (set! verbose #f)) ('times (set! times #t)) ('!times (set! times #f)) ('partial (set! fullsharing #f)) ('!partial (set! fullsharing #t)) ('pseudo (set! pseudo pseudo-subtype)) ('!pseudo (set! pseudo #f)) ('populated (set! populated #t)) ('!populated (set! populated #f)) ('matchst (set! matchst #t)) ('!matchst (set! matchst #f)) ('genmatch (set! genmatch #t)) ('!genmatch (set! genmatch #f)) ('letonce (set! letonce #t)) ('!letonce (set! letonce #f)) ('global-error (set! global-error #t)) ('!global-error (set! global-error #f)) ('share (set! share #t)) ('!share (set! share #f)) ('flags (set! flags #t)) ('!flags (set! flags #f)) ('depths (set! dump-depths #t)) ('!depths (set! dump-depths #f)) ('match (set! keep-match #t)) ('!match (set! keep-match #f)) (x (printf "Error: unknown debug switch ~a~%" x) (st:control))))) (if (null? args) (begin (printf "Current values:") (for-each (lambda (x) (printf " ~a" x)) (show-controls)) (printf "~%")) (for-each dbg args))))) (define show-controls (lambda () (list (if rawmode 'raw '!raw) (if verbose 'verbose '!verbose) (if times 'times '!times) (if share 'share '!share) (if flags 'flags '!flags) (if dump-depths 'depths '!depths) (if fullsharing '!partial 'partial) (if pseudo 'pseudo '!pseudo) (if populated 'populated '!populated) (if letonce 'letonce '!letonce) (if matchst 'matchst '!matchst) (if genmatch 'genmatch '!genmatch) (if global-error 'global-error '!global-error) (if keep-match 'match '!match)))) (define soft-def (lambda (exp output) (reinit-macros!) (reinit-types!) (reinit-output!) (set! visible-time 0) (match-let* ((before-parse (cpu-time)) (defs (parse-def exp)) (before-bind (cpu-time)) ((defs env tenv unbound) (bind-defs defs initial-env initial-type-env '() 0)) (_ (warn-unbound unbound)) (_ (if cons-is-mutable (printf "Note: use of ~a, treating cons as MUTABLE~%" cons-mutators) (printf "Note: no use of ~a, treating cons as immutable~%" cons-mutators))) (before-improve (cpu-time)) (defs (improve-defs defs)) (before-typecheck (cpu-time)) (_ (type-check defs)) (_ (set! global-env env)) (before-output (cpu-time)) (_ (check output)) (_ (print-summary "")) (before-end (cpu-time))) (when times (printf "~a seconds parsing,~%" (exact->inexact (* (- before-bind before-parse) clock-granularity))) (printf "~a seconds binding,~%" (exact->inexact (* (- before-improve before-bind) clock-granularity))) (printf "~a seconds improving,~%" (exact->inexact (* (- before-typecheck before-improve) clock-granularity))) (printf "~a seconds type checking,~%" (exact->inexact (* (- (- before-output before-typecheck) visible-time) clock-granularity))) (printf "~a seconds setting visibility,~%" (exact->inexact (* visible-time clock-granularity))) (printf "~a seconds writing output,~%" (exact->inexact (* (- before-end before-output) clock-granularity))) (printf "~a seconds in total.~%" (exact->inexact (* (- before-end before-parse) clock-granularity))))))) (define type-check (lambda (defs) (set! tree defs) (type-defs defs) defs)) (define soft-files (lambda (files output) (let ((contents (map (lambda (f) `(begin ,@(readfile f))) files))) (soft-def `(begin ,@contents) output)))) (define strip-suffix (lambda (name) (let ((n (string-length name))) (or (and (<= 3 n) (equal? ".ss" (substring name (- n 3) n)) (substring name 0 (- n 3))) (and (<= 4 n) (equal? ".scm" (substring name (- n 4) n)) (substring name 0 (- n 4))))))) (define st:deftype (match-lambda* (((? symbol? x) ? list? mutability) (=> fail) (if (andmap boolean? mutability) (deftype x mutability) (fail))) (args (use-error "Invalid command ~a" `(st:deftype ,@args))))) (define st:defprim (match-lambda* (((? symbol? x) type) (defprim x type 'impure)) (((? symbol? x) type (? symbol? mode)) (defprim x type mode)) (args (use-error "Invalid command ~a" `(st:defprim ,@args))))) (define st:help (lambda () (printf "Commands for Soft Scheme (~a)~%" st:version) (printf " (st: file (output)) type check file and execute~%") (printf " (st:type (name)) print types of global defs~%") (printf " (st:check file (output)) type check file~%") (printf " (st:run file) execute type checked file~%") (printf " (st:bench file) execute type checked file fast~%") (printf " (st:ltype (name)) print types of local defs~%") (printf " (st:cause) print cause of CHECKs~%") (printf " (st:summary) print summary of CHECKs~%") (printf " (st:help) prints this message~%") (printf " (st:defprim name type (mode)) define a new primitive~%") (printf " (st:deftype name bool ...) define a new type constructor~%") (printf " (st:control flag ...) set internal flags~%") (printf "For more info, see ftp://ftp.nj.nec.com/pub/wright/ssmanual/softscheme.html~%") (printf "Copyright (c) 1993, 1994, 1995 by Andrew K. Wright under the~%") (printf "terms of the Gnu Public License. No warranties of any kind apply.~%"))) (define st:type type) (define st:ltype localtype) (define st:cause cause) (define st:summary (lambda () (print-summary ""))) (define init! (lambda () (when customization-file (load (string-append installation-directory customization-file))) (let ((softrc (string-append home-directory "/.softschemerc"))) (when (file-exists? softrc) (load softrc))) (set! global-env initial-env) (st:help))) (init!)