Fix bootstrap problems
parent
f378122dc5
commit
31e15e3204
|
@ -98,26 +98,34 @@ H{ } clone class<map set
|
|||
H{ } clone update-map set
|
||||
|
||||
! Builtin classes
|
||||
: builtin-predicate ( class predicate -- )
|
||||
: builtin-predicate-quot ( class -- quot )
|
||||
[
|
||||
over "type" word-prop dup
|
||||
"type" word-prop dup
|
||||
\ tag-mask get < \ tag \ type ? , , \ eq? ,
|
||||
] [ ] make define-predicate* ;
|
||||
] [ ] make ;
|
||||
|
||||
: register-builtin ( class -- )
|
||||
dup "type" word-prop builtins get set-nth ;
|
||||
: define-builtin-predicate ( class -- )
|
||||
dup builtin-predicate-quot define-predicate ;
|
||||
|
||||
: lookup-type-number ( word -- n )
|
||||
global [ target-word ] bind type-number ;
|
||||
|
||||
: define-builtin ( symbol predicate slotspec -- )
|
||||
>r dup make-inline >r
|
||||
dup dup lookup-type-number "type" set-word-prop
|
||||
: register-builtin ( class -- )
|
||||
dup
|
||||
dup lookup-type-number "type" set-word-prop
|
||||
dup "type" word-prop builtins get set-nth ;
|
||||
|
||||
: define-builtin-slots ( symbol slotspec -- )
|
||||
dupd 1 simple-slots
|
||||
2dup "slots" set-word-prop
|
||||
define-slots ;
|
||||
|
||||
: define-builtin ( symbol slotspec -- )
|
||||
>r
|
||||
dup register-builtin
|
||||
dup f f builtin-class define-class
|
||||
dup r> builtin-predicate
|
||||
dup r> 1 simple-slots 2dup "slots" set-word-prop
|
||||
dupd define-slots
|
||||
register-builtin ;
|
||||
dup define-builtin-predicate
|
||||
r> define-builtin-slots ;
|
||||
|
||||
H{ } clone typemap set
|
||||
num-types get f <array> builtins set
|
||||
|
@ -128,17 +136,15 @@ num-types get f <array> builtins set
|
|||
|
||||
"null" "kernel" create drop
|
||||
|
||||
"fixnum" "math" create "fixnum?" "math" create { } define-builtin
|
||||
"fixnum" "math" create { } define-builtin
|
||||
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
|
||||
|
||||
"bignum" "math" create "bignum?" "math" create { } define-builtin
|
||||
"bignum" "math" create { } define-builtin
|
||||
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
|
||||
|
||||
"tuple" "kernel" create "tuple?" "kernel" create
|
||||
{ } define-builtin
|
||||
"tuple" "kernel" create { } define-builtin
|
||||
|
||||
"ratio" "math" create "ratio?" "math" create
|
||||
{
|
||||
"ratio" "math" create {
|
||||
{
|
||||
{ "integer" "math" }
|
||||
"numerator"
|
||||
|
@ -153,11 +159,10 @@ num-types get f <array> builtins set
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"float" "math" create "float?" "math" create { } define-builtin
|
||||
"float" "math" create { } define-builtin
|
||||
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
|
||||
|
||||
"complex" "math" create "complex?" "math" create
|
||||
{
|
||||
"complex" "math" create {
|
||||
{
|
||||
{ "real" "math" }
|
||||
"real-part"
|
||||
|
@ -172,14 +177,13 @@ num-types get f <array> builtins set
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"f" "syntax" lookup "not" "kernel" create
|
||||
{ } define-builtin
|
||||
"f" "syntax" lookup { } define-builtin
|
||||
|
||||
"array" "arrays" create "array?" "arrays" create
|
||||
{ } define-builtin
|
||||
! do not word...
|
||||
|
||||
"wrapper" "kernel" create "wrapper?" "kernel" create
|
||||
{
|
||||
"array" "arrays" create { } define-builtin
|
||||
|
||||
"wrapper" "kernel" create {
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"wrapped"
|
||||
|
@ -188,8 +192,7 @@ num-types get f <array> builtins set
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"string" "strings" create "string?" "strings" create
|
||||
{
|
||||
"string" "strings" create {
|
||||
{
|
||||
{ "array-capacity" "sequences.private" }
|
||||
"length"
|
||||
|
@ -203,8 +206,7 @@ num-types get f <array> builtins set
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"quotation" "quotations" create "quotation?" "quotations" create
|
||||
{
|
||||
"quotation" "quotations" create {
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"array"
|
||||
|
@ -219,8 +221,7 @@ num-types get f <array> builtins set
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"dll" "alien" create "dll?" "alien" create
|
||||
{
|
||||
"dll" "alien" create {
|
||||
{
|
||||
{ "byte-array" "byte-arrays" }
|
||||
"path"
|
||||
|
@ -230,8 +231,7 @@ num-types get f <array> builtins set
|
|||
}
|
||||
define-builtin
|
||||
|
||||
"alien" "alien" create "alien?" "alien" create
|
||||
{
|
||||
"alien" "alien" create {
|
||||
{
|
||||
{ "c-ptr" "alien" }
|
||||
"alien"
|
||||
|
@ -246,8 +246,7 @@ define-builtin
|
|||
}
|
||||
define-builtin
|
||||
|
||||
"word" "words" create "word?" "words" create
|
||||
{
|
||||
"word" "words" create {
|
||||
f
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
|
@ -287,20 +286,13 @@ define-builtin
|
|||
}
|
||||
} define-builtin
|
||||
|
||||
"byte-array" "byte-arrays" create
|
||||
"byte-array?" "byte-arrays" create
|
||||
{ } define-builtin
|
||||
"byte-array" "byte-arrays" create { } define-builtin
|
||||
|
||||
"bit-array" "bit-arrays" create
|
||||
"bit-array?" "bit-arrays" create
|
||||
{ } define-builtin
|
||||
"bit-array" "bit-arrays" create { } define-builtin
|
||||
|
||||
"float-array" "float-arrays" create
|
||||
"float-array?" "float-arrays" create
|
||||
{ } define-builtin
|
||||
"float-array" "float-arrays" create { } define-builtin
|
||||
|
||||
"callstack" "kernel" create "callstack?" "kernel" create
|
||||
{ } define-builtin
|
||||
"callstack" "kernel" create { } define-builtin
|
||||
|
||||
! Define general-t type, which is any object that is not f.
|
||||
"general-t" "kernel" create
|
||||
|
|
|
@ -76,7 +76,7 @@ M: win32-file close-handle ( handle -- )
|
|||
] when drop ;
|
||||
|
||||
: open-append ( path -- handle length )
|
||||
dup file-length dup [
|
||||
dup file-info file-info-size dup [
|
||||
>r (open-append) r> 2dup set-file-pointer
|
||||
] [
|
||||
drop open-write
|
||||
|
|
Loading…
Reference in New Issue