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 )
! 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
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-predicate ( type# symbol -- )
+ dup predicate-word
+ [ rot [ swap type eq? ] cons define-compound ] keep
+ "predicate" set-word-property ;
-: builtin-class ( number type -- )
+: 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 ;
#! 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
USE: presentation
USE: stdio
USE: strings
+USE: unparser
: exists? ( file -- ? )
stat >boolean ;
: 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 ;
: <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
: 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 ;
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 )
USE: vectors
USE: words
USE: math
+USE: generic
: expired-error ( obj -- )
"Object did not survive image save/load: " write . ;
"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
USE: words
USE: vectors
USE: unparser
+USE: generic
: heap-stat. ( type instances bytes -- )
dup 0 = [