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)
|
||||
: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
|
||||
|
|
@ -157,94 +158,55 @@
|
|||
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
|
||||
;;; OPTION ::= KEYWORD VALUE
|
||||
;;;
|
||||
(define (define-class-pre-definition keyword exp env)
|
||||
(case keyword
|
||||
(define (define-class-pre-definition kw val)
|
||||
(case kw
|
||||
((#:getter #:setter)
|
||||
`(process-class-pre-define-generic ',exp))
|
||||
`(if (or (not (defined? ',val))
|
||||
(not (is-a? ,val <generic>)))
|
||||
(define-generic ,val)))
|
||||
((#:accessor)
|
||||
`(process-class-pre-define-accessor ',exp))
|
||||
`(if (or (not (defined? ',val))
|
||||
(not (is-a? ,val <accessor>)))
|
||||
(define-accessor ,val)))
|
||||
(else #f)))
|
||||
|
||||
(define (process-class-pre-define-generic name)
|
||||
(let ((var (module-variable (current-module) name)))
|
||||
(if (not (and var
|
||||
(variable-bound? var)
|
||||
(is-a? (variable-ref var) <generic>)))
|
||||
(process-define-generic name))))
|
||||
|
||||
(define (process-class-pre-define-accessor name)
|
||||
(let ((var (module-variable (current-module) name)))
|
||||
(cond ((or (not var)
|
||||
(not (variable-bound? var)))
|
||||
(process-define-accessor name))
|
||||
((or (is-a? (variable-ref var) <accessor>)
|
||||
(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)))))
|
||||
(define (kw-do-map mapper f kwargs)
|
||||
(define (keywords l)
|
||||
(cond
|
||||
((null? l) '())
|
||||
((or (null? (cdr l)) (not (keyword? (car l))))
|
||||
(goops-error "malformed keyword arguments: ~a" kwargs))
|
||||
(else (cons (car l) (keywords (cddr l))))))
|
||||
(define (args l)
|
||||
(if (null? l) '() (cons (cadr l) (args (cddr l)))))
|
||||
;; let* to check keywords first
|
||||
(let* ((k (keywords kwargs))
|
||||
(a (args kwargs)))
|
||||
(mapper f k a)))
|
||||
|
||||
;;; This code should be implemented in C.
|
||||
;;;
|
||||
(define define-class
|
||||
(letrec (;; 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 error handling to class macro.
|
||||
;;
|
||||
(pre-definitions
|
||||
(lambda (slots env)
|
||||
(do ((slots slots (cdr slots))
|
||||
(definitions '()
|
||||
(if (pair? (car slots))
|
||||
(do ((options (cdar slots) (cddr options))
|
||||
(definitions definitions
|
||||
(cond ((not (symbol? (cadr options)))
|
||||
definitions)
|
||||
((define-class-pre-definition
|
||||
(car options)
|
||||
(cadr options)
|
||||
env)
|
||||
=> (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-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)
|
||||
|
||||
|
|
@ -253,69 +215,37 @@
|
|||
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
|
||||
;;; OPTION ::= KEYWORD VALUE
|
||||
;;;
|
||||
(define class
|
||||
(letrec ((slot-option-keyword car)
|
||||
(slot-option-value cadr)
|
||||
(process-slot-options
|
||||
(lambda (options)
|
||||
(let loop ((options options)
|
||||
(res '()))
|
||||
(cond ((null? options)
|
||||
(reverse res))
|
||||
((null? (cdr options))
|
||||
(goops-error "malformed slot option list"))
|
||||
((not (keyword? (slot-option-keyword options)))
|
||||
(goops-error "malformed slot option list"))
|
||||
(else
|
||||
(case (slot-option-keyword options)
|
||||
((#:init-form)
|
||||
(loop (cddr options)
|
||||
(append (list `(lambda ()
|
||||
,(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)))))))))))
|
||||
(define-macro (class supers . slots)
|
||||
(define (make-slot-definition-forms slots)
|
||||
(map
|
||||
(lambda (def)
|
||||
(cond
|
||||
((pair? def)
|
||||
`(list ',(car def)
|
||||
,@(kw-do-map append-map
|
||||
(lambda (kw arg)
|
||||
(case kw
|
||||
((#:init-form)
|
||||
`(#:init-form ',arg
|
||||
#:init-thunk (lambda () ,arg)))
|
||||
(else (list kw arg))))
|
||||
(cdr def))))
|
||||
(else
|
||||
`(list ',def))))
|
||||
slots))
|
||||
|
||||
(procedure->memoizing-macro
|
||||
(let ((supers cadr)
|
||||
(slots cddr)
|
||||
(options cdddr))
|
||||
(lambda (exp env)
|
||||
(cond ((not (and (list? exp) (>= (length exp) 2)))
|
||||
(goops-error "missing or extra expression"))
|
||||
((not (list? (supers exp)))
|
||||
(goops-error "malformed superclass list: ~S" (supers exp)))
|
||||
(else
|
||||
(let ((slot-defs (cons #f '())))
|
||||
(do ((slots (slots exp) (cdr slots))
|
||||
(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))))))))))))))
|
||||
(if (not (list? supers))
|
||||
(goops-error "malformed superclass list: ~S" supers))
|
||||
(let ((slot-defs (cons #f '()))
|
||||
(slots (take-while (lambda (x) (not (keyword? x))) slots))
|
||||
(options (or (find-tail keyword? slots) '())))
|
||||
`(make-class
|
||||
;; evaluate super class variables
|
||||
(list ,@supers)
|
||||
;; evaluate slot definitions, except the slot name!
|
||||
(list ,@(make-slot-definition-forms slots))
|
||||
;; evaluate class options
|
||||
,@options)))
|
||||
|
||||
(define (make-class supers slots . options)
|
||||
(let ((env (or (get-keyword #:environment options #f)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue