diff --git a/libguile/eval.c b/libguile/eval.c index 5b1473e06..05af5a1c5 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/oop/goops.scm b/module/oop/goops.scm index 7e9eae9a9..873e4b831 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 ))) - (define-generic ,val))) - ((#:accessor) - `(if (or (not (defined? ',val)) - (not (is-a? ,val ))) - (define-accessor ,val))) - (else #f))) (define (kw-do-map mapper f kwargs) (define (keywords l) @@ -180,71 +169,6 @@ (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 ) - (memq (class-precedence-list ,name))) - (class-redefinition ,name - (class ,supers ,@slots #:name ',name)) - (define ,name (class ,supers ,@slots #:name ',name))))) - -(define-syntax standard-define-class - (syntax-rules () - ((_ arg ...) (define-class arg ...)))) - -;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...) -;;; -;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) -;;; OPTION ::= KEYWORD VALUE -;;; -(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)) - - (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) (top-level-env)))) @@ -277,6 +201,108 @@ #:environment env options)))) +;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...) +;;; +;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) +;;; OPTION ::= KEYWORD VALUE +;;; +(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)) + (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-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 ))) + (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 ))) + (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 ) + (memq (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} ;;; @@ -1035,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/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 )) - (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 ) - (is-a? ,name ))) - (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 ))) + (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 ) + (is-a? name )))) + (toplevel-define! 'name + (ensure-generic + (if (defined? 'name) name #f) 'name))) + (add-method! name (method rest ...))))))