diff options
Diffstat (limited to 'module/oop/goops.scm')
-rw-r--r-- | module/oop/goops.scm | 258 |
1 files changed, 173 insertions, 85 deletions
diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 8e548d8e9..1b86399b3 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -25,54 +25,112 @@ ;;;; (define-module (oop goops) - :use-module (srfi srfi-1) - :export-syntax (define-class class standard-define-class - define-generic define-accessor define-method - define-extended-generic define-extended-generics - method) - :export (is-a? class-of - ensure-metaclass ensure-metaclass-with-supers - make-class - make-generic ensure-generic - make-extended-generic - make-accessor ensure-accessor - add-method! - class-slot-ref class-slot-set! slot-unbound slot-missing - slot-definition-name slot-definition-options - slot-definition-allocation - slot-definition-getter slot-definition-setter - slot-definition-accessor - slot-definition-init-value slot-definition-init-form - slot-definition-init-thunk slot-definition-init-keyword - slot-init-function class-slot-definition - method-source - compute-cpl compute-std-cpl compute-get-n-set compute-slots - compute-getter-method compute-setter-method - allocate-instance initialize make-instance make - no-next-method no-applicable-method no-method - change-class update-instance-for-different-class - shallow-clone deep-clone - class-redefinition - apply-generic apply-method apply-methods - compute-applicable-methods %compute-applicable-methods - method-more-specific? sort-applicable-methods - class-subclasses class-methods - goops-error - min-fixnum max-fixnum - ;;; *fixme* Should go into goops.c - instance? slot-ref-using-class - slot-set-using-class! slot-bound-using-class? - slot-exists-using-class? slot-ref slot-set! slot-bound? - class-name class-direct-supers class-direct-subclasses - class-direct-methods class-direct-slots class-precedence-list - class-slots - generic-function-name - generic-function-methods method-generic-function - method-specializers method-formals - primitive-generic-generic enable-primitive-generic! - method-procedure accessor-method-slot-definition - slot-exists? make find-method get-keyword) - :no-backtrace) + #:use-module (srfi srfi-1) + #:export-syntax (define-class class standard-define-class + define-generic define-accessor define-method + define-extended-generic define-extended-generics + method) + #:export ( ;; The root of everything. + <top> + <class> <object> + + ;; Slot types. + <foreign-slot> <protected-slot> <hidden-slot> <opaque-slot> + <read-only-slot> <self-slot> <protected-opaque-slot> + <protected-hidden-slot> <protected-read-only-slot> + <scm-slot> <int-slot> <float-slot> <double-slot> + + ;; Methods are implementations of generic functions. + <method> <accessor-method> + + ;; Applicable objects, either procedures or applicable structs. + <procedure-class> <applicable> + <procedure> <primitive-generic> + + ;; Applicable structs. + <applicable-struct-class> + <applicable-struct> + <generic> <extended-generic> + <generic-with-setter> <extended-generic-with-setter> + <accessor> <extended-accessor> + + ;; Types with their own allocated typecodes. + <boolean> <char> <list> <pair> <null> <string> <symbol> + <vector> <bytevector> <uvec> <foreign> <hashtable> + <fluid> <dynamic-state> <frame> <vm> <vm-continuation> + + ;; Numbers. + <number> <complex> <real> <integer> <fraction> + + ;; Unknown. + <unknown> + + ;; Particular SMOB data types. All SMOB types have + ;; corresponding classes, which may be obtained via class-of, + ;; once you have an instance. Perhaps FIXME to provide a + ;; smob-type-name->class procedure. + <arbiter> <promise> <thread> <mutex> <condition-variable> + <regexp> <hook> <bitvector> <random-state> <async> + <directory> <keyword> <array> <character-set> + <dynamic-object> <guardian> <macro> + + ;; Modules. + <module> + + ;; Ports. + <port> <input-port> <output-port> <input-output-port> + + ;; Like SMOB types, all port types have their own classes, + ;; which can be accessed via `class-of' once you have an + ;; instance. Here we export bindings just for file ports. + <file-port> + <file-input-port> <file-output-port> <file-input-output-port> + + is-a? class-of + ensure-metaclass ensure-metaclass-with-supers + make-class + make-generic ensure-generic + make-extended-generic + make-accessor ensure-accessor + add-method! + class-slot-ref class-slot-set! slot-unbound slot-missing + slot-definition-name slot-definition-options + slot-definition-allocation + + slot-definition-getter slot-definition-setter + slot-definition-accessor + slot-definition-init-value slot-definition-init-form + slot-definition-init-thunk slot-definition-init-keyword + slot-init-function class-slot-definition + method-source + compute-cpl compute-std-cpl compute-get-n-set compute-slots + compute-getter-method compute-setter-method + allocate-instance initialize make-instance make + no-next-method no-applicable-method no-method + change-class update-instance-for-different-class + shallow-clone deep-clone + class-redefinition + apply-generic apply-method apply-methods + compute-applicable-methods %compute-applicable-methods + method-more-specific? sort-applicable-methods + class-subclasses class-methods + goops-error + min-fixnum max-fixnum + +;;; *fixme* Should go into goops.c + instance? slot-ref-using-class + slot-set-using-class! slot-bound-using-class? + slot-exists-using-class? slot-ref slot-set! slot-bound? + class-name class-direct-supers class-direct-subclasses + class-direct-methods class-direct-slots class-precedence-list + class-slots + generic-function-name + generic-function-methods method-generic-function + method-specializers method-formals + primitive-generic-generic enable-primitive-generic! + method-procedure accessor-method-slot-definition + slot-exists? make find-method get-keyword) + #:no-backtrace) (define *goops-module* (current-module)) @@ -82,13 +140,7 @@ (eval-when (eval load compile) (use-modules ((language tree-il primitives) :select (add-interesting-primitive!))) - (add-interesting-primitive! 'class-of) - (define (@slot-ref o n) - (struct-ref o n)) - (define (@slot-set! o n v) - (struct-set! o n v)) - (add-interesting-primitive! '@slot-ref) - (add-interesting-primitive! '@slot-set!)) + (add-interesting-primitive! 'class-of)) ;; Then load the rest of GOOPS (use-modules (oop goops util) @@ -96,6 +148,7 @@ (oop goops compile)) +;; FIXME: deprecate. (eval-when (eval load compile) (define min-fixnum (- (expt 2 29))) (define max-fixnum (- (expt 2 29) 1))) @@ -814,6 +867,20 @@ ;;; Handling of duplicate bindings in the module system ;;; +(define (find-subclass super name) + (let lp ((classes (class-direct-subclasses super))) + (cond + ((null? classes) + (error "class not found" name)) + ((and (slot-bound? (car classes) 'name) + (eq? (class-name (car classes)) name)) + (car classes)) + (else + (lp (cdr classes)))))) + +;; A record type. +(define <module> (find-subclass <top> '<module>)) + (define-method (merge-generics (module <module>) (name <symbol>) (int1 <module>) @@ -1120,44 +1187,34 @@ (define (make-generic-bound-check-getter proc) (lambda (o) (assert-bound (proc o) o))) -;; the idea is to compile the index into the procedure, for fastest -;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes. - -(eval-when (eval load compile) - (define num-standard-pre-cache 20)) - -(define-macro (define-standard-accessor-method form . body) - (let ((name (caar form)) - (n-var (cadar form)) - (args (cdr form))) - (define (make-one x) - (define (body-trans form) - (cond ((not (pair? form)) form) - ((eq? (car form) '@slot-ref) - `(,(car form) ,(cadr form) ,x)) - ((eq? (car form) '@slot-set!) - `(,(car form) ,(cadr form) ,x ,(cadddr form))) - (else - (map body-trans form)))) - `(lambda ,args ,@(map body-trans body))) - `(define ,name - (let ((cache (vector ,@(map make-one (iota num-standard-pre-cache))))) - (lambda (n) - (if (< n ,num-standard-pre-cache) - (vector-ref cache n) - ((lambda (,n-var) (lambda ,args ,@body)) n))))))) +;;; Pre-generate getters and setters for the first 20 slots. +(define-syntax define-standard-accessor-method + (lambda (stx) + (define num-standard-pre-cache 20) + (syntax-case stx () + ((_ ((proc n) arg ...) body) + #`(define proc + (let ((cache (vector #,@(map (lambda (n*) + #`(lambda (arg ...) + (let ((n #,n*)) + body))) + (iota num-standard-pre-cache))))) + (lambda (n) + (if (< n #,num-standard-pre-cache) + (vector-ref cache n) + (lambda (arg ...) body))))))))) (define-standard-accessor-method ((bound-check-get n) o) - (let ((x (@slot-ref o n))) + (let ((x (struct-ref o n))) (if (unbound? x) (slot-unbound o) x))) (define-standard-accessor-method ((standard-get n) o) - (@slot-ref o n)) + (struct-ref o n)) (define-standard-accessor-method ((standard-set n) o v) - (@slot-set! o n v)) + (struct-set! o n v)) ;;; compute-getters-n-setters ;;; @@ -1659,3 +1716,34 @@ ;; Tell C code that the main bulk of Goops has been loaded (%goops-loaded) + + + + +;;; +;;; {SMOB and port classes} +;;; + +(define <arbiter> (find-subclass <top> '<arbiter>)) +(define <promise> (find-subclass <top> '<promise>)) +(define <thread> (find-subclass <top> '<thread>)) +(define <mutex> (find-subclass <top> '<mutex>)) +(define <condition-variable> (find-subclass <top> '<condition-variable>)) +(define <regexp> (find-subclass <top> '<regexp>)) +(define <hook> (find-subclass <top> '<hook>)) +(define <bitvector> (find-subclass <top> '<bitvector>)) +(define <random-state> (find-subclass <top> '<random-state>)) +(define <async> (find-subclass <top> '<async>)) +(define <directory> (find-subclass <top> '<directory>)) +(define <keyword> (find-subclass <top> '<keyword>)) +(define <array> (find-subclass <top> '<array>)) +(define <character-set> (find-subclass <top> '<character-set>)) +(define <dynamic-object> (find-subclass <top> '<dynamic-object>)) +(define <guardian> (find-subclass <applicable> '<guardian>)) +(define <macro> (find-subclass <top> '<macro>)) + +(define (define-class-subtree class) + (define! (class-name class) class) + (for-each define-class-subtree (class-direct-subclasses class))) + +(define-class-subtree (find-subclass <port> '<file-port>)) |