275 lines
10 KiB
Executable File

;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; General Public License for more details.
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(define-syntax define-ontology
(lambda (x)
(define (make-ontology main ls)
(define (set-cons x ls)
[(memq x ls) ls]
[else (cons x ls)]))
(define (union ls1 ls2)
[(null? ls1) ls2]
[else (union (cdr ls1) (set-cons (car ls1) ls2))]))
(define (difference ls1 ls2)
[(null? ls1) '()]
[(memq (car ls1) ls2) (difference (cdr ls1) ls2)]
[else (cons (car ls1) (difference (cdr ls1) ls2))]))
(define (collect-names ls)
(syntax-case ls ()
[() '()]
[((name (of name* ...)) . rest)
(union (cons #'name #'(name* ...)) (collect-names #'rest))]))
(define (expand x all)
(define (lookup x ls)
[(null? ls) (values 'tag '())]
(let ([a (car ls)])
[(eq? x (car a))
(values (cadr a) (cdr ls))]
(let-values ([(xp ls) (lookup x (cdr ls))])
(values xp (cons a ls)))]))]))
(let f ([x x] [ls ls])
(let-values ([(xp ls) (lookup x ls)])
[(pair? xp)
(cons (car xp) (map (lambda (x) (f x ls)) (cdr xp)))]
[(eq? xp 'tag) x]
[else (error 'expand-lookup "invalid" xp)]))))
(define (rename alist x)
[(symbol? x) (cdr (assq x alist))]
[else (cons (car x) (map (lambda (x) (rename alist x)) (cdr x)))]))
(define (enumerate ls)
(let f ([i 1] [ls ls])
[(null? ls) '()]
[else (cons i (f (* i 2) (cdr ls)))])))
(define (unique-elements x)
(define (exclude m ls)
[(null? ls) '()]
[(zero? (bitwise-and m (car ls)))
(cons (car ls) (exclude m (cdr ls)))]
[else (exclude m (cdr ls))]))
(define (exclusive* m* x**)
[(null? (cdr m*)) (values (car m*) (car x**))]
(let-values ([(m1 x1*) (values (car m*) (car x**))]
[(m2 x2*) (exclusive* (cdr m*) (cdr x**))])
(let ([x1* (exclude m2 x1*)]
[x2* (exclude m1 x2*)])
(values (bitwise-ior m1 m2) (append x1* x2*))))]))
(define (inclusive* m* x**)
[(null? (cdr m*)) (values (car m*) (car x**))]
(let-values ([(m1 x1*) (values (car m*) (car x**))]
[(m2 x2*) (inclusive* (cdr m*) (cdr x**))])
(values (bitwise-ior m1 m2)
(remp not
(apply append
(map (lambda (x)
(map (lambda (y)
(if (= (bitwise-and m1 m2 x)
(bitwise-and m1 m2 y))
(bitwise-ior x y)
(define (f* ls)
[(null? ls) (values '() '())]
(let-values ([(m x*) (f (car ls))]
[(m* x**) (f* (cdr ls))])
(values (cons m m*) (cons x* x**)))]))
(define (f x)
[(integer? x) (values x (list x))]
(let ([tag (car x)] [ls (cdr x)])
(let-values ([(m* x**) (f* ls)])
(case tag
[(exclusive) (exclusive* m* x**)]
[(inclusive) (inclusive* m* x**)]
[else (error 'f "invalid")])))]))
(let-values ([(m ls) (f x)])
(define (expand-names alist)
(lambda (n)
(let f ([alist alist])
[(null? alist) '()]
[(zero? (bitwise-and n (cdar alist)))
(f (cdr alist))]
(cons (caar alist) (f (cdr alist)))]))))
(define (extend-alist* ls alist)
(define (extend-alist x alist)
(define (lookup x)
[(assq x alist) => cdr]
[else (error 'lookup "cannot find" x alist)]))
(let ([name (car x)] [info (cadr x)])
(let ([tag (car info)] [x* (map lookup (cdr info))])
(case tag
(cons (cons name (apply bitwise-ior x*)) alist)]
(assert (= (apply bitwise-ior x*) (apply bitwise-and x*)))
(cons (cons name (apply bitwise-ior x*)) alist)]
[else (assert #f)]))))
[(null? ls) alist]
(extend-alist (car ls)
(extend-alist* (cdr ls) alist))]))
(let* ([names (difference (collect-names ls) (map car ls))]
[names-alist (map cons names (enumerate names))])
(let* ([expanded (expand main ls)]
[renamed (rename names-alist expanded)])
(let* ([unique* (list-sort < (unique-elements renamed))]
[canonicals (map (expand-names names-alist) unique*)])
(let* ([canonical-alist (map cons canonicals (enumerate canonicals))]
(lambda (x)
(let ([ls (filter (lambda (y) (memq x (car y))) canonical-alist)])
(cons x (apply bitwise-ior (map cdr ls)))))
(extend-alist* ls seed-alist))))))
(define (property-names ls)
[(null? ls) '()]
(let ([fst (car ls)] [rest (property-names (cdr ls))])
(let ([name (car fst)] [info (cadr fst)])
(case (car info)
[(exclusive) rest]
[(inclusive) (append (cdr info) rest)]
[else (assert #f)])))]))
(define (generate-base-cases T main ls)
(define (value-name x)
(datum->syntax T
(symbol->string (syntax->datum T))
(symbol->string x)))))
(define (predicate-name x)
(datum->syntax T
(symbol->string (syntax->datum T))
(symbol->string x)
(let ([maind (syntax->datum main)] [lsd (syntax->datum ls)])
(let ([alist (make-ontology maind lsd)]
[pnames (property-names lsd)])
(let ([alist (remp (lambda (x) (memq (car x) pnames)) alist)])
(lambda (x) (list (value-name (car x))
(predicate-name (car x))
(cdr x)))
(syntax-case x ()
[(_ T T:description T? T:=? T:and T:or [name cls] [name* cls*] ...)
(with-syntax ([((name* predname* val*) ...)
(generate-base-cases #'T #'name
#'([name cls] [name* cls*] ...))])
(define-record-type (T make-T T?)
(sealed #t)
(fields (immutable n T-n)))
(define (T:and x0 x1)
(make-T (bitwise-and (T-n x0) (T-n x1))))
(define (T:or x0 x1)
(make-T (bitwise-ior (T-n x0) (T-n x1))))
(define (test x v)
(let ([bits (bitwise-and x v)])
[(= 0 (bitwise-and x v)) 'no]
[(= v (bitwise-ior x v)) 'yes]
[else 'maybe])))
(define name* (make-T val*)) ...
(define (predname* x) (test (T-n x) val*)) ...
(define (T:description x)
(let* ([ls '()]
(case (predname* x)
[(yes) (cons 'name* ls)]
[else ls])]
(define (T:=? x y)
(= (T-n x) (T-n y)))
(define-ontology T T:description T? T=? T:and T:or
[object (inclusive obj-tag obj-immediacy obj-truth)]
[obj-immediacy (exclusive nonimmediate immediate)]
[immediate (exclusive fixnum boolean null char void)]
[obj-truth (exclusive false non-false)]
[obj-tag (exclusive procedure string vector pair null
boolean char number void bytevector
symbol other-object)]
[boolean (exclusive true false)]
[number (inclusive number-tag number-size number-exactness)]
[number-size (exclusive negative zero positive)]
[number-tag (exclusive fixnum flonum other-number)]
[number-exactness (exclusive exact inexact)]
[exact (exclusive fixnum other-exact)]
[inexact (exclusive flonum other-inexact)]
(define (do-test expr result expected)
(if (equal? result expected)
(printf "OK: ~s -> ~s\n" expr expected)
(error 'test "failed/got/expected" expr result expected)))
(define-syntax test
(syntax-rules ()
[(_ expr expected) (do-test 'expr expr 'expected)]))
(test (T:object? T:object) yes)
(test (T:object? T:true) yes)
(test (T:true? T:object) maybe)
(test (T:true? T:true) yes)
(test (T:true? T:false) no)
(test (T:true? T:null) no)
(test (T:non-false? T:true) yes)
(test (T:non-false? T:null) yes)
(test (T:non-false? T:false) no)
(test (T:non-false? T:boolean) maybe)
(test (T:non-false? T:object) maybe)
(test (T:boolean? T:true) yes)
(test (T:boolean? T:false) yes)
(test (T:boolean? (T:or T:true T:false)) yes)
(test (T:boolean? (T:and T:true T:false)) no)
(test (T:object? (T:and T:true T:false)) no)