mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-19 03:00:25 +02:00
make define-class' and class' into defmacros
* oop/goops.scm: Use srfi-1, as util.scm already does. (kw-do-map): New helper for processing keyword args. (define-class-pre-definition, define-class): Rework so that define-class is a defmacro without side effects. There are two functional differences: we don't check that define-class is called only at the toplevel, because defining a lexical class might makes sense, and defmacros don't give us the toplevel check that we would want. Second in the redefinition case, we don't do a `define', as we don't actually need a new variable. (class): Similarly, make `class' a defmacro.
This commit is contained in:
Andy Wingo
parent
6ce6dc03c1
commit
d31c5d197d
1 changed files with 73 additions and 143 deletions
216
oop/goops.scm
216
oop/goops.scm
|
|
@ -26,6 +26,7 @@
|
||||||
;;;;
|
;;;;
|
||||||
|
|
||||||
(define-module (oop goops)
|
(define-module (oop goops)
|
||||||
|
:use-module (srfi srfi-1)
|
||||||
:export-syntax (define-class class standard-define-class
|
:export-syntax (define-class class standard-define-class
|
||||||
define-generic define-accessor define-method
|
define-generic define-accessor define-method
|
||||||
define-extended-generic define-extended-generics
|
define-extended-generic define-extended-generics
|
||||||
|
|
@ -157,94 +158,55 @@
|
||||||
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
|
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
|
||||||
;;; OPTION ::= KEYWORD VALUE
|
;;; OPTION ::= KEYWORD VALUE
|
||||||
;;;
|
;;;
|
||||||
(define (define-class-pre-definition keyword exp env)
|
(define (define-class-pre-definition kw val)
|
||||||
(case keyword
|
(case kw
|
||||||
((#:getter #:setter)
|
((#:getter #:setter)
|
||||||
`(process-class-pre-define-generic ',exp))
|
`(if (or (not (defined? ',val))
|
||||||
|
(not (is-a? ,val <generic>)))
|
||||||
|
(define-generic ,val)))
|
||||||
((#:accessor)
|
((#:accessor)
|
||||||
`(process-class-pre-define-accessor ',exp))
|
`(if (or (not (defined? ',val))
|
||||||
|
(not (is-a? ,val <accessor>)))
|
||||||
|
(define-accessor ,val)))
|
||||||
(else #f)))
|
(else #f)))
|
||||||
|
|
||||||
(define (process-class-pre-define-generic name)
|
(define (kw-do-map mapper f kwargs)
|
||||||
(let ((var (module-variable (current-module) name)))
|
(define (keywords l)
|
||||||
(if (not (and var
|
(cond
|
||||||
(variable-bound? var)
|
((null? l) '())
|
||||||
(is-a? (variable-ref var) <generic>)))
|
((or (null? (cdr l)) (not (keyword? (car l))))
|
||||||
(process-define-generic name))))
|
(goops-error "malformed keyword arguments: ~a" kwargs))
|
||||||
|
(else (cons (car l) (keywords (cddr l))))))
|
||||||
(define (process-class-pre-define-accessor name)
|
(define (args l)
|
||||||
(let ((var (module-variable (current-module) name)))
|
(if (null? l) '() (cons (cadr l) (args (cddr l)))))
|
||||||
(cond ((or (not var)
|
;; let* to check keywords first
|
||||||
(not (variable-bound? var)))
|
(let* ((k (keywords kwargs))
|
||||||
(process-define-accessor name))
|
(a (args kwargs)))
|
||||||
((or (is-a? (variable-ref var) <accessor>)
|
(mapper f k a)))
|
||||||
(is-a? (variable-ref var) <extended-generic-with-setter>)))
|
|
||||||
((is-a? (variable-ref var) <generic>)
|
|
||||||
;;*fixme* don't mutate an imported object!
|
|
||||||
(variable-set! var (ensure-accessor (variable-ref var) name)))
|
|
||||||
(else
|
|
||||||
(process-define-accessor name)))))
|
|
||||||
|
|
||||||
;;; This code should be implemented in C.
|
;;; This code should be implemented in C.
|
||||||
;;;
|
;;;
|
||||||
(define define-class
|
(define-macro (define-class name supers . slots)
|
||||||
(letrec (;; Some slot options require extra definitions to be made.
|
;; Some slot options require extra definitions to be made. In
|
||||||
;; In particular, we want to make sure that the generic
|
;; particular, we want to make sure that the generic function objects
|
||||||
;; function objects which represent accessors exist
|
;; which represent accessors exist before `make-class' tries to add
|
||||||
;; before `make-class' tries to add methods to them.
|
;; methods to them.
|
||||||
;;
|
;;
|
||||||
;; Postpone error handling to class macro.
|
;; Postpone some error handling to class macro.
|
||||||
;;
|
;;
|
||||||
(pre-definitions
|
`(begin
|
||||||
(lambda (slots env)
|
;; define accessors
|
||||||
(do ((slots slots (cdr slots))
|
,@(append-map (lambda (slot)
|
||||||
(definitions '()
|
(kw-do-map filter-map
|
||||||
(if (pair? (car slots))
|
define-class-pre-definition
|
||||||
(do ((options (cdar slots) (cddr options))
|
(if (pair? slot) (cdr slot) '())))
|
||||||
(definitions definitions
|
(take-while (lambda (x) (not (keyword? x))) slots))
|
||||||
(cond ((not (symbol? (cadr options)))
|
(if (and (defined? ',name)
|
||||||
definitions)
|
(is-a? ,name <class>)
|
||||||
((define-class-pre-definition
|
(memq <object> (class-precedence-list ,name)))
|
||||||
(car options)
|
(class-redefinition ,name
|
||||||
(cadr options)
|
(class ,supers ,@slots #:name ',name))
|
||||||
env)
|
(define ,name (class ,supers ,@slots #:name ',name)))))
|
||||||
=> (lambda (definition)
|
|
||||||
(cons definition definitions)))
|
|
||||||
(else definitions))))
|
|
||||||
((not (and (pair? options)
|
|
||||||
(pair? (cdr options))))
|
|
||||||
definitions))
|
|
||||||
definitions)))
|
|
||||||
((or (not (pair? slots))
|
|
||||||
(keyword? (car slots)))
|
|
||||||
(reverse definitions)))))
|
|
||||||
|
|
||||||
;; Syntax
|
|
||||||
(name cadr)
|
|
||||||
(slots cdddr))
|
|
||||||
|
|
||||||
(procedure->memoizing-macro
|
|
||||||
(lambda (exp env)
|
|
||||||
(cond ((not (top-level-env? env))
|
|
||||||
(goops-error "define-class: Only allowed at top level"))
|
|
||||||
((not (and (list? exp) (>= (length exp) 3)))
|
|
||||||
(goops-error "missing or extra expression"))
|
|
||||||
(else
|
|
||||||
(let ((name (name exp)))
|
|
||||||
`(begin
|
|
||||||
;; define accessors
|
|
||||||
,@(pre-definitions (slots exp) env)
|
|
||||||
;; update the current-module
|
|
||||||
(let* ((class (class ,@(cddr exp) #:name ',name))
|
|
||||||
(var (module-ensure-local-variable!
|
|
||||||
(current-module) ',name))
|
|
||||||
(old (and (variable-bound? var)
|
|
||||||
(variable-ref var))))
|
|
||||||
(if (and old
|
|
||||||
(is-a? old <class>)
|
|
||||||
(memq <object> (class-precedence-list old)))
|
|
||||||
(variable-set! var (class-redefinition old class))
|
|
||||||
(variable-set! var class)))))))))))
|
|
||||||
|
|
||||||
(define standard-define-class define-class)
|
(define standard-define-class define-class)
|
||||||
|
|
||||||
|
|
@ -253,69 +215,37 @@
|
||||||
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
|
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
|
||||||
;;; OPTION ::= KEYWORD VALUE
|
;;; OPTION ::= KEYWORD VALUE
|
||||||
;;;
|
;;;
|
||||||
(define class
|
(define-macro (class supers . slots)
|
||||||
(letrec ((slot-option-keyword car)
|
(define (make-slot-definition-forms slots)
|
||||||
(slot-option-value cadr)
|
(map
|
||||||
(process-slot-options
|
(lambda (def)
|
||||||
(lambda (options)
|
(cond
|
||||||
(let loop ((options options)
|
((pair? def)
|
||||||
(res '()))
|
`(list ',(car def)
|
||||||
(cond ((null? options)
|
,@(kw-do-map append-map
|
||||||
(reverse res))
|
(lambda (kw arg)
|
||||||
((null? (cdr options))
|
(case kw
|
||||||
(goops-error "malformed slot option list"))
|
((#:init-form)
|
||||||
((not (keyword? (slot-option-keyword options)))
|
`(#:init-form ',arg
|
||||||
(goops-error "malformed slot option list"))
|
#:init-thunk (lambda () ,arg)))
|
||||||
(else
|
(else (list kw arg))))
|
||||||
(case (slot-option-keyword options)
|
(cdr def))))
|
||||||
((#:init-form)
|
(else
|
||||||
(loop (cddr options)
|
`(list ',def))))
|
||||||
(append (list `(lambda ()
|
slots))
|
||||||
,(slot-option-value options))
|
|
||||||
#:init-thunk
|
|
||||||
(list 'quote
|
|
||||||
(slot-option-value options))
|
|
||||||
#:init-form)
|
|
||||||
res)))
|
|
||||||
(else
|
|
||||||
(loop (cddr options)
|
|
||||||
(cons (cadr options)
|
|
||||||
(cons (car options)
|
|
||||||
res)))))))))))
|
|
||||||
|
|
||||||
(procedure->memoizing-macro
|
(if (not (list? supers))
|
||||||
(let ((supers cadr)
|
(goops-error "malformed superclass list: ~S" supers))
|
||||||
(slots cddr)
|
(let ((slot-defs (cons #f '()))
|
||||||
(options cdddr))
|
(slots (take-while (lambda (x) (not (keyword? x))) slots))
|
||||||
(lambda (exp env)
|
(options (or (find-tail keyword? slots) '())))
|
||||||
(cond ((not (and (list? exp) (>= (length exp) 2)))
|
`(make-class
|
||||||
(goops-error "missing or extra expression"))
|
;; evaluate super class variables
|
||||||
((not (list? (supers exp)))
|
(list ,@supers)
|
||||||
(goops-error "malformed superclass list: ~S" (supers exp)))
|
;; evaluate slot definitions, except the slot name!
|
||||||
(else
|
(list ,@(make-slot-definition-forms slots))
|
||||||
(let ((slot-defs (cons #f '())))
|
;; evaluate class options
|
||||||
(do ((slots (slots exp) (cdr slots))
|
,@options)))
|
||||||
(defs slot-defs (cdr defs)))
|
|
||||||
((or (null? slots)
|
|
||||||
(keyword? (car slots)))
|
|
||||||
`(make-class
|
|
||||||
;; evaluate super class variables
|
|
||||||
(list ,@(supers exp))
|
|
||||||
;; evaluate slot definitions, except the slot name!
|
|
||||||
(list ,@(cdr slot-defs))
|
|
||||||
;; evaluate class options
|
|
||||||
,@slots
|
|
||||||
;; place option last in case someone wants to
|
|
||||||
;; pass a different value
|
|
||||||
#:environment ',env))
|
|
||||||
(set-cdr!
|
|
||||||
defs
|
|
||||||
(list (if (pair? (car slots))
|
|
||||||
`(list ',(slot-definition-name (car slots))
|
|
||||||
,@(process-slot-options
|
|
||||||
(slot-definition-options
|
|
||||||
(car slots))))
|
|
||||||
`(list ',(car slots))))))))))))))
|
|
||||||
|
|
||||||
(define (make-class supers slots . options)
|
(define (make-class supers slots . options)
|
||||||
(let ((env (or (get-keyword #:environment options #f)
|
(let ((env (or (get-keyword #:environment options #f)
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue