mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
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.
This commit is contained in:
Andy Wingo
parent
2ce560b944
commit
b3501b8043
5 changed files with 138 additions and 129 deletions
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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,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 <class>)
|
||||
(memq <object> (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 <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}
|
||||
;;;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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 ...))))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue