plugin fix; type-name word cleaned up

cvs
Slava Pestov 2004-12-20 20:29:55 +00:00
parent cf5a90b3b7
commit 3a242efb51
8 changed files with 48 additions and 55 deletions

View File

@ -50,7 +50,7 @@ BUILTIN: alien 16
drop "name" get dlopen dup "dll" set drop "name" get dlopen dup "dll" set
] unless ; ] unless ;
SYMBOL: #c-invoke ( C ABI -- Unix and most Windows libs ) SYMBOL: #c-invoke ( C ABI -- Unix and some Windows libs )
SYMBOL: #cleanup ( unwind stack by parameter ) SYMBOL: #cleanup ( unwind stack by parameter )
SYMBOL: #c-call ( jump to raw address ) SYMBOL: #c-call ( jump to raw address )

View File

@ -39,6 +39,10 @@ USE: vectors
! Builtin metaclass for builtin types: fixnum, word, cons, etc. ! Builtin metaclass for builtin types: fixnum, word, cons, etc.
SYMBOL: builtin SYMBOL: builtin
! Vector in global namespace mapping type numbers to
! builtin classes.
SYMBOL: types
builtin [ builtin [
"builtin-type" word-property unit "builtin-type" word-property unit
] "builtin-supertypes" set-word-property ] "builtin-supertypes" set-word-property
@ -50,15 +54,17 @@ builtin [
builtin 50 "priority" set-word-property builtin 50 "priority" set-word-property
: builtin-predicate ( type# symbol -- word ) : add-builtin-table types get set-vector-nth ;
predicate-word [
swap [ swap type eq? ] cons define-compound
] keep ;
: builtin-class ( number type -- ) : builtin-predicate ( type# symbol -- )
dup predicate-word
[ rot [ swap type eq? ] cons define-compound ] keep
"predicate" set-word-property ;
: builtin-class ( type# symbol -- )
2dup swap add-builtin-table
dup undefined? [ dup define-symbol ] when dup undefined? [ dup define-symbol ] when
2dup builtin-predicate 2dup builtin-predicate
dupd "predicate" set-word-property
dup builtin "metaclass" set-word-property dup builtin "metaclass" set-word-property
swap "builtin-type" set-word-property ; swap "builtin-type" set-word-property ;
@ -67,5 +73,10 @@ builtin 50 "priority" set-word-property
#! type predicate with this number. #! type predicate with this number.
CREATE scan-word swap builtin-class ; parsing CREATE scan-word swap builtin-class ; parsing
: builtin-type ( symbol -- n ) : builtin-type ( n -- symbol )
"builtin-type" word-property ; types get vector-nth ;
: type-name ( n -- string )
builtin-type word-name ;
global [ num-types <vector> types set ] bind

View File

@ -33,6 +33,7 @@ USE: namespaces
USE: presentation USE: presentation
USE: stdio USE: stdio
USE: strings USE: strings
USE: unparser
: exists? ( file -- ? ) : exists? ( file -- ? )
stat >boolean ; stat >boolean ;
@ -78,7 +79,7 @@ USE: strings
: file-link. ( dir name -- ) : file-link. ( dir name -- )
tuck "/" swap cat3 dup "file-link" swons swap tuck "/" swap cat3 dup "file-link" swons swap
file-actions <actions> "actions" swons unparse file-actions <actions> "actions" swons
t "underline" swons t "underline" swons
3list write-attr ; 3list write-attr ;

View File

@ -36,7 +36,6 @@ USE: unparser
: <actions> ( path alist -- alist ) : <actions> ( path alist -- alist )
#! For each element of the alist, change the value to #! For each element of the alist, change the value to
#! path " " value #! path " " value
>r unparse r>
[ uncons >r over " " r> cat3 cons ] map nip ; [ uncons >r over " " r> cat3 cons ] map nip ;
! A style is an alist whose key/value pairs hold ! A style is an alist whose key/value pairs hold

View File

@ -86,29 +86,26 @@ M: object prettyprint* ( indent obj -- indent )
: word-link ( word -- link ) : word-link ( word -- link )
[ [
"vocabularies'" , dup word-name unparse ,
dup word-vocabulary , " [ " ,
"'" , word-vocabulary unparse ,
word-name , " ] search" ,
] make-string ; ] make-string ;
: word-actions ( -- list ) : word-actions ( search -- list )
[ [
[ "Describe" | "describe-path" ] [ "See" | "see" ]
[ "Push" | "lookup" ] [ "Push" | "" ]
[ "Execute" | "lookup execute" ] [ "Execute" | "execute" ]
[ "jEdit" | "lookup jedit" ] [ "jEdit" | "jedit" ]
[ "Usages" | "lookup usages." ] [ "Usages" | "usages." ]
] ; ] ;
: word-attrs ( word -- attrs ) : word-attrs ( word -- attrs )
#! Words without a vocabulary do not get a link or an action #! Words without a vocabulary do not get a link or an action
#! popup. #! popup.
dup word-vocabulary [ dup word-vocabulary [
word-link [ "object-link" swons ] keep word-link word-actions <actions> "actions" swons unit
word-actions <actions> "actions" swons
t "underline" swons
3list
] [ ] [
drop [ ] drop [ ]
] ifte ; ] ifte ;

View File

@ -36,34 +36,6 @@ USE: stdio
USE: strings USE: strings
USE: words USE: words
: type-name ( n -- str )
[
[ 0 | "fixnum" ]
[ 1 | "word" ]
[ 2 | "cons" ]
[ 3 | "object" ]
[ 4 | "ratio" ]
[ 5 | "complex" ]
[ 6 | "f" ]
[ 7 | "t" ]
[ 8 | "array" ]
[ 9 | "bignum" ]
[ 10 | "float" ]
[ 11 | "vector" ]
[ 12 | "string" ]
[ 13 | "sbuf" ]
[ 14 | "port" ]
[ 15 | "dll" ]
[ 16 | "alien" ]
! These values are only used by the kernel for error
! reporting.
[ 100 | "fixnum/bignum" ]
[ 101 | "fixnum/bignum/ratio" ]
[ 102 | "fixnum/bignum/ratio/float" ]
[ 103 | "fixnum/bignum/ratio/float/complex" ]
[ 104 | "fixnum/string" ]
] assoc ;
GENERIC: unparse ( obj -- str ) GENERIC: unparse ( obj -- str )
M: object unparse ( obj -- str ) M: object unparse ( obj -- str )

View File

@ -36,6 +36,7 @@ USE: unparser
USE: vectors USE: vectors
USE: words USE: words
USE: math USE: math
USE: generic
: expired-error ( obj -- ) : expired-error ( obj -- )
"Object did not survive image save/load: " write . ; "Object did not survive image save/load: " write . ;
@ -57,11 +58,22 @@ USE: math
"I/O error in kernel function " write "I/O error in kernel function " write
unswons write ": " write car print ; unswons write ": " write car print ;
: type-error-name ( n -- string )
#! These values are only used by the kernel for error
#! reporting.
[
[ 100 | "fixnum/bignum" ]
[ 101 | "fixnum/bignum/ratio" ]
[ 102 | "fixnum/bignum/ratio/float" ]
[ 103 | "fixnum/bignum/ratio/float/complex" ]
[ 104 | "fixnum/string" ]
] assoc [ type-name ] unless* ;
: type-check-error ( list -- ) : type-check-error ( list -- )
"Type check error" print "Type check error" print
uncons car dup "Object: " write . uncons car dup "Object: " write .
"Object type: " write type type-name print "Object type: " write type type-error-name print
"Expected type: " write type-name print ; "Expected type: " write type-error-name print ;
: array-range-error ( list -- ) : array-range-error ( list -- )
"Array range check error" print "Array range check error" print

View File

@ -35,6 +35,7 @@ USE: stdio
USE: words USE: words
USE: vectors USE: vectors
USE: unparser USE: unparser
USE: generic
: heap-stat. ( type instances bytes -- ) : heap-stat. ( type instances bytes -- )
dup 0 = [ dup 0 = [