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
;;> `foo'. The nice feature that comes out of this and the syntax system
;;> 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
;;> properly. If the place is not a form, then this will just use the

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

@ -398,17 +398,17 @@
;;> Note that slot names are usually symbols, but can be other values as
;;> well.
(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)
((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)
;;> Change the contents of the `slot' slot of `obj' to the given `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)
((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)
;;> An alias for `slot-set!', to enable using `setf!' on it.
(define* set-slot-ref! slot-set!)
@ -430,7 +430,7 @@
(not (eq? ??? (%slot-ref object slot-name))))
(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
;; (if (eq? class <class>)
;; ;;* This grounds out the slot-ref tower
@ -438,13 +438,13 @@
;; (%class-getters-n-setters class))
(%class-getters-n-setters class))
(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!
(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)
(lookup-slot-info class slot-name caddr))
(lookup-slot-info class slot-name mcdr))
;;>>... Singleton and Struct Specifiers
@ -627,8 +627,7 @@
(define getters-n-setters-for-class ; see lookup-slot-info
(map (lambda (s)
(let ([f (position-of s the-slots-of-a-class)])
(cons s
(mcons (lambda (o) (%instance-ref o f))
(cons s (mcons (lambda (o) (%instance-ref o f))
(lambda (o n) (%instance-set! o f n))))))
the-slots-of-a-class))
@ -663,12 +662,12 @@
;; slot-ref definition above is fine. So,
;; (%set-class-getters-n-setters! <class> getters-n-setters-for-class)
;; 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)
;; and now the direct `%class-getters-n-setters' version:
(set! %class-getters-n-setters
;; and (lookup-slot-info <class> 'getters-n-setters caddr) translates to:
(cadr (assq 'getters-n-setters getters-n-setters-for-class)))
;; and (lookup-slot-info <class> 'getters-n-setters mcar) translates to:
(mcar (cdr (assq 'getters-n-setters getters-n-setters-for-class))))
;;>> <top>
;;> 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
;; zillion other places. A method should be very similar to a lambda.
(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 ()
(raise* make-exn:fail:contract
"slot-set!: slot `~e' in <method> is locked" slot))))
@ -1613,9 +1612,9 @@
;; cache the setter
(unless setter
(set! setter
(caddr (assq (car slot)
(mcdr (cdr (assq (car slot)
(%class-getters-n-setters
class)))))
class))))))
(unless (eq? result nothing)
(setter #f result))))
(%class-initializers class)))))