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
] 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: #c-call ( jump to raw address )

View File

@ -39,6 +39,10 @@ USE: vectors
! Builtin metaclass for builtin types: fixnum, word, cons, etc.
SYMBOL: builtin
! Vector in global namespace mapping type numbers to
! builtin classes.
SYMBOL: types
builtin [
"builtin-type" word-property unit
] "builtin-supertypes" set-word-property
@ -50,15 +54,17 @@ builtin [
builtin 50 "priority" set-word-property
: builtin-predicate ( type# symbol -- word )
predicate-word [
swap [ swap type eq? ] cons define-compound
] keep ;
: add-builtin-table types get set-vector-nth ;
: 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
2dup builtin-predicate
dupd "predicate" set-word-property
dup builtin "metaclass" set-word-property
swap "builtin-type" set-word-property ;
@ -67,5 +73,10 @@ builtin 50 "priority" set-word-property
#! type predicate with this number.
CREATE scan-word swap builtin-class ; parsing
: builtin-type ( symbol -- n )
"builtin-type" word-property ;
: builtin-type ( n -- symbol )
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: stdio
USE: strings
USE: unparser
: exists? ( file -- ? )
stat >boolean ;
@ -78,7 +79,7 @@ USE: strings
: file-link. ( dir name -- )
tuck "/" swap cat3 dup "file-link" swons swap
file-actions <actions> "actions" swons
unparse file-actions <actions> "actions" swons
t "underline" swons
3list write-attr ;

View File

@ -36,7 +36,6 @@ USE: unparser
: <actions> ( path alist -- alist )
#! For each element of the alist, change the value to
#! path " " value
>r unparse r>
[ uncons >r over " " r> cat3 cons ] map nip ;
! 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 )
[
"vocabularies'" ,
dup word-vocabulary ,
"'" ,
word-name ,
dup word-name unparse ,
" [ " ,
word-vocabulary unparse ,
" ] search" ,
] make-string ;
: word-actions ( -- list )
: word-actions ( search -- list )
[
[ "Describe" | "describe-path" ]
[ "Push" | "lookup" ]
[ "Execute" | "lookup execute" ]
[ "jEdit" | "lookup jedit" ]
[ "Usages" | "lookup usages." ]
[ "See" | "see" ]
[ "Push" | "" ]
[ "Execute" | "execute" ]
[ "jEdit" | "jedit" ]
[ "Usages" | "usages." ]
] ;
: word-attrs ( word -- attrs )
#! Words without a vocabulary do not get a link or an action
#! popup.
dup word-vocabulary [
word-link [ "object-link" swons ] keep
word-actions <actions> "actions" swons
t "underline" swons
3list
word-link word-actions <actions> "actions" swons unit
] [
drop [ ]
] ifte ;

View File

@ -36,34 +36,6 @@ USE: stdio
USE: strings
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 )
M: object unparse ( obj -- str )

View File

@ -36,6 +36,7 @@ USE: unparser
USE: vectors
USE: words
USE: math
USE: generic
: expired-error ( obj -- )
"Object did not survive image save/load: " write . ;
@ -57,11 +58,22 @@ USE: math
"I/O error in kernel function " write
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" print
uncons car dup "Object: " write .
"Object type: " write type type-name print
"Expected type: " write type-name print ;
"Object type: " write type type-error-name print
"Expected type: " write type-error-name print ;
: array-range-error ( list -- )
"Array range check error" print

View File

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