513 lines
15 KiB
Scheme
513 lines
15 KiB
Scheme
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
|
|
; Generic procedure package
|
|
|
|
; This is written in fairly portable Scheme. It needs:
|
|
; Scheme 48 low-level macros (explicit renaming), in one small place.
|
|
; (CALL-ERROR message proc arg ...) - signal an error.
|
|
; Record package and DEFINE-RECORD-TYPES macro.
|
|
; An object :RECORD-TYPE which is the record type descriptor for
|
|
; record type descriptors (records are assumed to be records).
|
|
; This wouldn't be difficult to change.
|
|
; A RECORD? predicate (not essential - only for defining a DISCLOSE
|
|
; method for records).
|
|
|
|
; --------------------
|
|
; Simple types.
|
|
; More specific types have higher priorities. The priorities are used
|
|
; to establish the ordinary in which type predicates are called.
|
|
|
|
(define-record-type simple-type :simple-type
|
|
(really-make-simple-type supers predicate priority id)
|
|
simple-type?
|
|
(supers simple-type-superiors)
|
|
(predicate simple-type-predicate)
|
|
(priority simple-type-priority)
|
|
(id simple-type-id)
|
|
(more)) ;if needed later
|
|
|
|
(define-record-discloser :simple-type
|
|
(lambda (c) `(simple-type ,(simple-type-id c))))
|
|
|
|
(define (make-simple-type supers predicate id)
|
|
(make-immutable!
|
|
(really-make-simple-type supers
|
|
predicate
|
|
(compute-priority supers)
|
|
id)))
|
|
|
|
(define (compute-priority supers)
|
|
(if (null? supers)
|
|
0
|
|
(+ (apply max (map %type-priority supers))
|
|
*increment*)))
|
|
|
|
(define *increment* 10)
|
|
|
|
|
|
; These two procedures will become generic later, but must exist early
|
|
; in order to be able to bootstrap the method definition mechanism.
|
|
|
|
(define (%type-priority type)
|
|
(cond ((simple-type? type)
|
|
(simple-type-priority type))
|
|
((record-type? type)
|
|
(record-type-priority type))
|
|
(else (type-priority type)))) ;generic
|
|
|
|
(define (%type-predicate type)
|
|
(cond ((simple-type? type)
|
|
(simple-type-predicate type))
|
|
((record-type? type)
|
|
(record-predicate type))
|
|
(else (type-predicate type)))) ;generic
|
|
|
|
(define (%same-type? t1 t2)
|
|
(or (eq? t1 t2)
|
|
(if (simple-type? t1)
|
|
#f
|
|
(if (record-type? t1)
|
|
#f
|
|
(same-type? t1 t2)))))
|
|
|
|
|
|
(define-syntax define-simple-type
|
|
(syntax-rules ()
|
|
((define-simple-type ?name (?super ...) ?pred)
|
|
(define ?name (make-simple-type (list ?super ...) ?pred '?name)))))
|
|
|
|
; --------------------
|
|
; Built-in Scheme types
|
|
|
|
(define-simple-type :syntax () #f)
|
|
(define-simple-type :values () #f) ;any number of values
|
|
|
|
(define (value? x) #t)
|
|
(define-simple-type :value (:values) value?)
|
|
(define-simple-type :zero (:values) (lambda (x) #f))
|
|
|
|
(define-simple-type :number (:value) number?)
|
|
(define-simple-type :complex (:number) complex?)
|
|
(define-simple-type :real (:complex) real?)
|
|
(define-simple-type :rational (:real) rational?)
|
|
(define-simple-type :integer (:rational) integer?)
|
|
(define-simple-type :exact-integer (:integer)
|
|
(lambda (n) (and (integer? n) (exact? n))))
|
|
|
|
(define-simple-type :boolean (:value) boolean?)
|
|
(define-simple-type :symbol (:value) symbol?)
|
|
(define-simple-type :char (:value) char?)
|
|
(define-simple-type :null (:value) null?)
|
|
(define-simple-type :pair (:value) pair?)
|
|
(define-simple-type :vector (:value) vector?)
|
|
(define-simple-type :string (:value) string?)
|
|
(define-simple-type :procedure (:value) procedure?)
|
|
|
|
(define-simple-type :input-port (:value) input-port?)
|
|
(define-simple-type :output-port (:value) output-port?)
|
|
(define-simple-type :eof-object (:value) eof-object?)
|
|
|
|
; If there is no RECORD? predicate, do
|
|
; (define-simple-type :record (:value) value?)
|
|
; and change the DISCLOSE method for records to
|
|
; (or (disclose-record obj) (next-method)).
|
|
|
|
(define-simple-type :record (:value) record?)
|
|
|
|
; Given a record type, RECORD-TYPE-PRIORITY returns its priority.
|
|
; Here we establish that every record type is a direct subtype of the
|
|
; :RECORD type.
|
|
|
|
(define record-type-priority
|
|
(let ((r-priority
|
|
(simple-type-priority (make-simple-type (list :record) #f #f))))
|
|
(lambda (rt) r-priority)))
|
|
|
|
; --------------------
|
|
; Method-info records are triples <type-list, n-ary?, proc>.
|
|
|
|
(define-record-type method-info :method-info
|
|
(really-make-method-info types n-ary? proc)
|
|
method-info?
|
|
(types method-info-types)
|
|
(n-ary? method-info-n-ary?)
|
|
(proc method-info-proc))
|
|
|
|
(define (make-method-info types n-ary? proc)
|
|
(make-immutable! (really-make-method-info types n-ary? proc)))
|
|
|
|
(define-record-discloser :method-info
|
|
(lambda (info)
|
|
`(method-info ,(method-info-types info) ,(method-info-n-ary? info))))
|
|
|
|
; --------------------
|
|
; Method lists
|
|
|
|
; A method list is a list of method-info records, sorted in order from
|
|
; most specific to least specific.
|
|
|
|
(define (empty-method-list) '())
|
|
|
|
; insert-method inserts an entry into a method list so that the most
|
|
; specific methods come earliest in the list. The last method should
|
|
; be a default method or error signal(l)er.
|
|
|
|
(define (insert-method info ms)
|
|
(let recur ((ms ms))
|
|
(if (null? ms)
|
|
(cons info ms)
|
|
(if (more-specific? (car ms) info)
|
|
(cons (car ms) (recur (cdr ms)))
|
|
(cons info
|
|
(if (same-applicability? (car ms) info)
|
|
(cdr ms)
|
|
ms))))))
|
|
|
|
; Replace an existing method with identical domain.
|
|
|
|
(define (same-applicability? info1 info2)
|
|
(and (every2 %same-type?
|
|
(method-info-types info1)
|
|
(method-info-types info2))
|
|
(eq? (method-info-n-ary? info1) (method-info-n-ary? info2))))
|
|
|
|
(define (every2 pred l1 l2)
|
|
(if (null? l1)
|
|
(null? l2)
|
|
(if (null? l2)
|
|
#f
|
|
(and (pred (car l1) (car l2)) (every2 pred (cdr l1) (cdr l2))))))
|
|
|
|
; This interacts with methods->perform, below.
|
|
; In this version, it's supposed to be a total order.
|
|
|
|
(define (more-specific? info1 info2)
|
|
(let ((t1 (method-info-types info1))
|
|
(t2 (method-info-types info2)))
|
|
(let ((l1 (length t1))
|
|
(l2 (length t2))
|
|
(foo? (and (not (method-info-n-ary? info1))
|
|
(method-info-n-ary? info2))))
|
|
(if (= l1 l2)
|
|
(or foo?
|
|
(let loop ((l1 t1)
|
|
(l2 t2))
|
|
(if (null? l2)
|
|
#f
|
|
(or (more-specific-type? (car l1) (car l2))
|
|
(and (%same-type? (car l1) (car l2))
|
|
(loop (cdr l1) (cdr l2)))))))
|
|
(and (> l1 l2)
|
|
foo?)))))
|
|
|
|
|
|
(define (more-specific-type? t1 t2)
|
|
(> (%type-priority t1) (%type-priority t2)))
|
|
|
|
; --------------------
|
|
; A method table is a cell that contains a method list.
|
|
; Note that the method table is not reachable from the generic
|
|
; procedure. This means good things for the GC.
|
|
|
|
(define-record-type method-table :method-table
|
|
(really-make-method-table methods prototype
|
|
generic get-perform set-perform! id)
|
|
method-table?
|
|
(methods method-table-methods set-method-table-methods!)
|
|
(prototype method-table-prototype)
|
|
(generic make-generic)
|
|
(get-perform method-table-get-perform)
|
|
(set-perform! method-table-set-perform!)
|
|
(id method-table-id))
|
|
|
|
(define-record-discloser :method-table
|
|
(lambda (t) `(method-table ,(method-table-id t))))
|
|
|
|
(define (make-method-table id . option)
|
|
(let* ((prototype (if (null? option)
|
|
(make-method-info '() #t #f)
|
|
(car option)))
|
|
(mtable (call-with-values make-cell-for-generic
|
|
(lambda (generic get-perform set-perform!)
|
|
(really-make-method-table '()
|
|
prototype
|
|
generic
|
|
get-perform
|
|
set-perform!
|
|
id)))))
|
|
(set-final-method!
|
|
mtable
|
|
(lambda (next-method . args)
|
|
(apply call-error "invalid or unimplemented operation"
|
|
id args)))
|
|
mtable))
|
|
|
|
(define (make-cell-for-generic)
|
|
(let ((perform #f))
|
|
;; PERFORM always caches (METHODS->PERFORM method-list prototype).
|
|
(values (lambda args (perform args)) ;Generic proc
|
|
(lambda () perform)
|
|
(lambda (new) (set! perform new)))))
|
|
|
|
(define (add-to-method-table! mtable info)
|
|
(let ((l (insert-method info (method-table-methods mtable))))
|
|
(set-method-table-methods! mtable l)
|
|
((method-table-set-perform! mtable)
|
|
(methods->perform l (method-table-prototype mtable)))))
|
|
|
|
(define (set-final-method! mtable proc)
|
|
(add-to-method-table! mtable
|
|
(make-method-info '()
|
|
#t
|
|
proc)))
|
|
|
|
(define (apply-generic mtable args)
|
|
;; (apply (make-generic mtable) args)
|
|
(((method-table-get-perform mtable)) args)) ;+++
|
|
|
|
; DEFINE-GENERIC
|
|
|
|
(define-syntax define-generic
|
|
(syntax-rules ()
|
|
((define-generic ?name ?mtable-name)
|
|
(begin (define ?mtable-name (make-method-table '?name))
|
|
(define ?name (make-generic ?mtable-name))))
|
|
((define-generic ?name ?mtable-name (?spec . ?specs))
|
|
(begin (define ?mtable-name
|
|
(make-method-table '?name
|
|
(method-info ?name ("next" next-method
|
|
?spec . ?specs)
|
|
(next-method))))
|
|
(define ?name (make-generic ?mtable-name))))))
|
|
|
|
; --------------------
|
|
; Method combination.
|
|
|
|
; Here is the specification:
|
|
|
|
;(define (apply-generic mtable args)
|
|
; (let loop ((ms (method-table-methods mtable)))
|
|
; (let ((next-method (lambda () (loop (cdr ms)))))
|
|
; (if (let test ((ts (method-info-types (car ms)))
|
|
; (args args))
|
|
; (if (null? ts)
|
|
; (or (null? args)
|
|
; (method-info-n-ary? (car ms)))
|
|
; (and ((%type-predicate (car ts)) (car args))
|
|
; (test (cdr ts) (cdr args)))))
|
|
; (apply (method-info-proc (car ms))
|
|
; next-method
|
|
; args)
|
|
; (next-method)))))
|
|
|
|
; (perform arg-list)
|
|
; (apply proc next-method-thunk arg-list)
|
|
|
|
; This version of METHODS->PERFORM simply marches through all the
|
|
; methods, looking for one that handles the operation.
|
|
|
|
; The prototype is currently ignored, but it could be put to good use.
|
|
|
|
(define (methods->perform l prototype)
|
|
(let recur ((l l))
|
|
(let* ((info (car l))
|
|
(proc (method-info-proc info)))
|
|
(if (null? (cdr l))
|
|
(last-action proc)
|
|
(one-action (argument-sequence-predicate info)
|
|
proc
|
|
(recur (cdr l)))))))
|
|
|
|
(define (last-action proc)
|
|
(lambda (args)
|
|
(apply proc #f args)))
|
|
|
|
(define (one-action pred proc perform-next)
|
|
(lambda (args)
|
|
(if (pred args)
|
|
(apply proc
|
|
(lambda () (perform-next args)) ; next-method
|
|
args)
|
|
(perform-next args))))
|
|
|
|
(define (argument-sequence-predicate info)
|
|
(let recur ((types (method-info-types info)))
|
|
(if (null? types)
|
|
(if (method-info-n-ary? info) value? null?)
|
|
(let ((pred (%type-predicate (car types)))
|
|
(check-rest (recur (cdr types))))
|
|
(if (eq? pred value?)
|
|
(check-for-next check-rest) ;+++
|
|
(check-next pred check-rest))))))
|
|
|
|
(define (check-for-next check-rest)
|
|
(lambda (args)
|
|
(if (null? args)
|
|
#f
|
|
(check-rest (cdr args)))))
|
|
|
|
(define (check-next pred check-rest)
|
|
(lambda (args)
|
|
(if (null? args)
|
|
#f
|
|
(if (pred (car args))
|
|
(check-rest (cdr args))
|
|
#f))))
|
|
|
|
; --------------------
|
|
; METHOD-INFO macro.
|
|
; Returns a method-info record.
|
|
|
|
; You can specify the name of the next-method parameter by saying
|
|
; (method-info my-name (x y "next" n) body ...)
|
|
; Otherwise, the next-method parameter will be named next-method.
|
|
; Just pretend it's Dylan and that #next reads as "next".
|
|
|
|
(define-syntax method-info
|
|
(syntax-rules ()
|
|
((method-info ?id ?formals ?body ...)
|
|
(method-internal ?formals () () #f ?id ?body ...))))
|
|
|
|
(define-syntax method-internal
|
|
(syntax-rules ()
|
|
((method-internal ((?formal1 ?type1) . ?specs)
|
|
(?formal ...) (?type ...) ?next
|
|
. ?rest)
|
|
(method-internal ?specs
|
|
(?formal ... ?formal1) (?type ... ?type1) ?next
|
|
. ?rest))
|
|
|
|
((method-internal ("next" ?next . ?specs)
|
|
(?formal ...) (?type ...) ?ignore
|
|
. ?rest)
|
|
(method-internal ?specs
|
|
(?formal ...) (?type ...) ?next
|
|
. ?rest))
|
|
|
|
((method-internal (?spec . ?specs)
|
|
(?formal ...) (?type ...) ?next
|
|
. ?rest)
|
|
(method-internal ?specs
|
|
(?formal ... ?spec) (?type ... :value) ?next
|
|
. ?rest))
|
|
|
|
((method-internal ?rest
|
|
(?formal ...) (?type ...) ?next
|
|
?id ?body ...)
|
|
(make-method-info (list ?type ...)
|
|
(not (null? '?rest))
|
|
(let ((?id (with-next-method ?next (?formal ... . ?rest)
|
|
?body ...)))
|
|
;; The (let ...) is a hack for the Scheme 48
|
|
;; byte code compiler, which will remember
|
|
;; ?id as the procedure's name. This should
|
|
;; aid debugging a little bit since the name
|
|
;; shows up in backtraces and the inspector.
|
|
?id)))))
|
|
|
|
; Non-hygienic, a la Dylan
|
|
|
|
(define-syntax with-next-method
|
|
(cons (lambda (e r c)
|
|
(let ((next (or (cadr e) 'next-method)))
|
|
`(,(r 'lambda) (,next ,@(caddr e))
|
|
,@(cdddr e))))
|
|
'(lambda)))
|
|
|
|
; DEFINE-METHOD macro.
|
|
|
|
(define-syntax define-method
|
|
(syntax-rules ()
|
|
((define-method ?mtable ?formals ?body ...)
|
|
(add-method! ?mtable
|
|
(method-info ?mtable ?formals ?body ...)))))
|
|
|
|
(define-generic add-method! &add-method! (mtable info))
|
|
|
|
(let ((info
|
|
(method-info add-method! ((mtable :method-table) (info :method-info))
|
|
(add-to-method-table! mtable info))))
|
|
(add-to-method-table! &add-method! info))
|
|
|
|
; --------------------
|
|
; Generic functions on types: sort of a meta-object protocol, huh?
|
|
|
|
(define-generic type-predicate &type-predicate (t))
|
|
|
|
(define-method &type-predicate ((t :record-type)) (record-predicate t))
|
|
(define-method &type-predicate ((t :simple-type)) (simple-type-predicate t))
|
|
|
|
(define-generic type-priority &type-priority (t))
|
|
|
|
(define-method &type-priority ((t :record-type)) (record-type-priority t))
|
|
(define-method &type-priority ((t :simple-type)) (simple-type-priority t))
|
|
|
|
(define-generic type-superiors &type-superiors (t))
|
|
|
|
(define-method &type-superiors ((t :record-type)) (list :record))
|
|
(define-method &type-superiors ((t :simple-type)) (simple-type-superiors t))
|
|
|
|
|
|
; Type equivalence
|
|
|
|
(define-generic same-type? &same-type? (t1 t2))
|
|
|
|
(define-method &same-type? (t1 t2) (eq? t1 t2))
|
|
|
|
(define-method &same-type? ((t1 :simple-type) (t2 :simple-type))
|
|
(and (eq? (simple-type-predicate t1) (simple-type-predicate t2))
|
|
(eq? (simple-type-id t1) (simple-type-id t2)))) ;?
|
|
|
|
; --------------------
|
|
; Singleton types.
|
|
|
|
(define-record-type singleton :singleton
|
|
(singleton value)
|
|
(value singleton-value))
|
|
|
|
(define-record-discloser :singleton
|
|
(lambda (s) `(singleton ,(singleton-value s))))
|
|
|
|
(define (compare-to val)
|
|
(lambda (x) (eqv? x val)))
|
|
|
|
(define-method &type-predicate ((s :singleton))
|
|
(compare-to (singleton-value s)))
|
|
|
|
(define-method &type-priority ((s :singleton)) 1000000)
|
|
|
|
(define-method &same-type? ((s1 :singleton) (s2 :singleton))
|
|
(eqv? (singleton-value s1) (singleton-value s2)))
|
|
|
|
; --------------------
|
|
; DISCLOSE
|
|
|
|
; A generic procedure for producing printed representations.
|
|
; Should return one of
|
|
; - A list (symbol info ...), to be printed as #{Symbol info ...}
|
|
; - #f, meaning no information available on how to print.
|
|
; This is intended to be used not only by write and display, but also by
|
|
; the pretty printer.
|
|
|
|
(define-generic disclose &disclose (x))
|
|
|
|
(define-method &disclose (obj) #f)
|
|
|
|
(define-method &disclose ((obj :record))
|
|
(or (disclose-record obj)
|
|
'(record)))
|
|
|
|
(define-method &add-method! ((d (singleton &disclose)) info)
|
|
(let ((t (car (method-info-types info))))
|
|
(if (record-type? t)
|
|
(define-record-discloser t (proc->discloser (method-info-proc info)))
|
|
(next-method))))
|
|
|
|
(define (proc->discloser proc)
|
|
(lambda (arg)
|
|
(proc (lambda () #f) arg)))
|
|
|
|
;(define-method &disclose ((s :singleton))
|
|
; `(singleton ,(singleton-value s)))
|