steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2009-03-23 20:04:20 -05:00
parent 51e82806d6 919f544d64
commit 86f6763725
272 changed files with 2381 additions and 1499 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alien/c-types/c-types-tests.factor
View File

@ -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

2
basis/alien/destructors/destructors.factor
View File

@ -26,4 +26,4 @@ M: F-destructor dispose* alien>> F ;
;FUNCTOR
: DESTRUCTOR: scan-word define-destructor ; parsing
SYNTAX: DESTRUCTOR: scan-word define-destructor ;

14
basis/alien/fortran/fortran.factor
View File

@ -416,7 +416,7 @@ PRIVATE>
: define-fortran-record ( name vocab fields -- )
[ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
: RECORD: scan in get parse-definition define-fortran-record ; parsing
SYNTAX: RECORD: scan in get parse-definition define-fortran-record ;
: set-fortran-abi ( library -- )
library-fortran-abis get-global at fortran-abi set ;
@ -437,16 +437,16 @@ MACRO: fortran-invoke ( return library function parameters -- )
return library function parameters return [ "void" ] unless* parse-arglist
[ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
: SUBROUTINE:
SYNTAX: SUBROUTINE:
f "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ; parsing
[ "()" subseq? not ] filter define-fortran-function ;
: FUNCTION:
SYNTAX: FUNCTION:
scan "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter define-fortran-function ; parsing
[ "()" subseq? not ] filter define-fortran-function ;
: LIBRARY:
SYNTAX: LIBRARY:
scan
[ "c-library" set ]
[ set-fortran-abi ] bi ; parsing
[ set-fortran-abi ] bi ;

38
basis/alien/structs/fields/fields.factor
View File

@ -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 ;

2
basis/alien/structs/structs-tests.factor
View File

@ -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" } ;

22
basis/alien/structs/structs.factor
View File

@ -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>> ;

31
basis/alien/syntax/syntax.factor
View File

@ -7,35 +7,34 @@ effects assocs combinators lexer strings.parser alien.parser
fry vocabs.parser words.constant ;
IN: alien.syntax
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
SYNTAX: DLL" lexer get skip-blank parse-string dlopen parsed ;
: ALIEN: scan string>number <alien> parsed ; parsing
SYNTAX: ALIEN: scan string>number <alien> parsed ;
: BAD-ALIEN <bad-alien> parsed ; parsing
SYNTAX: BAD-ALIEN <bad-alien> parsed ;
: LIBRARY: scan "c-library" set ; parsing
SYNTAX: LIBRARY: scan "c-library" set ;
: FUNCTION:
SYNTAX: FUNCTION:
scan "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter
define-function ; parsing
define-function ;
: TYPEDEF:
scan scan typedef ; parsing
SYNTAX: TYPEDEF:
scan scan typedef ;
: C-STRUCT:
scan in get parse-definition define-struct ; parsing
SYNTAX: C-STRUCT:
scan in get parse-definition define-struct ;
: C-UNION:
scan parse-definition define-union ; parsing
SYNTAX: C-UNION:
scan parse-definition define-union ;
: C-ENUM:
SYNTAX: C-ENUM:
";" parse-tokens
[ [ create-in ] dip define-constant ] each-index ;
parsing
: address-of ( name library -- value )
load-library dlsym [ "No such symbol" throw ] unless* ;
: &:
scan "c-library" get '[ _ _ address-of ] over push-all ; parsing
SYNTAX: &:
scan "c-library" get '[ _ _ address-of ] over push-all ;

2
basis/bit-arrays/bit-arrays.factor
View File

@ -68,7 +68,7 @@ M: bit-array resize
M: bit-array byte-length length 7 + -3 shift ;
: ?{ \ } [ >bit-array ] parse-literal ; parsing
SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
: integer>bit-array ( n -- bit-array )
dup 0 = [

2
basis/bit-vectors/bit-vectors-tests.factor
View File

@ -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 ] [

2
basis/bit-vectors/bit-vectors.factor
View File

@ -31,7 +31,7 @@ M: bit-array new-resizable drop <bit-vector> ;
INSTANCE: bit-vector growable
: ?V{ \ } [ >bit-vector ] parse-literal ; parsing
SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;
M: bit-vector >pprint-sequence ;
M: bit-vector pprint-delims drop \ ?V{ \ } ;

11
basis/bootstrap/image/image.factor
View File

@ -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 )

2
basis/byte-vectors/byte-vectors-tests.factor
View File

@ -4,7 +4,7 @@ prettyprint ;
[ 0 ] [ 123 <byte-vector> length ] unit-test
: do-it
: do-it ( seq -- seq )
123 [ over push ] each ;
[ t ] [

2
basis/byte-vectors/byte-vectors.factor
View File

@ -42,7 +42,7 @@ M: byte-array like
M: byte-array new-resizable drop <byte-vector> ;
: BV{ \ } [ >byte-vector ] parse-literal ; parsing
SYNTAX: BV{ \ } [ >byte-vector ] parse-literal ;
M: byte-vector pprint* pprint-object ;
M: byte-vector pprint-delims drop \ BV{ \ } ;

2
basis/calendar/calendar-tests.factor
View File

@ -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

5
basis/calendar/format/format.factor
View File

@ -46,6 +46,11 @@ IN: calendar.format
: read-0000 ( -- n ) 4 read string>number ;
: hhmm>timestamp ( hhmm -- timestamp )
[
0 0 0 read-00 read-00 0 instant <timestamp>
] with-string-reader ;
GENERIC: day. ( obj -- )
M: integer day. ( n -- )

2
basis/cocoa/cocoa-tests.factor
View File

@ -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 ;

12
basis/cocoa/cocoa.factor
View File

@ -14,18 +14,14 @@ SYMBOL: sent-messages
: remember-send ( selector -- )
sent-messages (remember-send) ;
: ->
scan dup remember-send parsed \ send parsed ;
parsing
SYNTAX: -> scan dup remember-send parsed \ send parsed ;
SYMBOL: super-sent-messages
: remember-super-send ( selector -- )
super-sent-messages (remember-send) ;
: SUPER->
scan dup remember-super-send parsed \ super-send parsed ;
parsing
SYNTAX: SUPER-> scan dup remember-super-send parsed \ super-send parsed ;
SYMBOL: frameworks
@ -33,9 +29,9 @@ frameworks [ V{ } clone ] initialize
[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ; parsing
SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
: IMPORT: scan [ ] import-objc-class ; parsing
SYNTAX: IMPORT: scan [ ] import-objc-class ;
"Compiling Objective C bridge..." print

12
basis/cocoa/messages/messages.factor
View File

@ -22,15 +22,13 @@ SYMBOL: super-message-senders
message-senders [ H{ } clone ] initialize
super-message-senders [ H{ } clone ] initialize
: cache-stub ( method function hash -- )
[
over get [ 2drop ] [ over [ sender-stub ] dip set ] if
] bind ;
: cache-stub ( method assoc function -- )
'[ _ sender-stub ] cache drop ;
: cache-stubs ( method -- )
dup
"objc_msgSendSuper" super-message-senders get cache-stub
"objc_msgSend" message-senders get cache-stub ;
[ super-message-senders get "objc_msgSendSuper" cache-stub ]
[ message-senders get "objc_msgSend" cache-stub ]
bi ;
: <super> ( receiver -- super )
"objc-super" <c-object> [

4
basis/cocoa/subclassing/subclassing.factor
View File

@ -76,6 +76,6 @@ SYMBOL: +superclass+
import-objc-class
] bind ;
: CLASS:
SYNTAX: CLASS:
parse-definition unclip
>hashtable define-objc-class ; parsing
>hashtable define-objc-class ;

2
basis/colors/constants/constants.factor
View File

@ -30,4 +30,4 @@ ERROR: no-such-color name ;
: named-color ( name -- color )
dup rgb.txt at [ ] [ no-such-color ] ?if ;
: COLOR: scan named-color parsed ; parsing
SYNTAX: COLOR: scan named-color parsed ;

4
basis/compiler/cfg/instructions/syntax/syntax.factor
View File

@ -13,10 +13,10 @@ IN: compiler.cfg.instructions.syntax
: insn-effect ( word -- effect )
boa-effect in>> but-last f <effect> ;
: INSN:
SYNTAX: INSN:
parse-tuple-definition "regs" suffix
[ dup tuple eq? [ drop insn-word ] when ] dip
[ define-tuple-class ]
[ 2drop save-location ]
[ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
3tri ; parsing
3tri ;

6
basis/compiler/cfg/registers/registers.factor
View File

@ -17,6 +17,6 @@ C: <ds-loc> ds-loc
TUPLE: rs-loc < loc ;
C: <rs-loc> rs-loc
: V scan-word scan-word vreg boa parsed ; parsing
: D scan-word <ds-loc> parsed ; parsing
: R scan-word <rs-loc> parsed ; parsing
SYNTAX: V scan-word scan-word vreg boa parsed ;
SYNTAX: D scan-word <ds-loc> parsed ;
SYNTAX: R scan-word <rs-loc> parsed ;

9
basis/compiler/compiler.factor
View File

@ -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 ;

6
basis/compiler/tests/intrinsics.factor
View File

@ -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 [

26
basis/compiler/tests/optimizer.factor
View File

@ -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 ;

20
basis/compiler/tests/redefine15.factor Normal file
View File

@ -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

4
basis/compiler/tests/redefine2.factor
View File

@ -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

4
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -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 ]

6
basis/constructors/constructors.factor
View File

@ -16,8 +16,8 @@ MACRO: set-slots ( slots -- quot )
[ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
define-declared ;
: CONSTRUCTOR:
SYNTAX: CONSTRUCTOR:
scan-word [ name>> "<" ">" surround create-in ] keep
"(" expect ")" parse-effect
complete-effect
parse-definition
define-constructor ; parsing
define-constructor ;

4
basis/core-text/utilities/utilities.factor
View File

@ -3,7 +3,7 @@
USING: words parser alien alien.c-types kernel fry accessors ;
IN: core-text.utilities
: C-GLOBAL:
SYNTAX: C-GLOBAL:
CREATE-WORD
dup name>> '[ _ f dlsym *void* ]
(( -- value )) define-declared ; parsing
(( -- value )) define-declared ;

28
basis/cpu/ppc/assembler/backend/backend.factor
View File

@ -21,7 +21,7 @@ IN: cpu.ppc.assembler.backend
: define-d-insn ( word opcode -- )
[ d-insn ] curry (( d a simm -- )) define-declared ;
: D: CREATE scan-word define-d-insn ; parsing
SYNTAX: D: CREATE scan-word define-d-insn ;
: sd-insn ( d a simm opcode -- )
[ s>u16 { 0 21 16 } bitfield ] dip insn ;
@ -29,7 +29,7 @@ IN: cpu.ppc.assembler.backend
: define-sd-insn ( word opcode -- )
[ sd-insn ] curry (( d a simm -- )) define-declared ;
: SD: CREATE scan-word define-sd-insn ; parsing
SYNTAX: SD: CREATE scan-word define-sd-insn ;
: i-insn ( li aa lk opcode -- )
[ { 0 1 0 } bitfield ] dip insn ;
@ -40,26 +40,26 @@ IN: cpu.ppc.assembler.backend
: (X) ( -- word quot )
CREATE scan-word scan-word scan-word [ x-insn ] 3curry ;
: X: (X) (( a s b -- )) define-declared ; parsing
SYNTAX: X: (X) (( a s b -- )) define-declared ;
: (1) ( quot -- quot' ) [ 0 ] prepose ;
: X1: (X) (1) (( a s -- )) define-declared ; parsing
SYNTAX: X1: (X) (1) (( a s -- )) define-declared ;
: xfx-insn ( d spr xo opcode -- )
[ { 1 11 21 } bitfield ] dip insn ;
: CREATE-MF ( -- word ) scan "MF" prepend create-in ;
: MFSPR:
SYNTAX: MFSPR:
CREATE-MF scan-word 5 shift [ 339 31 xfx-insn ] curry
(( d -- )) define-declared ; parsing
(( d -- )) define-declared ;
: CREATE-MT ( -- word ) scan "MT" prepend create-in ;
: MTSPR:
SYNTAX: MTSPR:
CREATE-MT scan-word 5 shift [ 467 31 xfx-insn ] curry
(( d -- )) define-declared ; parsing
(( d -- )) define-declared ;
: xo-insn ( d a b oe rc xo opcode -- )
[ { 1 0 10 11 16 21 } bitfield ] dip insn ;
@ -68,9 +68,9 @@ IN: cpu.ppc.assembler.backend
CREATE scan-word scan-word scan-word scan-word
[ xo-insn ] 2curry 2curry ;
: XO: (XO) (( a s b -- )) define-declared ; parsing
SYNTAX: XO: (XO) (( a s b -- )) define-declared ;
: XO1: (XO) (1) (( a s -- )) define-declared ; parsing
SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ;
GENERIC# (B) 2 ( dest aa lk -- )
M: integer (B) 18 i-insn ;
@ -84,11 +84,11 @@ M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
: CREATE-B ( -- word ) scan "B" prepend create-in ;
: BC:
SYNTAX: BC:
CREATE-B scan-word scan-word
[ rot BC ] 2curry (( c -- )) define-declared ; parsing
[ rot BC ] 2curry (( c -- )) define-declared ;
: B:
SYNTAX: B:
CREATE-B scan-word scan-word scan-word scan-word scan-word
[ b-insn ] curry curry curry curry curry
(( bo -- )) define-declared ; parsing
(( bo -- )) define-declared ;

4
basis/cpu/ppc/bootstrap.factor
View File

@ -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 ;

3
basis/cpu/x86/assembler/syntax/syntax.factor
View File

@ -11,5 +11,4 @@ IN: cpu.x86.assembler.syntax
: define-registers ( names size -- )
'[ _ define-register ] each-index ;
: REGISTERS: ( -- )
scan-word ";" parse-tokens swap define-registers ; parsing
SYNTAX: REGISTERS: scan-word ";" parse-tokens swap define-registers ;

6
basis/db/tuples/tuples-tests.factor
View File

@ -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 }

4
basis/definitions/icons/icons.factor
View File

@ -14,10 +14,10 @@ GENERIC: definition-icon ( definition -- path )
<<
: ICON:
SYNTAX: ICON:
scan-word \ definition-icon create-method
scan '[ drop _ definition-icon-path ]
define ; parsing
define ;
>>

8
basis/delegate/delegate-tests.factor
View File

@ -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 ;

12
basis/delegate/delegate.factor
View File

@ -85,9 +85,9 @@ PRIVATE>
: define-consult ( consultation -- )
[ register-consult ] [ consult-methods ] bi ;
: CONSULT:
SYNTAX: CONSULT:
scan-word scan-word parse-definition <consultation>
[ save-location ] [ define-consult ] bi ; parsing
[ save-location ] [ define-consult ] bi ;
M: consultation where loc>> ;
@ -144,8 +144,8 @@ PRIVATE>
[ initialize-protocol-props ] 2tri
] 2bi ;
: PROTOCOL:
CREATE-WORD parse-definition define-protocol ; parsing
SYNTAX: PROTOCOL:
CREATE-WORD parse-definition define-protocol ;
PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
@ -159,7 +159,7 @@ M: protocol definer drop \ PROTOCOL: \ ; ;
M: protocol group-words protocol-words ;
: SLOT-PROTOCOL:
SYNTAX: SLOT-PROTOCOL:
CREATE-WORD ";" parse-tokens
[ [ reader-word ] [ writer-word ] bi 2array ] map concat
define-protocol ; parsing
define-protocol ;

6
basis/environment/environment-docs.factor
View File

@ -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

2
basis/farkup/farkup-docs.factor
View File

@ -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" } "." } ;

2
basis/fry/fry-tests.factor
View File

@ -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

2
basis/fry/fry.factor
View File

@ -53,4 +53,4 @@ M: callable deep-fry
M: object deep-fry , ;
: '[ parse-quotation fry over push-all ; parsing
SYNTAX: '[ parse-quotation fry over push-all ;

2
basis/functors/functors-tests.factor
View File

@ -13,7 +13,7 @@ WHERE
TUPLE: B { value T } ;
C: <B> B
C: <B> B ( T -- B )
;FUNCTOR

62
basis/functors/functors.factor
View File

@ -14,7 +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-declared* ( word def effect -- ) pick set-word define-declared ;
TUPLE: fake-quotation seq ;
@ -39,9 +41,14 @@ 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 ;
: `TUPLE:
: DEFINE* ( accum -- accum ) \ define-declared* parsed ;
SYNTAX: `TUPLE:
scan-param parsed
scan {
{ ";" [ tuple parsed f parsed ] }
@ -52,40 +59,38 @@ M: object fake-quotations> ;
make parsed
]
} case
\ define-tuple-class parsed ; parsing
\ define-tuple-class parsed ;
: `M:
effect off
SYNTAX: `M:
scan-param parsed
scan-param parsed
\ create-method-in parsed
parse-definition*
DEFINE* ; parsing
\ define* parsed ;
: `C:
effect off
SYNTAX: `C:
scan-param parsed
scan-param parsed
[ [ boa ] curry ] over push-all
DEFINE* ; parsing
complete-effect
[ [ [ boa ] curry ] over push-all ] dip parsed
\ define-declared* parsed ;
: `:
effect off
SYNTAX: `:
scan-param parsed
parse-declared*
\ define-declared* parsed ;
SYNTAX: `SYNTAX:
scan-param parsed
parse-definition*
DEFINE* ; parsing
\ define-syntax parsed ;
: `INSTANCE:
SYNTAX: `INSTANCE:
scan-param parsed
scan-param parsed
\ add-mixin-instance parsed ; parsing
\ add-mixin-instance parsed ;
: `inline [ word make-inline ] over push-all ; parsing
: `parsing [ word make-parsing ] over push-all ; parsing
: `(
")" parse-effect effect set ; parsing
SYNTAX: `inline [ word make-inline ] over push-all ;
: (INTERPOLATE) ( accum quot -- accum )
[ scan interpolate-locals ] dip
@ -93,11 +98,11 @@ M: object fake-quotations> ;
PRIVATE>
: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; parsing
SYNTAX: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ;
: DEFINES [ create-in ] (INTERPOLATE) ; parsing
SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ;
: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; parsing
SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;
DEFER: ;FUNCTOR delimiter
@ -110,9 +115,8 @@ DEFER: ;FUNCTOR delimiter
{ "C:" POSTPONE: `C: }
{ ":" POSTPONE: `: }
{ "INSTANCE:" POSTPONE: `INSTANCE: }
{ "SYNTAX:" POSTPONE: `SYNTAX: }
{ "inline" POSTPONE: `inline }
{ "parsing" POSTPONE: `parsing }
{ "(" POSTPONE: `( }
} ;
: push-functor-words ( -- )
@ -127,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>
: FUNCTOR: (FUNCTOR:) define ; parsing
SYNTAX: FUNCTOR: (FUNCTOR:) define-declared ;

2
basis/furnace/actions/actions-tests.factor
View File

@ -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

2
basis/furnace/furnace-tests.factor
View File

@ -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 ;

8
basis/furnace/sessions/sessions-tests.factor
View File

@ -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 ;

3
basis/grouping/grouping-docs.factor
View File

@ -97,8 +97,7 @@ HELP: <clumps>
{ $example
"USING: grouping sequences math prettyprint kernel ;"
"IN: scratchpad"
": share-price"
" { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"
"CONSTANT: share-price { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 }"
""
"share-price 4 <clumps> [ [ sum ] [ length ] bi / ] map ."
"{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"

2
basis/hash2/hash2-tests.factor
View File

@ -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

17
basis/help/cookbook/cookbook.factor
View File

@ -121,16 +121,16 @@ $nl
"sequences"
} ;
ARTICLE: "cookbook-variables" "Variables cookbook"
"Before using a variable, you must define a symbol for it:"
{ $code "SYMBOL: name" }
ARTICLE: "cookbook-variables" "Dynamic variables cookbook"
"A symbol is a word which pushes itself on the stack when executed. Try it:"
{ $example "SYMBOL: foo" "foo ." "foo" }
"Before using a variable, you must define a symbol for it:"
{ $code "SYMBOL: name" }
"Symbols can be passed to the " { $link get } " and " { $link set } " words to read and write variable values:"
{ $example "\"Slava\" name set" "name get print" "Slava" }
{ $unchecked-example "\"Slava\" name set" "name get print" "Slava" }
"If you set variables inside a " { $link with-scope } ", their values will be lost after leaving the scope:"
{ $example
": print-name name get print ;"
{ $unchecked-example
": print-name ( -- ) name get print ;"
"\"Slava\" name set"
"["
" \"Diana\" name set"
@ -139,11 +139,8 @@ ARTICLE: "cookbook-variables" "Variables cookbook"
"\"Here, the name is \" write print-name"
"There, the name is Diana\nHere, the name is Slava"
}
{ $curious
"Variables are dynamically-scoped in Factor."
}
{ $references
"There is a lot more to be said about variables and namespaces."
"There is a lot more to be said about dynamically-scoped variables and namespaces."
"namespaces"
} ;

4
basis/help/crossref/crossref-tests.factor
View File

@ -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
[ ] [

6
basis/help/definitions/definitions-tests.factor
View File

@ -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

2
basis/help/markup/markup-tests.factor
View File

@ -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
basis/help/markup/markup.factor
View File

@ -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 -- )

20
basis/help/syntax/syntax.factor
View File

@ -1,23 +1,19 @@
! 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
vocabs.parser ;
IN: help.syntax
: HELP:
SYNTAX: HELP:
scan-word bootstrap-word
dup set-word
dup >link save-location
\ ; parse-until >array swap set-word-help ; parsing
[ >link save-location ] [ [ \ ; parse-until >array ] dip set-word-help ] bi ;
: ARTICLE:
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 ; parsing
] dip remember-definition ;
: ABOUT:
in get vocab
dup changed-definition
scan-object >>help drop ; parsing
SYNTAX: ABOUT:
in get vocab scan-object >>help changed-definition ;

3
basis/hints/hints.factor
View File

@ -59,12 +59,11 @@ M: object specializer-declaration class ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;
: HINTS:
SYNTAX: HINTS:
scan-object
dup method-spec? [ first2 method ] when
[ redefined ]
[ parse-definition "specializer" set-word-prop ] bi ;
parsing
! Default specializers
{ first first2 first3 first4 }

6
basis/html/templates/chloe/chloe-tests.factor
View File

@ -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 ;
[ "" ] [
[

3
basis/html/templates/chloe/components/components.factor
View File

@ -25,8 +25,7 @@ M: tuple-class component-tag ( tag class -- )
[ compile-component-attrs ] 2bi
[ render ] [code] ;
: COMPONENT:
SYNTAX: COMPONENT:
scan-word
[ name>> ] [ '[ _ component-tag ] ] bi
define-chloe-tag ;
parsing

4
basis/html/templates/chloe/syntax/syntax.factor
View File

@ -15,8 +15,8 @@ tags [ H{ } clone ] initialize
: define-chloe-tag ( name quot -- ) swap tags get set-at ;
: CHLOE:
scan parse-definition define-chloe-tag ; parsing
SYNTAX: CHLOE:
scan parse-definition define-chloe-tag ;
CONSTANT: chloe-ns "http://factorcode.org/chloe/1.0"

2
basis/html/templates/fhtml/fhtml.factor
View File

@ -49,7 +49,7 @@ DEFER: <% delimiter
drop
] if ;
: %> lexer get parse-%> ; parsing
SYNTAX: %> lexer get parse-%> ;
: parse-template-lines ( lines -- quot )
<template-lexer> [

10
basis/http/http-tests.factor
View File

@ -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

4
basis/interpolate/interpolate.factor
View File

@ -38,6 +38,6 @@ MACRO: interpolate ( string -- )
: interpolate-locals ( string -- quot )
[ search [ ] ] (interpolate) ;
: I[
SYNTAX: I[
"]I" parse-multiline-string
interpolate-locals over push-all ; parsing
interpolate-locals over push-all ;

24
basis/interval-maps/interval-maps-docs.factor
View File

@ -1,22 +1,32 @@
USING: help.markup help.syntax ;
! Copyright (C) 2008, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax assocs kernel sequences ;
IN: interval-maps
HELP: interval-at*
{ $values { "key" "an object" } { "map" "an interval map" } { "value" "the value for the key, or f" } { "?" "whether the key is present" } }
{ $values { "key" object } { "map" interval-map } { "value" "the value for the key, or f" } { "?" "whether the key is present" } }
{ $description "Looks up a key in an interval map, returning the corresponding value if the item is in an interval in the map, and a boolean flag. The operation takes O(log n) time." } ;
HELP: interval-at
{ $values { "key" "an object" } { "map" "an interval map" } { "value" "the value for the key, or f" } }
{ $values { "key" object } { "map" interval-map } { "value" "the value for the key, or f" } }
{ $description "Looks up a key in an interval map, returning the value of the corresponding interval, or f if the interval is not present in the map." } ;
HELP: interval-key?
{ $values { "key" "an object" } { "map" "an interval map" } { "?" "a boolean" } }
{ $values { "key" object } { "map" interval-map } { "?" "a boolean" } }
{ $description "Tests whether an object is in an interval in the interval map, returning t if the object is present." } ;
HELP: <interval-map>
{ $values { "specification" "an assoc" } { "map" "an interval map" } }
{ $values { "specification" assoc } { "map" interval-map } }
{ $description "From a specification, produce an interval tree. The specification is an assoc where the keys are intervals, or pairs of numbers to represent intervals, or individual numbers to represent singleton intervals. The values are the values int he interval map. Construction time is O(n log n)." } ;
HELP: interval-values
{ $values { "map" interval-map } { "values" sequence } }
{ $description "Constructs a list of all of the values that interval map keys are associated with. This list may contain duplicates." } ;
HELP: coalesce
{ $values { "alist" "an association list with integer keys" } { "specification" { "array of the format used by " { $link <interval-map> } } } }
{ $description "Finds ranges used in the given alist, coalescing them into a single range." } ;
ARTICLE: "interval-maps" "Interval maps"
"The " { $vocab-link "interval-maps" } " vocabulary implements a data structure, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between."
$nl
@ -24,7 +34,9 @@ $nl
{ $subsection interval-at* }
{ $subsection interval-at }
{ $subsection interval-key? }
{ $subsection interval-values }
"Use the following to construct interval maps"
{ $subsection <interval-map> } ;
{ $subsection <interval-map> }
{ $subsection coalesce } ;
ABOUT: "interval-maps"

17
basis/interval-maps/interval-maps.factor
View File

@ -8,17 +8,21 @@ TUPLE: interval-map array ;
<PRIVATE
ALIAS: start first
ALIAS: end second
ALIAS: value third
: find-interval ( key interval-map -- interval-node )
[ first <=> ] with search nip ;
array>> [ start <=> ] with search nip ;
: interval-contains? ( key interval-node -- ? )
first2 between? ;
[ start ] [ end ] bi between? ;
: all-intervals ( sequence -- intervals )
[ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ;
: disjoint? ( node1 node2 -- ? )
[ second ] [ first ] bi* < ;
[ end ] [ start ] bi* < ;
: ensure-disjoint ( intervals -- intervals )
dup [ disjoint? ] monotonic?
@ -30,14 +34,17 @@ TUPLE: interval-map array ;
PRIVATE>
: interval-at* ( key map -- value ? )
[ drop ] [ array>> find-interval ] 2bi
[ drop ] [ find-interval ] 2bi
[ nip ] [ interval-contains? ] 2bi
[ third t ] [ drop f f ] if ;
[ value t ] [ drop f f ] if ;
: interval-at ( key map -- value ) interval-at* drop ;
: interval-key? ( key map -- ? ) interval-at* nip ;
: interval-values ( map -- values )
array>> [ value ] map ;
: <interval-map> ( specification -- map )
all-intervals [ [ first second ] compare ] sort
>intervals ensure-disjoint interval-map boa ;

8
basis/io/backend/unix/unix-tests.factor
View File

@ -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

4
basis/io/encodings/euc/euc.factor
View File

@ -63,6 +63,6 @@ SYMBOL: euc-table
PRIVATE>
: EUC:
SYNTAX: EUC:
! EUC: euc-kr "vocab:io/encodings/korean/cp949.txt"
CREATE-CLASS scan-object define-euc ; parsing
CREATE-CLASS scan-object define-euc ;

44
basis/io/encodings/iso2022/iso2022-tests.factor
View File

@ -7,30 +7,30 @@ IN: io.encodings.iso2022
[ "hello" ] [ "hello" >byte-array iso2022 decode ] unit-test
[ "hello" ] [ "hello" iso2022 encode >string ] unit-test
[ "hi" ] [ B{ CHAR: h $ ESC CHAR: ( CHAR: B CHAR: i } iso2022 decode ] unit-test
[ "hi" ] [ B{ CHAR: h CHAR: i $ ESC CHAR: ( CHAR: B } iso2022 decode ] unit-test
[ "hi\u00fffd" ] [ B{ CHAR: h CHAR: i $ ESC CHAR: ( } iso2022 decode ] unit-test
[ "hi\u00fffd" ] [ B{ CHAR: h CHAR: i $ ESC } iso2022 decode ] unit-test
[ "hi" ] [ B{ CHAR: h ESC CHAR: ( CHAR: B CHAR: i } iso2022 decode ] unit-test
[ "hi" ] [ B{ CHAR: h CHAR: i ESC CHAR: ( CHAR: B } iso2022 decode ] unit-test
[ "hi\u00fffd" ] [ B{ CHAR: h CHAR: i ESC CHAR: ( } iso2022 decode ] unit-test
[ "hi\u00fffd" ] [ B{ CHAR: h CHAR: i ESC } iso2022 decode ] unit-test
[ B{ CHAR: h $ ESC CHAR: ( CHAR: J HEX: D8 } ] [ "h\u00ff98" iso2022 encode ] unit-test
[ "h\u00ff98" ] [ B{ CHAR: h $ ESC CHAR: ( CHAR: J HEX: D8 } iso2022 decode ] unit-test
[ "hi" ] [ B{ CHAR: h $ ESC CHAR: ( CHAR: J CHAR: i } iso2022 decode ] unit-test
[ "h" ] [ B{ CHAR: h $ ESC CHAR: ( CHAR: J } iso2022 decode ] unit-test
[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: ( CHAR: J HEX: 80 } iso2022 decode ] unit-test
[ B{ CHAR: h ESC CHAR: ( CHAR: J HEX: D8 } ] [ "h\u00ff98" iso2022 encode ] unit-test
[ "h\u00ff98" ] [ B{ CHAR: h ESC CHAR: ( CHAR: J HEX: D8 } iso2022 decode ] unit-test
[ "hi" ] [ B{ CHAR: h ESC CHAR: ( CHAR: J CHAR: i } iso2022 decode ] unit-test
[ "h" ] [ B{ CHAR: h ESC CHAR: ( CHAR: J } iso2022 decode ] unit-test
[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: ( CHAR: J HEX: 80 } iso2022 decode ] unit-test
[ B{ CHAR: h $ ESC CHAR: $ CHAR: B HEX: 3E HEX: 47 } ] [ "h\u007126" iso2022 encode ] unit-test
[ "h\u007126" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: B HEX: 3E HEX: 47 } iso2022 decode ] unit-test
[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: B HEX: 3E } iso2022 decode ] unit-test
[ "h" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: B } iso2022 decode ] unit-test
[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ } iso2022 decode ] unit-test
[ "h\u00fffd" ] [ B{ CHAR: h $ ESC } iso2022 decode ] unit-test
[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: B HEX: 80 HEX: 80 } iso2022 decode ] unit-test
[ B{ CHAR: h ESC CHAR: $ CHAR: B HEX: 3E HEX: 47 } ] [ "h\u007126" iso2022 encode ] unit-test
[ "h\u007126" ] [ B{ CHAR: h ESC CHAR: $ CHAR: B HEX: 3E HEX: 47 } iso2022 decode ] unit-test
[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ CHAR: B HEX: 3E } iso2022 decode ] unit-test
[ "h" ] [ B{ CHAR: h ESC CHAR: $ CHAR: B } iso2022 decode ] unit-test
[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ } iso2022 decode ] unit-test
[ "h\u00fffd" ] [ B{ CHAR: h ESC } iso2022 decode ] unit-test
[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ CHAR: B HEX: 80 HEX: 80 } iso2022 decode ] unit-test
[ B{ CHAR: h $ ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 HEX: 54 } ] [ "h\u0058ce" iso2022 encode ] unit-test
[ "h\u0058ce" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 HEX: 54 } iso2022 decode ] unit-test
[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 } iso2022 decode ] unit-test
[ "h" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: ( CHAR: D } iso2022 decode ] unit-test
[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: ( } iso2022 decode ] unit-test
[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: ( CHAR: D HEX: 70 HEX: 70 } iso2022 decode ] unit-test
[ B{ CHAR: h ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 HEX: 54 } ] [ "h\u0058ce" iso2022 encode ] unit-test
[ "h\u0058ce" ] [ B{ CHAR: h ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 HEX: 54 } iso2022 decode ] unit-test
[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 } iso2022 decode ] unit-test
[ "h" ] [ B{ CHAR: h ESC CHAR: $ CHAR: ( CHAR: D } iso2022 decode ] unit-test
[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ CHAR: ( } iso2022 decode ] unit-test
[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ CHAR: ( CHAR: D HEX: 70 HEX: 70 } iso2022 decode ] unit-test
[ "\u{syriac-music}" iso2022 encode ] must-fail

12
basis/io/encodings/iso2022/iso2022.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings kernel sequences io simple-flat-file sets math
combinators.short-circuit io.binary values arrays assocs
locals accessors combinators literals biassocs byte-arrays ;
locals accessors combinators biassocs byte-arrays parser ;
IN: io.encodings.iso2022
SINGLETON: iso2022
@ -31,12 +31,12 @@ M: iso2022 <encoder>
M: iso2022 <decoder>
make-iso-coder <decoder> ;
CONSTANT: ESC HEX: 16
<< SYNTAX: ESC HEX: 16 parsed ; >>
CONSTANT: switch-ascii B{ $ ESC CHAR: ( CHAR: B }
CONSTANT: switch-jis201 B{ $ ESC CHAR: ( CHAR: J }
CONSTANT: switch-jis208 B{ $ ESC CHAR: $ CHAR: B }
CONSTANT: switch-jis212 B{ $ ESC CHAR: $ CHAR: ( CHAR: D }
CONSTANT: switch-ascii B{ ESC CHAR: ( CHAR: B }
CONSTANT: switch-jis201 B{ ESC CHAR: ( CHAR: J }
CONSTANT: switch-jis208 B{ ESC CHAR: $ CHAR: B }
CONSTANT: switch-jis212 B{ ESC CHAR: $ CHAR: ( CHAR: D }
: find-type ( char -- code type )
{

4
basis/io/encodings/strict/strict-docs.factor
View File

@ -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
basis/io/encodings/utf16n/utf16n-tests.factor
View File

@ -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

8
basis/io/files/unique/unique-docs.factor
View File

@ -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." } ;

4
basis/io/streams/duplex/duplex-tests.factor
View File

@ -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 ;

4
basis/listener/listener-tests.factor
View File

@ -3,7 +3,7 @@ tools.test parser math namespaces continuations vocabs kernel
compiler.units eval vocabs.parser ;
IN: listener.tests
: hello "Hi" print ; parsing
SYNTAX: hello "Hi" print ;
: parse-interactive ( string -- quot )
<string-reader> stream-read-quot ;
@ -50,7 +50,7 @@ IN: listener.tests
[
[ ] [
"IN: listener.tests : hello\n\"world\" ;" parse-interactive
"IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive
drop
] unit-test
] with-file-vocabs

2
basis/lists/lazy/lazy-docs.factor
View File

@ -108,7 +108,7 @@ HELP: lappend
{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
HELP: lfrom-by
{ $values { "n" "an integer" } { "quot" { $quotation "( -- int )" } } { "list" "a lazy list of integers" } }
{ $values { "n" "an integer" } { "quot" { $quotation "( -- int )" } } { "lazy-from-by" "a lazy list of integers" } }
{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;
HELP: lfrom

2
basis/lists/lazy/lazy.factor
View File

@ -203,7 +203,7 @@ M: lazy-append nil? ( lazy-append -- bool )
TUPLE: lazy-from-by n quot ;
C: lfrom-by lazy-from-by ( n quot -- list )
C: lfrom-by lazy-from-by
: lfrom ( n -- list )
[ 1+ ] lfrom-by ;

4
basis/lists/lists-docs.factor
View File

@ -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

71
basis/locals/locals-tests.factor
View File

@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order math.functions
definitions compiler.units fry lexer words.symbol see ;
definitions compiler.units fry lexer words.symbol see multiline ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
@ -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 )
@ -392,6 +392,65 @@ ERROR: punned-class x ;
[ 9 ] [ 3 big-case-test ] unit-test
! Dan found this problem
: littledan-case-problem-1 ( a -- b )
{
{ t [ 3 ] }
{ f [ 4 ] }
[| x | x 12 + { "howdy" } nth ]
} case ;
\ littledan-case-problem-1 must-infer
[ "howdy" ] [ -12 \ littledan-case-problem-1 def>> call ] unit-test
[ "howdy" ] [ -12 littledan-case-problem-1 ] unit-test
:: littledan-case-problem-2 ( a -- b )
a {
{ t [ a not ] }
{ f [ 4 ] }
[| x | x a - { "howdy" } nth ]
} case ;
\ littledan-case-problem-2 must-infer
[ "howdy" ] [ -12 \ littledan-case-problem-2 def>> call ] unit-test
[ "howdy" ] [ -12 littledan-case-problem-2 ] unit-test
:: littledan-cond-problem-1 ( a -- b )
a {
{ [ dup 0 < ] [ drop a not ] }
{ [| y | y y 0 > ] [ drop 4 ] }
[| x | x a - { "howdy" } nth ]
} cond ;
\ littledan-cond-problem-1 must-infer
[ f ] [ -12 \ littledan-cond-problem-1 def>> call ] unit-test
[ 4 ] [ 12 \ littledan-cond-problem-1 def>> call ] unit-test
[ "howdy" ] [ 0 \ littledan-cond-problem-1 def>> call ] unit-test
[ f ] [ -12 littledan-cond-problem-1 ] unit-test
[ 4 ] [ 12 littledan-cond-problem-1 ] unit-test
[ "howdy" ] [ 0 littledan-cond-problem-1 ] unit-test
/*
:: littledan-case-problem-3 ( a quot -- b )
a {
{ t [ a not ] }
{ f [ 4 ] }
quot
} case ; inline
[ f ] [ t [ ] littledan-case-problem-3 ] unit-test
[ 144 ] [ 12 [ sq ] littledan-case-problem-3 ] unit-test
[| | [| a | a ] littledan-case-problem-3 ] must-infer
: littledan-case-problem-4 ( a -- b )
[ 1 + ] littledan-case-problem-3 ;
\ littledan-case-problem-4 must-infer
*/
GENERIC: lambda-method-forget-test ( a -- b )
M:: integer lambda-method-forget-test ( a -- b ) ;

24
basis/locals/locals.factor
View File

@ -1,31 +1,29 @@
! 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
locals.errors ;
IN: locals
: :>
SYNTAX: :>
scan locals get [ :>-outside-lambda-error ] unless*
[ make-local ] bind <def> parsed ; parsing
[ make-local ] bind <def> parsed ;
: [| parse-lambda over push-all ; parsing
SYNTAX: [| parse-lambda over push-all ;
: [let parse-let over push-all ; parsing
SYNTAX: [let parse-let over push-all ;
: [let* parse-let* over push-all ; parsing
SYNTAX: [let* parse-let* over push-all ;
: [wlet parse-wlet over push-all ; parsing
SYNTAX: [wlet parse-wlet over push-all ;
: :: (::) define ; parsing
SYNTAX: :: (::) define-declared ;
: M:: (M::) define ; parsing
SYNTAX: M:: (M::) define ;
: MACRO:: (::) define-macro ; parsing
SYNTAX: MACRO:: (::) define-macro ;
: MEMO:: (::) define-memoized ; parsing
USE: syntax
SYNTAX: MEMO:: (::) define-memoized ;
{
"locals.macros"

7
basis/locals/macros/macros.factor
View File

@ -1,6 +1,6 @@
! 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: accessors assocs kernel locals.types macros.expander ;
USING: accessors assocs kernel locals.types macros.expander fry ;
IN: locals.macros
M: lambda expand-macros clone [ expand-macros ] change-body ;
@ -14,3 +14,6 @@ M: binding-form expand-macros
M: binding-form expand-macros* expand-macros literal ;
M: lambda condomize? drop t ;
M: lambda condomize '[ @ ] ;

17
basis/locals/parser/parser.factor
View File

@ -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 ;

4
basis/logging/logging.factor
View File

@ -135,11 +135,11 @@ PRIVATE>
[ [ input-logging-quot ] 2keep drop error-logging-quot ]
(define-logging) ;
: LOG:
SYNTAX: LOG:
#! Syntax: name level
CREATE-WORD dup scan-word
'[ 1array stack>message _ _ log-message ]
(( message -- )) define-declared ; parsing
(( message -- )) define-declared ;
USE: vocabs.loader

22
basis/macros/expander/expander.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private namespaces make
quotations accessors words continuations vectors effects math
generalizations fry ;
generalizations fry arrays ;
IN: macros.expander
GENERIC: expand-macros ( quot -- quot' )
@ -17,7 +17,23 @@ SYMBOL: stack
[ delete-all ]
bi ;
: literal ( obj -- ) stack get push ;
GENERIC: condomize? ( obj -- ? )
M: array condomize? [ condomize? ] any? ;
M: callable condomize? [ condomize? ] any? ;
M: object condomize? drop f ;
GENERIC: condomize ( obj -- obj' )
M: array condomize [ condomize ] map ;
M: callable condomize [ condomize ] map ;
M: object condomize ;
: literal ( obj -- ) dup condomize? [ condomize ] when stack get push ;
GENERIC: expand-macros* ( obj -- )

10
basis/macros/macros-tests.factor
View File

@ -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

15
basis/macros/macros.factor
View File

@ -6,17 +6,18 @@ 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 ;
: MACRO: (:) define-macro ; parsing
SYNTAX: MACRO: (:) define-macro ;
PREDICATE: macro < word "macro" word-prop >boolean ;

4
basis/match/match.factor
View File

@ -16,8 +16,8 @@ SYMBOL: _
: define-match-vars ( seq -- )
[ define-match-var ] each ;
: MATCH-VARS: ! vars ...
";" parse-tokens define-match-vars ; parsing
SYNTAX: MATCH-VARS: ! vars ...
";" parse-tokens define-match-vars ;
: match-var? ( symbol -- bool )
dup word? [ "match-var" word-prop ] [ drop f ] if ;

4
basis/math/bitwise/bitwise-docs.factor
View File

@ -139,8 +139,8 @@ HELP: flags
{ $examples
{ $example "USING: math.bitwise kernel prettyprint ;"
"IN: scratchpad"
": MY-CONSTANT HEX: 1 ; inline"
"{ HEX: 20 MY-CONSTANT BIN: 100 } flags .h"
"CONSTANT: x HEX: 1"
"{ HEX: 20 x BIN: 100 } flags .h"
"25"
}
} ;

2
basis/math/blas/matrices/matrices.factor
View File

@ -289,7 +289,7 @@ M: MATRIX n*V(*)V+M!
M: MATRIX n*V(*)Vconj+M!
(prepare-ger) [ XGERC ] dip ;
: XMATRIX{ \ } [ >MATRIX ] parse-literal ; parsing
SYNTAX: XMATRIX{ \ } [ >MATRIX ] parse-literal ;
M: MATRIX pprint-delims
drop \ XMATRIX{ \ } ;

2
basis/math/blas/vectors/vectors.factor
View File

@ -179,7 +179,7 @@ M: VECTOR n*V+V!
M: VECTOR n*V!
(prepare-scal) [ XSCAL ] dip ;
: XVECTOR{ \ } [ >VECTOR ] parse-literal ; parsing
SYNTAX: XVECTOR{ \ } [ >VECTOR ] parse-literal ;
M: VECTOR pprint-delims
drop \ XVECTOR{ \ } ;

2
basis/math/complex/complex.factor
View File

@ -31,7 +31,7 @@ M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ;
IN: syntax
: C{ \ } [ first2 rect> ] parse-literal ; parsing
SYNTAX: C{ \ } [ first2 rect> ] parse-literal ;
USE: prettyprint.custom

6
basis/memoize/memoize-docs.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg.
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup ;
USING: help.syntax help.markup words quotations effects ;
IN: memoize
HELP: define-memoized
{ $values { "word" "the word to be defined" } { "quot" "a quotation" } }
{ $values { "word" word } { "quot" quotation } { "effect" effect } }
{ $description "defines the given word at runtime as one which memoizes its output given a particular input" }
{ $notes "A maximum of four input and four output arguments can be used" }
{ $see-also POSTPONE: MEMO: } ;

11
basis/memoize/memoize.factor
View File

@ -34,14 +34,13 @@ 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 ;
: MEMO: (:) define-memoized ; parsing
SYNTAX: MEMO: (:) define-memoized ;
PREDICATE: memoized < word "memoize" word-prop ;

2
basis/models/models-tests.factor
View File

@ -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 ;

2
basis/models/range/range-tests.factor
View File

@ -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

22
basis/multiline/multiline.factor
View File

@ -20,10 +20,10 @@ PRIVATE>
[ (parse-here) ] "" make but-last
lexer get next-line ;
: STRING:
SYNTAX: STRING:
CREATE-WORD
parse-here 1quotation
(( -- string )) define-inline ; parsing
(( -- string )) define-inline ;
<PRIVATE
@ -48,16 +48,16 @@ PRIVATE>
change-column drop
] "" make ;
: <"
"\">" parse-multiline-string parsed ; parsing
SYNTAX: <"
"\">" parse-multiline-string parsed ;
: <'
"'>" parse-multiline-string parsed ; parsing
SYNTAX: <'
"'>" parse-multiline-string parsed ;
: {'
"'}" parse-multiline-string parsed ; parsing
SYNTAX: {'
"'}" parse-multiline-string parsed ;
: {"
"\"}" parse-multiline-string parsed ; parsing
SYNTAX: {"
"\"}" parse-multiline-string parsed ;
: /* "*/" parse-multiline-string drop ; parsing
SYNTAX: /* "*/" parse-multiline-string drop ;

2
basis/nibble-arrays/nibble-arrays.factor
View File

@ -62,7 +62,7 @@ M: nibble-array resize
M: nibble-array byte-length length nibbles>bytes ;
: N{ \ } [ >nibble-array ] parse-literal ; parsing
SYNTAX: N{ \ } [ >nibble-array ] parse-literal ;
INSTANCE: nibble-array sequence

5
basis/opengl/gl/extensions/extensions.factor
View File

@ -47,7 +47,7 @@ reset-gl-function-number-counter
parameters return parse-arglist [ abi indirect-quot ] dip
define-declared ;
: GL-FUNCTION:
SYNTAX: GL-FUNCTION:
gl-function-calling-convention
scan
scan dup
@ -55,5 +55,4 @@ reset-gl-function-number-counter
gl-function-number
[ gl-function-pointer ] 2curry swap
";" parse-tokens [ "()" subseq? not ] filter
define-indirect
; parsing
define-indirect ;

4
basis/openssl/libssl/libssl.factor
View File

@ -279,12 +279,12 @@ H{ } clone verify-messages set-global
: verify-message ( n -- word ) verify-messages get-global at ;
: X509_V_:
SYNTAX: X509_V_:
scan "X509_V_" prepend create-in
scan-word
[ 1quotation (( -- value )) define-inline ]
[ verify-messages get set-at ]
2bi ; parsing
2bi ;
>>

18
basis/peg/ebnf/ebnf.factor
View File

@ -34,9 +34,9 @@ TUPLE: tokenizer any one many ;
: reset-tokenizer ( -- )
default-tokenizer \ tokenizer set-global ;
: TOKENIZER:
SYNTAX: TOKENIZER:
scan search [ "Tokenizer not found" throw ] unless*
execute( -- tokenizer ) \ tokenizer set-global ; parsing
execute( -- tokenizer ) \ tokenizer set-global ;
TUPLE: ebnf-non-terminal symbol ;
TUPLE: ebnf-terminal symbol ;
@ -522,16 +522,14 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
parse-ebnf dup dup parser [ main swap at compile ] with-variable
[ compiled-parse ] curry [ with-scope ast>> ] curry ;
: <EBNF "EBNF>" reset-tokenizer parse-multiline-string parse-ebnf main swap at
parsed reset-tokenizer ; parsing
SYNTAX: <EBNF "EBNF>" reset-tokenizer parse-multiline-string parse-ebnf main swap at
parsed reset-tokenizer ;
: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip
parsed \ call parsed reset-tokenizer ; parsing
SYNTAX: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip
parsed \ call parsed reset-tokenizer ;
: EBNF:
SYNTAX: EBNF:
reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string
ebnf>quot swapd (( input -- ast )) define-declared "ebnf-parser" set-word-prop
reset-tokenizer ; parsing
reset-tokenizer ;

4
basis/peg/parsers/parsers.factor
View File

@ -9,14 +9,14 @@ TUPLE: just-parser p1 ;
CONSTANT: just-pattern
[
execute dup [
dup [
dup remaining>> empty? [ drop f ] unless
] when
]
M: just-parser (compile) ( parser -- quot )
p1>> compile-parser just-pattern curry ;
p1>> compile-parser-quot just-pattern compose ;
: just ( parser -- parser )
just-parser boa wrap-peg ;

64
basis/peg/peg.factor
View File

@ -116,7 +116,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
#! Evaluate a rule, return an ast resulting from it.
#! Return fail if the rule failed. The rule has
#! stack effect ( -- parse-result )
pos get swap execute process-rule-result ; inline
pos get swap execute( -- parse-result ) process-rule-result ; inline
: memo ( pos id -- memo-entry )
#! Return the result from the memo cache.
@ -244,14 +244,15 @@ TUPLE: peg-head rule-id involved-set eval-set ;
: with-packrat ( input quot -- result )
#! Run the quotation with a packrat cache active.
swap [
input set
[
swap input set
0 pos set
f lrstack set
V{ } clone error-stack set
H{ } clone \ heads set
H{ } clone \ packrat set
] H{ } make-assoc swap bind ; inline
call
] with-scope ; inline
GENERIC: (compile) ( peg -- quot )
@ -264,20 +265,16 @@ GENERIC: (compile) ( peg -- quot )
] if ;
: execute-parser ( word -- result )
pos get apply-rule process-parser-result ; inline
: parser-body ( parser -- quot )
#! Return the body of the word that is the compiled version
#! of the parser.
gensym 2dup swap peg>> (compile) (( -- result )) define-declared
swap dupd id>> "peg-id" set-word-prop
[ execute-parser ] curry ;
pos get apply-rule process-parser-result ;
: preset-parser-word ( parser -- parser word )
gensym [ >>compiled ] keep ;
: define-parser-word ( parser word -- )
swap parser-body (( -- result )) define-declared ;
#! Return the body of the word that is the compiled version
#! of the parser.
2dup swap peg>> (compile) (( -- result )) define-declared
swap id>> "peg-id" set-word-prop ;
: compile-parser ( parser -- word )
#! Look to see if the given parser has been compiled.
@ -292,19 +289,22 @@ GENERIC: (compile) ( peg -- quot )
preset-parser-word [ define-parser-word ] keep
] if* ;
: compile-parser-quot ( parser -- quot )
compile-parser [ execute-parser ] curry ;
SYMBOL: delayed
: fixup-delayed ( -- )
#! Work through all delayed parsers and recompile their
#! words to have the correct bodies.
delayed get [
call( -- parser ) compile-parser 1quotation (( -- result )) define-declared
call( -- parser ) compile-parser-quot (( -- result )) define-declared
] assoc-each ;
: compile ( parser -- word )
[
H{ } clone delayed [
compile-parser fixup-delayed
compile-parser-quot (( -- result )) define-temp fixup-delayed
] with-variable
] with-compilation-unit ;
@ -411,8 +411,8 @@ M: seq-parser (compile) ( peg -- quot )
[
[ input-slice V{ } clone <parse-result> ] %
[
parsers>> unclip compile-parser 1quotation [ parse-seq-element ] curry ,
[ compile-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each
parsers>> unclip compile-parser-quot [ parse-seq-element ] curry ,
[ compile-parser-quot [ merge-errors ] compose [ parse-seq-element ] curry , ] each
] { } make , \ 1&& ,
] [ ] make ;
@ -421,8 +421,8 @@ TUPLE: choice-parser parsers ;
M: choice-parser (compile) ( peg -- quot )
[
[
parsers>> [ compile-parser ] map
unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each
parsers>> [ compile-parser-quot ] map
unclip , [ [ merge-errors ] compose , ] each
] { } make , \ 0|| ,
] [ ] make ;
@ -438,7 +438,7 @@ TUPLE: repeat0-parser p1 ;
] if* ; inline recursive
M: repeat0-parser (compile) ( peg -- quot )
p1>> compile-parser 1quotation '[
p1>> compile-parser-quot '[
input-slice V{ } clone <parse-result> _ swap (repeat)
] ;
@ -452,7 +452,7 @@ TUPLE: repeat1-parser p1 ;
] if* ;
M: repeat1-parser (compile) ( peg -- quot )
p1>> compile-parser 1quotation '[
p1>> compile-parser-quot '[
input-slice V{ } clone <parse-result> _ swap (repeat) repeat1-empty-check
] ;
@ -462,7 +462,7 @@ TUPLE: optional-parser p1 ;
[ input-slice f <parse-result> ] unless* ;
M: optional-parser (compile) ( peg -- quot )
p1>> compile-parser 1quotation '[ @ check-optional ] ;
p1>> compile-parser-quot '[ @ check-optional ] ;
TUPLE: semantic-parser p1 quot ;
@ -474,7 +474,7 @@ TUPLE: semantic-parser p1 quot ;
] if ; inline
M: semantic-parser (compile) ( peg -- quot )
[ p1>> compile-parser 1quotation ] [ quot>> ] bi
[ p1>> compile-parser-quot ] [ quot>> ] bi
'[ @ _ check-semantic ] ;
TUPLE: ensure-parser p1 ;
@ -483,7 +483,7 @@ TUPLE: ensure-parser p1 ;
[ ignore <parse-result> ] [ drop f ] if ;
M: ensure-parser (compile) ( peg -- quot )
p1>> compile-parser 1quotation '[ input-slice @ check-ensure ] ;
p1>> compile-parser-quot '[ input-slice @ check-ensure ] ;
TUPLE: ensure-not-parser p1 ;
@ -491,7 +491,7 @@ TUPLE: ensure-not-parser p1 ;
[ drop f ] [ ignore <parse-result> ] if ;
M: ensure-not-parser (compile) ( peg -- quot )
p1>> compile-parser 1quotation '[ input-slice @ check-ensure-not ] ;
p1>> compile-parser-quot '[ input-slice @ check-ensure-not ] ;
TUPLE: action-parser p1 quot ;
@ -503,12 +503,12 @@ TUPLE: action-parser p1 quot ;
] if ; inline
M: action-parser (compile) ( peg -- quot )
[ p1>> compile-parser 1quotation ] [ quot>> ] bi '[ @ _ check-action ] ;
[ p1>> compile-parser-quot ] [ quot>> ] bi '[ @ _ check-action ] ;
TUPLE: sp-parser p1 ;
M: sp-parser (compile) ( peg -- quot )
p1>> compile-parser 1quotation '[
p1>> compile-parser-quot '[
input-slice [ blank? ] trim-head-slice input-from pos set @
] ;
@ -527,7 +527,7 @@ M: box-parser (compile) ( peg -- quot )
#! to produce the parser to be compiled.
#! This differs from 'delay' which calls
#! it at run time.
quot>> call( -- parser ) compile-parser 1quotation ;
quot>> call( -- parser ) compile-parser-quot ;
PRIVATE>
@ -616,9 +616,9 @@ PRIVATE>
ERROR: parse-failed input word ;
: PEG:
SYNTAX: PEG:
(:)
[let | def [ ] word [ ] |
[let | effect [ ] def [ ] word [ ] |
[
[
[let | compiled-def [ def call compile ] |
@ -626,11 +626,11 @@ ERROR: parse-failed input word ;
dup compiled-def compiled-parse
[ ast>> ] [ word parse-failed ] ?if
]
word swap define
word swap effect define-declared
]
] with-compilation-unit
] over push-all
] ; parsing
] ;
USING: vocabs vocabs.loader ;

2
basis/persistent/hashtables/hashtables.factor
View File

@ -48,7 +48,7 @@ M: persistent-hash hashcode* nip assoc-size ;
M: persistent-hash clone ;
: PH{ \ } [ >persistent-hash ] parse-literal ; parsing
SYNTAX: PH{ \ } [ >persistent-hash ] parse-literal ;
M: persistent-hash pprint-delims drop \ PH{ \ } ;
M: persistent-hash >pprint-sequence >alist ;

Some files were not shown because too many files have changed in this diff Show More