mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

(syntax foo) -> #'foo in goops

Browse source 
* module/oop/goops.scm: Change instances of (syntax foo) to #'foo.
This commit is contained in:
Andy Wingo 2011-05-21 13:12:44 +02:00
parent a02a606716
commit 0dd8493cb3
1 changed files with 73 additions and 79 deletions
Download patch file Download diff file Expand all files Collapse all files

152
module/oop/goops.scm
View file

@ -1,6 +1,6 @@
;;; installed-scm-file ;;; installed-scm-file
;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010 Free Software Foundation, Inc. ;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -245,31 +245,28 @@
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((_ (k arg rest ...) out ...) ((_ (k arg rest ...) out ...)
(keyword? (syntax->datum (syntax k))) (keyword? (syntax->datum #'k))
(case (syntax->datum (syntax k)) (case (syntax->datum #'k)
((#:getter #:setter) ((#:getter #:setter)
(syntax #'(define-class-pre-definition (rest ...)
(define-class-pre-definition (rest ...) out ...
out ... (if (or (not (defined? 'arg))
(if (or (not (defined? 'arg)) (not (is-a? arg <generic>)))
(not (is-a? arg <generic>))) (toplevel-define!
(toplevel-define! 'arg
'arg (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
(ensure-generic (if (defined? 'arg) arg #f) 'arg))))))
((#:accessor) ((#:accessor)
(syntax #'(define-class-pre-definition (rest ...)
(define-class-pre-definition (rest ...) out ...
out ... (if (or (not (defined? 'arg))
(if (or (not (defined? 'arg)) (not (is-a? arg <accessor>)))
(not (is-a? arg <accessor>))) (toplevel-define!
(toplevel-define! 'arg
'arg (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
(ensure-accessor (if (defined? 'arg) arg #f) 'arg))))))
(else (else
(syntax #'(define-class-pre-definition (rest ...) out ...))))
(define-class-pre-definition (rest ...) out ...)))))
((_ () out ...) ((_ () out ...)
(syntax (begin out ...)))))) #'(begin out ...)))))
;; Some slot options require extra definitions to be made. In ;; Some slot options require extra definitions to be made. In
;; particular, we want to make sure that the generic function objects ;; particular, we want to make sure that the generic function objects
@ -279,17 +276,17 @@
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((_ () out ...) ((_ () out ...)
(syntax (begin out ...))) #'(begin out ...))
((_ (slot rest ...) out ...) ((_ (slot rest ...) out ...)
(keyword? (syntax->datum (syntax slot))) (keyword? (syntax->datum #'slot))
(syntax (begin out ...))) #'(begin out ...))
((_ (slot rest ...) out ...) ((_ (slot rest ...) out ...)
(identifier? (syntax slot)) (identifier? #'slot)
(syntax (define-class-pre-definitions (rest ...) #'(define-class-pre-definitions (rest ...)
out ...))) out ...))
((_ ((slotname slotopt ...) rest ...) out ...) ((_ ((slotname slotopt ...) rest ...) out ...)
(syntax (define-class-pre-definitions (rest ...) #'(define-class-pre-definitions (rest ...)
out ... (define-class-pre-definition (slotopt ...)))))))) out ... (define-class-pre-definition (slotopt ...)))))))
(define-syntax define-class (define-syntax define-class
(syntax-rules () (syntax-rules ()
@ -491,46 +488,46 @@
(let lp ((ls args) (formals '()) (specializers '())) (let lp ((ls args) (formals '()) (specializers '()))
(syntax-case ls () (syntax-case ls ()
(((f s) . rest) (((f s) . rest)
(and (identifier? (syntax f)) (identifier? (syntax s))) (and (identifier? #'f) (identifier? #'s))
(lp (syntax rest) (lp #'rest
(cons (syntax f) formals) (cons #'f formals)
(cons (syntax s) specializers))) (cons #'s specializers)))
((f . rest) ((f . rest)
(identifier? (syntax f)) (identifier? #'f)
(lp (syntax rest) (lp #'rest
(cons (syntax f) formals) (cons #'f formals)
(cons (syntax <top>) specializers))) (cons #'<top> specializers)))
(() (()
(list (reverse formals) (list (reverse formals)
(reverse (cons (syntax '()) specializers)))) (reverse (cons #''() specializers))))
(tail (tail
(identifier? (syntax tail)) (identifier? #'tail)
(list (append (reverse formals) (syntax tail)) (list (append (reverse formals) #'tail)
(reverse (cons (syntax <top>) specializers))))))) (reverse (cons #'<top> specializers)))))))
(define (find-free-id exp referent) (define (find-free-id exp referent)
(syntax-case exp () (syntax-case exp ()
((x . y) ((x . y)
(or (find-free-id (syntax x) referent) (or (find-free-id #'x referent)
(find-free-id (syntax y) referent))) (find-free-id #'y referent)))
(x (x
(identifier? (syntax x)) (identifier? #'x)
(let ((id (datum->syntax (syntax x) referent))) (let ((id (datum->syntax #'x referent)))
(and (free-identifier=? (syntax x) id) id))) (and (free-identifier=? #'x id) id)))
(_ #f))) (_ #f)))
(define (compute-procedure formals body) (define (compute-procedure formals body)
(syntax-case body () (syntax-case body ()
((body0 ...) ((body0 ...)
(with-syntax ((formals formals)) (with-syntax ((formals formals))
(syntax (lambda formals body0 ...)))))) #'(lambda formals body0 ...)))))
(define (->proper args) (define (->proper args)
(let lp ((ls args) (out '())) (let lp ((ls args) (out '()))
(syntax-case ls () (syntax-case ls ()
((x . xs) (lp (syntax xs) (cons (syntax x) out))) ((x . xs) (lp #'xs (cons #'x out)))
(() (reverse out)) (() (reverse out))
(tail (reverse (cons (syntax tail) out)))))) (tail (reverse (cons #'tail out))))))
(define (compute-make-procedure formals body next-method) (define (compute-make-procedure formals body next-method)
(syntax-case body () (syntax-case body ()
@ -538,24 +535,22 @@
(with-syntax ((next-method next-method)) (with-syntax ((next-method next-method))
(syntax-case formals () (syntax-case formals ()
((formal ...) ((formal ...)
(syntax #'(lambda (real-next-method)
(lambda (real-next-method) (lambda (formal ...)
(lambda (formal ...) (let ((next-method (lambda args
(let ((next-method (lambda args (if (null? args)
(if (null? args) (real-next-method formal ...)
(real-next-method formal ...) (apply real-next-method args)))))
(apply real-next-method args))))) body ...))))
body ...)))))
(formals (formals
(with-syntax (((formal ...) (->proper (syntax formals)))) (with-syntax (((formal ...) (->proper #'formals)))
(syntax #'(lambda (real-next-method)
(lambda (real-next-method) (lambda formals
(lambda formals (let ((next-method (lambda args
(let ((next-method (lambda args (if (null? args)
(if (null? args) (apply real-next-method formal ...)
(apply real-next-method formal ...) (apply real-next-method args)))))
(apply real-next-method args))))) body ...))))))))))
body ...)))))))))))
(define (compute-procedures formals body) (define (compute-procedures formals body)
;; So, our use of this is broken, because it operates on the ;; So, our use of this is broken, because it operates on the
@ -564,28 +559,27 @@
(let ((id (find-free-id body 'next-method))) (let ((id (find-free-id body 'next-method)))
(if id (if id
;; return a make-procedure ;; return a make-procedure
(values (syntax #f) (values #'#f
(compute-make-procedure formals body id)) (compute-make-procedure formals body id))
(values (compute-procedure formals body) (values (compute-procedure formals body)
(syntax #f))))) #'#f))))
(syntax-case x () (syntax-case x ()
((_ args) (syntax (method args (if #f #f)))) ((_ args) #'(method args (if #f #f)))
((_ args body0 body1 ...) ((_ args body0 body1 ...)
(with-syntax (((formals (specializer ...)) (parse-args (syntax args)))) (with-syntax (((formals (specializer ...)) (parse-args #'args)))
(call-with-values (call-with-values
(lambda () (lambda ()
(compute-procedures (syntax formals) (syntax (body0 body1 ...)))) (compute-procedures #'formals #'(body0 body1 ...)))
(lambda (procedure make-procedure) (lambda (procedure make-procedure)
(with-syntax ((procedure procedure) (with-syntax ((procedure procedure)
(make-procedure make-procedure)) (make-procedure make-procedure))
(syntax #'(make <method>
(make <method> #:specializers (cons* specializer ...)
#:specializers (cons* specializer ...) #:formals 'formals
#:formals 'formals #:body '(body0 body1 ...)
#:body '(body0 body1 ...) #:make-procedure make-procedure
#:make-procedure make-procedure #:procedure procedure)))))))))
#:procedure procedure))))))))))
;;; ;;;
;;; {add-method!} ;;; {add-method!}