suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

v4 patch, mostly from Doug Orleans

Browse Source 
svn: r8521
This commit is contained in:
Eli Barzilay 2008-02-04 05:00:38 +00:00
parent 8f186accdf
commit 22551978a1
2 changed files with 40 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/swindle/setf.ss
View File

@ -17,7 +17,7 @@
;;> either as a function or a syntax in the same definition context of ;;> either as a function or a syntax in the same definition context of
;;> `foo'. The nice feature that comes out of this and the syntax system ;;> `foo'. The nice feature that comes out of this and the syntax system
;;> is that examples like the following work as expected: ;;> is that examples like the following work as expected:
;;> (let ([foo car] [set-foo! set-car!]) (setf! (foo a) 11)) ;;> (let ([foo mcar] [set-foo! set-mcar!]) (setf! (foo a) 11))
;;> ;;>
;;> `place' gets expanded before this processing is done so macros work ;;> `place' gets expanded before this processing is done so macros work
;;> properly. If the place is not a form, then this will just use the ;;> properly. If the place is not a form, then this will just use the

79
collects/swindle/tiny-clos.ss
View File

@ -398,17 +398,17 @@
;;> Note that slot names are usually symbols, but can be other values as ;;> Note that slot names are usually symbols, but can be other values as
;;> well. ;;> well.
(define* (slot-ref object slot-name) (define* (slot-ref object slot-name)
((lookup-slot-info (class-of object) slot-name cadr) object)) ((lookup-slot-info (class-of object) slot-name mcar) object))
(defsubst (%slot-ref object slot-name) (defsubst (%slot-ref object slot-name)
((lookup-slot-info (class-of object) slot-name cadr) object)) ((lookup-slot-info (class-of object) slot-name mcar) object))
;;>> (slot-set! obj slot new) ;;>> (slot-set! obj slot new)
;;> Change the contents of the `slot' slot of `obj' to the given `new' ;;> Change the contents of the `slot' slot of `obj' to the given `new'
;;> value. ;;> value.
(define* (slot-set! object slot-name new-value) (define* (slot-set! object slot-name new-value)
((lookup-slot-info (class-of object) slot-name caddr) object new-value)) ((lookup-slot-info (class-of object) slot-name mcdr) object new-value))
(defsubst (%slot-set! object slot-name new-value) (defsubst (%slot-set! object slot-name new-value)
((lookup-slot-info (class-of object) slot-name caddr) object new-value)) ((lookup-slot-info (class-of object) slot-name mcdr) object new-value))
;;>> (set-slot-ref! obj slot new) ;;>> (set-slot-ref! obj slot new)
;;> An alias for `slot-set!', to enable using `setf!' on it. ;;> An alias for `slot-set!', to enable using `setf!' on it.
(define* set-slot-ref! slot-set!) (define* set-slot-ref! slot-set!)
@ -430,21 +430,21 @@
(not (eq? ??? (%slot-ref object slot-name)))) (not (eq? ??? (%slot-ref object slot-name))))
(define (lookup-slot-info class slot-name selector) (define (lookup-slot-info class slot-name selector)
(selector (or (assq slot-name (selector (cdr (or (assq slot-name
;; no need to ground slot-ref any more! -- see below ;; no need to ground slot-ref any more! -- see below
;; (if (eq? class <class>) ;; (if (eq? class <class>)
;; ;;* This grounds out the slot-ref tower ;; ;;* This grounds out the slot-ref tower
;; getters-n-setters-for-class ;; getters-n-setters-for-class
;; (%class-getters-n-setters class)) ;; (%class-getters-n-setters class))
(%class-getters-n-setters class)) (%class-getters-n-setters class))
(raise* make-exn:fail:contract (raise* make-exn:fail:contract
"slot-ref: no slot `~e' in ~e" slot-name class)))) "slot-ref: no slot `~e' in ~e" slot-name class)))))
;;; These are for optimizations - works only for single inheritance! ;;; These are for optimizations - works only for single inheritance!
(define (%slot-getter class slot-name) (define (%slot-getter class slot-name)
(lookup-slot-info class slot-name cadr)) (lookup-slot-info class slot-name mcar))
(define (%slot-setter class slot-name) (define (%slot-setter class slot-name)
(lookup-slot-info class slot-name caddr)) (lookup-slot-info class slot-name mcdr))
;;>>... Singleton and Struct Specifiers ;;>>... Singleton and Struct Specifiers
@ -627,9 +627,8 @@
(define getters-n-setters-for-class ; see lookup-slot-info (define getters-n-setters-for-class ; see lookup-slot-info
(map (lambda (s) (map (lambda (s)
(let ([f (position-of s the-slots-of-a-class)]) (let ([f (position-of s the-slots-of-a-class)])
(cons s (cons s (mcons (lambda (o) (%instance-ref o f))
(mcons (lambda (o) (%instance-ref o f)) (lambda (o n) (%instance-set! o f n))))))
(lambda (o n) (%instance-set! o f n))))))
the-slots-of-a-class)) the-slots-of-a-class))
;;>>... ;;>>...
@ -663,12 +662,12 @@
;; slot-ref definition above is fine. So, ;; slot-ref definition above is fine. So,
;; (%set-class-getters-n-setters! <class> getters-n-setters-for-class) ;; (%set-class-getters-n-setters! <class> getters-n-setters-for-class)
;; translates into this: ;; translates into this:
((caddr (assq 'getters-n-setters getters-n-setters-for-class)) ((mcdr (cdr (assq 'getters-n-setters getters-n-setters-for-class)))
<class> getters-n-setters-for-class) <class> getters-n-setters-for-class)
;; and now the direct `%class-getters-n-setters' version: ;; and now the direct `%class-getters-n-setters' version:
(set! %class-getters-n-setters (set! %class-getters-n-setters
;; and (lookup-slot-info <class> 'getters-n-setters caddr) translates to: ;; and (lookup-slot-info <class> 'getters-n-setters mcar) translates to:
(cadr (assq 'getters-n-setters getters-n-setters-for-class))) (mcar (cdr (assq 'getters-n-setters getters-n-setters-for-class))))
;;>> <top> ;;>> <top>
;;> This is the "mother of all values": every value is an instance of ;;> This is the "mother of all values": every value is an instance of
@ -782,7 +781,7 @@
;; Do this since compute-apply-method relies on them not changing, as well as a ;; Do this since compute-apply-method relies on them not changing, as well as a
;; zillion other places. A method should be very similar to a lambda. ;; zillion other places. A method should be very similar to a lambda.
(dolist [slot '(specializers procedure qualifier)] (dolist [slot '(specializers procedure qualifier)]
(make-setter-locked! (lookup-slot-info <method> slot cdr) #t (make-setter-locked! (lookup-slot-info <method> slot values) #t
(lambda () (lambda ()
(raise* make-exn:fail:contract (raise* make-exn:fail:contract
"slot-set!: slot `~e' in <method> is locked" slot)))) "slot-set!: slot `~e' in <method> is locked" slot))))
@ -1587,15 +1586,15 @@
[(:instance) [(:instance)
(let* ([f (allocator init-slot)] (let* ([f (allocator init-slot)]
[g+s (mcons (lambda (o) (%instance-ref o f)) [g+s (mcons (lambda (o) (%instance-ref o f))
(if (and type (not (eq? <top> type))) (if (and type (not (eq? <top> type)))
(lambda (o n) (lambda (o n)
(if (instance-of? n type) (if (instance-of? n type)
(%instance-set! o f n) (%instance-set! o f n)
(raise* make-exn:fail:contract (raise* make-exn:fail:contract
"slot-set!: wrong type for slot ~ "slot-set!: wrong type for slot ~
~e in ~e (~e not in ~e)" ~e in ~e (~e not in ~e)"
(car slot) class n type))) (car slot) class n type)))
(lambda (o n) (%instance-set! o f n))))]) (lambda (o n) (%instance-set! o f n))))])
(when lock (when lock
(make-setter-locked! g+s lock (make-setter-locked! g+s lock
(lambda () (lambda ()
@ -1613,9 +1612,9 @@
;; cache the setter ;; cache the setter
(unless setter (unless setter
(set! setter (set! setter
(caddr (assq (car slot) (mcdr (cdr (assq (car slot)
(%class-getters-n-setters (%class-getters-n-setters
class))))) class))))))
(unless (eq? result nothing) (unless (eq? result nothing)
(setter #f result)))) (setter #f result))))
(%class-initializers class))))) (%class-initializers class)))))
@ -1626,14 +1625,14 @@
;; the slot was declared as :class here ;; the slot was declared as :class here
(let* ([cell (init)] ; default value - no arguments (let* ([cell (init)] ; default value - no arguments
[g+s (mcons (lambda (o) cell) [g+s (mcons (lambda (o) cell)
(lambda (o n) (lambda (o n)
(if (and type (not (instance-of? n type))) (if (and type (not (instance-of? n type)))
(raise* (raise*
make-exn:fail:contract make-exn:fail:contract
"slot-set!: wrong type for shared slot ~ "slot-set!: wrong type for shared slot ~
~e in ~e (~e not in ~e)" ~e in ~e (~e not in ~e)"
(car slot) class n type) (car slot) class n type)
(set! cell n))))]) (set! cell n))))])
(when lock (when lock
(make-setter-locked! (car slot) g+s lock (make-setter-locked! (car slot) g+s lock
(lambda () (lambda ()