plugin fix; type-name word cleaned up
parent
cf5a90b3b7
commit
3a242efb51
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -35,6 +35,7 @@ USE: stdio
|
|||
USE: words
|
||||
USE: vectors
|
||||
USE: unparser
|
||||
USE: generic
|
||||
|
||||
: heap-stat. ( type instances bytes -- )
|
||||
dup 0 = [
|
||||
|
|
Loading…
Reference in New Issue