; 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