steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Defining an "error-class", and printing error tuples out with ERROR:. See #188.

db4
John Benediktsson 2011-09-25 16:33:08 -07:00
parent eead1f0487
commit 7ef1aecf88
2 changed files with 22 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
basis/see/see.factor
View File

@ -191,8 +191,8 @@ M: array pprint-slot-name
: superclass. ( class -- ) : superclass. ( class -- )
superclass dup tuple eq? [ drop ] [ "<" text pprint-word ] if ; superclass dup tuple eq? [ drop ] [ "<" text pprint-word ] if ;
M: tuple-class see-class* : pprint-tuple-class ( class definer -- )
<colon \ TUPLE: pprint-word <colon pprint-word
{ {
[ pprint-word ] [ pprint-word ]
[ superclass. ] [ superclass. ]
@ -201,6 +201,12 @@ M: tuple-class see-class*
} cleave } cleave
block> ; block> ;
M: tuple-class see-class*
\ TUPLE: pprint-tuple-class ;
M: error-class see-class* ( class -- )
\ ERROR: pprint-tuple-class ;
M: word see-class* drop ; M: word see-class* drop ;
M: builtin-class see-class* M: builtin-class see-class*

9
core/classes/tuple/tuple.factor
View File

@ -290,16 +290,21 @@ M: tuple-class (define-tuple-class)
3dup tuple-class-unchanged? 3dup tuple-class-unchanged?
[ 2drop ?define-symbol ] [ redefine-tuple-class ] if ; [ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
PREDICATE: error-class < tuple-class
"error-class" word-prop ;
: define-error-class ( class superclass slots -- ) : define-error-class ( class superclass slots -- )
error-slots error-slots {
[ define-tuple-class ] [ define-tuple-class ]
[ 2drop reset-generic ] [ 2drop reset-generic ]
[ 2drop t "error-class" set-word-prop ]
[ [
2drop 2drop
[ dup [ boa throw ] curry ] [ dup [ boa throw ] curry ]
[ all-slots thrower-effect ] [ all-slots thrower-effect ]
bi define-declared bi define-declared
] 3tri ; ]
} 3cleave ;
: boa-effect ( class -- effect ) : boa-effect ( class -- effect )
[ all-slots [ name>> ] map ] [ name>> 1array ] bi <effect> ; [ all-slots [ name>> ] map ] [ name>> 1array ] bi <effect> ;