Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
8dfe860b17
|
|
@ -4,7 +4,7 @@ sequences system libc alien.strings io.encodings.utf8 ;
|
|||
|
||||
\ expand-constants must-infer
|
||||
|
||||
: xyz 123 ;
|
||||
CONSTANT: xyz 123
|
||||
|
||||
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel kernel.private math namespaces
|
||||
make sequences strings words effects combinators alien.c-types ;
|
||||
|
|
@ -6,28 +6,6 @@ IN: alien.structs.fields
|
|||
|
||||
TUPLE: field-spec name offset type reader writer ;
|
||||
|
||||
: reader-effect ( type spec -- effect )
|
||||
[ 1array ] [ name>> 1array ] bi* <effect> ;
|
||||
|
||||
PREDICATE: slot-reader < word "reading" word-prop >boolean ;
|
||||
|
||||
: set-reader-props ( class spec -- )
|
||||
2dup reader-effect
|
||||
over reader>>
|
||||
swap "declared-effect" set-word-prop
|
||||
reader>> swap "reading" set-word-prop ;
|
||||
|
||||
: writer-effect ( type spec -- effect )
|
||||
name>> swap 2array 0 <effect> ;
|
||||
|
||||
PREDICATE: slot-writer < word "writing" word-prop >boolean ;
|
||||
|
||||
: set-writer-props ( class spec -- )
|
||||
2dup writer-effect
|
||||
over writer>>
|
||||
swap "declared-effect" set-word-prop
|
||||
writer>> swap "writing" set-word-prop ;
|
||||
|
||||
: reader-word ( class name vocab -- word )
|
||||
[ "-" glue ] dip create ;
|
||||
|
||||
|
|
@ -55,17 +33,13 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
|
|||
: define-struct-slot-word ( word quot spec effect -- )
|
||||
[ offset>> prefix ] dip define-inline ;
|
||||
|
||||
: define-getter ( type spec -- )
|
||||
[ set-reader-props ] keep
|
||||
[ reader>> ]
|
||||
[ type>> c-type-getter-boxer ]
|
||||
[ ] tri
|
||||
: define-getter ( spec -- )
|
||||
[ reader>> ] [ type>> c-type-getter-boxer ] [ ] tri
|
||||
(( c-ptr -- value )) define-struct-slot-word ;
|
||||
|
||||
: define-setter ( type spec -- )
|
||||
[ set-writer-props ] keep
|
||||
: define-setter ( spec -- )
|
||||
[ writer>> ] [ type>> c-setter ] [ ] tri
|
||||
(( value c-ptr -- )) define-struct-slot-word ;
|
||||
|
||||
: define-field ( type spec -- )
|
||||
[ define-getter ] [ define-setter ] 2bi ;
|
||||
: define-field ( spec -- )
|
||||
[ define-getter ] [ define-setter ] bi ;
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ os winnt? cpu x86? and [
|
|||
] when
|
||||
] when
|
||||
|
||||
: MAX_FOOS 30 ;
|
||||
CONSTANT: MAX_FOOS 30
|
||||
|
||||
C-STRUCT: foox
|
||||
{ { "int" MAX_FOOS } "x" } ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs generic hashtables kernel kernel.private
|
||||
math namespaces parser sequences strings words libc fry
|
||||
|
|
@ -56,10 +56,10 @@ M: struct-type stack-size
|
|||
: (define-struct) ( name size align fields -- )
|
||||
[ [ align ] keep ] dip
|
||||
struct-type new
|
||||
swap >>fields
|
||||
swap >>align
|
||||
swap >>size
|
||||
swap typedef ;
|
||||
swap >>fields
|
||||
swap >>align
|
||||
swap >>size
|
||||
swap typedef ;
|
||||
|
||||
: make-fields ( name vocab fields -- fields )
|
||||
[ first2 <field-spec> ] with with map ;
|
||||
|
|
@ -68,12 +68,11 @@ M: struct-type stack-size
|
|||
[ c-type-align ] [ max ] map-reduce ;
|
||||
|
||||
: define-struct ( name vocab fields -- )
|
||||
[
|
||||
[ 2drop ] [ make-fields ] 3bi
|
||||
[ struct-offsets ] keep
|
||||
[ [ type>> ] map compute-struct-align ] keep
|
||||
[ (define-struct) ] keep
|
||||
] [ 2drop '[ _ swap define-field ] ] 3bi each ;
|
||||
[ 2drop ] [ make-fields ] 3bi
|
||||
[ struct-offsets ] keep
|
||||
[ [ type>> ] map compute-struct-align ] keep
|
||||
[ (define-struct) ] keep
|
||||
[ define-field ] each ;
|
||||
|
||||
: define-union ( name members -- )
|
||||
[ expand-constants ] map
|
||||
|
|
@ -83,4 +82,3 @@ M: struct-type stack-size
|
|||
: offset-of ( field struct -- offset )
|
||||
c-types get at fields>>
|
||||
[ name>> = ] with find nip offset>> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ USING: tools.test bit-vectors vectors sequences kernel math ;
|
|||
|
||||
[ 0 ] [ 123 <bit-vector> length ] unit-test
|
||||
|
||||
: do-it
|
||||
: do-it ( seq -- )
|
||||
1234 swap [ [ even? ] dip push ] curry each ;
|
||||
|
||||
[ t ] [
|
||||
|
|
|
|||
|
|
@ -95,10 +95,10 @@ CONSTANT: -1-offset 9
|
|||
SYMBOL: sub-primitives
|
||||
|
||||
: make-jit ( quot rc rt offset -- quad )
|
||||
[ { } make ] 3dip 4array ; inline
|
||||
[ [ call( -- ) ] { } make ] 3dip 4array ;
|
||||
|
||||
: jit-define ( quot rc rt offset name -- )
|
||||
[ make-jit ] dip set ; inline
|
||||
[ make-jit ] dip set ;
|
||||
|
||||
: define-sub-primitive ( quot rc rt offset word -- )
|
||||
[ make-jit ] dip sub-primitives get set-at ;
|
||||
|
|
@ -398,9 +398,14 @@ M: byte-array '
|
|||
] emit-object ;
|
||||
|
||||
! Tuples
|
||||
ERROR: tuple-removed class ;
|
||||
|
||||
: require-tuple-layout ( word -- layout )
|
||||
dup tuple-layout [ ] [ tuple-removed ] ?if ;
|
||||
|
||||
: (emit-tuple) ( tuple -- pointer )
|
||||
[ tuple-slots ]
|
||||
[ class transfer-word tuple-layout ] bi prefix [ ' ] map
|
||||
[ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
|
||||
tuple type-number dup [ emit-seq ] emit-object ;
|
||||
|
||||
: emit-tuple ( tuple -- pointer )
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ prettyprint ;
|
|||
|
||||
[ 0 ] [ 123 <byte-vector> length ] unit-test
|
||||
|
||||
: do-it
|
||||
: do-it ( seq -- seq )
|
||||
123 [ over push ] each ;
|
||||
|
||||
[ t ] [
|
||||
|
|
|
|||
|
|
@ -148,7 +148,7 @@ IN: calendar.tests
|
|||
[ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
|
||||
[ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
|
||||
|
||||
: checktime+ now dup clone [ rot time+ drop ] keep = ;
|
||||
: checktime+ ( duration -- ? ) now dup clone [ rot time+ drop ] keep = ;
|
||||
|
||||
[ t ] [ 5 seconds checktime+ ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ CLASS: {
|
|||
[ gc "x" set 2drop ]
|
||||
} ;
|
||||
|
||||
: test-foo
|
||||
: test-foo ( -- )
|
||||
Foo -> alloc -> init
|
||||
dup 1.0 2.0 101.0 102.0 <CGRect> -> foo:
|
||||
-> release ;
|
||||
|
|
|
|||
|
|
@ -35,11 +35,14 @@ SYMBOLS: +optimized+ +unoptimized+ ;
|
|||
[ usage [ word? ] filter ] [ compiled-usage keys ] if
|
||||
[ queue-compile ] each ;
|
||||
|
||||
: ripple-up? ( word status -- ? )
|
||||
swap "compiled-status" word-prop [ = not ] keep and ;
|
||||
: ripple-up? ( status word -- ? )
|
||||
[
|
||||
[ nip changed-effects get key? ]
|
||||
[ "compiled-status" word-prop eq? not ] 2bi or
|
||||
] keep "compiled-status" word-prop and ;
|
||||
|
||||
: save-compiled-status ( word status -- )
|
||||
[ dupd ripple-up? [ ripple-up ] [ drop ] if ]
|
||||
[ over ripple-up? [ ripple-up ] [ drop ] if ]
|
||||
[ "compiled-status" set-word-prop ]
|
||||
2bi ;
|
||||
|
||||
|
|
|
|||
|
|
@ -270,7 +270,7 @@ cell 8 = [
|
|||
] when
|
||||
|
||||
! Some randomized tests
|
||||
: compiled-fixnum* fixnum* ;
|
||||
: compiled-fixnum* ( a b -- c ) fixnum* ;
|
||||
|
||||
[ ] [
|
||||
10000 [
|
||||
|
|
@ -281,7 +281,7 @@ cell 8 = [
|
|||
] times
|
||||
] unit-test
|
||||
|
||||
: compiled-fixnum>bignum fixnum>bignum ;
|
||||
: compiled-fixnum>bignum ( a -- b ) fixnum>bignum ;
|
||||
|
||||
[ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test
|
||||
|
||||
|
|
@ -293,7 +293,7 @@ cell 8 = [
|
|||
] times
|
||||
] unit-test
|
||||
|
||||
: compiled-bignum>fixnum bignum>fixnum ;
|
||||
: compiled-bignum>fixnum ( a -- b ) bignum>fixnum ;
|
||||
|
||||
[ ] [
|
||||
10000 [
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ M: array xyz xyz ;
|
|||
[ t ] [ \ xyz optimized>> ] unit-test
|
||||
|
||||
! Test predicate inlining
|
||||
: pred-test-1
|
||||
: pred-test-1 ( a -- b c )
|
||||
dup fixnum? [
|
||||
dup integer? [ "integer" ] [ "nope" ] if
|
||||
] [
|
||||
|
|
@ -24,7 +24,7 @@ M: array xyz xyz ;
|
|||
|
||||
TUPLE: pred-test ;
|
||||
|
||||
: pred-test-2
|
||||
: pred-test-2 ( a -- b c )
|
||||
dup tuple? [
|
||||
dup pred-test? [ "pred-test" ] [ "nope" ] if
|
||||
] [
|
||||
|
|
@ -33,7 +33,7 @@ TUPLE: pred-test ;
|
|||
|
||||
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
|
||||
|
||||
: pred-test-3
|
||||
: pred-test-3 ( a -- b c )
|
||||
dup pred-test? [
|
||||
dup tuple? [ "pred-test" ] [ "nope" ] if
|
||||
] [
|
||||
|
|
@ -42,14 +42,14 @@ TUPLE: pred-test ;
|
|||
|
||||
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
|
||||
|
||||
: inline-test
|
||||
: inline-test ( a -- b )
|
||||
"nom" = ;
|
||||
|
||||
[ t ] [ "nom" inline-test ] unit-test
|
||||
[ f ] [ "shayin" inline-test ] unit-test
|
||||
[ f ] [ 3 inline-test ] unit-test
|
||||
|
||||
: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
|
||||
: fixnum-declarations ( a -- b ) >fixnum 24 shift 1234 bitxor ;
|
||||
|
||||
[ ] [ 1000000 fixnum-declarations . ] unit-test
|
||||
|
||||
|
|
@ -61,13 +61,13 @@ TUPLE: pred-test ;
|
|||
|
||||
! regression
|
||||
|
||||
: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
|
||||
: bad-kill-2 bad-kill-1 drop ;
|
||||
: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline recursive
|
||||
: bad-kill-2 ( a b -- c d ) bad-kill-1 drop ;
|
||||
|
||||
[ 3 ] [ t bad-kill-2 ] unit-test
|
||||
|
||||
! regression
|
||||
: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
|
||||
: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline recursive
|
||||
: the-test ( -- x y ) 2 dup (the-test) ;
|
||||
|
||||
[ 2 0 ] [ the-test ] unit-test
|
||||
|
|
@ -77,7 +77,7 @@ TUPLE: pred-test ;
|
|||
< [
|
||||
6 1 (double-recursion)
|
||||
3 2 (double-recursion)
|
||||
] when ; inline
|
||||
] when ; inline recursive
|
||||
|
||||
: double-recursion ( -- ) 0 2 (double-recursion) ;
|
||||
|
||||
|
|
@ -85,7 +85,7 @@ TUPLE: pred-test ;
|
|||
|
||||
! regression
|
||||
: double-label-1 ( a b c -- d )
|
||||
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline
|
||||
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline recursive
|
||||
|
||||
: double-label-2 ( a -- b )
|
||||
dup array? [ ] [ ] if 0 t double-label-1 ;
|
||||
|
|
@ -100,7 +100,7 @@ GENERIC: void-generic ( obj -- * )
|
|||
|
||||
! regression
|
||||
: branch-fold-regression-0 ( m -- n )
|
||||
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
|
||||
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline recursive
|
||||
|
||||
: branch-fold-regression-1 ( -- m )
|
||||
10 branch-fold-regression-0 ;
|
||||
|
|
@ -224,7 +224,7 @@ USE: binary-search.private
|
|||
] unit-test
|
||||
|
||||
! Regression
|
||||
: empty-compound ;
|
||||
: empty-compound ( -- ) ;
|
||||
|
||||
: node-successor-f-bug ( x -- * )
|
||||
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
|
||||
|
|
@ -293,7 +293,7 @@ HINTS: recursive-inline-hang-3 array ;
|
|||
|
||||
! Wow
|
||||
: counter-example ( a b c d -- a' b' c' d' )
|
||||
dup 0 > [ 1 - [ rot 2 * ] dip counter-example ] when ; inline
|
||||
dup 0 > [ 1 - [ rot 2 * ] dip counter-example ] when ; inline recursive
|
||||
|
||||
: counter-example' ( -- a' b' c' d' )
|
||||
1 2 3.0 3 counter-example ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,20 @@
|
|||
USING: compiler.units words tools.test math kernel ;
|
||||
IN: compiler.tests.redefine15
|
||||
|
||||
DEFER: word-1
|
||||
|
||||
: word-2 ( a -- b ) word-1 ;
|
||||
|
||||
[ \ word-1 [ ] (( a -- b )) define-declared ] with-compilation-unit
|
||||
|
||||
[ "a" ] [ "a" word-2 ] unit-test
|
||||
|
||||
: word-3 ( a -- b ) 1 + ;
|
||||
|
||||
: word-4 ( a -- b c ) 0 swap word-3 swap 1+ ;
|
||||
|
||||
[ 1 1 ] [ 0 word-4 ] unit-test
|
||||
|
||||
[ \ word-3 [ [ 2 + ] bi@ ] (( a b -- c d )) define-declared ] with-compilation-unit
|
||||
|
||||
[ 2 3 ] [ 0 word-4 ] unit-test
|
||||
|
|
@ -1,12 +1,14 @@
|
|||
IN: compiler.tests
|
||||
USING: compiler compiler.units tools.test math parser kernel
|
||||
sequences sequences.private classes.mixin generic definitions
|
||||
arrays words assocs eval ;
|
||||
arrays words assocs eval words.symbol ;
|
||||
|
||||
DEFER: redefine2-test
|
||||
|
||||
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test
|
||||
|
||||
[ t ] [ \ redefine2-test symbol? ] unit-test
|
||||
|
||||
[ t ] [ redefine2-test new sequence? ] unit-test
|
||||
|
||||
[ 3 ] [ 0 redefine2-test new nth-unsafe ] unit-test
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@ M: object xyz ;
|
|||
[ swap [ call 1+ ] dip ] keep (i-repeat)
|
||||
] if ; inline recursive
|
||||
|
||||
: i-repeat [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
|
||||
: i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
|
||||
|
||||
[ t ] [
|
||||
[ [ dup xyz drop ] i-repeat ] \ xyz inlined?
|
||||
|
|
@ -197,7 +197,7 @@ M: fixnum annotate-entry-test-1 drop ;
|
|||
[ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
|
||||
] if ; inline recursive
|
||||
|
||||
: annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
|
||||
: annotate-entry-test-2 ( from to -- ) 0 -rot (annotate-entry-test-2) ; inline
|
||||
|
||||
[ f ] [
|
||||
[ { bignum } declare annotate-entry-test-2 ]
|
||||
|
|
|
|||
|
|
@ -18,6 +18,6 @@ MACRO: set-slots ( slots -- quot )
|
|||
|
||||
SYNTAX: CONSTRUCTOR:
|
||||
scan-word [ name>> "<" ">" surround create-in ] keep
|
||||
"(" expect ")" parse-effect
|
||||
complete-effect
|
||||
parse-definition
|
||||
define-constructor ;
|
||||
|
|
@ -11,8 +11,8 @@ big-endian on
|
|||
|
||||
4 jit-code-format set
|
||||
|
||||
: ds-reg 29 ;
|
||||
: rs-reg 30 ;
|
||||
CONSTANT: ds-reg 29
|
||||
CONSTANT: rs-reg 30
|
||||
|
||||
: factor-area-size ( -- n ) 4 bootstrap-cells ;
|
||||
|
||||
|
|
|
|||
|
|
@ -285,7 +285,7 @@ paste "PASTE"
|
|||
[ test-cascade ] test-postgresql
|
||||
[ test-restrict ] test-postgresql
|
||||
|
||||
: test-repeated-insert
|
||||
: test-repeated-insert ( -- )
|
||||
[ ] [ person ensure-table ] unit-test
|
||||
[ ] [ person1 get insert-tuple ] unit-test
|
||||
[ person1 get insert-tuple ] must-fail ;
|
||||
|
|
@ -458,7 +458,7 @@ TUPLE: bignum-test id m n o ;
|
|||
swap >>n
|
||||
swap >>m ;
|
||||
|
||||
: test-bignum
|
||||
: test-bignum ( -- )
|
||||
bignum-test "BIGNUM_TEST"
|
||||
{
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
|
|
@ -478,7 +478,7 @@ TUPLE: bignum-test id m n o ;
|
|||
TUPLE: secret n message ;
|
||||
C: <secret> secret
|
||||
|
||||
: test-random-id
|
||||
: test-random-id ( -- )
|
||||
secret "SECRET"
|
||||
{
|
||||
{ "n" "ID" +random-id+ system-random-generator }
|
||||
|
|
|
|||
|
|
@ -41,13 +41,13 @@ M: hello bing hello-test ;
|
|||
|
||||
[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" ] [ [ baz see ] with-string-writer ] unit-test
|
||||
|
||||
GENERIC: one
|
||||
GENERIC: one ( a -- b )
|
||||
M: integer one ;
|
||||
GENERIC: two
|
||||
GENERIC: two ( a -- b )
|
||||
M: integer two ;
|
||||
GENERIC: three
|
||||
GENERIC: three ( a -- b )
|
||||
M: integer three ;
|
||||
GENERIC: four
|
||||
GENERIC: four ( a -- b )
|
||||
M: integer four ;
|
||||
|
||||
PROTOCOL: alpha one two ;
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ HELP: (set-os-envs)
|
|||
{ $notes "In most cases, use " { $link set-os-envs } " instead." } ;
|
||||
|
||||
|
||||
HELP: os-env ( key -- value )
|
||||
HELP: os-env
|
||||
{ $values { "key" string } { "value" string } }
|
||||
{ $description "Looks up the value of a shell environment variable." }
|
||||
{ $examples
|
||||
|
|
@ -39,14 +39,14 @@ HELP: set-os-envs
|
|||
"Names and values of environment variables are operating system-specific. Windows NT allows values up to 32766 characters in length."
|
||||
} ;
|
||||
|
||||
HELP: set-os-env ( value key -- )
|
||||
HELP: set-os-env
|
||||
{ $values { "value" string } { "key" string } }
|
||||
{ $description "Set an environment variable." }
|
||||
{ $notes
|
||||
"Names and values of environment variables are operating system-specific."
|
||||
} ;
|
||||
|
||||
HELP: unset-os-env ( key -- )
|
||||
HELP: unset-os-env
|
||||
{ $values { "key" string } }
|
||||
{ $description "Unset an environment variable." }
|
||||
{ $notes
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ HELP: write-farkup
|
|||
{ $values { "string" string } }
|
||||
{ $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ;
|
||||
|
||||
HELP: parse-farkup ( string -- farkup )
|
||||
HELP: parse-farkup
|
||||
{ $values { "string" string } { "farkup" "a Farkup syntax tree node" } }
|
||||
{ $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ sequences eval accessors ;
|
|||
{ "a" "b" "c" } swap map
|
||||
] unit-test
|
||||
|
||||
: funny-dip '[ [ @ ] dip ] call ; inline
|
||||
: funny-dip ( obj quot -- ) '[ [ @ ] dip ] call ; inline
|
||||
|
||||
[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ WHERE
|
|||
|
||||
TUPLE: B { value T } ;
|
||||
|
||||
C: <B> B
|
||||
C: <B> B ( T -- B )
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
|
|
|
|||
|
|
@ -14,9 +14,9 @@ IN: functors
|
|||
|
||||
: scan-param ( -- obj ) scan-object literalize ;
|
||||
|
||||
: define* ( word def effect -- ) pick set-word define-declared ;
|
||||
: define* ( word def -- ) over set-word define ;
|
||||
|
||||
: define-syntax* ( word def -- ) over set-word define-syntax ;
|
||||
: define-declared* ( word def effect -- ) pick set-word define-declared ;
|
||||
|
||||
TUPLE: fake-quotation seq ;
|
||||
|
||||
|
|
@ -41,7 +41,12 @@ M: object fake-quotations> ;
|
|||
: parse-definition* ( accum -- accum )
|
||||
parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
|
||||
|
||||
: DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ;
|
||||
: parse-declared* ( accum -- accum )
|
||||
complete-effect
|
||||
[ parse-definition* ] dip
|
||||
parsed ;
|
||||
|
||||
: DEFINE* ( accum -- accum ) \ define-declared* parsed ;
|
||||
|
||||
SYNTAX: `TUPLE:
|
||||
scan-param parsed
|
||||
|
|
@ -57,31 +62,28 @@ SYNTAX: `TUPLE:
|
|||
\ define-tuple-class parsed ;
|
||||
|
||||
SYNTAX: `M:
|
||||
effect off
|
||||
scan-param parsed
|
||||
scan-param parsed
|
||||
\ create-method-in parsed
|
||||
parse-definition*
|
||||
DEFINE* ;
|
||||
\ define* parsed ;
|
||||
|
||||
SYNTAX: `C:
|
||||
effect off
|
||||
scan-param parsed
|
||||
scan-param parsed
|
||||
[ [ boa ] curry ] over push-all
|
||||
DEFINE* ;
|
||||
complete-effect
|
||||
[ [ [ boa ] curry ] over push-all ] dip parsed
|
||||
\ define-declared* parsed ;
|
||||
|
||||
SYNTAX: `:
|
||||
effect off
|
||||
scan-param parsed
|
||||
parse-definition*
|
||||
DEFINE* ;
|
||||
parse-declared*
|
||||
\ define-declared* parsed ;
|
||||
|
||||
SYNTAX: `SYNTAX:
|
||||
effect off
|
||||
scan-param parsed
|
||||
parse-definition*
|
||||
\ define-syntax* parsed ;
|
||||
\ define-syntax parsed ;
|
||||
|
||||
SYNTAX: `INSTANCE:
|
||||
scan-param parsed
|
||||
|
|
@ -90,9 +92,6 @@ SYNTAX: `INSTANCE:
|
|||
|
||||
SYNTAX: `inline [ word make-inline ] over push-all ;
|
||||
|
||||
SYNTAX: `(
|
||||
")" parse-effect effect set ;
|
||||
|
||||
: (INTERPOLATE) ( accum quot -- accum )
|
||||
[ scan interpolate-locals ] dip
|
||||
'[ _ with-string-writer @ ] parsed ;
|
||||
|
|
@ -118,7 +117,6 @@ DEFER: ;FUNCTOR delimiter
|
|||
{ "INSTANCE:" POSTPONE: `INSTANCE: }
|
||||
{ "SYNTAX:" POSTPONE: `SYNTAX: }
|
||||
{ "inline" POSTPONE: `inline }
|
||||
{ "(" POSTPONE: `( }
|
||||
} ;
|
||||
|
||||
: push-functor-words ( -- )
|
||||
|
|
@ -133,9 +131,9 @@ DEFER: ;FUNCTOR delimiter
|
|||
[ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) <let*> 1quotation
|
||||
pop-functor-words ;
|
||||
|
||||
: (FUNCTOR:) ( -- word def )
|
||||
: (FUNCTOR:) ( -- word def effect )
|
||||
CREATE-WORD [ parse-functor-body ] parse-locals-definition ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SYNTAX: FUNCTOR: (FUNCTOR:) define ;
|
||||
SYNTAX: FUNCTOR: (FUNCTOR:) define-declared ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: furnace.actions.tests
|
|||
[ "a" param "b" param [ string>number ] bi@ + ] >>display
|
||||
"action-1" set
|
||||
|
||||
: lf>crlf "\n" split "\r\n" join ;
|
||||
: lf>crlf ( string -- string' ) "\n" split "\r\n" join ;
|
||||
|
||||
STRING: action-request-test-1
|
||||
GET http://foo/bar?a=12&b=13 HTTP/1.1
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ http.server furnace furnace.utilities tools.test kernel
|
|||
namespaces accessors io.streams.string urls xml.writer ;
|
||||
TUPLE: funny-dispatcher < dispatcher ;
|
||||
|
||||
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
|
||||
: <funny-dispatcher> ( -- dispatcher ) funny-dispatcher new-dispatcher ;
|
||||
|
||||
TUPLE: base-path-check-responder ;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ io.streams.string io.files io.files.temp io.directories
|
|||
splitting destructors sequences db db.tuples db.sqlite
|
||||
continuations urls math.parser furnace furnace.utilities ;
|
||||
|
||||
: with-session
|
||||
: with-session ( session quot -- )
|
||||
[
|
||||
[ [ save-session-after ] [ session set ] bi ] dip call
|
||||
] with-destructors ; inline
|
||||
|
|
@ -22,7 +22,7 @@ M: foo call-responder*
|
|||
"x" [ 1+ ] schange
|
||||
"x" sget number>string "text/html" <content> ;
|
||||
|
||||
: url-responder-mock-test
|
||||
: url-responder-mock-test ( -- )
|
||||
[
|
||||
<request>
|
||||
"GET" >>method
|
||||
|
|
@ -34,7 +34,7 @@ M: foo call-responder*
|
|||
[ write-response-body drop ] with-string-writer
|
||||
] with-destructors ;
|
||||
|
||||
: sessions-mock-test
|
||||
: sessions-mock-test ( -- )
|
||||
[
|
||||
<request>
|
||||
"GET" >>method
|
||||
|
|
@ -45,7 +45,7 @@ M: foo call-responder*
|
|||
[ write-response-body drop ] with-string-writer
|
||||
] with-destructors ;
|
||||
|
||||
: <exiting-action>
|
||||
: <exiting-action> ( -- action )
|
||||
<action>
|
||||
[ [ ] "text/plain" <content> exit-with ] >>display ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: hash2.tests
|
|||
[ t ] [ 1 2 { 1 2 } 2= ] unit-test
|
||||
[ f ] [ 1 3 { 1 2 } 2= ] unit-test
|
||||
|
||||
: sample-hash
|
||||
: sample-hash ( -- )
|
||||
5 <hash2>
|
||||
dup 2 3 "foo" roll set-hash2
|
||||
dup 4 2 "bar" roll set-hash2
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ definitions assocs sequences kernel namespaces parser arrays
|
|||
io.streams.string continuations debugger compiler.units eval ;
|
||||
|
||||
[ ] [
|
||||
"IN: help.crossref.tests USING: help.syntax help.markup ; : foo ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval
|
||||
"IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval
|
||||
] unit-test
|
||||
|
||||
[ $subsection ] [
|
||||
|
|
@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ;
|
|||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: help.crossref.tests USING: help.syntax help.markup ; : bar ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval
|
||||
"IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: help.definitions.tests
|
|||
|
||||
[
|
||||
[ 4 ] [
|
||||
"IN: help.definitions.tests USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" <string-reader> "foo"
|
||||
"IN: help.definitions.tests USING: help.syntax ; : hello ( -- ) ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" <string-reader> "foo"
|
||||
parse-stream drop
|
||||
|
||||
"foo" source-file definitions>> first assoc-size
|
||||
|
|
@ -20,7 +20,7 @@ IN: help.definitions.tests
|
|||
] unit-test
|
||||
|
||||
[ 2 ] [
|
||||
"IN: help.definitions.tests USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" <string-reader> "foo"
|
||||
"IN: help.definitions.tests USING: help.syntax ; : hello ( -- ) ; ARTICLE: \"hello\" \"world\" ;" <string-reader> "foo"
|
||||
parse-stream drop
|
||||
|
||||
"foo" source-file definitions>> first assoc-size
|
||||
|
|
@ -32,7 +32,7 @@ IN: help.definitions.tests
|
|||
"hello" "help.definitions.tests" lookup "help" word-prop
|
||||
] unit-test
|
||||
|
||||
[ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test
|
||||
[ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval ] unit-test
|
||||
|
||||
[ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ TUPLE: blahblah quux ;
|
|||
[ ] [ \ >>quux print-topic ] unit-test
|
||||
[ ] [ \ blahblah? print-topic ] unit-test
|
||||
|
||||
: fooey "fooey" throw ;
|
||||
: fooey ( -- * ) "fooey" throw ;
|
||||
|
||||
[ ] [ \ fooey print-topic ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: accessors arrays definitions generic io kernel assocs
|
|||
hashtables namespaces make parser prettyprint sequences strings
|
||||
io.styles vectors words math sorting splitting classes slots fry
|
||||
sets vocabs help.stylesheet help.topics vocabs.loader quotations
|
||||
combinators see ;
|
||||
combinators see present ;
|
||||
IN: help.markup
|
||||
|
||||
PREDICATE: simple-element < array
|
||||
|
|
@ -276,7 +276,7 @@ M: f ($instance)
|
|||
$snippet ;
|
||||
|
||||
: values-row ( seq -- seq )
|
||||
unclip \ $snippet swap ?word-name 2array
|
||||
unclip \ $snippet swap present 2array
|
||||
swap dup first word? [ \ $instance prefix ] when 2array ;
|
||||
|
||||
: $values ( element -- )
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel parser sequences words help
|
||||
help.topics namespaces vocabs definitions compiler.units
|
||||
|
|
@ -7,17 +7,13 @@ IN: help.syntax
|
|||
|
||||
SYNTAX: HELP:
|
||||
scan-word bootstrap-word
|
||||
dup set-word
|
||||
dup >link save-location
|
||||
\ ; parse-until >array swap set-word-help ;
|
||||
[ >link save-location ] [ [ \ ; parse-until >array ] dip set-word-help ] bi ;
|
||||
|
||||
SYNTAX: ARTICLE:
|
||||
location [
|
||||
\ ; parse-until >array [ first2 ] keep 2 tail <article>
|
||||
\ ; parse-until >array [ first2 ] [ 2 tail ] bi <article>
|
||||
over add-article >link
|
||||
] dip remember-definition ;
|
||||
|
||||
SYNTAX: ABOUT:
|
||||
in get vocab
|
||||
dup changed-definition
|
||||
scan-object >>help drop ;
|
||||
in get vocab scan-object >>help changed-definition ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ splitting unicode.categories furnace accessors
|
|||
html.templates.chloe.compiler ;
|
||||
IN: html.templates.chloe.tests
|
||||
|
||||
: run-template
|
||||
: run-template ( quot -- string )
|
||||
with-string-writer [ "\r\n\t" member? not ] filter
|
||||
"?>" split1 nip ; inline
|
||||
|
||||
|
|
@ -37,7 +37,7 @@ IN: html.templates.chloe.tests
|
|||
] run-template
|
||||
] unit-test
|
||||
|
||||
: test4-aux? t ;
|
||||
: test4-aux? ( -- ? ) t ;
|
||||
|
||||
[ "True" ] [
|
||||
[
|
||||
|
|
@ -45,7 +45,7 @@ IN: html.templates.chloe.tests
|
|||
] run-template
|
||||
] unit-test
|
||||
|
||||
: test5-aux? f ;
|
||||
: test5-aux? ( -- ? ) f ;
|
||||
|
||||
[ "" ] [
|
||||
[
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ IN: http.tests
|
|||
|
||||
[ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test
|
||||
|
||||
: lf>crlf "\n" split "\r\n" join ;
|
||||
: lf>crlf ( string -- string' ) "\n" split "\r\n" join ;
|
||||
|
||||
STRING: read-request-test-1
|
||||
POST /bar HTTP/1.1
|
||||
|
|
@ -180,14 +180,14 @@ accessors namespaces threads
|
|||
http.server.responses http.server.redirection furnace.redirection
|
||||
http.server.dispatchers db.tuples ;
|
||||
|
||||
: add-quit-action
|
||||
: add-quit-action ( responder -- responder )
|
||||
<action>
|
||||
[ stop-this-server "Goodbye" "text/html" <content> ] >>display
|
||||
"quit" add-responder ;
|
||||
|
||||
: test-db-file "test.db" temp-file ;
|
||||
: test-db-file ( -- path ) "test.db" temp-file ;
|
||||
|
||||
: test-db test-db-file <sqlite-db> ;
|
||||
: test-db ( -- db ) test-db-file <sqlite-db> ;
|
||||
|
||||
[ test-db-file delete-file ] ignore-errors
|
||||
|
||||
|
|
@ -268,7 +268,7 @@ test-db [
|
|||
test-httpd
|
||||
] unit-test
|
||||
|
||||
: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
|
||||
: 404? ( response -- ? ) [ download-failed? ] [ response>> code>> 404 = ] bi and ;
|
||||
|
||||
! This should give a 404 not an infinite redirect loop
|
||||
[ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ io.streams.duplex destructors make io.launcher ;
|
|||
IN: io.backend.unix.tests
|
||||
|
||||
! Unix domain stream sockets
|
||||
: socket-server "unix-domain-socket-test" temp-file ;
|
||||
: socket-server ( -- path ) "unix-domain-socket-test" temp-file ;
|
||||
|
||||
[
|
||||
[ socket-server delete-file ] ignore-errors
|
||||
|
|
@ -33,8 +33,8 @@ yield
|
|||
] { } make
|
||||
] unit-test
|
||||
|
||||
: datagram-server "unix-domain-datagram-test" temp-file ;
|
||||
: datagram-client "unix-domain-datagram-test-2" temp-file ;
|
||||
: datagram-server ( -- path ) "unix-domain-datagram-test" temp-file ;
|
||||
: datagram-client ( -- path ) "unix-domain-datagram-test-2" temp-file ;
|
||||
|
||||
! Unix domain datagram sockets
|
||||
[ datagram-server delete-file ] ignore-errors
|
||||
|
|
@ -104,7 +104,7 @@ datagram-client <local> <datagram>
|
|||
[ ] [ "d" get dispose ] unit-test
|
||||
|
||||
! Test error behavior
|
||||
: another-datagram "unix-domain-datagram-test-3" temp-file ;
|
||||
: another-datagram ( -- path ) "unix-domain-datagram-test-3" temp-file ;
|
||||
|
||||
[ another-datagram delete-file ] ignore-errors
|
||||
|
||||
|
|
|
|||
|
|
@ -3,6 +3,6 @@
|
|||
USING: help.syntax help.markup ;
|
||||
IN: io.encodings.strict
|
||||
|
||||
HELP: strict ( encoding -- strict-encoding )
|
||||
{ $values { "encoding" "an encoding descriptor" } { "strict-encoding" "a strict encoding descriptor" } }
|
||||
HELP: strict ( code -- strict )
|
||||
{ $values { "code" "an encoding descriptor" } { "strict" "a strict encoding descriptor" } }
|
||||
{ $description "Makes an encoding strict, that is, in the presence of a malformed code point, an error is thrown. Note that the existence of a replacement character in a file (U+FFFD) also throws an error." } ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: accessors alien.c-types kernel
|
|||
io.encodings.utf16 io.streams.byte-array tools.test ;
|
||||
IN: io.encodings.utf16n
|
||||
|
||||
: correct-endian
|
||||
: correct-endian ( obj -- ? )
|
||||
code>> little-endian? [ utf16le = ] [ utf16be = ] if ;
|
||||
|
||||
[ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ HELP: unique-retries
|
|||
|
||||
{ unique-length unique-retries } related-words
|
||||
|
||||
HELP: make-unique-file ( prefix suffix -- path )
|
||||
HELP: make-unique-file
|
||||
{ $values { "prefix" "a string" } { "suffix" "a string" }
|
||||
{ "path" "a pathname string" } }
|
||||
{ $description "Creates a file that is guaranteed not to exist in the directory stored in " { $link current-temporary-directory } ". The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." }
|
||||
|
|
@ -31,18 +31,18 @@ HELP: make-unique-file ( prefix suffix -- path )
|
|||
|
||||
{ unique-file make-unique-file cleanup-unique-file } related-words
|
||||
|
||||
HELP: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- )
|
||||
HELP: cleanup-unique-file
|
||||
{ $values { "prefix" "a string" } { "suffix" "a string" }
|
||||
{ "quot" "a quotation" } }
|
||||
{ $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." }
|
||||
{ $notes "The unique file will be deleted after calling this word." } ;
|
||||
|
||||
HELP: unique-directory ( -- path )
|
||||
HELP: unique-directory
|
||||
{ $values { "path" "a pathname string" } }
|
||||
{ $description "Creates a directory in the value in " { $link current-temporary-directory } " that is guaranteed not to exist in and returns the full pathname." }
|
||||
{ $errors "Throws an error if the directory cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ;
|
||||
|
||||
HELP: cleanup-unique-directory ( quot -- )
|
||||
HELP: cleanup-unique-directory
|
||||
{ $values { "quot" "a quotation" } }
|
||||
{ $description "Creates a directory with " { $link unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-temporary-directory } " combinator. The quotation can access the " { $link current-temporary-directory } " symbol for the name of the temporary directory. Subsequent unique files will be created in this unique directory until the combinator returns." }
|
||||
{ $notes "The directory will be deleted after calling this word, even if an error is thrown in the quotation. This combinator is like " { $link with-unique-directory } " but does not delete the directory." } ;
|
||||
|
|
|
|||
|
|
@ -5,13 +5,13 @@ IN: io.streams.duplex.tests
|
|||
! Test duplex stream close behavior
|
||||
TUPLE: closing-stream < disposable ;
|
||||
|
||||
: <closing-stream> closing-stream new ;
|
||||
: <closing-stream> ( -- stream ) closing-stream new ;
|
||||
|
||||
M: closing-stream dispose* drop ;
|
||||
|
||||
TUPLE: unclosable-stream ;
|
||||
|
||||
: <unclosable-stream> unclosable-stream new ;
|
||||
: <unclosable-stream> ( -- stream ) unclosable-stream new ;
|
||||
|
||||
M: unclosable-stream dispose
|
||||
"Can't close me!" throw ;
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ SYNTAX: hello "Hi" print ;
|
|||
|
||||
[
|
||||
[ ] [
|
||||
"IN: listener.tests : hello\n\"world\" ;" parse-interactive
|
||||
"IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive
|
||||
drop
|
||||
] unit-test
|
||||
] with-file-vocabs
|
||||
|
|
|
|||
|
|
@ -83,10 +83,6 @@ HELP: nil?
|
|||
|
||||
{ nil nil? } related-words
|
||||
|
||||
HELP: list? ( object -- ? )
|
||||
{ $values { "object" "an object" } { "?" "a boolean" } }
|
||||
{ $description "Returns true if the object conforms to the list protocol." } ;
|
||||
|
||||
{ 1list 2list 3list } related-words
|
||||
|
||||
HELP: 1list
|
||||
|
|
|
|||
|
|
@ -192,14 +192,14 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
|
|||
DEFER: xyzzy
|
||||
|
||||
[ ] [
|
||||
"IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;"
|
||||
"IN: locals.tests USE: math GENERIC: xyzzy ( a -- b ) M: integer xyzzy ;"
|
||||
<string-reader> "lambda-generic-test" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ 10 ] [ 10 xyzzy ] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;"
|
||||
"IN: locals.tests USE: math USE: locals GENERIC: xyzzy ( a -- b ) M:: integer xyzzy ( n -- x ) 5 ;"
|
||||
<string-reader> "lambda-generic-test" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
|
|
@ -245,7 +245,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
|
|||
|
||||
[ 5 ] [ 1 next-method-test ] unit-test
|
||||
|
||||
: no-with-locals-test { 1 2 3 } [| x | x 3 + ] map ;
|
||||
: no-with-locals-test ( -- seq ) { 1 2 3 } [| x | x 3 + ] map ;
|
||||
|
||||
[ { 4 5 6 } ] [ no-with-locals-test ] unit-test
|
||||
|
||||
|
|
@ -259,7 +259,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
|
|||
|
||||
:: a-word-with-locals ( a b -- ) ;
|
||||
|
||||
: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" ;
|
||||
CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n"
|
||||
|
||||
[ ] [ new-definition eval ] unit-test
|
||||
|
||||
|
|
@ -268,7 +268,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
|
|||
new-definition =
|
||||
] unit-test
|
||||
|
||||
: method-definition "USING: locals locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n" ;
|
||||
CONSTANT: method-definition "USING: locals locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n"
|
||||
|
||||
GENERIC: method-with-locals ( x -- y )
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lexer macros memoize parser sequences vocabs
|
||||
vocabs.loader words kernel namespaces locals.parser locals.types
|
||||
|
|
@ -17,7 +17,7 @@ SYNTAX: [let* parse-let* over push-all ;
|
|||
|
||||
SYNTAX: [wlet parse-wlet over push-all ;
|
||||
|
||||
SYNTAX: :: (::) define ;
|
||||
SYNTAX: :: (::) define-declared ;
|
||||
|
||||
SYNTAX: M:: (M::) define ;
|
||||
|
||||
|
|
|
|||
|
|
@ -103,18 +103,19 @@ M: lambda-parser parse-quotation ( -- quotation )
|
|||
"|" expect "|" parse-wbindings
|
||||
(parse-lambda) <wlet> ?rewrite-closures ;
|
||||
|
||||
: parse-locals ( -- vars assoc )
|
||||
"(" expect ")" parse-effect
|
||||
word [ over "declared-effect" set-word-prop ] when*
|
||||
: parse-locals ( -- effect vars assoc )
|
||||
complete-effect
|
||||
dup
|
||||
in>> [ dup pair? [ first ] when ] map make-locals ;
|
||||
|
||||
: parse-locals-definition ( word reader -- word quot )
|
||||
: parse-locals-definition ( word reader -- word quot effect )
|
||||
[ parse-locals ] dip
|
||||
((parse-lambda)) <lambda>
|
||||
[ "lambda" set-word-prop ]
|
||||
[ rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ] 2bi ; inline
|
||||
[ nip "lambda" set-word-prop ]
|
||||
[ nip rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ]
|
||||
[ drop nip ] 3tri ; inline
|
||||
|
||||
: (::) ( -- word def )
|
||||
: (::) ( -- word def effect )
|
||||
CREATE-WORD
|
||||
[ parse-definition ]
|
||||
parse-locals-definition ;
|
||||
|
|
@ -123,5 +124,5 @@ M: lambda-parser parse-quotation ( -- quotation )
|
|||
CREATE-METHOD
|
||||
[
|
||||
[ parse-definition ]
|
||||
parse-locals-definition
|
||||
parse-locals-definition drop
|
||||
] with-method-definition ;
|
||||
|
|
@ -2,16 +2,22 @@ IN: macros.tests
|
|||
USING: tools.test macros math kernel arrays
|
||||
vectors io.streams.string prettyprint parser eval see ;
|
||||
|
||||
MACRO: see-test ( a b -- c ) + ;
|
||||
MACRO: see-test ( a b -- quot ) + ;
|
||||
|
||||
[ "USING: macros math ;\nIN: macros.tests\nMACRO: see-test ( a b -- c ) + ;\n" ]
|
||||
[ t ] [ \ see-test macro? ] unit-test
|
||||
|
||||
[ "USING: macros math ;\nIN: macros.tests\nMACRO: see-test ( a b -- quot ) + ;\n" ]
|
||||
[ [ \ see-test see ] with-string-writer ]
|
||||
unit-test
|
||||
|
||||
[ t ] [ \ see-test macro? ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval
|
||||
[ \ see-test see ] with-string-writer =
|
||||
] unit-test
|
||||
|
||||
[ f ] [ \ see-test macro? ] unit-test
|
||||
|
||||
[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -6,15 +6,16 @@ IN: macros
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: real-macro-effect ( word -- effect' )
|
||||
stack-effect in>> 1 <effect> ;
|
||||
: real-macro-effect ( effect -- effect' )
|
||||
in>> { "quot" } <effect> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: define-macro ( word definition -- )
|
||||
[ "macro" set-word-prop ]
|
||||
[ over real-macro-effect memoize-quot [ call ] append define ]
|
||||
2bi ;
|
||||
: define-macro ( word definition effect -- )
|
||||
real-macro-effect
|
||||
[ [ memoize-quot [ call ] append ] keep define-declared ]
|
||||
[ drop "macro" set-word-prop ]
|
||||
3bi ;
|
||||
|
||||
SYNTAX: MACRO: (:) define-macro ;
|
||||
|
||||
|
|
|
|||
|
|
@ -34,11 +34,10 @@ M: too-many-arguments summary
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: define-memoized ( word quot -- )
|
||||
[ H{ } clone ] dip
|
||||
[ pick stack-effect make-memoizer define ]
|
||||
[ nip "memo-quot" set-word-prop ]
|
||||
[ drop "memoize" set-word-prop ]
|
||||
: define-memoized ( word quot effect -- )
|
||||
[ drop "memo-quot" set-word-prop ]
|
||||
[ 2drop H{ } clone "memoize" set-word-prop ]
|
||||
[ [ [ dup "memoize" word-prop ] 2dip make-memoizer ] keep define-declared ]
|
||||
3tri ;
|
||||
|
||||
SYNTAX: MEMO: (:) define-memoized ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: models.tests
|
|||
|
||||
TUPLE: model-tester hit? ;
|
||||
|
||||
: <model-tester> model-tester new ;
|
||||
: <model-tester> ( -- model-tester ) model-tester new ;
|
||||
|
||||
M: model-tester model-changed nip t >>hit? drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ USING: arrays generic kernel math models namespaces sequences assocs
|
|||
tools.test models.range ;
|
||||
|
||||
! Test <range>
|
||||
: setup-range 0 0 0 255 <range> ;
|
||||
: setup-range ( -- range ) 0 0 0 255 <range> ;
|
||||
|
||||
! clamp-value should not go past range ends
|
||||
[ 0 ] [ -10 setup-range clamp-value ] unit-test
|
||||
|
|
|
|||
|
|
@ -618,7 +618,7 @@ ERROR: parse-failed input word ;
|
|||
|
||||
SYNTAX: PEG:
|
||||
(:)
|
||||
[let | def [ ] word [ ] |
|
||||
[let | effect [ ] def [ ] word [ ] |
|
||||
[
|
||||
[
|
||||
[let | compiled-def [ def call compile ] |
|
||||
|
|
@ -626,7 +626,7 @@ SYNTAX: PEG:
|
|||
dup compiled-def compiled-parse
|
||||
[ ast>> ] [ word parse-failed ] ?if
|
||||
]
|
||||
word swap define
|
||||
word swap effect define-declared
|
||||
]
|
||||
] with-compilation-unit
|
||||
] over push-all
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
USING: persistent.heaps tools.test ;
|
||||
IN: persistent.heaps.tests
|
||||
|
||||
: test-input
|
||||
CONSTANT: test-input
|
||||
{ { "hello" 3 } { "goodbye" 2 } { "whatever" 5 }
|
||||
{ "foo" 1 } { "bar" -1 } { "baz" -7 } { "bing" 0 } } ;
|
||||
{ "foo" 1 } { "bar" -1 } { "baz" -7 } { "bing" 0 } }
|
||||
|
||||
[
|
||||
{ { "baz" -7 } { "bar" -1 } { "bing" 0 } { "foo" 1 }
|
||||
|
|
|
|||
|
|
@ -63,7 +63,7 @@ unit-test
|
|||
[ "USING: math ;\nIN: prettyprint.tests\n: bar ( x -- y ) 2 + ;\n" ]
|
||||
[ [ \ bar see ] with-string-writer ] unit-test
|
||||
|
||||
: blah
|
||||
: blah ( a a a a a a a a a a a a a a a a a a a a -- )
|
||||
drop
|
||||
drop
|
||||
drop
|
||||
|
|
@ -102,7 +102,7 @@ unit-test
|
|||
] keep =
|
||||
] with-scope ;
|
||||
|
||||
GENERIC: method-layout
|
||||
GENERIC: method-layout ( a -- b )
|
||||
|
||||
M: complex method-layout
|
||||
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
|
||||
|
|
@ -135,7 +135,7 @@ M: object method-layout ;
|
|||
[ \ method-layout see-methods ] with-string-writer "\n" split
|
||||
] unit-test
|
||||
|
||||
: soft-break-test
|
||||
: soft-break-test ( -- str )
|
||||
{
|
||||
"USING: kernel math sequences strings ;"
|
||||
"IN: prettyprint.tests"
|
||||
|
|
@ -152,7 +152,7 @@ M: object method-layout ;
|
|||
|
||||
DEFER: parse-error-file
|
||||
|
||||
: another-soft-break-test
|
||||
: another-soft-break-test ( -- str )
|
||||
{
|
||||
"USING: make sequences ;"
|
||||
"IN: prettyprint.tests"
|
||||
|
|
@ -166,7 +166,7 @@ DEFER: parse-error-file
|
|||
check-see
|
||||
] unit-test
|
||||
|
||||
: string-layout
|
||||
: string-layout ( -- str )
|
||||
{
|
||||
"USING: accessors debugger io kernel ;"
|
||||
"IN: prettyprint.tests"
|
||||
|
|
@ -187,7 +187,7 @@ DEFER: parse-error-file
|
|||
|
||||
\ send soft "break-after" set-word-prop
|
||||
|
||||
: final-soft-break-test
|
||||
: final-soft-break-test ( -- str )
|
||||
{
|
||||
"USING: kernel sequences ;"
|
||||
"IN: prettyprint.tests"
|
||||
|
|
@ -202,7 +202,7 @@ DEFER: parse-error-file
|
|||
"final-soft-break-layout" final-soft-break-test check-see
|
||||
] unit-test
|
||||
|
||||
: narrow-test
|
||||
: narrow-test ( -- str )
|
||||
{
|
||||
"USING: arrays combinators continuations kernel sequences ;"
|
||||
"IN: prettyprint.tests"
|
||||
|
|
@ -218,7 +218,7 @@ DEFER: parse-error-file
|
|||
"narrow-layout" narrow-test check-see
|
||||
] unit-test
|
||||
|
||||
: another-narrow-test
|
||||
: another-narrow-test ( -- str )
|
||||
{
|
||||
"IN: prettyprint.tests"
|
||||
": another-narrow-layout ( -- obj )"
|
||||
|
|
@ -326,7 +326,7 @@ INTERSECTION: intersection-see-test sequence number ;
|
|||
|
||||
TUPLE: started-out-hustlin' ;
|
||||
|
||||
GENERIC: ended-up-ballin'
|
||||
GENERIC: ended-up-ballin' ( a -- b )
|
||||
|
||||
M: started-out-hustlin' ended-up-ballin' ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ sequences math prettyprint parser classes math.constants
|
|||
io.encodings.binary random assocs serialize.private ;
|
||||
IN: serialize.tests
|
||||
|
||||
: test-serialize-cell
|
||||
: test-serialize-cell ( a -- ? )
|
||||
2^ random dup
|
||||
binary [ serialize-cell ] with-byte-writer
|
||||
binary [ deserialize-cell ] with-byte-reader = ;
|
||||
|
|
@ -27,7 +27,7 @@ TUPLE: serialize-test a b ;
|
|||
|
||||
C: <serialize-test> serialize-test
|
||||
|
||||
: objects
|
||||
CONSTANT: objects
|
||||
{
|
||||
f
|
||||
t
|
||||
|
|
@ -52,7 +52,7 @@ C: <serialize-test> serialize-test
|
|||
<< 1 [ 2 ] curry parsed >>
|
||||
{ { "a" "bc" } { "de" "fg" } }
|
||||
H{ { "a" "bc" } { "de" "fg" } }
|
||||
} ;
|
||||
}
|
||||
|
||||
: check-serialize-1 ( obj -- ? )
|
||||
"=====" print
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: tools.test tools.annotations tools.time math parser eval
|
|||
io.streams.string kernel strings ;
|
||||
IN: tools.annotations.tests
|
||||
|
||||
: foo ;
|
||||
: foo ( -- ) ;
|
||||
\ foo watch
|
||||
|
||||
[ ] [ foo ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ tools.crossref tools.test parser namespaces source-files generic
|
|||
definitions ;
|
||||
IN: tools.crossref.tests
|
||||
|
||||
GENERIC: foo
|
||||
GENERIC: foo ( a b -- c )
|
||||
|
||||
M: integer foo + ;
|
||||
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ M: word disassemble word-xt 2array disassemble ;
|
|||
|
||||
M: method-spec disassemble first2 method disassemble ;
|
||||
|
||||
cpu x86? os unix? and
|
||||
cpu x86?
|
||||
"tools.disassembler.udis"
|
||||
"tools.disassembler.gdb" ?
|
||||
require
|
||||
|
|
|
|||
|
|
@ -30,9 +30,9 @@ CONSTANT: UD_VENDOR_AMD 0
|
|||
CONSTANT: UD_VENDOR_INTEL 1
|
||||
|
||||
FUNCTION: void ud_init ( ud* u ) ;
|
||||
FUNCTION: void ud_set_mode ( ud* u, uint8_t mode ) ;
|
||||
FUNCTION: void ud_set_mode ( ud* u, uchar mode ) ;
|
||||
FUNCTION: void ud_set_pc ( ud* u, ulonglong pc ) ;
|
||||
FUNCTION: void ud_set_input_buffer ( ud* u, uint8_t* offset, size_t size ) ;
|
||||
FUNCTION: void ud_set_input_buffer ( ud* u, uchar* offset, size_t size ) ;
|
||||
FUNCTION: void ud_set_vendor ( ud* u, uint vendor ) ;
|
||||
FUNCTION: void ud_set_syntax ( ud* u, void* syntax ) ;
|
||||
FUNCTION: void ud_input_skip ( ud* u, size_t size ) ;
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ IN: tools.walker.tests
|
|||
[ 2 2 fixnum+ ] test-walker
|
||||
] unit-test
|
||||
|
||||
: foo 2 2 fixnum+ ;
|
||||
: foo ( -- x ) 2 2 fixnum+ ;
|
||||
|
||||
[ { 8 } ] [
|
||||
[ foo 4 fixnum+ ] test-walker
|
||||
|
|
|
|||
|
|
@ -5,9 +5,9 @@ IN: ui.gadgets.buttons.tests
|
|||
|
||||
TUPLE: foo-gadget ;
|
||||
|
||||
: com-foo-a ;
|
||||
: com-foo-a ( -- ) ;
|
||||
|
||||
: com-foo-b ;
|
||||
: com-foo-b ( -- ) ;
|
||||
|
||||
\ foo-gadget "toolbar" f {
|
||||
{ f com-foo-a }
|
||||
|
|
|
|||
|
|
@ -119,14 +119,14 @@ M: mock-gadget ungraft*
|
|||
[ { f f } ] [ "g" get graft-state>> ] unit-test
|
||||
] with-variable
|
||||
|
||||
: add-some-children
|
||||
: add-some-children ( gadget -- gadget )
|
||||
3 [
|
||||
<mock-gadget> over <model> >>model
|
||||
"g" get over add-gadget drop
|
||||
swap 1+ number>string set
|
||||
] each ;
|
||||
|
||||
: status-flags
|
||||
: status-flags ( -- seq )
|
||||
{ "g" "1" "2" "3" } [ get graft-state>> ] map prune ;
|
||||
|
||||
: notify-combo ( ? ? -- )
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ help.stylesheet splitting tools.test.ui models math summary
|
|||
inspector accessors help.topics see ;
|
||||
IN: ui.gadgets.panes.tests
|
||||
|
||||
: #children "pane" get children>> length ;
|
||||
: #children ( -- n ) "pane" get children>> length ;
|
||||
|
||||
[ ] [ <pane> "pane" set ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ USING: ui.operations ui.commands prettyprint kernel namespaces
|
|||
tools.test ui.gadgets ui.gadgets.editors parser io
|
||||
io.streams.string math help help.markup accessors ;
|
||||
|
||||
: my-pprint pprint ;
|
||||
: my-pprint ( obj -- ) pprint ;
|
||||
|
||||
[ drop t ] \ my-pprint [ ] f operation boa "op" set
|
||||
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ IN: ui.tools.listener.tests
|
|||
|
||||
[ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
|
||||
|
||||
: text "Hello world.\nThis is a test." ;
|
||||
CONSTANT: text "Hello world.\nThis is a test."
|
||||
|
||||
[ ] [ text "interactor" get set-editor-string ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ IN: urls.tests
|
|||
USING: urls urls.private tools.test
|
||||
arrays kernel assocs present accessors ;
|
||||
|
||||
: urls
|
||||
CONSTANT: urls
|
||||
{
|
||||
{
|
||||
T{ url
|
||||
|
|
@ -80,7 +80,7 @@ arrays kernel assocs present accessors ;
|
|||
}
|
||||
"ftp://slava:secret@ftp.kernel.org/"
|
||||
}
|
||||
} ;
|
||||
}
|
||||
|
||||
urls [
|
||||
[ 1array ] [ [ >url ] curry ] bi* unit-test
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: words assocs kernel accessors parser sequences summary
|
||||
lexer splitting combinators locals xml.data memoize sequences.deep
|
||||
xml.data xml.state xml namespaces present arrays generalizations strings
|
||||
make math macros multiline inverse combinators.short-circuit
|
||||
sorting fry unicode.categories ;
|
||||
USING: words assocs kernel accessors parser effects.parser
|
||||
sequences summary lexer splitting combinators locals xml.data
|
||||
memoize sequences.deep xml.data xml.state xml namespaces present
|
||||
arrays generalizations strings make math macros multiline
|
||||
inverse combinators.short-circuit sorting fry unicode.categories
|
||||
effects ;
|
||||
IN: xml.syntax
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -17,26 +18,26 @@ M: no-tag summary
|
|||
>alist swap '[ _ no-tag boa throw ] suffix
|
||||
'[ dup main>> _ case ] ;
|
||||
|
||||
: define-tags ( word -- )
|
||||
dup dup "xtable" word-prop compile-tags define ;
|
||||
: define-tags ( word effect -- )
|
||||
[ dup dup "xtable" word-prop compile-tags ] dip define-declared ;
|
||||
|
||||
:: define-tag ( string word quot -- )
|
||||
quot string word "xtable" word-prop set-at
|
||||
word define-tags ;
|
||||
word word stack-effect define-tags ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SYNTAX: TAGS:
|
||||
CREATE
|
||||
[ H{ } clone "xtable" set-word-prop ]
|
||||
[ define-tags ] bi ;
|
||||
CREATE-WORD complete-effect
|
||||
[ drop H{ } clone "xtable" set-word-prop ]
|
||||
[ define-tags ]
|
||||
2bi ;
|
||||
|
||||
SYNTAX: TAG:
|
||||
scan scan-word parse-definition define-tag ;
|
||||
|
||||
SYNTAX: XML-NS:
|
||||
CREATE-WORD (( string -- name )) over set-stack-effect
|
||||
scan '[ f swap _ <name> ] define-memoized ;
|
||||
CREATE-WORD scan '[ f swap _ <name> ] (( string -- name )) define-memoized ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@ USING: kernel xml sequences assocs tools.test io arrays namespaces fry
|
|||
accessors xml.data xml.traversal xml.writer generic sequences.deep multiline ;
|
||||
IN: xml.tests
|
||||
|
||||
: sub-tag
|
||||
T{ name f f "sub" "http://littledan.onigirihouse.com/namespaces/replace" } ;
|
||||
CONSTANT: sub-tag
|
||||
T{ name f f "sub" "http://littledan.onigirihouse.com/namespaces/replace" }
|
||||
|
||||
SYMBOL: ref-table
|
||||
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ TUPLE: xml-test id uri sections description type ;
|
|||
: parse-tests ( xml -- tests )
|
||||
"TEST" tags-named [ >xml-test ] map ;
|
||||
|
||||
: base "vocab:xml/tests/xmltest/" ;
|
||||
CONSTANT: base "vocab:xml/tests/xmltest/"
|
||||
|
||||
MACRO: drop-output ( quot -- newquot )
|
||||
dup infer out>> '[ @ _ ndrop ] ;
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ IN: xml.writer.tests
|
|||
[ "<foo> bar </foo>" string>xml pprint-xml>string ] unit-test
|
||||
[ "<foo'>" ] [ "<foo'>" <unescaped> xml>string ] unit-test
|
||||
|
||||
: test-file "resource:basis/xml/writer/test.xml" ;
|
||||
CONSTANT: test-file "resource:basis/xml/writer/test.xml"
|
||||
|
||||
[ ] [ "<?xml version='1.0' encoding='UTF-16BE'?><x/>" string>xml test-file utf8 [ write-xml ] with-file-writer ] unit-test
|
||||
[ "x" ] [ test-file file>xml body>> name>> main>> ] unit-test
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ H{ } clone sub-primitives set
|
|||
"syntax" vocab vocab-words bootstrap-syntax set {
|
||||
dictionary
|
||||
new-classes
|
||||
changed-definitions changed-generics
|
||||
changed-definitions changed-generics changed-effects
|
||||
outdated-generics forgotten-definitions
|
||||
root-cache source-files update-map implementors-map
|
||||
} [ H{ } clone swap set ] each
|
||||
|
|
@ -48,9 +48,9 @@ init-caches
|
|||
|
||||
dummy-compiler compiler-impl set
|
||||
|
||||
call
|
||||
call
|
||||
call
|
||||
call( -- )
|
||||
call( -- )
|
||||
call( -- )
|
||||
|
||||
! After we execute bootstrap/layouts
|
||||
num-types get f <array> builtins set
|
||||
|
|
@ -335,205 +335,204 @@ tuple
|
|||
(( quot1 quot2 -- compose )) define-declared
|
||||
|
||||
! Sub-primitive words
|
||||
: make-sub-primitive ( word vocab -- )
|
||||
create
|
||||
dup reset-word
|
||||
dup 1quotation define ;
|
||||
: make-sub-primitive ( word vocab effect -- )
|
||||
[ create dup 1quotation ] dip define-declared ;
|
||||
|
||||
{
|
||||
{ "(execute)" "words.private" }
|
||||
{ "(call)" "kernel.private" }
|
||||
{ "both-fixnums?" "math.private" }
|
||||
{ "fixnum+fast" "math.private" }
|
||||
{ "fixnum-fast" "math.private" }
|
||||
{ "fixnum*fast" "math.private" }
|
||||
{ "fixnum-bitand" "math.private" }
|
||||
{ "fixnum-bitor" "math.private" }
|
||||
{ "fixnum-bitxor" "math.private" }
|
||||
{ "fixnum-bitnot" "math.private" }
|
||||
{ "fixnum-mod" "math.private" }
|
||||
{ "fixnum-shift-fast" "math.private" }
|
||||
{ "fixnum/i-fast" "math.private" }
|
||||
{ "fixnum/mod-fast" "math.private" }
|
||||
{ "fixnum<" "math.private" }
|
||||
{ "fixnum<=" "math.private" }
|
||||
{ "fixnum>" "math.private" }
|
||||
{ "fixnum>=" "math.private" }
|
||||
{ "drop" "kernel" }
|
||||
{ "2drop" "kernel" }
|
||||
{ "3drop" "kernel" }
|
||||
{ "dup" "kernel" }
|
||||
{ "2dup" "kernel" }
|
||||
{ "3dup" "kernel" }
|
||||
{ "rot" "kernel" }
|
||||
{ "-rot" "kernel" }
|
||||
{ "dupd" "kernel" }
|
||||
{ "swapd" "kernel" }
|
||||
{ "nip" "kernel" }
|
||||
{ "2nip" "kernel" }
|
||||
{ "tuck" "kernel" }
|
||||
{ "over" "kernel" }
|
||||
{ "pick" "kernel" }
|
||||
{ "swap" "kernel" }
|
||||
{ "eq?" "kernel" }
|
||||
{ "tag" "kernel.private" }
|
||||
{ "slot" "slots.private" }
|
||||
{ "get-local" "locals.backend" }
|
||||
{ "load-local" "locals.backend" }
|
||||
{ "drop-locals" "locals.backend" }
|
||||
} [ make-sub-primitive ] assoc-each
|
||||
{ "(execute)" "words.private" (( word -- )) }
|
||||
{ "(call)" "kernel.private" (( quot -- )) }
|
||||
{ "both-fixnums?" "math.private" (( x y -- ? )) }
|
||||
{ "fixnum+fast" "math.private" (( x y -- z )) }
|
||||
{ "fixnum-fast" "math.private" (( x y -- z )) }
|
||||
{ "fixnum*fast" "math.private" (( x y -- z )) }
|
||||
{ "fixnum-bitand" "math.private" (( x y -- z )) }
|
||||
{ "fixnum-bitor" "math.private" (( x y -- z )) }
|
||||
{ "fixnum-bitxor" "math.private" (( x y -- z )) }
|
||||
{ "fixnum-bitnot" "math.private" (( x -- y )) }
|
||||
{ "fixnum-mod" "math.private" (( x y -- z )) }
|
||||
{ "fixnum-shift-fast" "math.private" (( x y -- z )) }
|
||||
{ "fixnum/i-fast" "math.private" (( x y -- z )) }
|
||||
{ "fixnum/mod-fast" "math.private" (( x y -- z w )) }
|
||||
{ "fixnum<" "math.private" (( x y -- ? )) }
|
||||
{ "fixnum<=" "math.private" (( x y -- z )) }
|
||||
{ "fixnum>" "math.private" (( x y -- ? )) }
|
||||
{ "fixnum>=" "math.private" (( x y -- ? )) }
|
||||
{ "drop" "kernel" (( x -- )) }
|
||||
{ "2drop" "kernel" (( x y -- )) }
|
||||
{ "3drop" "kernel" (( x y z -- )) }
|
||||
{ "dup" "kernel" (( x -- x x )) }
|
||||
{ "2dup" "kernel" (( x y -- x y x y )) }
|
||||
{ "3dup" "kernel" (( x y z -- x y z x y z )) }
|
||||
{ "rot" "kernel" (( x y z -- y z x )) }
|
||||
{ "-rot" "kernel" (( x y z -- z x y )) }
|
||||
{ "dupd" "kernel" (( x y -- x x y )) }
|
||||
{ "swapd" "kernel" (( x y z -- y x z )) }
|
||||
{ "nip" "kernel" (( x y -- y )) }
|
||||
{ "2nip" "kernel" (( x y z -- z )) }
|
||||
{ "tuck" "kernel" (( x y -- y x y )) }
|
||||
{ "over" "kernel" (( x y -- x y x )) }
|
||||
{ "pick" "kernel" (( x y z -- x y z x )) }
|
||||
{ "swap" "kernel" (( x y -- y x )) }
|
||||
{ "eq?" "kernel" (( obj1 obj2 -- ? )) }
|
||||
{ "tag" "kernel.private" (( object -- n )) }
|
||||
{ "slot" "slots.private" (( obj m -- value )) }
|
||||
{ "get-local" "locals.backend" (( n -- obj )) }
|
||||
{ "load-local" "locals.backend" (( obj -- )) }
|
||||
{ "drop-locals" "locals.backend" (( n -- )) }
|
||||
} [ first3 make-sub-primitive ] each
|
||||
|
||||
! Primitive words
|
||||
: make-primitive ( word vocab n -- )
|
||||
[ create dup reset-word ] dip
|
||||
[ do-primitive ] curry [ ] like define ;
|
||||
: make-primitive ( word vocab n effect -- )
|
||||
[
|
||||
[ create dup reset-word ] dip
|
||||
[ do-primitive ] curry
|
||||
] dip define-declared ;
|
||||
|
||||
{
|
||||
{ "bignum>fixnum" "math.private" }
|
||||
{ "float>fixnum" "math.private" }
|
||||
{ "fixnum>bignum" "math.private" }
|
||||
{ "float>bignum" "math.private" }
|
||||
{ "fixnum>float" "math.private" }
|
||||
{ "bignum>float" "math.private" }
|
||||
{ "<ratio>" "math.private" }
|
||||
{ "string>float" "math.private" }
|
||||
{ "float>string" "math.private" }
|
||||
{ "float>bits" "math" }
|
||||
{ "double>bits" "math" }
|
||||
{ "bits>float" "math" }
|
||||
{ "bits>double" "math" }
|
||||
{ "<complex>" "math.private" }
|
||||
{ "fixnum+" "math.private" }
|
||||
{ "fixnum-" "math.private" }
|
||||
{ "fixnum*" "math.private" }
|
||||
{ "fixnum/i" "math.private" }
|
||||
{ "fixnum/mod" "math.private" }
|
||||
{ "fixnum-shift" "math.private" }
|
||||
{ "bignum=" "math.private" }
|
||||
{ "bignum+" "math.private" }
|
||||
{ "bignum-" "math.private" }
|
||||
{ "bignum*" "math.private" }
|
||||
{ "bignum/i" "math.private" }
|
||||
{ "bignum-mod" "math.private" }
|
||||
{ "bignum/mod" "math.private" }
|
||||
{ "bignum-bitand" "math.private" }
|
||||
{ "bignum-bitor" "math.private" }
|
||||
{ "bignum-bitxor" "math.private" }
|
||||
{ "bignum-bitnot" "math.private" }
|
||||
{ "bignum-shift" "math.private" }
|
||||
{ "bignum<" "math.private" }
|
||||
{ "bignum<=" "math.private" }
|
||||
{ "bignum>" "math.private" }
|
||||
{ "bignum>=" "math.private" }
|
||||
{ "bignum-bit?" "math.private" }
|
||||
{ "bignum-log2" "math.private" }
|
||||
{ "byte-array>bignum" "math" }
|
||||
{ "float=" "math.private" }
|
||||
{ "float+" "math.private" }
|
||||
{ "float-" "math.private" }
|
||||
{ "float*" "math.private" }
|
||||
{ "float/f" "math.private" }
|
||||
{ "float-mod" "math.private" }
|
||||
{ "float<" "math.private" }
|
||||
{ "float<=" "math.private" }
|
||||
{ "float>" "math.private" }
|
||||
{ "float>=" "math.private" }
|
||||
{ "<word>" "words" }
|
||||
{ "word-xt" "words" }
|
||||
{ "getenv" "kernel.private" }
|
||||
{ "setenv" "kernel.private" }
|
||||
{ "(exists?)" "io.files.private" }
|
||||
{ "gc" "memory" }
|
||||
{ "gc-stats" "memory" }
|
||||
{ "save-image" "memory" }
|
||||
{ "save-image-and-exit" "memory" }
|
||||
{ "datastack" "kernel" }
|
||||
{ "retainstack" "kernel" }
|
||||
{ "callstack" "kernel" }
|
||||
{ "set-datastack" "kernel" }
|
||||
{ "set-retainstack" "kernel" }
|
||||
{ "set-callstack" "kernel" }
|
||||
{ "exit" "system" }
|
||||
{ "data-room" "memory" }
|
||||
{ "code-room" "memory" }
|
||||
{ "micros" "system" }
|
||||
{ "modify-code-heap" "compiler.units" }
|
||||
{ "dlopen" "alien" }
|
||||
{ "dlsym" "alien" }
|
||||
{ "dlclose" "alien" }
|
||||
{ "<byte-array>" "byte-arrays" }
|
||||
{ "(byte-array)" "byte-arrays" }
|
||||
{ "<displaced-alien>" "alien" }
|
||||
{ "alien-signed-cell" "alien.accessors" }
|
||||
{ "set-alien-signed-cell" "alien.accessors" }
|
||||
{ "alien-unsigned-cell" "alien.accessors" }
|
||||
{ "set-alien-unsigned-cell" "alien.accessors" }
|
||||
{ "alien-signed-8" "alien.accessors" }
|
||||
{ "set-alien-signed-8" "alien.accessors" }
|
||||
{ "alien-unsigned-8" "alien.accessors" }
|
||||
{ "set-alien-unsigned-8" "alien.accessors" }
|
||||
{ "alien-signed-4" "alien.accessors" }
|
||||
{ "set-alien-signed-4" "alien.accessors" }
|
||||
{ "alien-unsigned-4" "alien.accessors" }
|
||||
{ "set-alien-unsigned-4" "alien.accessors" }
|
||||
{ "alien-signed-2" "alien.accessors" }
|
||||
{ "set-alien-signed-2" "alien.accessors" }
|
||||
{ "alien-unsigned-2" "alien.accessors" }
|
||||
{ "set-alien-unsigned-2" "alien.accessors" }
|
||||
{ "alien-signed-1" "alien.accessors" }
|
||||
{ "set-alien-signed-1" "alien.accessors" }
|
||||
{ "alien-unsigned-1" "alien.accessors" }
|
||||
{ "set-alien-unsigned-1" "alien.accessors" }
|
||||
{ "alien-float" "alien.accessors" }
|
||||
{ "set-alien-float" "alien.accessors" }
|
||||
{ "alien-double" "alien.accessors" }
|
||||
{ "set-alien-double" "alien.accessors" }
|
||||
{ "alien-cell" "alien.accessors" }
|
||||
{ "set-alien-cell" "alien.accessors" }
|
||||
{ "alien-address" "alien" }
|
||||
{ "set-slot" "slots.private" }
|
||||
{ "string-nth" "strings.private" }
|
||||
{ "set-string-nth-fast" "strings.private" }
|
||||
{ "set-string-nth-slow" "strings.private" }
|
||||
{ "resize-array" "arrays" }
|
||||
{ "resize-string" "strings" }
|
||||
{ "<array>" "arrays" }
|
||||
{ "begin-scan" "memory" }
|
||||
{ "next-object" "memory" }
|
||||
{ "end-scan" "memory" }
|
||||
{ "size" "memory" }
|
||||
{ "die" "kernel" }
|
||||
{ "fopen" "io.streams.c" }
|
||||
{ "fgetc" "io.streams.c" }
|
||||
{ "fread" "io.streams.c" }
|
||||
{ "fputc" "io.streams.c" }
|
||||
{ "fwrite" "io.streams.c" }
|
||||
{ "fflush" "io.streams.c" }
|
||||
{ "fclose" "io.streams.c" }
|
||||
{ "<wrapper>" "kernel" }
|
||||
{ "(clone)" "kernel" }
|
||||
{ "<string>" "strings" }
|
||||
{ "array>quotation" "quotations.private" }
|
||||
{ "quotation-xt" "quotations" }
|
||||
{ "<tuple>" "classes.tuple.private" }
|
||||
{ "profiling" "tools.profiler.private" }
|
||||
{ "become" "kernel.private" }
|
||||
{ "(sleep)" "threads.private" }
|
||||
{ "<tuple-boa>" "classes.tuple.private" }
|
||||
{ "callstack>array" "kernel" }
|
||||
{ "innermost-frame-quot" "kernel.private" }
|
||||
{ "innermost-frame-scan" "kernel.private" }
|
||||
{ "set-innermost-frame-quot" "kernel.private" }
|
||||
{ "call-clear" "kernel" }
|
||||
{ "resize-byte-array" "byte-arrays" }
|
||||
{ "dll-valid?" "alien" }
|
||||
{ "unimplemented" "kernel.private" }
|
||||
{ "gc-reset" "memory" }
|
||||
{ "jit-compile" "quotations" }
|
||||
{ "load-locals" "locals.backend" }
|
||||
{ "check-datastack" "kernel.private" }
|
||||
}
|
||||
[ [ first2 ] dip make-primitive ] each-index
|
||||
{ "bignum>fixnum" "math.private" (( x -- y )) }
|
||||
{ "float>fixnum" "math.private" (( x -- y )) }
|
||||
{ "fixnum>bignum" "math.private" (( x -- y )) }
|
||||
{ "float>bignum" "math.private" (( x -- y )) }
|
||||
{ "fixnum>float" "math.private" (( x -- y )) }
|
||||
{ "bignum>float" "math.private" (( x -- y )) }
|
||||
{ "<ratio>" "math.private" (( a b -- a/b )) }
|
||||
{ "string>float" "math.private" (( str -- n/f )) }
|
||||
{ "float>string" "math.private" (( n -- str )) }
|
||||
{ "float>bits" "math" (( x -- n )) }
|
||||
{ "double>bits" "math" (( x -- n )) }
|
||||
{ "bits>float" "math" (( n -- x )) }
|
||||
{ "bits>double" "math" (( n -- x )) }
|
||||
{ "<complex>" "math.private" (( x y -- z )) }
|
||||
{ "fixnum+" "math.private" (( x y -- z )) }
|
||||
{ "fixnum-" "math.private" (( x y -- z )) }
|
||||
{ "fixnum*" "math.private" (( x y -- z )) }
|
||||
{ "fixnum/i" "math.private" (( x y -- z )) }
|
||||
{ "fixnum/mod" "math.private" (( x y -- z w )) }
|
||||
{ "fixnum-shift" "math.private" (( x y -- z )) }
|
||||
{ "bignum=" "math.private" (( x y -- ? )) }
|
||||
{ "bignum+" "math.private" (( x y -- z )) }
|
||||
{ "bignum-" "math.private" (( x y -- z )) }
|
||||
{ "bignum*" "math.private" (( x y -- z )) }
|
||||
{ "bignum/i" "math.private" (( x y -- z )) }
|
||||
{ "bignum-mod" "math.private" (( x y -- z )) }
|
||||
{ "bignum/mod" "math.private" (( x y -- z w )) }
|
||||
{ "bignum-bitand" "math.private" (( x y -- z )) }
|
||||
{ "bignum-bitor" "math.private" (( x y -- z )) }
|
||||
{ "bignum-bitxor" "math.private" (( x y -- z )) }
|
||||
{ "bignum-bitnot" "math.private" (( x -- y )) }
|
||||
{ "bignum-shift" "math.private" (( x y -- z )) }
|
||||
{ "bignum<" "math.private" (( x y -- ? )) }
|
||||
{ "bignum<=" "math.private" (( x y -- ? )) }
|
||||
{ "bignum>" "math.private" (( x y -- ? )) }
|
||||
{ "bignum>=" "math.private" (( x y -- ? )) }
|
||||
{ "bignum-bit?" "math.private" (( n x -- ? )) }
|
||||
{ "bignum-log2" "math.private" (( x -- n )) }
|
||||
{ "byte-array>bignum" "math" (( x -- y )) }
|
||||
{ "float=" "math.private" (( x y -- ? )) }
|
||||
{ "float+" "math.private" (( x y -- z )) }
|
||||
{ "float-" "math.private" (( x y -- z )) }
|
||||
{ "float*" "math.private" (( x y -- z )) }
|
||||
{ "float/f" "math.private" (( x y -- z )) }
|
||||
{ "float-mod" "math.private" (( x y -- z )) }
|
||||
{ "float<" "math.private" (( x y -- ? )) }
|
||||
{ "float<=" "math.private" (( x y -- ? )) }
|
||||
{ "float>" "math.private" (( x y -- ? )) }
|
||||
{ "float>=" "math.private" (( x y -- ? )) }
|
||||
{ "<word>" "words" (( name vocab -- word )) }
|
||||
{ "word-xt" "words" (( word -- start end )) }
|
||||
{ "getenv" "kernel.private" (( n -- obj )) }
|
||||
{ "setenv" "kernel.private" (( obj n -- )) }
|
||||
{ "(exists?)" "io.files.private" (( path -- ? )) }
|
||||
{ "gc" "memory" (( -- )) }
|
||||
{ "gc-stats" "memory" f }
|
||||
{ "save-image" "memory" (( path -- )) }
|
||||
{ "save-image-and-exit" "memory" (( path -- )) }
|
||||
{ "datastack" "kernel" (( -- ds )) }
|
||||
{ "retainstack" "kernel" (( -- rs )) }
|
||||
{ "callstack" "kernel" (( -- cs )) }
|
||||
{ "set-datastack" "kernel" (( ds -- )) }
|
||||
{ "set-retainstack" "kernel" (( rs -- )) }
|
||||
{ "set-callstack" "kernel" (( cs -- )) }
|
||||
{ "exit" "system" (( n -- )) }
|
||||
{ "data-room" "memory" (( -- cards generations )) }
|
||||
{ "code-room" "memory" (( -- code-free code-total )) }
|
||||
{ "micros" "system" (( -- us )) }
|
||||
{ "modify-code-heap" "compiler.units" (( alist -- )) }
|
||||
{ "dlopen" "alien" (( path -- dll )) }
|
||||
{ "dlsym" "alien" (( name dll -- alien )) }
|
||||
{ "dlclose" "alien" (( dll -- )) }
|
||||
{ "<byte-array>" "byte-arrays" (( n -- byte-array )) }
|
||||
{ "(byte-array)" "byte-arrays" (( n -- byte-array )) }
|
||||
{ "<displaced-alien>" "alien" (( displacement c-ptr -- alien )) }
|
||||
{ "alien-signed-cell" "alien.accessors" f }
|
||||
{ "set-alien-signed-cell" "alien.accessors" f }
|
||||
{ "alien-unsigned-cell" "alien.accessors" f }
|
||||
{ "set-alien-unsigned-cell" "alien.accessors" f }
|
||||
{ "alien-signed-8" "alien.accessors" f }
|
||||
{ "set-alien-signed-8" "alien.accessors" f }
|
||||
{ "alien-unsigned-8" "alien.accessors" f }
|
||||
{ "set-alien-unsigned-8" "alien.accessors" f }
|
||||
{ "alien-signed-4" "alien.accessors" f }
|
||||
{ "set-alien-signed-4" "alien.accessors" f }
|
||||
{ "alien-unsigned-4" "alien.accessors" f }
|
||||
{ "set-alien-unsigned-4" "alien.accessors" f }
|
||||
{ "alien-signed-2" "alien.accessors" f }
|
||||
{ "set-alien-signed-2" "alien.accessors" f }
|
||||
{ "alien-unsigned-2" "alien.accessors" f }
|
||||
{ "set-alien-unsigned-2" "alien.accessors" f }
|
||||
{ "alien-signed-1" "alien.accessors" f }
|
||||
{ "set-alien-signed-1" "alien.accessors" f }
|
||||
{ "alien-unsigned-1" "alien.accessors" f }
|
||||
{ "set-alien-unsigned-1" "alien.accessors" f }
|
||||
{ "alien-float" "alien.accessors" f }
|
||||
{ "set-alien-float" "alien.accessors" f }
|
||||
{ "alien-double" "alien.accessors" f }
|
||||
{ "set-alien-double" "alien.accessors" f }
|
||||
{ "alien-cell" "alien.accessors" f }
|
||||
{ "set-alien-cell" "alien.accessors" f }
|
||||
{ "alien-address" "alien" (( c-ptr -- addr )) }
|
||||
{ "set-slot" "slots.private" (( value obj n -- )) }
|
||||
{ "string-nth" "strings.private" (( n string -- ch )) }
|
||||
{ "set-string-nth-fast" "strings.private" (( ch n string -- )) }
|
||||
{ "set-string-nth-slow" "strings.private" (( ch n string -- )) }
|
||||
{ "resize-array" "arrays" (( n array -- newarray )) }
|
||||
{ "resize-string" "strings" (( n str -- newstr )) }
|
||||
{ "<array>" "arrays" (( n elt -- array )) }
|
||||
{ "begin-scan" "memory" (( -- )) }
|
||||
{ "next-object" "memory" (( -- obj )) }
|
||||
{ "end-scan" "memory" (( -- )) }
|
||||
{ "size" "memory" (( obj -- n )) }
|
||||
{ "die" "kernel" (( -- )) }
|
||||
{ "fopen" "io.streams.c" (( path mode -- alien )) }
|
||||
{ "fgetc" "io.streams.c" (( alien -- ch/f )) }
|
||||
{ "fread" "io.streams.c" (( n alien -- str/f )) }
|
||||
{ "fputc" "io.streams.c" (( ch alien -- )) }
|
||||
{ "fwrite" "io.streams.c" (( string alien -- )) }
|
||||
{ "fflush" "io.streams.c" (( alien -- )) }
|
||||
{ "fclose" "io.streams.c" (( alien -- )) }
|
||||
{ "<wrapper>" "kernel" (( obj -- wrapper )) }
|
||||
{ "(clone)" "kernel" (( obj -- newobj )) }
|
||||
{ "<string>" "strings" (( n ch -- string )) }
|
||||
{ "array>quotation" "quotations.private" (( array -- quot )) }
|
||||
{ "quotation-xt" "quotations" (( quot -- xt )) }
|
||||
{ "<tuple>" "classes.tuple.private" (( layout -- tuple )) }
|
||||
{ "profiling" "tools.profiler.private" (( ? -- )) }
|
||||
{ "become" "kernel.private" (( old new -- )) }
|
||||
{ "(sleep)" "threads.private" (( us -- )) }
|
||||
{ "<tuple-boa>" "classes.tuple.private" (( ... layout -- tuple )) }
|
||||
{ "callstack>array" "kernel" (( callstack -- array )) }
|
||||
{ "innermost-frame-quot" "kernel.private" (( callstack -- quot )) }
|
||||
{ "innermost-frame-scan" "kernel.private" (( callstack -- n )) }
|
||||
{ "set-innermost-frame-quot" "kernel.private" (( n callstack -- )) }
|
||||
{ "call-clear" "kernel" (( quot -- )) }
|
||||
{ "resize-byte-array" "byte-arrays" (( n byte-array -- newbyte-array )) }
|
||||
{ "dll-valid?" "alien" (( dll -- ? )) }
|
||||
{ "unimplemented" "kernel.private" (( -- * )) }
|
||||
{ "gc-reset" "memory" (( -- )) }
|
||||
{ "jit-compile" "quotations" (( quot -- )) }
|
||||
{ "load-locals" "locals.backend" (( ... n -- )) }
|
||||
{ "check-datastack" "kernel.private" (( array in# out# -- ? )) }
|
||||
} [ [ first3 ] dip swap make-primitive ] each-index
|
||||
|
||||
! Bump build number
|
||||
"build" "kernel" create build 1+ [ ] curry (( -- n )) define-declared
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays definitions assocs kernel kernel.private
|
||||
slots.private namespaces make sequences strings words words.symbol
|
||||
|
|
@ -126,14 +126,19 @@ M: sequence implementors [ implementors ] gather ;
|
|||
} spread
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: ?define-symbol ( word -- )
|
||||
dup deferred? [ define-symbol ] [ drop ] if ;
|
||||
|
||||
: (define-class) ( word props -- )
|
||||
[
|
||||
dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
|
||||
dup reset-class
|
||||
dup deferred? [ dup define-symbol ] when
|
||||
dup redefined
|
||||
dup props>>
|
||||
] dip assoc-union >>props
|
||||
{
|
||||
[ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ]
|
||||
[ reset-class ]
|
||||
[ ?define-symbol ]
|
||||
[ redefined ]
|
||||
[ ]
|
||||
} cleave
|
||||
] dip [ assoc-union ] curry change-props
|
||||
dup predicate-word
|
||||
[ 1quotation "predicate" set-word-prop ]
|
||||
[ swap "predicating" set-word-prop ]
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ GENERIC: zammo ( obj -- str )
|
|||
|
||||
SINGLETON: word-and-singleton
|
||||
|
||||
: word-and-singleton 3 ;
|
||||
: word-and-singleton ( -- x ) 3 ;
|
||||
|
||||
[ t ] [ \ word-and-singleton word-and-singleton? ] unit-test
|
||||
[ 3 ] [ word-and-singleton ] unit-test
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@ namespaces quotations sequences.private classes continuations
|
|||
generic.standard effects classes.tuple classes.tuple.private
|
||||
arrays vectors strings compiler.units accessors classes.algebra
|
||||
calendar prettyprint io.streams.string splitting summary
|
||||
columns math.order classes.private slots slots.private eval see ;
|
||||
columns math.order classes.private slots slots.private eval see
|
||||
words.symbol ;
|
||||
IN: classes.tuple.tests
|
||||
|
||||
TUPLE: rect x y w h ;
|
||||
|
|
@ -62,7 +63,7 @@ TUPLE: predicate-test ;
|
|||
|
||||
C: <predicate-test> predicate-test
|
||||
|
||||
: predicate-test drop f ;
|
||||
: predicate-test ( a -- ? ) drop f ;
|
||||
|
||||
[ t ] [ <predicate-test> predicate-test? ] unit-test
|
||||
|
||||
|
|
@ -97,7 +98,7 @@ TUPLE: size-test a b c d ;
|
|||
size-test tuple-layout second =
|
||||
] unit-test
|
||||
|
||||
GENERIC: <yo-momma>
|
||||
GENERIC: <yo-momma> ( a -- b )
|
||||
|
||||
TUPLE: yo-momma ;
|
||||
|
||||
|
|
@ -123,7 +124,7 @@ TUPLE: loc-recording ;
|
|||
|
||||
TUPLE: forget-robustness ;
|
||||
|
||||
GENERIC: forget-robustness-generic
|
||||
GENERIC: forget-robustness-generic ( a -- b )
|
||||
|
||||
M: forget-robustness forget-robustness-generic ;
|
||||
|
||||
|
|
@ -493,7 +494,7 @@ must-fail-with
|
|||
[ t ] [ "z" accessor-exists? ] unit-test
|
||||
|
||||
[ [ ] ] [
|
||||
"IN: classes.tuple.tests GENERIC: forget-accessors-test"
|
||||
"IN: classes.tuple.tests GENERIC: forget-accessors-test ( a -- b )"
|
||||
<string-reader>
|
||||
"forget-accessors-test" parse-stream
|
||||
] unit-test
|
||||
|
|
@ -508,7 +509,7 @@ TUPLE: another-forget-accessors-test ;
|
|||
|
||||
|
||||
[ [ ] ] [
|
||||
"IN: classes.tuple.tests GENERIC: another-forget-accessors-test"
|
||||
"IN: classes.tuple.tests GENERIC: another-forget-accessors-test ( a -- b )"
|
||||
<string-reader>
|
||||
"another-forget-accessors-test" parse-stream
|
||||
] unit-test
|
||||
|
|
@ -567,7 +568,7 @@ GENERIC: break-me ( obj -- )
|
|||
|
||||
[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests : subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests : subclass-reset-test ( -- ) ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
|
||||
|
||||
[ f ] [ subclass-reset-test-1 tuple-class? ] unit-test
|
||||
[ f ] [ subclass-reset-test-2 tuple-class? ] unit-test
|
||||
|
|
@ -666,7 +667,7 @@ DEFER: error-y
|
|||
|
||||
[ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests GENERIC: error-y" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval ] unit-test
|
||||
|
||||
[ f ] [ \ error-y tuple-class? ] unit-test
|
||||
|
||||
|
|
@ -730,4 +731,18 @@ SLOT: kex
|
|||
] unit-test
|
||||
|
||||
[ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
|
||||
[ f ] [ \ change-slot-test \ kex>> method "reading" word-prop ] unit-test
|
||||
[ f ] [ \ change-slot-test \ kex>> method "reading" word-prop ] unit-test
|
||||
|
||||
DEFER: redefine-tuple-twice
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test
|
||||
|
||||
[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval ] unit-test
|
||||
|
||||
[ t ] [ \ redefine-tuple-twice deferred? ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test
|
||||
|
||||
[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
|
||||
|
|
@ -247,8 +247,7 @@ M: tuple-class update-class
|
|||
bi
|
||||
] each-subclass
|
||||
]
|
||||
[ define-new-tuple-class ]
|
||||
3bi ;
|
||||
[ define-new-tuple-class ] 3bi ;
|
||||
|
||||
: tuple-class-unchanged? ( class superclass slots -- ? )
|
||||
[ [ superclass ] [ bootstrap-word ] bi* = ]
|
||||
|
|
@ -275,7 +274,7 @@ M: word (define-tuple-class)
|
|||
|
||||
M: tuple-class (define-tuple-class)
|
||||
3dup tuple-class-unchanged?
|
||||
[ 3drop ] [ redefine-tuple-class ] if ;
|
||||
[ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
|
||||
|
||||
: thrower-effect ( slots -- effect )
|
||||
[ dup array? [ first ] when ] map { "*" } <effect> ;
|
||||
|
|
|
|||
|
|
@ -288,7 +288,7 @@ CONSTANT: case-const-2 2
|
|||
} case
|
||||
] unit-test
|
||||
|
||||
: do-not-call "do not call" throw ;
|
||||
: do-not-call ( -- * ) "do not call" throw ;
|
||||
|
||||
: test-case-6 ( obj -- value )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -148,6 +148,7 @@ GENERIC: definitions-changed ( assoc obj -- )
|
|||
[
|
||||
H{ } clone changed-definitions set
|
||||
H{ } clone changed-generics set
|
||||
H{ } clone changed-effects set
|
||||
H{ } clone outdated-generics set
|
||||
H{ } clone outdated-tuples set
|
||||
H{ } clone new-classes set
|
||||
|
|
@ -158,6 +159,7 @@ GENERIC: definitions-changed ( assoc obj -- )
|
|||
[
|
||||
H{ } clone changed-definitions set
|
||||
H{ } clone changed-generics set
|
||||
H{ } clone changed-effects set
|
||||
H{ } clone outdated-generics set
|
||||
H{ } clone forgotten-definitions set
|
||||
H{ } clone outdated-tuples set
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ continuations debugger parser memory arrays words
|
|||
kernel.private accessors eval ;
|
||||
IN: continuations.tests
|
||||
|
||||
: (callcc1-test)
|
||||
: (callcc1-test) ( -- )
|
||||
[ 1- dup ] dip ?push
|
||||
over 0 = [ "test-cc" get continue-with ] when
|
||||
(callcc1-test) ;
|
||||
|
|
@ -59,10 +59,10 @@ IN: continuations.tests
|
|||
! : callstack-overflow callstack-overflow f ;
|
||||
! [ callstack-overflow ] must-fail
|
||||
|
||||
: don't-compile-me { } [ ] each ;
|
||||
: don't-compile-me ( -- ) { } [ ] each ;
|
||||
|
||||
: foo callstack "c" set 3 don't-compile-me ;
|
||||
: bar 1 foo 2 ;
|
||||
: foo ( -- ) callstack "c" set 3 don't-compile-me ;
|
||||
: bar ( -- a b ) 1 foo 2 ;
|
||||
|
||||
[ 1 3 2 ] [ bar ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,13 +1,11 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: definitions
|
||||
USING: kernel sequences namespaces assocs graphs math math.order ;
|
||||
IN: definitions
|
||||
|
||||
ERROR: no-compilation-unit definition ;
|
||||
|
||||
SYMBOL: inlined-dependency
|
||||
SYMBOL: flushed-dependency
|
||||
SYMBOL: called-dependency
|
||||
SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
|
||||
|
||||
: set-in-unit ( value key assoc -- )
|
||||
[ set-at ] [ no-compilation-unit ] if* ;
|
||||
|
|
@ -17,6 +15,11 @@ SYMBOL: changed-definitions
|
|||
: changed-definition ( defspec -- )
|
||||
inlined-dependency swap changed-definitions get set-in-unit ;
|
||||
|
||||
SYMBOL: changed-effects
|
||||
|
||||
: changed-effect ( word -- )
|
||||
dup changed-effects get set-in-unit ;
|
||||
|
||||
SYMBOL: changed-generics
|
||||
|
||||
SYMBOL: outdated-generics
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ T{ dispose-dummy } "b" set
|
|||
|
||||
TUPLE: dummy-obj destroyed? ;
|
||||
|
||||
: <dummy-obj> dummy-obj new ;
|
||||
: <dummy-obj> ( -- obj ) dummy-obj new ;
|
||||
|
||||
TUPLE: dummy-destructor obj ;
|
||||
|
||||
|
|
@ -30,10 +30,10 @@ C: <dummy-destructor> dummy-destructor
|
|||
M: dummy-destructor dispose ( obj -- )
|
||||
obj>> t >>destroyed? drop ;
|
||||
|
||||
: destroy-always
|
||||
: destroy-always ( obj -- )
|
||||
<dummy-destructor> &dispose drop ;
|
||||
|
||||
: destroy-later
|
||||
: destroy-later ( obj -- )
|
||||
<dummy-destructor> |dispose drop ;
|
||||
|
||||
[ t ] [
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: lexer sets sequences kernel splitting effects
|
||||
combinators arrays parser ;
|
||||
combinators arrays ;
|
||||
IN: effects.parser
|
||||
|
||||
DEFER: parse-effect
|
||||
|
|
@ -12,9 +12,9 @@ ERROR: bad-effect ;
|
|||
scan [ nip ] [ = ] 2bi [ drop f ] [
|
||||
dup { f "(" "((" } member? [ bad-effect ] [
|
||||
":" ?tail [
|
||||
scan-word {
|
||||
{ \ ( [ ")" parse-effect ] }
|
||||
[ ]
|
||||
scan {
|
||||
{ "(" [ ")" parse-effect ] }
|
||||
{ f [ ")" unexpected-eof ] }
|
||||
} case 2array
|
||||
] when
|
||||
] if
|
||||
|
|
@ -27,5 +27,8 @@ ERROR: bad-effect ;
|
|||
parse-effect-tokens { "--" } split1 dup
|
||||
[ <effect> ] [ "Stack effect declaration must contain --" throw ] if ;
|
||||
|
||||
: complete-effect ( -- effect )
|
||||
"(" expect ")" parse-effect ;
|
||||
|
||||
: parse-call( ( accum word -- accum )
|
||||
[ ")" parse-effect parsed ] dip parsed ;
|
||||
[ ")" parse-effect ] dip 2array over push-all ;
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
USING: help.markup help.syntax words classes classes.algebra
|
||||
definitions kernel alien sequences math quotations
|
||||
generic.standard generic.math combinators prettyprint ;
|
||||
generic.standard generic.math combinators prettyprint effects ;
|
||||
IN: generic
|
||||
|
||||
ARTICLE: "method-order" "Method precedence"
|
||||
|
|
@ -115,7 +115,7 @@ HELP: make-generic
|
|||
$low-level-note ;
|
||||
|
||||
HELP: define-generic
|
||||
{ $values { "word" word } { "combination" "a method combination" } }
|
||||
{ $values { "word" word } { "effect" effect } { "combination" "a method combination" } }
|
||||
{ $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." }
|
||||
{ $contract "The method combination quotation is called each time the generic word has to be updated (for example, when a method is added), and thus must be side-effect free." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -186,7 +186,7 @@ M: f generic-forget-test-3 ;
|
|||
|
||||
[ f ] [ f generic-forget-test-3 ] unit-test
|
||||
|
||||
: a-word ;
|
||||
: a-word ( -- ) ;
|
||||
|
||||
GENERIC: a-generic ( a -- b )
|
||||
|
||||
|
|
@ -196,7 +196,7 @@ M: integer a-generic a-word ;
|
|||
|
||||
[ t ] [ "m" get \ a-word usage memq? ] unit-test
|
||||
|
||||
[ ] [ "IN: generic.tests : a-generic ;" eval ] unit-test
|
||||
[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval ] unit-test
|
||||
|
||||
[ f ] [ "m" get \ a-word usage memq? ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -185,13 +185,21 @@ M: sequence update-methods ( class seq -- )
|
|||
[ changed-generic ] [ remake-generic drop ] 2bi
|
||||
] with each ;
|
||||
|
||||
: define-generic ( word combination -- )
|
||||
over "combination" word-prop over = [ drop ] [
|
||||
2dup "combination" set-word-prop
|
||||
over "methods" word-prop values forget-all
|
||||
over H{ } clone "methods" set-word-prop
|
||||
dupd define-default-method
|
||||
] if remake-generic ;
|
||||
: define-generic ( word combination effect -- )
|
||||
[ nip swap set-stack-effect ]
|
||||
[
|
||||
drop
|
||||
2dup [ "combination" word-prop ] dip = [ 2drop ] [
|
||||
{
|
||||
[ "combination" set-word-prop ]
|
||||
[ drop "methods" word-prop values forget-all ]
|
||||
[ drop H{ } clone "methods" set-word-prop ]
|
||||
[ define-default-method ]
|
||||
}
|
||||
2cleave
|
||||
] if
|
||||
]
|
||||
[ 2drop remake-generic ] 3tri ;
|
||||
|
||||
M: generic subwords
|
||||
[
|
||||
|
|
|
|||
|
|
@ -72,7 +72,7 @@ SYMBOL: picker
|
|||
\ dispatch ,
|
||||
] [ ] make ; inline
|
||||
|
||||
TUPLE: math-combination ;
|
||||
SINGLETON: math-combination
|
||||
|
||||
M: math-combination make-default-method
|
||||
drop default-math-method ;
|
||||
|
|
|
|||
|
|
@ -1,12 +1,15 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser kernel words generic namespaces ;
|
||||
USING: parser kernel words generic namespaces effects.parser ;
|
||||
IN: generic.parser
|
||||
|
||||
ERROR: not-in-a-method-error ;
|
||||
|
||||
: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
|
||||
|
||||
: (GENERIC:) ( quot -- )
|
||||
[ CREATE-GENERIC ] dip call complete-effect define-generic ; inline
|
||||
|
||||
: create-method-in ( class generic -- method )
|
||||
create-method dup set-word dup save-location ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: generic help.markup help.syntax sequences math
|
||||
math.parser ;
|
||||
math.parser effects ;
|
||||
IN: generic.standard
|
||||
|
||||
HELP: no-method
|
||||
|
|
@ -28,7 +28,7 @@ HELP: hook-combination
|
|||
} ;
|
||||
|
||||
HELP: define-simple-generic
|
||||
{ $values { "word" "a word" } }
|
||||
{ $values { "word" "a word" } { "effect" effect } }
|
||||
{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
|
||||
|
||||
{ standard-combination hook-combination } related-words
|
||||
|
|
|
|||
|
|
@ -280,16 +280,6 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
|
|||
V{ } my-var [ call-next-hooker ] with-variable
|
||||
] unit-test
|
||||
|
||||
GENERIC: no-stack-effect-decl
|
||||
|
||||
M: hashtable no-stack-effect-decl ;
|
||||
M: vector no-stack-effect-decl ;
|
||||
M: sbuf no-stack-effect-decl ;
|
||||
|
||||
[ ] [ \ no-stack-effect-decl see ] unit-test
|
||||
|
||||
[ ] [ \ no-stack-effect-decl def>> . ] unit-test
|
||||
|
||||
! Cross-referencing with generic words
|
||||
TUPLE: xref-tuple-1 ;
|
||||
TUPLE: xref-tuple-2 < xref-tuple-1 ;
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ M: quotation engine>quot
|
|||
ERROR: no-method object generic ;
|
||||
|
||||
: error-method ( word -- quot )
|
||||
picker swap [ no-method ] curry append ;
|
||||
[ picker ] dip [ no-method ] curry append ;
|
||||
|
||||
: push-method ( method specializer atomic assoc -- )
|
||||
[
|
||||
|
|
@ -56,7 +56,7 @@ ERROR: no-method object generic ;
|
|||
|
||||
: find-default ( methods -- quot )
|
||||
#! Side-effects methods.
|
||||
object bootstrap-word swap delete-at* [
|
||||
[ object bootstrap-word ] dip delete-at* [
|
||||
drop generic get "default-method" word-prop mangle-method
|
||||
] unless ;
|
||||
|
||||
|
|
@ -104,8 +104,10 @@ PREDICATE: standard-generic < generic
|
|||
PREDICATE: simple-generic < standard-generic
|
||||
"combination" word-prop #>> zero? ;
|
||||
|
||||
: define-simple-generic ( word -- )
|
||||
T{ standard-combination f 0 } define-generic ;
|
||||
CONSTANT: simple-combination T{ standard-combination f 0 }
|
||||
|
||||
: define-simple-generic ( word effect -- )
|
||||
[ simple-combination ] dip define-generic ;
|
||||
|
||||
: with-standard ( combination quot -- quot' )
|
||||
[ #>> (dispatch#) ] dip with-variable ; inline
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: io.tests
|
||||
USE: math
|
||||
: foo 2 2 + ;
|
||||
: foo ( -- x ) 2 2 + ;
|
||||
FORGET: foo
|
||||
|
|
@ -21,21 +21,21 @@ IN: kernel.tests
|
|||
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
: overflow-d 3 overflow-d ;
|
||||
: overflow-d ( -- ) 3 overflow-d ;
|
||||
|
||||
[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with
|
||||
|
||||
[ ] [ :c ] unit-test
|
||||
|
||||
: (overflow-d-alt) 3 ;
|
||||
: (overflow-d-alt) ( -- ) 3 ;
|
||||
|
||||
: overflow-d-alt (overflow-d-alt) overflow-d-alt ;
|
||||
: overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
|
||||
|
||||
[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with
|
||||
|
||||
[ ] [ [ :c ] with-string-writer drop ] unit-test
|
||||
|
||||
: overflow-r 3 load-local overflow-r ;
|
||||
: overflow-r ( -- ) 3 load-local overflow-r ;
|
||||
|
||||
[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with
|
||||
|
||||
|
|
@ -99,7 +99,7 @@ IN: kernel.tests
|
|||
[ ] [ :c ] unit-test
|
||||
|
||||
! Doesn't compile; important
|
||||
: foo 5 + 0 [ ] each ;
|
||||
: foo ( a -- b ) 5 + 0 [ ] each ;
|
||||
|
||||
[ drop foo ] must-fail
|
||||
[ ] [ :c ] unit-test
|
||||
|
|
@ -115,7 +115,7 @@ IN: kernel.tests
|
|||
[ loop ] must-fail
|
||||
|
||||
! Discovered on Windows
|
||||
: total-failure-1 "" [ ] map unimplemented ;
|
||||
: total-failure-1 ( -- ) "" [ ] map unimplemented ;
|
||||
|
||||
[ total-failure-1 ] must-fail
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel.private slots.private math.private
|
||||
classes.tuple.private ;
|
||||
USING: kernel.private slots.private math.private ;
|
||||
IN: kernel
|
||||
|
||||
DEFER: dip
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ IN: parser.tests
|
|||
|
||||
[ "hello world" ]
|
||||
[
|
||||
"IN: parser.tests : hello \"hello world\" ;"
|
||||
"IN: parser.tests : hello ( -- str ) \"hello world\" ;"
|
||||
eval "USE: parser.tests hello" eval
|
||||
] unit-test
|
||||
|
||||
|
|
@ -78,12 +78,8 @@ IN: parser.tests
|
|||
[ T{ effect f { "a" "b" } { "d" } f } ]
|
||||
[ \ effect-parsing-test "declared-effect" word-prop ] unit-test
|
||||
|
||||
[ ] [ "IN: parser.tests : effect-parsing-test ;" eval ] unit-test
|
||||
|
||||
[ f ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test
|
||||
|
||||
! Funny bug
|
||||
[ 2 ] [ "IN: parser.tests : \0. 2 ; \0." eval ] unit-test
|
||||
[ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval ] unit-test
|
||||
|
||||
[ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail
|
||||
|
||||
|
|
@ -110,7 +106,7 @@ IN: parser.tests
|
|||
|
||||
[ ] [ "USE: parser.tests foo" eval ] unit-test
|
||||
|
||||
"IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ;" eval
|
||||
"IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval
|
||||
|
||||
[ t ] [
|
||||
"USE: parser.tests \\ foo" eval
|
||||
|
|
@ -120,7 +116,7 @@ IN: parser.tests
|
|||
! Test smudging
|
||||
|
||||
[ 1 ] [
|
||||
"IN: parser.tests : smudge-me ;" <string-reader> "foo"
|
||||
"IN: parser.tests : smudge-me ( -- ) ;" <string-reader> "foo"
|
||||
parse-stream drop
|
||||
|
||||
"foo" source-file definitions>> first assoc-size
|
||||
|
|
@ -129,7 +125,7 @@ IN: parser.tests
|
|||
[ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests : smudge-me-more ;" <string-reader> "foo"
|
||||
"IN: parser.tests : smudge-me-more ( -- ) ;" <string-reader> "foo"
|
||||
parse-stream drop
|
||||
] unit-test
|
||||
|
||||
|
|
@ -137,7 +133,7 @@ IN: parser.tests
|
|||
[ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
|
||||
|
||||
[ 3 ] [
|
||||
"IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
|
||||
"IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
|
||||
parse-stream drop
|
||||
|
||||
"foo" source-file definitions>> first assoc-size
|
||||
|
|
@ -151,7 +147,7 @@ IN: parser.tests
|
|||
] unit-test
|
||||
|
||||
[ 2 ] [
|
||||
"IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" <string-reader> "foo"
|
||||
"IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ;" <string-reader> "foo"
|
||||
parse-stream drop
|
||||
|
||||
"foo" source-file definitions>> first assoc-size
|
||||
|
|
@ -190,7 +186,7 @@ IN: parser.tests
|
|||
[ ] [
|
||||
"a" source-files get delete-at
|
||||
2 [
|
||||
"IN: parser.tests DEFER: x : y x ; : x y ;"
|
||||
"IN: parser.tests DEFER: x : y ( -- ) x ; : x ( -- ) y ;"
|
||||
<string-reader> "a" parse-stream drop
|
||||
] times
|
||||
] unit-test
|
||||
|
|
@ -198,7 +194,7 @@ IN: parser.tests
|
|||
"a" source-files get delete-at
|
||||
|
||||
[
|
||||
"IN: parser.tests : x ; : y 3 throw ; this is an error"
|
||||
"IN: parser.tests : x ( -- ) ; : y ( -- * ) 3 throw ; this is an error"
|
||||
<string-reader> "a" parse-stream
|
||||
] [ source-file-error? ] must-fail-with
|
||||
|
||||
|
|
@ -207,7 +203,7 @@ IN: parser.tests
|
|||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
"IN: parser.tests : x ;"
|
||||
"IN: parser.tests : x ( -- ) ;"
|
||||
<string-reader> "a" parse-stream drop
|
||||
|
||||
"y" "parser.tests" lookup
|
||||
|
|
@ -215,18 +211,18 @@ IN: parser.tests
|
|||
|
||||
! Test new forward definition logic
|
||||
[ ] [
|
||||
"IN: axx : axx ;"
|
||||
"IN: axx : axx ( -- ) ;"
|
||||
<string-reader> "axx" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"USE: axx IN: bxx : bxx ; : cxx axx bxx ;"
|
||||
"USE: axx IN: bxx : bxx ( -- ) ; : cxx ( -- ) axx bxx ;"
|
||||
<string-reader> "bxx" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
! So we move the bxx word to axx...
|
||||
[ ] [
|
||||
"IN: axx : axx ; : bxx ;"
|
||||
"IN: axx : axx ( -- ) ; : bxx ( -- ) ;"
|
||||
<string-reader> "axx" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
|
|
@ -234,7 +230,7 @@ IN: parser.tests
|
|||
|
||||
! And reload the file that uses it...
|
||||
[ ] [
|
||||
"USE: axx IN: bxx : cxx axx bxx ;"
|
||||
"USE: axx IN: bxx ( -- ) : cxx ( -- ) axx bxx ;"
|
||||
<string-reader> "bxx" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
|
|
@ -243,17 +239,17 @@ IN: parser.tests
|
|||
! Turning a generic into a non-generic could cause all
|
||||
! kinds of funnyness
|
||||
[ ] [
|
||||
"IN: ayy USE: kernel GENERIC: ayy M: object ayy ;"
|
||||
"IN: ayy USE: kernel GENERIC: ayy ( a -- b ) M: object ayy ;"
|
||||
<string-reader> "ayy" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: ayy USE: kernel : ayy ;"
|
||||
"IN: ayy USE: kernel : ayy ( -- ) ;"
|
||||
<string-reader> "ayy" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: azz TUPLE: my-class ; GENERIC: a-generic"
|
||||
"IN: azz TUPLE: my-class ; GENERIC: a-generic ( a -- b )"
|
||||
<string-reader> "azz" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
|
|
@ -263,7 +259,7 @@ IN: parser.tests
|
|||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: azz GENERIC: a-generic"
|
||||
"IN: azz GENERIC: a-generic ( a -- b )"
|
||||
<string-reader> "azz" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
|
|
@ -273,12 +269,12 @@ IN: parser.tests
|
|||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests : <bogus-error> ; : bogus <bogus-error> ;"
|
||||
"IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- ) <bogus-error> ;"
|
||||
<string-reader> "bogus-error" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus <bogus-error> ;"
|
||||
"IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus ( -- ) <bogus-error> ;"
|
||||
<string-reader> "bogus-error" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
|
|
@ -298,7 +294,7 @@ IN: parser.tests
|
|||
] unit-test
|
||||
|
||||
[
|
||||
"IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?"
|
||||
"IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test? ( a -- b )"
|
||||
<string-reader> "removing-the-predicate" parse-stream
|
||||
] [ error>> error>> error>> redefine-error? ] must-fail-with
|
||||
|
||||
|
|
@ -313,7 +309,7 @@ IN: parser.tests
|
|||
] unit-test
|
||||
|
||||
[
|
||||
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
|
||||
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ( -- ) ;"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] [ error>> error>> error>> redefine-error? ] must-fail-with
|
||||
|
||||
|
|
@ -338,7 +334,7 @@ IN: parser.tests
|
|||
] [ error>> error>> error>> no-word-error? ] must-fail-with
|
||||
|
||||
[
|
||||
"IN: parser.tests : foo ; TUPLE: foo ;"
|
||||
"IN: parser.tests : foo ( -- ) ; TUPLE: foo ;"
|
||||
<string-reader> "redefining-a-class-4" parse-stream drop
|
||||
] [ error>> error>> error>> redefine-error? ] must-fail-with
|
||||
|
||||
|
|
@ -369,7 +365,7 @@ IN: parser.tests
|
|||
|
||||
2 [
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b )"
|
||||
<string-reader> "redefining-a-class-5" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
|
|
@ -381,14 +377,14 @@ IN: parser.tests
|
|||
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b )"
|
||||
<string-reader> "redefining-a-class-5" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo"
|
||||
"IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b )"
|
||||
<string-reader> "redefining-a-class-7" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
|
|
@ -438,7 +434,7 @@ IN: parser.tests
|
|||
{
|
||||
"IN: parser.tests"
|
||||
"USING: math arrays ;"
|
||||
"GENERIC: change-combination"
|
||||
"GENERIC: change-combination ( a -- b )"
|
||||
"M: integer change-combination 1 ;"
|
||||
"M: array change-combination 2 ;"
|
||||
} "\n" join <string-reader> "change-combination-test" parse-stream drop
|
||||
|
|
@ -448,7 +444,7 @@ IN: parser.tests
|
|||
{
|
||||
"IN: parser.tests"
|
||||
"USING: math arrays ;"
|
||||
"GENERIC# change-combination 1"
|
||||
"GENERIC# change-combination 1 ( a -- b )"
|
||||
"M: integer change-combination 1 ;"
|
||||
"M: array change-combination 2 ;"
|
||||
} "\n" join <string-reader> "change-combination-test" parse-stream drop
|
||||
|
|
@ -467,7 +463,7 @@ IN: parser.tests
|
|||
] unit-test
|
||||
|
||||
[ [ ] ] [
|
||||
"IN: parser.tests : staging-problem-test-1 1 ; : staging-problem-test-2 staging-problem-test-1 ;"
|
||||
"IN: parser.tests : staging-problem-test-1 ( -- ) 1 ; : staging-problem-test-2 ( -- ) staging-problem-test-1 ;"
|
||||
<string-reader> "staging-problem-test" parse-stream
|
||||
] unit-test
|
||||
|
||||
|
|
@ -476,7 +472,7 @@ IN: parser.tests
|
|||
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
|
||||
|
||||
[ [ ] ] [
|
||||
"IN: parser.tests << : staging-problem-test-1 1 ; >> : staging-problem-test-2 staging-problem-test-1 ;"
|
||||
"IN: parser.tests << : staging-problem-test-1 ( -- ) 1 ; >> : staging-problem-test-2 ( -- ) staging-problem-test-1 ;"
|
||||
<string-reader> "staging-problem-test" parse-stream
|
||||
] unit-test
|
||||
|
||||
|
|
@ -495,7 +491,7 @@ IN: parser.tests
|
|||
! Bogus error message
|
||||
DEFER: blahy
|
||||
|
||||
[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ; TUPLE: blahy < tuple ; : blahy ;" eval ]
|
||||
[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval ]
|
||||
[ error>> error>> def>> \ blahy eq? ] must-fail-with
|
||||
|
||||
[ ] [ f lexer set f file set "Hello world" note. ] unit-test
|
||||
|
|
@ -510,7 +506,7 @@ SYMBOLS: a b c ;
|
|||
|
||||
DEFER: blah
|
||||
|
||||
[ ] [ "IN: parser.tests GENERIC: blah" eval ] unit-test
|
||||
[ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval ] unit-test
|
||||
[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval ] unit-test
|
||||
|
||||
[ f ] [ \ blah generic? ] unit-test
|
||||
|
|
@ -523,13 +519,13 @@ DEFER: blah1
|
|||
must-fail-with
|
||||
|
||||
IN: qualified.tests.foo
|
||||
: x 1 ;
|
||||
: y 5 ;
|
||||
: x ( -- a ) 1 ;
|
||||
: y ( -- a ) 5 ;
|
||||
IN: qualified.tests.bar
|
||||
: x 2 ;
|
||||
: y 4 ;
|
||||
: x ( -- a ) 2 ;
|
||||
: y ( -- a ) 4 ;
|
||||
IN: qualified.tests.baz
|
||||
: x 3 ;
|
||||
: x ( -- a ) 3 ;
|
||||
|
||||
QUALIFIED: qualified.tests.foo
|
||||
QUALIFIED: qualified.tests.bar
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: arrays definitions generic assocs kernel math namespaces
|
|||
sequences strings vectors words words.symbol quotations io combinators
|
||||
sorting splitting math.parser effects continuations io.files vocabs
|
||||
io.encodings.utf8 source-files classes hashtables compiler.errors
|
||||
compiler.units accessors sets lexer vocabs.parser slots ;
|
||||
compiler.units accessors sets lexer vocabs.parser effects.parser slots ;
|
||||
IN: parser
|
||||
|
||||
: location ( -- loc )
|
||||
|
|
@ -132,7 +132,10 @@ M: f parse-quotation \ ] parse-until >quotation ;
|
|||
: parse-definition ( -- quot )
|
||||
\ ; parse-until >quotation ;
|
||||
|
||||
: (:) ( -- word def ) CREATE-WORD parse-definition ;
|
||||
: (:) ( -- word def effect )
|
||||
CREATE-WORD
|
||||
complete-effect
|
||||
parse-definition swap ;
|
||||
|
||||
ERROR: bad-number ;
|
||||
|
||||
|
|
|
|||
|
|
@ -176,7 +176,7 @@ PRIVATE>
|
|||
3 swap bounds-check nip first4-unsafe ; flushable
|
||||
|
||||
: ?nth ( n seq -- elt/f )
|
||||
2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; flushable
|
||||
2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; inline
|
||||
|
||||
MIXIN: virtual-sequence
|
||||
GENERIC: virtual-seq ( seq -- seq' )
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
|
|||
object bootstrap-word >>class ;
|
||||
|
||||
: define-typecheck ( class generic quot props -- )
|
||||
[ dup define-simple-generic create-method ] 2dip
|
||||
[ create-method ] 2dip
|
||||
[ [ props>> ] [ drop ] [ ] tri* update ]
|
||||
[ drop define ]
|
||||
3bi ;
|
||||
|
|
@ -36,7 +36,6 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
|
|||
|
||||
: reader-word ( name -- word )
|
||||
">>" append "accessors" create
|
||||
dup (( object -- value )) "declared-effect" set-word-prop
|
||||
dup t "reader" set-word-prop ;
|
||||
|
||||
: reader-props ( slot-spec -- assoc )
|
||||
|
|
@ -46,13 +45,18 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
|
|||
t "flushable" set
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: define-reader-generic ( name -- )
|
||||
reader-word (( object -- value )) define-simple-generic ;
|
||||
|
||||
: define-reader ( class slot-spec -- )
|
||||
[ name>> reader-word ] [ reader-quot ] [ reader-props ] tri
|
||||
define-typecheck ;
|
||||
[ nip name>> define-reader-generic ]
|
||||
[
|
||||
[ name>> reader-word ] [ reader-quot ] [ reader-props ] tri
|
||||
define-typecheck
|
||||
] 2bi ;
|
||||
|
||||
: writer-word ( name -- word )
|
||||
"(>>" ")" surround "accessors" create
|
||||
dup (( value object -- )) "declared-effect" set-word-prop
|
||||
dup t "writer" set-word-prop ;
|
||||
|
||||
ERROR: bad-slot-value value class ;
|
||||
|
|
@ -92,9 +96,14 @@ ERROR: bad-slot-value value class ;
|
|||
: writer-props ( slot-spec -- assoc )
|
||||
"writing" associate ;
|
||||
|
||||
: define-writer-generic ( name -- )
|
||||
writer-word (( object value -- )) define-simple-generic ;
|
||||
|
||||
: define-writer ( class slot-spec -- )
|
||||
[ name>> writer-word ] [ writer-quot ] [ writer-props ] tri
|
||||
define-typecheck ;
|
||||
[ nip name>> define-writer-generic ] [
|
||||
[ name>> writer-word ] [ writer-quot ] [ writer-props ] tri
|
||||
define-typecheck
|
||||
] 2bi ;
|
||||
|
||||
: setter-word ( name -- word )
|
||||
">>" prepend "accessors" create ;
|
||||
|
|
@ -134,8 +143,8 @@ ERROR: bad-slot-value value class ;
|
|||
|
||||
: define-protocol-slot ( name -- )
|
||||
{
|
||||
[ reader-word define-simple-generic ]
|
||||
[ writer-word define-simple-generic ]
|
||||
[ define-reader-generic ]
|
||||
[ define-writer-generic ]
|
||||
[ define-setter ]
|
||||
[ define-changer ]
|
||||
} cleave ;
|
||||
|
|
|
|||
|
|
@ -508,8 +508,8 @@ HELP: P"
|
|||
HELP: (
|
||||
{ $syntax "( inputs -- outputs )" }
|
||||
{ $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } }
|
||||
{ $description "Declares the stack effect of the most recently defined word, storing a new " { $link effect } " instance in the " { $snippet "\"declared-effect\"" } " word property." }
|
||||
{ $notes "All words except those only pushing literals on the stack must have a stack effect declaration. See " { $link "effect-declaration" } " for details." } ;
|
||||
{ $description "A stack effect declaration. This is treated as a comment unless it appears inside a word definition." }
|
||||
{ $see-also "effect-declaration" } ;
|
||||
|
||||
HELP: ((
|
||||
{ $syntax "(( inputs -- outputs ))" }
|
||||
|
|
|
|||
|
|
@ -111,7 +111,7 @@ IN: bootstrap.syntax
|
|||
"delimiter" [ word t "delimiter" set-word-prop ] define-core-syntax
|
||||
|
||||
"SYNTAX:" [
|
||||
(:) define-syntax
|
||||
CREATE-WORD parse-definition define-syntax
|
||||
] define-core-syntax
|
||||
|
||||
"SYMBOL:" [
|
||||
|
|
@ -127,6 +127,11 @@ IN: bootstrap.syntax
|
|||
";" parse-tokens
|
||||
[ create-class-in define-singleton-class ] each
|
||||
] define-core-syntax
|
||||
|
||||
"DEFER:" [
|
||||
scan current-vocab create
|
||||
[ fake-definition ] [ set-word ] [ [ undefined ] define ] tri
|
||||
] define-core-syntax
|
||||
|
||||
"ALIAS:" [
|
||||
CREATE-WORD scan-word define-alias
|
||||
|
|
@ -136,32 +141,24 @@ IN: bootstrap.syntax
|
|||
CREATE scan-object define-constant
|
||||
] define-core-syntax
|
||||
|
||||
"DEFER:" [
|
||||
scan current-vocab create
|
||||
[ fake-definition ] [ set-word ] [ [ undefined ] define ] tri
|
||||
] define-core-syntax
|
||||
|
||||
":" [
|
||||
(:) define
|
||||
(:) define-declared
|
||||
] define-core-syntax
|
||||
|
||||
"GENERIC:" [
|
||||
CREATE-GENERIC define-simple-generic
|
||||
[ simple-combination ] (GENERIC:)
|
||||
] define-core-syntax
|
||||
|
||||
"GENERIC#" [
|
||||
CREATE-GENERIC
|
||||
scan-word <standard-combination> define-generic
|
||||
[ scan-word <standard-combination> ] (GENERIC:)
|
||||
] define-core-syntax
|
||||
|
||||
"MATH:" [
|
||||
CREATE-GENERIC
|
||||
T{ math-combination } define-generic
|
||||
[ math-combination ] (GENERIC:)
|
||||
] define-core-syntax
|
||||
|
||||
"HOOK:" [
|
||||
CREATE-GENERIC scan-word
|
||||
<hook-combination> define-generic
|
||||
[ scan-word <hook-combination> ] (GENERIC:)
|
||||
] define-core-syntax
|
||||
|
||||
"M:" [
|
||||
|
|
@ -221,8 +218,7 @@ IN: bootstrap.syntax
|
|||
] define-core-syntax
|
||||
|
||||
"(" [
|
||||
")" parse-effect
|
||||
word dup [ set-stack-effect ] [ 2drop ] if
|
||||
")" parse-effect drop
|
||||
] define-core-syntax
|
||||
|
||||
"((" [
|
||||
|
|
|
|||
|
|
@ -132,7 +132,7 @@ IN: vocabs.loader.tests
|
|||
"vocabs.loader.test.d" vocab source-loaded?>>
|
||||
] unit-test
|
||||
|
||||
: forget-junk
|
||||
: forget-junk ( -- )
|
||||
[
|
||||
{ "2" "a" "b" "d" "e" "f" }
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
IN: vocabs.loader.test.d
|
||||
|
||||
: foo iterate-next ;
|
||||
: foo ( -- ) iterate-next ;
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007, 2008 Daniel Ehrenberg, Bruno Deferrari,
|
||||
! Copyright (C) 2007, 2009 Daniel Ehrenberg, Bruno Deferrari,
|
||||
! Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs hashtables kernel namespaces sequences
|
||||
|
|
@ -56,4 +56,4 @@ SYMBOL: in
|
|||
dup string? [ "Vocabulary name must be a string" throw ] unless ;
|
||||
|
||||
: set-in ( name -- )
|
||||
check-vocab-string dup in set create-vocab (use+) ;
|
||||
check-vocab-string dup in set create-vocab (use+) ;
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue