[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. b3501b8043
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. b3501b8043d36a3215ec51e321a2aa3733ea54cc |
|
Date: |
Sat, 25 Apr 2009 12:48:35 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=b3501b8043d36a3215ec51e321a2aa3733ea54cc
The branch, syncase-in-boot-9 has been updated
via b3501b8043d36a3215ec51e321a2aa3733ea54cc (commit)
via 2ce560b944c8af2047415612835fcd23fa3de473 (commit)
from 0ee32d0131b49ee0661669b7a0b595d0a6565de4 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit b3501b8043d36a3215ec51e321a2aa3733ea54cc
Author: Andy Wingo <address@hidden>
Date: Sat Apr 25 14:10:08 2009 +0200
all of guile compiles now, expanded with syncase
* libguile/eval.c (scm_m_eval_when): Whoops, eval-when has an implicit
begin. Fix.
* module/oop/goops.scm: Syncase doesn't like definitions in expression
context, and grudgingly I have decided to go along with that. But that
doesn't mean we can't keep the old semantics, via accessing the module
system directly. So do so. I took the opportunity to rewrite some
macros with syntax-rules and syntax-case -- the former is nicer than
the latter, of course.
* module/oop/goops/save.scm: Don't define within an expression.
* module/oop/goops/simple.scm (define-class): Use define-syntax.
* module/oop/goops/stklos.scm (define-class): Use define-syntax.
commit 2ce560b944c8af2047415612835fcd23fa3de473
Author: Andy Wingo <address@hidden>
Date: Sat Apr 25 12:50:53 2009 +0200
fix bad syntax in define-macro, (ice-9 match), and (oop goops)
* module/ice-9/boot-9.scm (define-macro): Use syntax-case to destructure
macro arguments, so we get good errors.
* module/ice-9/match.scm (defstruct, define-const-structure): Don't
unquote in the `defstruct' macro as a value in expansions.
* module/oop/goops.scm (standard-define-class): Can't define a macro with
`define', use `define-syntax' instead.
(define-accessor): Use syntax-rules. Doesn't give us much in this case.
(toplevel-define!): New helper, to let us keep GOOPS' behavior with the
new expander. Some solution that works lexically and at the toplevel
would be nice, though.
(define-method): Reimplement with syntax-rules -- soooo much nicer.
* module/oop/goops/dispatch.scm (lookup-create-cmethod): Don't define
within an expression.
-----------------------------------------------------------------------
Summary of changes:
libguile/eval.c | 4 +-
module/ice-9/boot-9.scm | 6 +-
module/ice-9/match.scm | 4 +-
module/oop/goops.scm | 243 ++++++++++++++++++++++-------------------
module/oop/goops/dispatch.scm | 5 +-
module/oop/goops/save.scm | 4 +-
module/oop/goops/simple.scm | 5 +-
module/oop/goops/stklos.scm | 71 ++++--------
8 files changed, 171 insertions(+), 171 deletions(-)
diff --git a/libguile/eval.c b/libguile/eval.c
index 5b1473e..05af5a1 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -2149,12 +2149,12 @@ SCM_SYMBOL (sym_load, "load");
SCM
scm_m_eval_when (SCM expr, SCM env SCM_UNUSED)
{
- ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr);
if (scm_is_true (scm_memq (sym_eval, scm_cadr (expr)))
|| scm_is_true (scm_memq (sym_load, scm_cadr (expr))))
- return scm_caddr (expr);
+ return scm_cons (SCM_IM_BEGIN, scm_cddr (expr));
return scm_list_1 (SCM_IM_BEGIN);
}
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 235d96c..51f1958 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -216,8 +216,10 @@
(syntax
(define-syntax macro
(lambda (y)
- (let ((v (syntax-object->datum y)))
- (datum->syntax-object y (apply transformer (cdr v)))))))))))
+ (syntax-case y ()
+ ((_ . args)
+ (let ((v (syntax-object->datum (syntax args))))
+ (datum->syntax-object y (apply transformer v))))))))))))
(define-syntax defmacro
(lambda (x)
diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm
index e6fe560..baa4d5a 100644
--- a/module/ice-9/match.scm
+++ b/module/ice-9/match.scm
@@ -194,6 +194,6 @@
(define match:runtime-structures #f)
(define match:set-runtime-structures (lambda (v) (set!
match:runtime-structures v)))
(define match:primitive-vector? vector?)
-(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda ()
#t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x))
(null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda
(x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair?
(cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x)))))
(mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x)
(pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x))
(match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda
(l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi
(cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let
((g296 (lambda () (match:syntax-err (quasiquote ((unquote defstruct)
(unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol?
(car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args))
(symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args))
(g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate
fields) (let* ((selectors (map selector-name fields)) (mutators (map
mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote
(quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq?
match:structure-control (quote disjoint)) (quote match:primitive-vector?))
((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq?
match:structure-control (quote disjoint)) (if (eq? vector?
match:primitive-vector?) (set! vector? (lambda (v) (and
(match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol?
(vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not
(memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates
(cons predicate match:disjoint-predicates)))) ((eq? match:structure-control
(quote vector)) (if (not (memq predicate match:vector-structures)) (set!
match:vector-structures (cons predicate match:vector-structures)))) (else
(match:syntax-err (quote (vector disjoint)) "invalid value for
match:structure-control, legal values are"))) (quasiquote (begin
(unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote
tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define
(unquote constructor) (lambda (unquote selectors) (vector (unquote tag)
(unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and
((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length
selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing
(filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda
(obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing
(filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n)
(lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators))))))
(car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299))
(g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296)))))
+(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda ()
#t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x))
(null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda
(x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair?
(cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x)))))
(mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x)
(pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x))
(match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda
(l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi
(cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let
((g296 (lambda () (match:syntax-err (quasiquote (defstruct (unquote-splicing
args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair?
(cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args))
(list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if
(null? g299) ((lambda (name constructor predicate fields) (let* ((selectors
(map selector-name fields)) (mutators (map mutator-name fields)) (tag (if
match:runtime-structures (gensym) (quasiquote (quote (unquote
(match:make-structure-tag name)))))) (vectorP (cond ((eq?
match:structure-control (quote disjoint)) (quote match:primitive-vector?))
((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq?
match:structure-control (quote disjoint)) (if (eq? vector?
match:primitive-vector?) (set! vector? (lambda (v) (and
(match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol?
(vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not
(memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates
(cons predicate match:disjoint-predicates)))) ((eq? match:structure-control
(quote vector)) (if (not (memq predicate match:vector-structures)) (set!
match:vector-structures (cons predicate match:vector-structures)))) (else
(match:syntax-err (quote (vector disjoint)) "invalid value for
match:structure-control, legal values are"))) (quasiquote (begin
(unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote
tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define
(unquote constructor) (lambda (unquote selectors) (vector (unquote tag)
(unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and
((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length
selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing
(filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda
(obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing
(filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n)
(lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators))))))
(car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299))
(g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296)))))
(defmacro define-structure args (let ((g311 (lambda () (match:syntax-err
(quasiquote (define-structure (unquote-splicing args))) "syntax error in"))))
(if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr
args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name)
(unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr
args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ()))
(g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1
id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote
@)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x)
(cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote
(define-const-structure ((unquote name) (unquote-splicing (map mk-id id1)))
(unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v))))
id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311))
(if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308
(cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311)))
(g311))))
-(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol?
id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair?
(cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda ()
#f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator?
(lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec
((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x)
(cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l
1)))) (symbol-append (lambda l (string->symbol (apply string-append (map
(lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string
x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote
(define-const-structure (unquote-splicing args))) "syntax error in")))) (if
(and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr
args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name)
(unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar
args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if
(and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args))
(g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args))
((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor
(symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote
make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin
((unquote defstruct) (unquote name) (unquote raw-constructor) (unquote
predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if
(has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i))
(unquote (symbol-append (quote set-) name (quote -) i (quote !)))))
(symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2)
(quasiquote (define (unquote constructor) (unquote raw-constructor))) (let*
((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map
make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name
id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1)
(let* (unquote (map list names2 val)) ((unquote raw-constructor)
(unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing
(filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _))
#f (quasiquote (define (unquote (symbol-append name (quote -) (field-name
field))) (unquote (symbol-append name (quote -) i)))))) id1id2))
(unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq?
(field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote
(define (unquote (symbol-append (quote set-) name (quote -) (field-name field)
(quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote
!))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331))
(g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333))
(null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar
g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons
(car g329) g327)) (g335)))) (g335))) (g335)))))
+(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol?
id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair?
(cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda ()
#f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator?
(lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec
((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x)
(cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l
1)))) (symbol-append (lambda l (string->symbol (apply string-append (map
(lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string
x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote
(define-const-structure (unquote-splicing args))) "syntax error in")))) (if
(and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr
args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name)
(unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar
args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if
(and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args))
(g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args))
((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor
(symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote
make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin
(defstruct (unquote name) (unquote raw-constructor) (unquote predicate)
(unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg)
(quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append
(quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i)))
id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor)
(unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _)
x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map
make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor)
(lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote
raw-constructor) (unquote-splicing names1) (unquote-splicing names2)))))))))
(unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name
field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -)
(field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2))
(unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq?
(field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote
(define (unquote (symbol-append (quote set-) name (quote -) (field-name field)
(quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote
!))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331))
(g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333))
(null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar
g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons
(car g329) g327)) (g335)))) (g335))) (g335)))))
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 2254f93..873e4b8 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-object->datum (syntax k)))
+ (case (syntax-object->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-object->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,42 +452,30 @@
;;; {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 (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-macro (method args . body)
(letrec ((specializers
@@ -1045,11 +1061,14 @@
;; the idea is to compile the index into the procedure, for fastest
;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
+;; separate expression so that we affect the expansion of the subsequent
+;; expression
(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))
+ (system base pmatch)))
+(eval-when (compile)
;; unfortunately, can't use define-inline because these are primitive
;; syntaxen.
(define-scheme-translator @slot-ref
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index a540447..ed9f307 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 4d64da8..2aedd76 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 48e76f3..c0cb76f 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 60ab293..ef943cf 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 ...))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. b3501b8043d36a3215ec51e321a2aa3733ea54cc,
Andy Wingo <=