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
|
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 )
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 = [
|
||||||
|
|
Loading…
Reference in New Issue