300 lines
7.7 KiB
Scheme
300 lines
7.7 KiB
Scheme
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
|
|
; Dilapidated Object-Oriented Dynamic Language
|
|
; Dynamic Object-Oriented Dynamic Language
|
|
; Drug-crazed Object-Oriented Dynamic Language
|
|
|
|
; Written for clarity, not for speed.
|
|
|
|
; Tests are in test-doodl.scm.
|
|
|
|
(define <object> :value)
|
|
(define <number> :number)
|
|
(define <complex> :complex)
|
|
(define <real> :real)
|
|
(define <rational> :rational)
|
|
(define <integer> :integer)
|
|
(define <pair> :pair)
|
|
(define <symbol> :symbol)
|
|
(define <char> :char)
|
|
(define <null> :null)
|
|
(define <vector> :vector)
|
|
(define <string> :string)
|
|
(define <eof-object> :eof-object)
|
|
(define <function> :procedure)
|
|
(define <input-port> :input-port)
|
|
(define <output-port> :output-port)
|
|
|
|
|
|
; --------------------
|
|
; Generic functions
|
|
|
|
(define method-table? (type-predicate :method-table))
|
|
|
|
(define-syntax define-generic-function
|
|
(syntax-rules (setter)
|
|
((define-generic-function (setter ?name) ?parameter-list) ;for define-slot
|
|
(define-setter ?name
|
|
(make-generic-function
|
|
'(setter ?name)
|
|
(method-info ?name ("next" next-method . ?parameter-list)
|
|
(next-method)))))
|
|
((define-generic-function ?name ?parameter-list)
|
|
(define ?name
|
|
(make-generic-function
|
|
'?name
|
|
(method-info ?name ("next" next-method . ?parameter-list)
|
|
(next-method)))))))
|
|
|
|
(define (make-generic-function id prototype)
|
|
(let ((mtable (make-method-table id prototype)))
|
|
(annotate-procedure (make-generic mtable) mtable)))
|
|
|
|
(define (generic-function? f)
|
|
(and (procedure? f)
|
|
(method-table? (procedure-annotation f))))
|
|
|
|
(define-simple-type <generic-function> (<function>) generic-function?)
|
|
|
|
(define-method &add-method! ((g <generic-function>) foo)
|
|
(add-method! (procedure-annotation g) foo))
|
|
|
|
(define-method &disclose ((g <generic-function>))
|
|
`(generic-function ,(method-table-id (procedure-annotation g))))
|
|
|
|
(define method-table-id (record-accessor :method-table 'id))
|
|
|
|
; --------------------
|
|
; Method info (applicability / action pairs)
|
|
|
|
; D***n-style METHOD syntax
|
|
|
|
(define-syntax method
|
|
(syntax-rules ()
|
|
((method ?specs ?body ...)
|
|
(make-method (method-info anonymous ?specs ?body ...)))))
|
|
|
|
(define method-table-methods (record-accessor :method-table 'methods))
|
|
|
|
(define (make-method info)
|
|
(letrec ((perform (methods->perform
|
|
(list info
|
|
(method-info method args
|
|
(apply call-error "invalid arguments" m args)))
|
|
;; This oughta be a prototype
|
|
#f))
|
|
(m (annotate-procedure (lambda args (perform args))
|
|
info)))
|
|
m))
|
|
|
|
(define method-info? (record-predicate :method-info))
|
|
|
|
(define (method? f)
|
|
(and (procedure? f)
|
|
(method-info? (procedure-annotation f))))
|
|
|
|
(define-simple-type <method> (<function>) method?)
|
|
|
|
(define-method &disclose ((m <method>))
|
|
`(method ,(procedure-annotation m)))
|
|
|
|
; --------------------
|
|
; (SETTER foo)
|
|
|
|
(define-syntax setter
|
|
(lambda (e r c)
|
|
(string->symbol (string-append (symbol->string (cadr e))
|
|
"-"
|
|
(symbol->string 'setter)))))
|
|
|
|
(define-syntax define-setter ;for define-slot
|
|
(lambda (e r c)
|
|
`(,(r 'define)
|
|
,(string->symbol (string-append (symbol->string (cadr e))
|
|
"-"
|
|
(symbol->string 'setter)))
|
|
,(caddr e))))
|
|
|
|
(define-syntax set
|
|
(syntax-rules ()
|
|
((set (?fun ?arg ...) ?val)
|
|
((setter ?fun) ?arg ... ?val))
|
|
((set ?var ?val)
|
|
(set! ?var ?val))))
|
|
|
|
(define car-setter set-car!)
|
|
(define cdr-setter set-cdr!)
|
|
(define vector-ref-setter vector-set!)
|
|
|
|
; --------------------
|
|
; DEFINE-CLASS
|
|
|
|
(define-syntax define-class
|
|
(syntax-rules ()
|
|
((define-class ?class-name (?super ...) ?slot ...)
|
|
(begin (define-slot ?slot)
|
|
...
|
|
(define ?class-name
|
|
(make-class (list ?super ...)
|
|
(list ?slot ...)
|
|
'?class-name))))))
|
|
|
|
(define-syntax define-slot
|
|
(syntax-rules ()
|
|
((define-slot ?slot)
|
|
(begin (define-generic-function ?slot (x))
|
|
(define-generic-function (setter ?slot) (x new-val))
|
|
(define-method ?slot ((x <instance>))
|
|
(instance-slot-ref x ?slot))
|
|
(define-method (setter ?slot) ((x <instance>) new-val)
|
|
(instance-slot-set! x ?slot new-val))))))
|
|
|
|
; Instances
|
|
|
|
(define-record-type instance <instance>
|
|
(make-instance classes slots)
|
|
instance?
|
|
(classes instance-classes)
|
|
(slots instance-slot-values))
|
|
|
|
(define (instance-slot-ref instance slot)
|
|
(cond ((assq slot (instance-slot-values instance)) => cdr)
|
|
(else (call-error "no such slot"
|
|
instance-slot-ref instance slot))))
|
|
|
|
(define (instance-slot-set! instance slot new-value)
|
|
(cond ((assq slot (instance-slot-values instance))
|
|
=> (lambda (z) (set-cdr! z new-value)))
|
|
(else (call-error "no such slot"
|
|
instance-slot-set! instance slot new-value))))
|
|
|
|
; Classes
|
|
|
|
(define-record-type class <class>
|
|
(really-make-class classes predicate priority slots id)
|
|
class?
|
|
(classes class-classes)
|
|
(predicate class-predicate)
|
|
(priority class-priority)
|
|
(slots class-slots)
|
|
(id class-id))
|
|
|
|
(define-record-discloser <class>
|
|
(lambda (c) `(class ,(class-id c))))
|
|
|
|
(define-method &type-predicate ((c <class>)) (class-predicate c))
|
|
(define-method &type-priority ((c <class>)) (class-priority c))
|
|
|
|
(define (make-class supers slots id)
|
|
(letrec ((class
|
|
(really-make-class
|
|
(reduce unionq '() (map get-classes supers))
|
|
(lambda (x) ;Predicate
|
|
(and (instance? x)
|
|
(memq class (instance-classes x))))
|
|
(if (null? supers) ;Priority
|
|
(type-priority <instance>)
|
|
(+ (apply max (map type-priority supers))
|
|
*increment*))
|
|
(unionq slots
|
|
(reduce unionq '() (map get-slots supers)))
|
|
id)))
|
|
class))
|
|
|
|
(define *increment* 10)
|
|
|
|
(define (get-classes type)
|
|
(if (class? type)
|
|
(cons type
|
|
(class-classes type))
|
|
'()))
|
|
|
|
(define (get-slots type)
|
|
(if (class? type)
|
|
(class-slots type)
|
|
'()))
|
|
|
|
(define-generic-function make (class . key/value-pairs))
|
|
|
|
(define-method make ((c <class>) . key/value-pairs)
|
|
(let ((i (make-instance (cons c (class-classes c))
|
|
(map (lambda (slot)
|
|
(cons slot '*uninitialized*))
|
|
(class-slots c)))))
|
|
(apply initialize i key/value-pairs)
|
|
i))
|
|
|
|
(define-generic-function initialize (i . key/value-pairs))
|
|
|
|
(define-method initialize ((i <instance>)) (unspecific))
|
|
|
|
|
|
(define (unionq l1 l2)
|
|
(cond ((null? l1) l2)
|
|
((null? l2) l1)
|
|
((memq (car l1) l2) (unionq (cdr l1) l2))
|
|
(else (cons (car l1) (unionq (cdr l1) l2)))))
|
|
|
|
; --------------------
|
|
; Random
|
|
|
|
(define id? eq?)
|
|
|
|
(define-syntax bind
|
|
(lambda (e r c)
|
|
(if (and (pair? (cdr e))
|
|
(list? (cadr e)))
|
|
(let ((%call-with-values (r 'call-with-values))
|
|
(%lambda (r 'lambda))
|
|
(%method (r 'method))
|
|
(%begin (r 'begin)))
|
|
(let recur ((specs (cadr e)))
|
|
(if (null? specs)
|
|
`(,%begin ,@(cddr e))
|
|
(let ((rspec (reverse (car specs))))
|
|
`(,%call-with-values
|
|
(,%lambda () ,(car rspec))
|
|
(,%method ,(reverse (cdr rspec))
|
|
,(recur (cdr specs))))))))
|
|
e)))
|
|
|
|
(define-simple-type <list> (<object>) list?)
|
|
|
|
; --------------------
|
|
; More?
|
|
|
|
; (instance? obj class)
|
|
; (as class object) => instance
|
|
|
|
; <type>
|
|
; (union type1 type2)
|
|
; (union* type ...)
|
|
; (subtype? type1 type2 )
|
|
; per design note 05
|
|
|
|
; (define-method foo (x y #values (foo <integer>)) ...)
|
|
; per design note 21
|
|
|
|
; (define-method f ((x (limited <integer> min: -1000 max: 1000)) ...)
|
|
; ...)
|
|
; design note 06
|
|
|
|
; <collection>, etc.
|
|
|
|
|
|
; <exact> and <inexact> ?
|
|
|
|
;(define <sequence>
|
|
; (make-generalization (list <list> <vector> <string>) '<sequence>))
|
|
|
|
;(define <port>
|
|
; (make-generalization (list <input-port> <output-port>) '<port>))
|
|
|
|
|
|
; Need reader syntax:
|
|
; #next #rest #key etc.
|
|
; - implement with (define-sharp-macro #\n ...) ?
|
|
; keywords - foo:
|
|
; - implement by customizing parse-token
|