summaryrefslogtreecommitdiff
path: root/module/oop
diff options
context:
space:
mode:
Diffstat (limited to 'module/oop')
-rw-r--r--module/oop/goops.scm400
-rw-r--r--module/oop/goops/compile.scm32
-rw-r--r--module/oop/goops/dispatch.scm5
-rw-r--r--module/oop/goops/save.scm4
-rw-r--r--module/oop/goops/simple.scm5
-rw-r--r--module/oop/goops/stklos.scm71
6 files changed, 266 insertions, 251 deletions
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 2254f93e5..6e3b15009 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -154,17 +154,6 @@
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
;;; OPTION ::= KEYWORD VALUE
;;;
-(define (define-class-pre-definition kw val)
- (case kw
- ((#:getter #:setter)
- `(if (or (not (defined? ',val))
- (not (is-a? ,val <generic>)))
- (define-generic ,val)))
- ((#:accessor)
- `(if (or (not (defined? ',val))
- (not (is-a? ,val <accessor>)))
- (define-accessor ,val)))
- (else #f)))
(define (kw-do-map mapper f kwargs)
(define (keywords l)
@@ -180,31 +169,37 @@
(a (args kwargs)))
(mapper f k a)))
-;;; This code should be implemented in C.
-;;;
-(define-macro (define-class name supers . slots)
- ;; Some slot options require extra definitions to be made. In
- ;; particular, we want to make sure that the generic function objects
- ;; which represent accessors exist before `make-class' tries to add
- ;; methods to them.
- ;;
- ;; Postpone some error handling to class macro.
- ;;
- `(begin
- ;; define accessors
- ,@(append-map (lambda (slot)
- (kw-do-map filter-map
- define-class-pre-definition
- (if (pair? slot) (cdr slot) '())))
- (take-while (lambda (x) (not (keyword? x))) slots))
- (if (and (defined? ',name)
- (is-a? ,name <class>)
- (memq <object> (class-precedence-list ,name)))
- (class-redefinition ,name
- (class ,supers ,@slots #:name ',name))
- (define ,name (class ,supers ,@slots #:name ',name)))))
-
-(define standard-define-class define-class)
+(define (make-class supers slots . options)
+ (let ((env (or (get-keyword #:environment options #f)
+ (top-level-env))))
+ (let* ((name (get-keyword #:name options (make-unbound)))
+ (supers (if (not (or-map (lambda (class)
+ (memq <object>
+ (class-precedence-list class)))
+ supers))
+ (append supers (list <object>))
+ supers))
+ (metaclass (or (get-keyword #:metaclass options #f)
+ (ensure-metaclass supers env))))
+
+ ;; Verify that all direct slots are different and that we don't inherit
+ ;; several time from the same class
+ (let ((tmp1 (find-duplicate supers))
+ (tmp2 (find-duplicate (map slot-definition-name slots))))
+ (if tmp1
+ (goops-error "make-class: super class ~S is duplicate in class ~S"
+ tmp1 name))
+ (if tmp2
+ (goops-error "make-class: slot ~S is duplicate in class ~S"
+ tmp2 name)))
+
+ ;; Everything seems correct, build the class
+ (apply make metaclass
+ #:dsupers supers
+ #:slots slots
+ #:name name
+ #:environment env
+ options))))
;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
;;;
@@ -229,7 +224,6 @@
(else
`(list ',def))))
slots))
-
(if (not (list? supers))
(goops-error "malformed superclass list: ~S" supers))
(let ((slot-defs (cons #f '()))
@@ -243,37 +237,71 @@
;; evaluate class options
,@options)))
-(define (make-class supers slots . options)
- (let ((env (or (get-keyword #:environment options #f)
- (top-level-env))))
- (let* ((name (get-keyword #:name options (make-unbound)))
- (supers (if (not (or-map (lambda (class)
- (memq <object>
- (class-precedence-list class)))
- supers))
- (append supers (list <object>))
- supers))
- (metaclass (or (get-keyword #:metaclass options #f)
- (ensure-metaclass supers env))))
-
- ;; Verify that all direct slots are different and that we don't inherit
- ;; several time from the same class
- (let ((tmp1 (find-duplicate supers))
- (tmp2 (find-duplicate (map slot-definition-name slots))))
- (if tmp1
- (goops-error "make-class: super class ~S is duplicate in class ~S"
- tmp1 name))
- (if tmp2
- (goops-error "make-class: slot ~S is duplicate in class ~S"
- tmp2 name)))
-
- ;; Everything seems correct, build the class
- (apply make metaclass
- #:dsupers supers
- #:slots slots
- #:name name
- #:environment env
- options))))
+(define-syntax define-class-pre-definition
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (k arg rest ...) out ...)
+ (keyword? (syntax->datum (syntax k)))
+ (case (syntax->datum (syntax k))
+ ((#:getter #:setter)
+ (syntax
+ (define-class-pre-definition (rest ...)
+ out ...
+ (if (or (not (defined? 'arg))
+ (not (is-a? arg <generic>)))
+ (toplevel-define!
+ 'arg
+ (ensure-generic (if (defined? 'arg) arg #f) 'arg))))))
+ ((#:accessor)
+ (syntax
+ (define-class-pre-definition (rest ...)
+ out ...
+ (if (or (not (defined? 'arg))
+ (not (is-a? arg <accessor>)))
+ (toplevel-define!
+ 'arg
+ (ensure-accessor (if (defined? 'arg) arg #f) 'arg))))))
+ (else
+ (syntax
+ (define-class-pre-definition (rest ...) out ...)))))
+ ((_ () out ...)
+ (syntax (begin out ...))))))
+
+;; Some slot options require extra definitions to be made. In
+;; particular, we want to make sure that the generic function objects
+;; which represent accessors exist before `make-class' tries to add
+;; methods to them.
+(define-syntax define-class-pre-definitions
+ (lambda (x)
+ (syntax-case x ()
+ ((_ () out ...)
+ (syntax (begin out ...)))
+ ((_ (slot rest ...) out ...)
+ (keyword? (syntax->datum (syntax slot)))
+ (syntax (begin out ...)))
+ ((_ (slot rest ...) out ...)
+ (identifier? (syntax slot))
+ (syntax (define-class-pre-definitions (rest ...)
+ out ...)))
+ ((_ ((slotname slotopt ...) rest ...) out ...)
+ (syntax (define-class-pre-definitions (rest ...)
+ out ... (define-class-pre-definition (slotopt ...))))))))
+
+(define-syntax define-class
+ (syntax-rules ()
+ ((_ name supers slot ...)
+ (begin
+ (define-class-pre-definitions (slot ...))
+ (if (and (defined? 'name)
+ (is-a? name <class>)
+ (memq <object> (class-precedence-list name)))
+ (class-redefinition name
+ (class supers slot ... #:name 'name))
+ (toplevel-define! 'name (class supers slot ... #:name 'name)))))))
+
+(define-syntax standard-define-class
+ (syntax-rules ()
+ ((_ arg ...) (define-class arg ...))))
;;;
;;; {Generic functions and accessors}
@@ -363,13 +391,13 @@
(else (make <generic> #:name name)))))
;; same semantics as <generic>
-(define-macro (define-accessor name)
- (if (not (symbol? name))
- (goops-error "bad accessor name: ~S" name))
- `(define ,name
- (if (and (defined? ',name) (is-a? ,name <accessor>))
- (make <accessor> #:name ',name)
- (ensure-accessor (if (defined? ',name) ,name #f) ',name))))
+(define-syntax define-accessor
+ (syntax-rules ()
+ ((_ name)
+ (define name
+ (cond ((not (defined? 'name)) (ensure-accessor #f 'name))
+ ((is-a? name <accessor>) (make <accessor> #:name 'name))
+ (else (ensure-accessor name 'name)))))))
(define (make-setter-name name)
(string->symbol (string-append "setter:" (symbol->string name))))
@@ -424,78 +452,132 @@
;;; {Methods}
;;;
-(define-macro (define-method head . body)
- (if (not (pair? head))
- (goops-error "bad method head: ~S" head))
- (let ((gf (car head)))
- (cond ((and (pair? gf)
- (eq? (car gf) 'setter)
- (pair? (cdr gf))
- (symbol? (cadr gf))
- (null? (cddr gf)))
- ;; named setter method
- (let ((name (cadr gf)))
- (cond ((not (symbol? name))
- `(add-method! (setter ,name)
- (method ,(cdr head) ,@body)))
- (else
- `(begin
- (if (or (not (defined? ',name))
- (not (is-a? ,name <accessor>)))
- (define-accessor ,name))
- (add-method! (setter ,name)
- (method ,(cdr head) ,@body)))))))
- ((not (symbol? gf))
- `(add-method! ,gf (method ,(cdr head) ,@body)))
- (else
- `(begin
- ;; FIXME: this code is how it always was, but it's quite
- ;; cracky: it will only define the generic function if it
- ;; was undefined before (ok), or *was defined to #f*. The
- ;; latter is crack. But there are bootstrap issues about
- ;; fixing this -- change it to (is-a? ,gf <generic>) and
- ;; see.
- (if (or (not (defined? ',gf))
- (not ,gf))
- (define-generic ,gf))
- (add-method! ,gf
- (method ,(cdr head) ,@body)))))))
-
-(define-macro (method args . body)
- (letrec ((specializers
- (lambda (ls)
- (cond ((null? ls) (list (list 'quote '())))
- ((pair? ls) (cons (if (pair? (car ls))
- (cadar ls)
- '<top>)
- (specializers (cdr ls))))
- (else '(<top>)))))
- (formals
- (lambda (ls)
- (if (pair? ls)
- (cons (if (pair? (car ls)) (caar ls) (car ls))
- (formals (cdr ls)))
- ls))))
- (let ((make-proc (compile-make-procedure (formals args)
- (specializers args)
- body)))
- `(make <method>
- #:specializers (cons* ,@(specializers args))
- #:formals ',(formals args)
- #:body ',body
- #:make-procedure ,make-proc
- #:procedure ,(and (not make-proc)
- ;; that is to say: we set #:procedure if
- ;; `compile-make-procedure' returned `#f',
- ;; which is the case if `body' does not
- ;; contain a call to `next-method'
- `(lambda ,(formals args)
- ,@(if (null? body)
- ;; This used to be '((begin)), but
- ;; guile's memoizer doesn't like
- ;; (lambda args (begin)).
- '((if #f #f))
- body)))))))
+(define (toplevel-define! name val)
+ (module-define! (current-module) name val))
+
+(define-syntax define-method
+ (syntax-rules (setter)
+ ((_ ((setter name) . args) body ...)
+ (begin
+ (if (or (not (defined? 'name))
+ (not (is-a? name <accessor>)))
+ (toplevel-define! 'name
+ (ensure-accessor
+ (if (defined? 'name) name #f) 'name)))
+ (add-method! (setter name) (method args body ...))))
+ ((_ (name . args) body ...)
+ (begin
+ ;; FIXME: this code is how it always was, but it's quite cracky:
+ ;; it will only define the generic function if it was undefined
+ ;; before (ok), or *was defined to #f*. The latter is crack. But
+ ;; there are bootstrap issues about fixing this -- change it to
+ ;; (is-a? name <generic>) and see.
+ (if (or (not (defined? 'name))
+ (not name))
+ (toplevel-define! 'name (make <generic> #:name 'name)))
+ (add-method! name (method args body ...))))))
+
+(define-syntax method
+ (lambda (x)
+ (define (parse-args args)
+ (let lp ((ls args) (formals '()) (specializers '()))
+ (syntax-case ls ()
+ (((f s) . rest)
+ (and (identifier? (syntax f)) (identifier? (syntax s)))
+ (lp (syntax rest)
+ (cons (syntax f) formals)
+ (cons (syntax s) specializers)))
+ ((f . rest)
+ (identifier? (syntax f))
+ (lp (syntax rest)
+ (cons (syntax f) formals)
+ (cons (syntax <top>) specializers)))
+ (()
+ (list (reverse formals)
+ (reverse (cons (syntax '()) specializers))))
+ (tail
+ (identifier? (syntax tail))
+ (list (append (reverse formals) (syntax tail))
+ (reverse (cons (syntax <top>) specializers)))))))
+
+ (define (find-free-id exp referent)
+ (syntax-case exp ()
+ ((x . y)
+ (or (find-free-id (syntax x) referent)
+ (find-free-id (syntax y) referent)))
+ (x
+ (identifier? (syntax x))
+ (let ((id (datum->syntax (syntax x) referent)))
+ (and (free-identifier=? (syntax x) id) id)))
+ (_ #f)))
+
+ (define (compute-procedure formals body)
+ (syntax-case body ()
+ ((body0 ...)
+ (with-syntax ((formals formals))
+ (syntax (lambda formals body0 ...))))))
+
+ (define (->proper args)
+ (let lp ((ls args) (out '()))
+ (syntax-case ls ()
+ ((x . xs) (lp (syntax xs) (cons (syntax x) out)))
+ (() (reverse out))
+ (tail (reverse (cons (syntax tail) out))))))
+
+ (define (compute-make-procedure formals body next-method)
+ (syntax-case body ()
+ ((body ...)
+ (with-syntax ((next-method next-method))
+ (syntax-case formals ()
+ ((formal ...)
+ (syntax
+ (lambda (real-next-method)
+ (lambda (formal ...)
+ (let ((next-method (lambda args
+ (if (null? args)
+ (real-next-method formal ...)
+ (apply real-next-method args)))))
+ body ...)))))
+ (formals
+ (with-syntax (((formal ...) (->proper (syntax formals))))
+ (syntax
+ (lambda (real-next-method)
+ (lambda formals
+ (let ((next-method (lambda args
+ (if (null? args)
+ (apply real-next-method formal ...)
+ (apply real-next-method args)))))
+ body ...)))))))))))
+
+ (define (compute-procedures formals body)
+ ;; So, our use of this is broken, because it operates on the
+ ;; pre-expansion source code. It's equivalent to just searching
+ ;; for referent in the datums. Ah well.
+ (let ((id (find-free-id body 'next-method)))
+ (if id
+ ;; return a make-procedure
+ (values (syntax #f)
+ (compute-make-procedure formals body id))
+ (values (compute-procedure formals body)
+ (syntax #f)))))
+
+ (syntax-case x ()
+ ((_ args) (syntax (method args (if #f #f))))
+ ((_ args body0 body1 ...)
+ (with-syntax (((formals (specializer ...)) (parse-args (syntax args))))
+ (call-with-values
+ (lambda ()
+ (compute-procedures (syntax formals) (syntax (body0 body1 ...))))
+ (lambda (procedure make-procedure)
+ (with-syntax ((procedure procedure)
+ (make-procedure make-procedure))
+ (syntax
+ (make <method>
+ #:specializers (cons* specializer ...)
+ #:formals 'formals
+ #:body '(body0 body1 ...)
+ #:make-procedure make-procedure
+ #:procedure procedure))))))))))
;;;
;;; {add-method!}
@@ -1046,27 +1128,9 @@
;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
(eval-when (compile)
- (use-modules ((language scheme compile-ghil) :select (define-scheme-translator))
- ((language ghil) :select (make-ghil-inline make-ghil-call))
- (system base pmatch))
-
- ;; unfortunately, can't use define-inline because these are primitive
- ;; syntaxen.
- (define-scheme-translator @slot-ref
- ((,obj ,index) (guard (integer? index)
- (>= index 0) (< index max-fixnum))
- (make-ghil-inline #f #f 'slot-ref
- (list (retrans obj) (retrans index))))
- (else
- (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp)))))
-
- (define-scheme-translator @slot-set!
- ((,obj ,index ,val) (guard (integer? index)
- (>= index 0) (< index max-fixnum))
- (make-ghil-inline #f #f 'slot-set
- (list (retrans obj) (retrans index) (retrans val))))
- (else
- (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp))))))
+ (use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
+ (add-interesting-primitive! '@slot-ref)
+ (add-interesting-primitive! '@slot-set!))
(eval-when (eval load compile)
(define num-standard-pre-cache 20))
diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm
index 3962be4bc..e6b13c416 100644
--- a/module/oop/goops/compile.scm
+++ b/module/oop/goops/compile.scm
@@ -24,7 +24,7 @@
(define-module (oop goops compile)
:use-module (oop goops)
:use-module (oop goops util)
- :export (compute-cmethod compile-make-procedure)
+ :export (compute-cmethod)
:no-backtrace
)
@@ -60,9 +60,7 @@
;;; So, for the reader: there basic idea is that, given that the
;;; semantics of `next-method' depend on the concrete types being
;;; dispatched, why not compile a specific procedure to handle each type
-;;; combination that we see at runtime. There are two compilation
-;;; strategies implemented: one for the memoizer, and one for the VM
-;;; compiler.
+;;; combination that we see at runtime.
;;;
;;; In theory we can do much better than a bytecode compilation, because
;;; we know the *exact* types of the arguments. It's ideal for native
@@ -71,32 +69,6 @@
;;; I think this whole generic application mess would benefit from a
;;; strict MOP.
-;;; Temporary solution---return #f if x doesn't refer to `next-method'.
-(define (next-method? x)
- (and (pair? x)
- (or (eq? (car x) 'next-method)
- (next-method? (car x))
- (next-method? (cdr x)))))
-
-;; Called by the `method' macro in goops.scm.
-(define (compile-make-procedure formals specializers body)
- (and (next-method? body)
- (let ((next-method-sym (gensym " next-method"))
- (args-sym (gensym)))
- `(lambda (,next-method-sym)
- (lambda ,formals
- (let ((next-method (lambda ,args-sym
- (if (null? ,args-sym)
- ,(if (list? formals)
- `(,next-method-sym ,@formals)
- `(apply
- ,next-method-sym
- ,@(improper->proper formals)))
- (apply ,next-method-sym ,args-sym)))))
- ,@(if (null? body)
- '((begin))
- body)))))))
-
(define (compile-method methods types)
(let ((make-procedure (slot-ref (car methods) 'make-procedure)))
(if make-procedure
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index a54044729..ed9f3077e 100644
--- a/module/oop/goops/dispatch.scm
+++ b/module/oop/goops/dispatch.scm
@@ -209,9 +209,8 @@
;;;
;; Backward compatibility
-(if (not (defined? 'lookup-create-cmethod))
- (define (lookup-create-cmethod gf args)
- (no-applicable-method (car args) (cadr args))))
+(define (lookup-create-cmethod gf args)
+ (no-applicable-method (car args) (cadr args)))
(define (memoize-method! gf args exp)
(if (not (slot-ref gf 'used-by))
diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm
index 4d64da8bb..2aedd7698 100644
--- a/module/oop/goops/save.scm
+++ b/module/oop/goops/save.scm
@@ -110,9 +110,7 @@
;;; Readables
;;;
-(if (or (not (defined? 'readables))
- (not readables))
- (define readables (make-weak-key-hash-table 61)))
+(define readables (make-weak-key-hash-table 61))
(define-macro (readable exp)
`(make-readable ,exp ',(copy-tree exp)))
diff --git a/module/oop/goops/simple.scm b/module/oop/goops/simple.scm
index 48e76f312..c0cb76fbb 100644
--- a/module/oop/goops/simple.scm
+++ b/module/oop/goops/simple.scm
@@ -23,6 +23,9 @@
:export (define-class)
:no-backtrace)
-(define define-class define-class-with-accessors-keywords)
+(define-syntax define-class
+ (syntax-rules ()
+ ((_ arg ...)
+ (define-class-with-accessors-keywords arg ...))))
(module-use! %module-public-interface (resolve-interface '(oop goops)))
diff --git a/module/oop/goops/stklos.scm b/module/oop/goops/stklos.scm
index 60ab293c3..ef943cf96 100644
--- a/module/oop/goops/stklos.scm
+++ b/module/oop/goops/stklos.scm
@@ -47,51 +47,30 @@
;;; Enable keyword support (*fixme*---currently this has global effect)
(read-set! keywords 'prefix)
-(define standard-define-class-transformer
- (macro-transformer standard-define-class))
+(define-syntax define-class
+ (syntax-rules ()
+ ((_ name supers (slot ...) rest ...)
+ (standard-define-class name supers slot ... rest ...))))
-(define define-class
- ;; Syntax
- (let ((name cadr)
- (supers caddr)
- (slots cadddr)
- (rest cddddr))
- (procedure->memoizing-macro
- (lambda (exp env)
- (standard-define-class-transformer
- `(define-class ,(name exp) ,(supers exp) ,@(slots exp)
- ,@(rest exp))
- env)))))
+(define (toplevel-define! name val)
+ (module-define! (current-module) name val))
-(define define-method
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((name (cadr exp)))
- (if (and (pair? name)
- (eq? (car name) 'setter)
- (pair? (cdr name))
- (null? (cddr name)))
- (let ((name (cadr name)))
- (cond ((not (symbol? name))
- (goops-error "bad method name: ~S" name))
- ((defined? name env)
- `(begin
- (if (not (is-a? ,name <generic-with-setter>))
- (define-accessor ,name))
- (add-method! (setter ,name) (method ,@(cddr exp)))))
- (else
- `(begin
- (define-accessor ,name)
- (add-method! (setter ,name) (method ,@(cddr exp)))))))
- (cond ((not (symbol? name))
- (goops-error "bad method name: ~S" name))
- ((defined? name env)
- `(begin
- (if (not (or (is-a? ,name <generic>)
- (is-a? ,name <primitive-generic>)))
- (define-generic ,name))
- (add-method! ,name (method ,@(cddr exp)))))
- (else
- `(begin
- (define-generic ,name)
- (add-method! ,name (method ,@(cddr exp)))))))))))
+(define-syntax define-method
+ (syntax-rules (setter)
+ ((_ (setter name) rest ...)
+ (begin
+ (if (or (not (defined? 'name))
+ (not (is-a? name <generic-with-setter>)))
+ (toplevel-define! 'name
+ (ensure-accessor
+ (if (defined? 'name) name #f) 'name)))
+ (add-method! (setter name) (method rest ...))))
+ ((_ name rest ...)
+ (begin
+ (if (or (not (defined? 'name))
+ (not (or (is-a? name <generic>)
+ (is-a? name <primitive-generic>))))
+ (toplevel-define! 'name
+ (ensure-generic
+ (if (defined? 'name) name #f) 'name)))
+ (add-method! name (method rest ...))))))