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

applicable structs

Browse Source 
svn: r5937
This commit is contained in:
Eli Barzilay 2007-04-14 06:28:56 +00:00
parent e2a460e2d9
commit c798f43dbb
2 changed files with 15 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/swindle/readme.txt
View File

@ -152,6 +152,6 @@ Copyright (C) 1998-2007 Eli Barzilay (eli@barzilay.org)
You should have received a copy of the GNU Lesser General Public You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301 USA 02110-1301 USA.
====< * >=============================================================== ====< * >===============================================================

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

@ -496,14 +496,17 @@
(define* (struct-type->class stype) (define* (struct-type->class stype)
(hash-table-get (hash-table-get
struct-to-class-table stype struct-to-class-table stype
(thunk (let-values ([(name init-field-k auto-field-k accessor mutator (thunk
(let-values ([(name init-field-k auto-field-k accessor mutator
immutable-k-list super skipped?) immutable-k-list super skipped?)
(struct-type-info stype)]) (struct-type-info stype)])
(let* ([super (cond [super (struct-type->class super)] (let* ([supers (list (cond [super (struct-type->class super)]
[skipped? <opaque-struct>] [skipped? <opaque-struct>]
[else <struct>])] [else <struct>]))]
[proc? (procedure-struct-type? stype)]
[supers (if proc? (cons <primitive-procedure> supers) supers)]
[this (parameterize ([*default-object-class* #f]) [this (parameterize ([*default-object-class* #f])
(make <primitive-class> (make (if proc? <procedure-class> <primitive-class>)
:name name :direct-supers (list super)))]) :name name :direct-supers (list super)))])
(hash-table-put! struct-to-class-table stype this) (hash-table-put! struct-to-class-table stype this)
this))))) this)))))