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

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

db4
Joe Groff 2008-01-13 18:21:12 -08:00
parent d73d8820c1 969901a73d
commit a808ce5325
38 changed files with 431 additions and 507 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
core/assocs/assocs.factor
View File

@ -43,7 +43,7 @@ M: assoc assoc-find
inline inline
: assoc-push-if ( key value quot accum -- ) : assoc-push-if ( key value quot accum -- )
>r 2over 2slip r> roll >r 2keep r> roll
[ >r 2array r> push ] [ 3drop ] if ; inline [ >r 2array r> push ] [ 3drop ] if ; inline
: assoc-pusher ( quot -- quot' accum ) : assoc-pusher ( quot -- quot' accum )
@ -52,12 +52,12 @@ M: assoc assoc-find
: assoc-subset ( assoc quot -- subassoc ) : assoc-subset ( assoc quot -- subassoc )
over >r assoc-pusher >r assoc-each r> r> assoc-like ; inline over >r assoc-pusher >r assoc-each r> r> assoc-like ; inline
: assoc-all? ( assoc quot -- ? )
[ not ] compose assoc-find 2nip not ; inline
: assoc-contains? ( assoc quot -- ? ) : assoc-contains? ( assoc quot -- ? )
assoc-find 2nip ; inline assoc-find 2nip ; inline
: assoc-all? ( assoc quot -- ? )
[ not ] compose assoc-contains? not ; inline
: at ( key assoc -- value/f ) : at ( key assoc -- value/f )
at* drop ; inline at* drop ; inline

2
core/continuations/continuations.factor
View File

@ -128,7 +128,7 @@ PRIVATE>
: cleanup ( try cleanup-always cleanup-error -- ) : cleanup ( try cleanup-always cleanup-error -- )
over >r compose [ dip rethrow ] curry over >r compose [ dip rethrow ] curry
>r (catch) r> ifcc r> call ; inline recover r> call ; inline
: attempt-all ( seq quot -- obj ) : attempt-all ( seq quot -- obj )
[ [

2
core/cpu/x86/32/32.factor
View File

@ -46,7 +46,7 @@ M: float-regs push-return-reg
: FLD 4 = [ FLDS ] [ FLDL ] if ; : FLD 4 = [ FLDS ] [ FLDL ] if ;
: load/store-float-return reg-size >r stack-reg swap [+] r> ; : load/store-float-return reg-size >r stack@ r> ;
M: float-regs load-return-reg load/store-float-return FLD ; M: float-regs load-return-reg load/store-float-return FLD ;
M: float-regs store-return-reg load/store-float-return FSTP ; M: float-regs store-return-reg load/store-float-return FSTP ;

10
core/io/files/files.factor
View File

@ -35,7 +35,11 @@ M: object root-directory? ( path -- ? ) path-separator? ;
: stat ( path -- directory? permissions length modified ) : stat ( path -- directory? permissions length modified )
normalize-pathname (stat) ; normalize-pathname (stat) ;
: exists? ( path -- ? ) stat >r 3drop r> >boolean ; : file-length ( path -- n ) stat 4array third ;
: file-modified ( path -- n ) stat >r 3drop r> ; inline
: exists? ( path -- ? ) file-modified >boolean ;
: directory? ( path -- ? ) stat 3drop ; : directory? ( path -- ? ) stat 3drop ;
@ -52,10 +56,6 @@ M: object root-directory? ( path -- ? ) path-separator? ;
: directory ( path -- seq ) : directory ( path -- seq )
normalize-directory dup (directory) fixup-directory ; normalize-directory dup (directory) fixup-directory ;
: file-length ( path -- n ) stat 4array third ;
: file-modified ( path -- n ) stat >r 3drop r> ;
: last-path-separator ( path -- n ? ) : last-path-separator ( path -- n ? )
[ length 2 [-] ] keep [ path-separator? ] find-last* ; [ length 2 [-] ] keep [ path-separator? ] find-last* ;

2
core/math/intervals/intervals.factor
View File

@ -68,7 +68,7 @@ C: <interval> interval
: (interval-op) ( p1 p2 quot -- p3 ) : (interval-op) ( p1 p2 quot -- p3 )
2over >r >r 2over >r >r
>r [ first ] 2apply r> call >r [ first ] 2apply r> call
r> r> [ second ] 2apply and 2array ; inline r> r> [ second ] both? 2array ; inline
: interval-op ( i1 i2 quot -- i3 ) : interval-op ( i1 i2 quot -- i3 )
pick interval-from pick interval-from pick (interval-op) >r pick interval-from pick interval-from pick (interval-op) >r

2
core/threads/threads.factor
View File

@ -32,7 +32,7 @@ PRIVATE>
: stop ( -- ) : stop ( -- )
walker-hook [ walker-hook [
f swap continue-with continue
] [ ] [
run-queue pop-back dup array? run-queue pop-back dup array?
[ first2 continue-with ] [ continue ] if [ first2 continue-with ] [ continue ] if

2
core/tuples/tuples.factor
View File

@ -15,7 +15,7 @@ M: tuple class class-of-tuple ;
<PRIVATE <PRIVATE
: tuple= ( tuple1 tuple2 -- ? ) : tuple= ( tuple1 tuple2 -- ? )
over array-capacity over array-capacity dup -rot number= [ over array-capacity over array-capacity tuck number= [
-rot -rot
[ >r over r> array-nth >r array-nth r> = ] 2curry [ >r over r> array-nth >r array-nth r> = ] 2curry
all-integers? all-integers?

2
core/vocabs/vocabs.factor
View File

@ -102,7 +102,7 @@ M: vocab-link vocab-name vocab-link-name ;
UNION: vocab-spec vocab vocab-link ; UNION: vocab-spec vocab vocab-link ;
: forget-vocab ( vocab -- ) : forget-vocab ( vocab -- )
dup vocab-words values forget-all dup words forget-all
vocab-name dictionary get delete-at ; vocab-name dictionary get delete-at ;
M: vocab-spec forget* forget-vocab ; M: vocab-spec forget* forget-vocab ;

2
extra/benchmark/nsieve-bits/nsieve-bits.factor
View File

@ -28,7 +28,7 @@ bit-arrays namespaces io ;
: nsieve-bits-main ( n -- ) : nsieve-bits-main ( n -- )
dup 2^ 10000 * nsieve-bits. dup 2^ 10000 * nsieve-bits.
dup 1 - 2^ 10000 * nsieve-bits. dup 1- 2^ 10000 * nsieve-bits.
2 - 2^ 10000 * nsieve-bits. ; 2 - 2^ 10000 * nsieve-bits. ;
: nsieve-bits-main* 11 nsieve-bits-main ; : nsieve-bits-main* 11 nsieve-bits-main ;

16
extra/calendar/calendar.factor
View File

@ -4,7 +4,7 @@
USING: arrays hashtables io io.streams.string kernel math USING: arrays hashtables io io.streams.string kernel math
math.vectors math.functions math.parser namespaces sequences math.vectors math.functions math.parser namespaces sequences
strings tuples system debugger combinators vocabs.loader strings tuples system debugger combinators vocabs.loader
calendar.backend structs alien.c-types ; calendar.backend structs alien.c-types math.vectors ;
IN: calendar IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ; TUPLE: timestamp year month day hour minute second gmt-offset ;
@ -96,12 +96,12 @@ SYMBOL: m
: zero-dt ( -- <dt> ) 0 0 0 0 0 0 <dt> ; : zero-dt ( -- <dt> ) 0 0 0 0 0 0 <dt> ;
: years ( n -- dt ) zero-dt [ set-dt-year ] keep ; : years ( n -- dt ) zero-dt [ set-dt-year ] keep ;
: months ( n -- dt ) zero-dt [ set-dt-month ] keep ; : months ( n -- dt ) zero-dt [ set-dt-month ] keep ;
: weeks ( n -- dt ) 7 * zero-dt [ set-dt-day ] keep ;
: days ( n -- dt ) zero-dt [ set-dt-day ] keep ; : days ( n -- dt ) zero-dt [ set-dt-day ] keep ;
: weeks ( n -- dt ) 7 * days ;
: hours ( n -- dt ) zero-dt [ set-dt-hour ] keep ; : hours ( n -- dt ) zero-dt [ set-dt-hour ] keep ;
: minutes ( n -- dt ) zero-dt [ set-dt-minute ] keep ; : minutes ( n -- dt ) zero-dt [ set-dt-minute ] keep ;
: seconds ( n -- dt ) zero-dt [ set-dt-second ] keep ; : seconds ( n -- dt ) zero-dt [ set-dt-second ] keep ;
: milliseconds ( n -- dt ) 1000 /f zero-dt [ set-dt-second ] keep ; : milliseconds ( n -- dt ) 1000 /f seconds ;
: julian-day-number>timestamp ( n -- timestamp ) : julian-day-number>timestamp ( n -- timestamp )
julian-day-number>date 0 0 0 0 <timestamp> ; julian-day-number>date 0 0 0 0 <timestamp> ;
@ -186,7 +186,8 @@ M: number +second ( timestamp n -- timestamp )
#! data #! data
tuple-slots tuple-slots
{ 1 12 365.2425 8765.82 525949.2 31556952.0 } { 1 12 365.2425 8765.82 525949.2 31556952.0 }
[ / ] 2map sum ; v/ sum ;
: dt>months ( dt -- x ) dt>years 12 * ; : dt>months ( dt -- x ) dt>years 12 * ;
: dt>days ( dt -- x ) dt>years 365.2425 * ; : dt>days ( dt -- x ) dt>years 365.2425 * ;
: dt>hours ( dt -- x ) dt>years 8765.82 * ; : dt>hours ( dt -- x ) dt>years 8765.82 * ;
@ -235,7 +236,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
unix-1970 millis 1000 /f seconds +dt ; unix-1970 millis 1000 /f seconds +dt ;
: now ( -- timestamp ) gmt >local-time ; : now ( -- timestamp ) gmt >local-time ;
: before ( dt -- -dt ) tuple-slots [ neg ] map array>dt ; : before ( dt -- -dt ) tuple-slots vneg array>dt ;
: from-now ( dt -- timestamp ) now swap +dt ; : from-now ( dt -- timestamp ) now swap +dt ;
: ago ( dt -- timestamp ) before from-now ; : ago ( dt -- timestamp ) before from-now ;
@ -258,10 +259,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
1+ + 7 mod ; 1+ + 7 mod ;
: day-of-week ( timestamp -- n ) : day-of-week ( timestamp -- n )
[ timestamp-year ] keep >date< zeller-congruence ;
[ timestamp-month ] keep
timestamp-day
zeller-congruence ;
: day-of-year ( timestamp -- n ) : day-of-year ( timestamp -- n )
[ [

4
extra/combinators/cleave/cleave.factor
View File

@ -7,7 +7,7 @@ IN: combinators.cleave
! The cleaver family ! The cleaver family
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: bi ( obj quot quot -- val val ) >r over slip r> call ; inline : bi ( obj quot quot -- val val ) >r keep r> call ; inline
: tri ( obj quot quot quot -- val val val ) : tri ( obj quot quot quot -- val val val )
>r pick >r bi r> r> call ; inline >r pick >r bi r> r> call ; inline
@ -23,7 +23,7 @@ IN: combinators.cleave
! The spread family ! The spread family
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: bi* ( obj obj quot quot -- val val ) >r swap >r call r> r> call ; inline : bi* ( obj obj quot quot -- val val ) >r swap slip r> call ; inline
: tri* ( obj obj obj quot quot quot -- val val val ) : tri* ( obj obj obj quot quot quot -- val val val )
>r rot >r bi* r> r> call ; inline >r rot >r bi* r> r> call ; inline

2
extra/crypto/common/common.factor
View File

@ -40,7 +40,7 @@ SYMBOL: big-endian?
] "" make 64 group ; ] "" make 64 group ;
: shift-mod ( n s w -- n ) : shift-mod ( n s w -- n )
>r shift r> 1 swap shift 1 - bitand ; inline >r shift r> 2^ 1- bitand ; inline
: update-old-new ( old new -- ) : update-old-new ( old new -- )
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline

2
extra/crypto/sha1/sha1.factor
View File

@ -126,7 +126,7 @@ SYMBOL: K
: string>sha1-bignum ( string -- n ) string>sha1 be> ; : string>sha1-bignum ( string -- n ) string>sha1 be> ;
: file>sha1 ( file -- sha1 ) <file-reader> stream>sha1 ; : file>sha1 ( file -- sha1 ) <file-reader> stream>sha1 ;
: string>sha1-interleave ( string -- ) : string>sha1-interleave ( string -- seq )
[ zero? ] left-trim [ zero? ] left-trim
dup length odd? [ 1 tail ] when dup length odd? [ 1 tail ] when
seq>2seq [ string>sha1 ] 2apply seq>2seq [ string>sha1 ] 2apply

4
extra/editors/gvim/backend/backend.factor Normal file
View File

@ -0,0 +1,4 @@
USING: io.backend ;
IN: editors.gvim.backend
HOOK: gvim-path io-backend ( -- path )

7
extra/editors/gvim/gvim.factor
View File

@ -1,13 +1,10 @@
USING: io.backend io.files kernel math math.parser USING: io.backend io.files kernel math math.parser
namespaces editors.vim sequences system combinators namespaces sequences system combinators
vocabs.loader ; editors.vim editors.gvim.backend vocabs.loader ;
IN: editors.gvim IN: editors.gvim
TUPLE: gvim ; TUPLE: gvim ;
HOOK: gvim-path io-backend ( -- path )
M: gvim vim-command ( file line -- string ) M: gvim vim-command ( file line -- string )
[ "\"" % gvim-path % "\" \"" % swap % "\" +" % # ] "" make ; [ "\"" % gvim-path % "\" \"" % swap % "\" +" % # ] "" make ;

2
extra/editors/gvim/unix/unix.factor
View File

@ -1,4 +1,4 @@
USING: editors.gvim io.unix.backend kernel namespaces ; USING: io.unix.backend kernel namespaces editors.gvim.backend ;
IN: editors.gvim.unix IN: editors.gvim.unix
M: unix-io gvim-path M: unix-io gvim-path

3
extra/editors/vim/vim-docs.factor
View File

@ -1,5 +1,6 @@
USING: definitions editors.vim help help.markup help.syntax io io.files USING: definitions help help.markup help.syntax io io.files
editors words ; editors words ;
IN: editors.vim
ARTICLE: { "vim" "vim" } "Vim support" ARTICLE: { "vim" "vim" } "Vim support"
"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim-location } ". The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "." "This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim-location } ". The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "."

2
extra/http/client/client.factor
View File

@ -29,7 +29,7 @@ IN: http.client
: crlf "\r\n" write ; : crlf "\r\n" write ;
: http-request ( host resource method -- ) : http-request ( host resource method -- )
write " " write write " HTTP/1.0" write crlf write bl write " HTTP/1.0" write crlf
"Host: " write write crlf ; "Host: " write write crlf ;
: get-request ( host resource -- ) : get-request ( host resource -- )

2
extra/inverse/inverse.factor
View File

@ -69,7 +69,7 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
} cond ; } cond ;
: math-exp? ( n n word -- ? ) : math-exp? ( n n word -- ? )
{ + - * / ^ } member? -rot [ number? ] 2apply and and ; { + - * / ^ } member? -rot [ number? ] both? and ;
: (fold-constants) ( quot -- ) : (fold-constants) ( quot -- )
dup length 3 < [ % ] [ dup length 3 < [ % ] [

2
extra/lazy-lists/lazy-lists.factor
View File

@ -319,7 +319,7 @@ TUPLE: lazy-from-by n quot ;
C: lfrom-by lazy-from-by ( n quot -- list ) C: lfrom-by lazy-from-by ( n quot -- list )
: lfrom ( n -- list ) : lfrom ( n -- list )
[ 1 + ] lfrom-by ; [ 1+ ] lfrom-by ;
M: lazy-from-by car ( lazy-from-by -- car ) M: lazy-from-by car ( lazy-from-by -- car )
lazy-from-by-n ; lazy-from-by-n ;

43
extra/lint/lint.factor
View File

@ -83,7 +83,8 @@ def-hash get-global [
! Remove n m shift defs ! Remove n m shift defs
[ [
drop dup length 3 = [ drop dup length 3 = [
dup first2 [ number? ] 2apply and swap third \ shift = and not dup first2 [ number? ] both?
swap third \ shift = and not
] [ drop t ] if ] [ drop t ] if
] assoc-subset ] assoc-subset
@ -120,7 +121,7 @@ M: word lint ( word -- seq )
: word-path. ( word -- ) : word-path. ( word -- )
[ word-vocabulary ":" ] keep unparse 3append write nl ; [ word-vocabulary ":" ] keep unparse 3append write nl ;
: lint. ( array -- ) : (lint.) ( pair -- )
first2 >r word-path. r> [ first2 >r word-path. r> [
bl bl bl bl bl bl bl bl
dup . dup .
@ -128,32 +129,46 @@ M: word lint ( word -- seq )
def-hash get at [ bl bl bl bl word-path. ] each def-hash get at [ bl bl bl bl word-path. ] each
nl nl
] each nl nl ; ] each nl nl ;
: lint. ( alist -- )
[ (lint.) ] each ;
GENERIC: run-lint ( obj -- obj ) GENERIC: run-lint ( obj -- obj )
: (trim-self)
def-hash get-global at* [
dupd remove empty? not
] [
drop f
] if ;
: trim-self ( seq -- newseq ) : trim-self ( seq -- newseq )
[ [ (trim-self) ] subset ] assoc-map ;
: filter-symbols ( alist -- alist )
[ [
first2 [ nip first dup def-hash get at
def-hash get-global at* [ [ first ] 2apply literalize = not
dupd remove empty? not ] assoc-subset ;
] [
drop f
] if
] subset 2array
] map ;
M: sequence run-lint ( seq -- seq ) M: sequence run-lint ( seq -- seq )
[ [
global [ dup . flush ] bind global [ dup . flush ] bind
dup lint 2array dup lint
] map ] { } map>assoc
trim-self trim-self
[ second empty? not ] subset ; [ second empty? not ] subset
filter-symbols ;
M: word run-lint ( word -- seq ) M: word run-lint ( word -- seq )
1array run-lint ; 1array run-lint ;
: lint-all ( -- seq ) : lint-all ( -- seq )
all-words run-lint dup [ lint. ] each ; all-words run-lint dup lint. ;
: lint-vocab ( vocab -- seq )
words run-lint dup lint. ;
: lint-word ( word -- seq )
1array run-lint dup lint. ;

55
extra/math/miller-rabin/miller-rabin.factor
View File

@ -18,43 +18,38 @@ SYMBOL: trials
: next-odd ( m -- n ) : next-odd ( m -- n )
dup even? [ 1+ ] [ 2 + ] if ; dup even? [ 1+ ] [ 2 + ] if ;
: random-bits ( m -- n ) : random-bits ( m -- n ) 2^ random ; foldable
#! Top bit is always set
2^ [ random ] keep -1 shift bitor ; foldable
: (factor-2s) ( s n -- s n ) TUPLE: positive-even-expected n ;
: (factor-2s) ( r s -- r s )
dup even? [ -1 shift >r 1+ r> (factor-2s) ] when ; dup even? [ -1 shift >r 1+ r> (factor-2s) ] when ;
: factor-2s ( n -- r s ) : factor-2s ( n -- r s )
#! factor an even number into 2 ^ s * m #! factor an even number into s * 2 ^ r
dup even? over 0 > and [ dup even? over 0 > and [
"input must be positive and even" throw positive-even-expected construct-boa throw
] unless 0 swap (factor-2s) ; ] unless 0 swap (factor-2s) ;
:: (miller-rabin) | n prime?! | :: (miller-rabin) | n prime?! |
n dup 1 = over even? or [ n 1- factor-2s s set r set
drop f trials get [
] [ n 1- [1,b] random a set
1- factor-2s s set r set a get s get n ^mod 1 = [
trials get [ 0 count set
n 1- [1,b] random a set r get [
a get s get n ^mod 1 = [ 2^ s get * a get swap n ^mod n - -1 = [
0 count set count [ 1+ ] change
r get [ r get +
2^ s get * a get swap n ^mod n - -1 = [
count [ 1+ ] change
r get +
] when
] each
count get zero? [
f prime?!
trials get +
] when ] when
] unless ] each
drop count get zero? [
] each f prime?!
prime? trials get +
] if ; ] when
] unless
drop
] each prime? ;
TUPLE: miller-rabin-bounds ; TUPLE: miller-rabin-bounds ;
@ -62,6 +57,7 @@ TUPLE: miller-rabin-bounds ;
over { over {
{ [ dup 1 <= ] [ 3drop f ] } { [ dup 1 <= ] [ 3drop f ] }
{ [ dup 2 = ] [ 3drop t ] } { [ dup 2 = ] [ 3drop t ] }
{ [ dup even? ] [ 3drop f ] }
{ [ t ] [ [ drop trials set t (miller-rabin) ] with-scope ] } { [ t ] [ [ drop trials set t (miller-rabin) ] with-scope ] }
} cond ; } cond ;
@ -81,10 +77,9 @@ TUPLE: miller-rabin-bounds ;
>odd (find-relative-prime) ; >odd (find-relative-prime) ;
: find-relative-prime ( n -- p ) : find-relative-prime ( n -- p )
dup random >odd (find-relative-prime) ; dup random find-relative-prime* ;
: unique-primes ( numbits n -- seq ) : unique-primes ( numbits n -- seq )
#! generate two primes #! generate two primes
over 5 < [ "not enough primes below 5 bits" throw ] when over 5 < [ "not enough primes below 5 bits" throw ] when
[ [ drop random-prime ] with map ] [ all-unique? ] generate ; [ [ drop random-prime ] with map ] [ all-unique? ] generate ;

4
extra/openal/other/other.factor
View File

@ -2,13 +2,13 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! !
IN: openal.other IN: openal.other
USING: openal alien.c-types kernel alien alien.syntax shuffle combinators.lib ; USING: openal.backend alien.c-types kernel alien alien.syntax shuffle combinators.lib ;
LIBRARY: alut LIBRARY: alut
FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ; FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
M: other-openal-impl load-wav-file ( filename -- format data size frequency ) M: other-openal-backend load-wav-file ( filename -- format data size frequency )
0 <int> f <void*> 0 <int> 0 <int> 0 <int> f <void*> 0 <int> 0 <int>
[ 0 <char> alutLoadWAVFile ] 4keep [ 0 <char> alutLoadWAVFile ] 4keep
>r >r >r *int r> *void* r> *int r> *int ; >r >r >r *int r> *void* r> *int r> *int ;

2
extra/opengl/opengl.factor
View File

@ -27,7 +27,7 @@ IN: opengl
swap glBegin call glEnd ; inline swap glBegin call glEnd ; inline
: do-enabled ( what quot -- ) : do-enabled ( what quot -- )
over glEnable swap slip glDisable ; inline over glEnable dip glDisable ; inline
: do-matrix ( mode quot -- ) : do-matrix ( mode quot -- )
swap [ glMatrixMode glPushMatrix call ] keep swap [ glMatrixMode glPushMatrix call ] keep

7
extra/pack/pack.factor
View File

@ -2,7 +2,7 @@ USING: alien alien.c-types arrays assocs byte-arrays inference
inference.transforms io io.binary io.streams.string kernel inference.transforms io io.binary io.streams.string kernel
math math.parser namespaces parser prettyprint math math.parser namespaces parser prettyprint
quotations sequences strings threads vectors quotations sequences strings threads vectors
words macros ; words macros math.functions ;
IN: pack IN: pack
SYMBOL: big-endian SYMBOL: big-endian
@ -10,9 +10,6 @@ SYMBOL: big-endian
: big-endian? ( -- ? ) : big-endian? ( -- ? )
1 <int> *char zero? ; 1 <int> *char zero? ;
: clear-bit ( m n -- o )
2^ bitnot bitand ;
: >endian ( obj n -- str ) : >endian ( obj n -- str )
big-endian get [ >be ] [ >le ] if ; inline big-endian get [ >be ] [ >le ] if ; inline
@ -88,7 +85,7 @@ M: string b, ( n string -- ) heap-size b, ;
"\0" read-until [ drop f ] unless ; "\0" read-until [ drop f ] unless ;
: read-c-string* ( n -- str/f ) : read-c-string* ( n -- str/f )
read [ 0 = ] right-trim dup empty? [ drop f ] when ; read [ zero? ] right-trim dup empty? [ drop f ] when ;
: (read-128-ber) ( n -- n ) : (read-128-ber) ( n -- n )
1 read first 1 read first

366
extra/peg/ebnf/ebnf.factor
View File

@ -1,184 +1,184 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser words arrays strings math.parser sequences USING: kernel parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg ; quotations vectors namespaces math assocs continuations peg ;
IN: peg.ebnf IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ; TUPLE: ebnf-non-terminal symbol ;
TUPLE: ebnf-terminal symbol ; TUPLE: ebnf-terminal symbol ;
TUPLE: ebnf-choice options ; TUPLE: ebnf-choice options ;
TUPLE: ebnf-sequence elements ; TUPLE: ebnf-sequence elements ;
TUPLE: ebnf-repeat0 group ; TUPLE: ebnf-repeat0 group ;
TUPLE: ebnf-optional elements ; TUPLE: ebnf-optional elements ;
TUPLE: ebnf-rule symbol elements ; TUPLE: ebnf-rule symbol elements ;
TUPLE: ebnf-action word ; TUPLE: ebnf-action word ;
TUPLE: ebnf rules ; TUPLE: ebnf rules ;
C: <ebnf-non-terminal> ebnf-non-terminal C: <ebnf-non-terminal> ebnf-non-terminal
C: <ebnf-terminal> ebnf-terminal C: <ebnf-terminal> ebnf-terminal
C: <ebnf-choice> ebnf-choice C: <ebnf-choice> ebnf-choice
C: <ebnf-sequence> ebnf-sequence C: <ebnf-sequence> ebnf-sequence
C: <ebnf-repeat0> ebnf-repeat0 C: <ebnf-repeat0> ebnf-repeat0
C: <ebnf-optional> ebnf-optional C: <ebnf-optional> ebnf-optional
C: <ebnf-rule> ebnf-rule C: <ebnf-rule> ebnf-rule
C: <ebnf-action> ebnf-action C: <ebnf-action> ebnf-action
C: <ebnf> ebnf C: <ebnf> ebnf
SYMBOL: parsers SYMBOL: parsers
SYMBOL: non-terminals SYMBOL: non-terminals
SYMBOL: last-parser SYMBOL: last-parser
: reset-parser-generation ( -- ) : reset-parser-generation ( -- )
V{ } clone parsers set V{ } clone parsers set
H{ } clone non-terminals set H{ } clone non-terminals set
f last-parser set ; f last-parser set ;
: store-parser ( parser -- number ) : store-parser ( parser -- number )
parsers get [ push ] keep length 1- ; parsers get [ push ] keep length 1- ;
: get-parser ( index -- parser ) : get-parser ( index -- parser )
parsers get nth ; parsers get nth ;
: non-terminal-index ( name -- number ) : non-terminal-index ( name -- number )
dup non-terminals get at [ dup non-terminals get at [
nip nip
] [ ] [
f store-parser [ swap non-terminals get set-at ] keep f store-parser [ swap non-terminals get set-at ] keep
] if* ; ] if* ;
GENERIC: (generate-parser) ( ast -- id ) GENERIC: (generate-parser) ( ast -- id )
: generate-parser ( ast -- id ) : generate-parser ( ast -- id )
(generate-parser) dup last-parser set ; (generate-parser) dup last-parser set ;
M: ebnf-terminal (generate-parser) ( ast -- id ) M: ebnf-terminal (generate-parser) ( ast -- id )
ebnf-terminal-symbol token sp store-parser ; ebnf-terminal-symbol token sp store-parser ;
M: ebnf-non-terminal (generate-parser) ( ast -- id ) M: ebnf-non-terminal (generate-parser) ( ast -- id )
[ [
ebnf-non-terminal-symbol dup non-terminal-index , ebnf-non-terminal-symbol dup non-terminal-index ,
parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or , parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or ,
] [ ] make delay sp store-parser ; ] [ ] make delay sp store-parser ;
M: ebnf-choice (generate-parser) ( ast -- id ) M: ebnf-choice (generate-parser) ( ast -- id )
ebnf-choice-options [ ebnf-choice-options [
generate-parser get-parser generate-parser get-parser
] map choice store-parser ; ] map choice store-parser ;
M: ebnf-sequence (generate-parser) ( ast -- id ) M: ebnf-sequence (generate-parser) ( ast -- id )
ebnf-sequence-elements [ ebnf-sequence-elements [
generate-parser get-parser generate-parser get-parser
] map seq store-parser ; ] map seq store-parser ;
M: ebnf-repeat0 (generate-parser) ( ast -- id ) M: ebnf-repeat0 (generate-parser) ( ast -- id )
ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ; ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;
M: ebnf-optional (generate-parser) ( ast -- id ) M: ebnf-optional (generate-parser) ( ast -- id )
ebnf-optional-elements generate-parser get-parser optional store-parser ; ebnf-optional-elements generate-parser get-parser optional store-parser ;
M: ebnf-rule (generate-parser) ( ast -- id ) M: ebnf-rule (generate-parser) ( ast -- id )
dup ebnf-rule-symbol non-terminal-index swap dup ebnf-rule-symbol non-terminal-index swap
ebnf-rule-elements generate-parser get-parser ! nt-id body ebnf-rule-elements generate-parser get-parser ! nt-id body
swap [ parsers get set-nth ] keep ; swap [ parsers get set-nth ] keep ;
M: ebnf-action (generate-parser) ( ast -- id ) M: ebnf-action (generate-parser) ( ast -- id )
ebnf-action-word search 1quotation ebnf-action-word search 1quotation
last-parser get get-parser swap action store-parser ; last-parser get get-parser swap action store-parser ;
M: vector (generate-parser) ( ast -- id ) M: vector (generate-parser) ( ast -- id )
[ generate-parser ] map peek ; [ generate-parser ] map peek ;
M: f (generate-parser) ( ast -- id ) M: f (generate-parser) ( ast -- id )
drop last-parser get ; drop last-parser get ;
M: ebnf (generate-parser) ( ast -- id ) M: ebnf (generate-parser) ( ast -- id )
ebnf-rules [ ebnf-rules [
generate-parser generate-parser
] map peek ; ] map peek ;
DEFER: 'rhs' DEFER: 'rhs'
: 'non-terminal' ( -- parser ) : 'non-terminal' ( -- parser )
CHAR: a CHAR: z range repeat1 [ >string <ebnf-non-terminal> ] action ; CHAR: a CHAR: z range repeat1 [ >string <ebnf-non-terminal> ] action ;
: 'terminal' ( -- parser ) : 'terminal' ( -- parser )
"'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string <ebnf-terminal> ] action ; "'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string <ebnf-terminal> ] action ;
: 'element' ( -- parser ) : 'element' ( -- parser )
'non-terminal' 'terminal' 2array choice ; 'non-terminal' 'terminal' 2array choice ;
DEFER: 'choice' DEFER: 'choice'
: 'group' ( -- parser ) : 'group' ( -- parser )
"(" token sp hide "(" token sp hide
[ 'choice' sp ] delay [ 'choice' sp ] delay
")" token sp hide ")" token sp hide
3array seq [ first ] action ; 3array seq [ first ] action ;
: 'repeat0' ( -- parser ) : 'repeat0' ( -- parser )
"{" token sp hide "{" token sp hide
[ 'choice' sp ] delay [ 'choice' sp ] delay
"}" token sp hide "}" token sp hide
3array seq [ first <ebnf-repeat0> ] action ; 3array seq [ first <ebnf-repeat0> ] action ;
: 'optional' ( -- parser ) : 'optional' ( -- parser )
"[" token sp hide "[" token sp hide
[ 'choice' sp ] delay [ 'choice' sp ] delay
"]" token sp hide "]" token sp hide
3array seq [ first <ebnf-optional> ] action ; 3array seq [ first <ebnf-optional> ] action ;
: 'sequence' ( -- parser ) : 'sequence' ( -- parser )
[ [
'element' sp , 'element' sp ,
'group' sp , 'group' sp ,
'repeat0' sp , 'repeat0' sp ,
'optional' sp , 'optional' sp ,
] { } make choice ] { } make choice
repeat1 [ repeat1 [
dup length 1 = [ first ] [ <ebnf-sequence> ] if dup length 1 = [ first ] [ <ebnf-sequence> ] if
] action ; ] action ;
: 'choice' ( -- parser ) : 'choice' ( -- parser )
'sequence' sp "|" token sp list-of [ 'sequence' sp "|" token sp list-of [
dup length 1 = [ first ] [ <ebnf-choice> ] if dup length 1 = [ first ] [ <ebnf-choice> ] if
] action ; ] action ;
: 'action' ( -- parser ) : 'action' ( -- parser )
"=>" token hide "=>" token hide
[ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp [ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp
2array seq [ first <ebnf-action> ] action ; 2array seq [ first <ebnf-action> ] action ;
: 'rhs' ( -- parser ) : 'rhs' ( -- parser )
'choice' 'action' sp optional 2array seq ; 'choice' 'action' sp optional 2array seq ;
: 'rule' ( -- parser ) : 'rule' ( -- parser )
'non-terminal' [ ebnf-non-terminal-symbol ] action 'non-terminal' [ ebnf-non-terminal-symbol ] action
"=" token sp hide "=" token sp hide
'rhs' 'rhs'
3array seq [ first2 <ebnf-rule> ] action ; 3array seq [ first2 <ebnf-rule> ] action ;
: 'ebnf' ( -- parser ) : 'ebnf' ( -- parser )
'rule' sp "." token sp hide list-of [ <ebnf> ] action ; 'rule' sp "." token sp hide list-of [ <ebnf> ] action ;
: ebnf>quot ( string -- quot ) : ebnf>quot ( string -- quot )
'ebnf' parse [ 'ebnf' parse [
parse-result-ast [ parse-result-ast [
reset-parser-generation reset-parser-generation
generate-parser drop generate-parser drop
[ [
non-terminals get non-terminals get
[ [
get-parser [ get-parser [
swap , \ in , \ get , \ create , swap , \ in , \ get , \ create ,
1quotation , \ define-compound , 1quotation , \ define ,
] [ ] [
drop drop
] if* ] if*
] assoc-each ] assoc-each
] [ ] make ] [ ] make
] with-scope ] with-scope
] [ ] [
f f
] if* ; ] if* ;
: <EBNF "EBNF>" parse-tokens " " join ebnf>quot call ; parsing : <EBNF "EBNF>" parse-tokens " " join ebnf>quot call ; parsing

283
extra/peg/peg-docs.factor
View File

@ -1,142 +1,143 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax peg ; USING: help.markup help.syntax ;
IN: peg
HELP: parse
{ $values HELP: parse
{ "input" "a string" } { $values
{ "parser" "a parser" } { "input" "a string" }
{ "result" "a parse-result or f" } { "parser" "a parser" }
} { "result" "a parse-result or f" }
{ $description }
"Given the input string, parse it using the given parser. The result is a <parse-result> object if " { $description
"the parse was successful, otherwise it is f." } ; "Given the input string, parse it using the given parser. The result is a <parse-result> object if "
"the parse was successful, otherwise it is f." } ;
HELP: token
{ $values HELP: token
{ "string" "a string" } { $values
{ "parser" "a parser" } { "string" "a string" }
} { "parser" "a parser" }
{ $description }
"Returns a parser that matches the given string." } ; { $description
"Returns a parser that matches the given string." } ;
HELP: satisfy
{ $values HELP: satisfy
{ "quot" "a quotation" } { $values
{ "parser" "a parser" } { "quot" "a quotation" }
} { "parser" "a parser" }
{ $description }
"Returns a parser that calls the quotation on the first character of the input string, " { $description
"succeeding if that quotation returns true. The AST is the character from the string." } ; "Returns a parser that calls the quotation on the first character of the input string, "
"succeeding if that quotation returns true. The AST is the character from the string." } ;
HELP: range
{ $values HELP: range
{ "min" "a character" } { $values
{ "max" "a character" } { "min" "a character" }
{ "parser" "a parser" } { "max" "a character" }
} { "parser" "a parser" }
{ $description }
"Returns a parser that matches a single character that lies within the range of characters given, inclusive." } { $description
{ $examples { $code ": digit ( -- parser ) CHAR: 0 CHAR: 9 range ;" } } ; "Returns a parser that matches a single character that lies within the range of characters given, inclusive." }
{ $examples { $code ": digit ( -- parser ) CHAR: 0 CHAR: 9 range ;" } } ;
HELP: seq
{ $values HELP: seq
{ "seq" "a sequence of parsers" } { $values
{ "parser" "a parser" } { "seq" "a sequence of parsers" }
} { "parser" "a parser" }
{ $description }
"Returns a parser that calls all parsers in the given sequence, in order. The parser succeeds if " { $description
"all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by " "Returns a parser that calls all parsers in the given sequence, in order. The parser succeeds if "
"the individual parsers." } ; "all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by "
"the individual parsers." } ;
HELP: choice
{ $values HELP: choice
{ "seq" "a sequence of parsers" } { $values
{ "parser" "a parser" } { "seq" "a sequence of parsers" }
} { "parser" "a parser" }
{ $description }
"Returns a parser that will try all the parsers in the sequence, in order, until one succeeds. " { $description
"The resulting AST is that produced by the successful parser." } ; "Returns a parser that will try all the parsers in the sequence, in order, until one succeeds. "
"The resulting AST is that produced by the successful parser." } ;
HELP: repeat0
{ $values HELP: repeat0
{ "parser" "a parser" } { $values
} { "parser" "a parser" }
{ $description }
"Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is " { $description
"an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were " "Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is "
"parsed." } ; "an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were "
"parsed." } ;
HELP: repeat1
{ $values HELP: repeat1
{ "parser" "a parser" } { $values
} { "parser" "a parser" }
{ $description }
"Returns a parser that parses 1 or more instances of the 'p1' parser. The AST produced is " { $description
"an array of the AST produced by the 'p1' parser." } ; "Returns a parser that parses 1 or more instances of the 'p1' parser. The AST produced is "
"an array of the AST produced by the 'p1' parser." } ;
HELP: optional
{ $values HELP: optional
{ "parser" "a parser" } { $values
} { "parser" "a parser" }
{ $description }
"Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is " { $description
"'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ; "Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "
"'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;
HELP: ensure
{ $values HELP: ensure
{ "parser" "a parser" } { $values
} { "parser" "a parser" }
{ $description }
"Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the " { $description
"AST and does not move the location in the input string. This can be used for lookahead and " "Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the "
"disambiguation, along with the " { $link ensure-not } " word." } "AST and does not move the location in the input string. This can be used for lookahead and "
{ $examples { $code "\"0\" token ensure octal-parser" } } ; "disambiguation, along with the " { $link ensure-not } " word." }
{ $examples { $code "\"0\" token ensure octal-parser" } } ;
HELP: ensure-not
{ $values HELP: ensure-not
{ "parser" "a parser" } { $values
} { "parser" "a parser" }
{ $description }
"Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the " { $description
"AST and does not move the location in the input string. This can be used for lookahead and " "Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the "
"disambiguation, along with the " { $link ensure } " word." } "AST and does not move the location in the input string. This can be used for lookahead and "
{ $code "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ; "disambiguation, along with the " { $link ensure } " word." }
{ $code "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ;
HELP: action
{ $values HELP: action
{ "parser" "a parser" } { $values
{ "quot" "a quotation with stack effect ( ast -- ast )" } { "parser" "a parser" }
} { "quot" "a quotation with stack effect ( ast -- ast )" }
{ $description }
"Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting " { $description
"from that parse. The result of the quotation is then used as the final AST. This can be used " "Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "
"for manipulating the parse tree to produce a AST better suited for the task at hand rather than " "from that parse. The result of the quotation is then used as the final AST. This can be used "
"the default AST." } "for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ; "the default AST." }
{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
HELP: sp
{ $values HELP: sp
{ "parser" "a parser" } { $values
} { "parser" "a parser" }
{ $description }
"Returns a parser that calls the original parser 'p1' after stripping any whitespace " { $description
" from the left of the input string." } ; "Returns a parser that calls the original parser 'p1' after stripping any whitespace "
" from the left of the input string." } ;
HELP: hide
{ $values HELP: hide
{ "parser" "a parser" } { $values
} { "parser" "a parser" }
{ $description }
"Returns a parser that succeeds if the original parser succeeds, but does not " { $description
"put any result in the AST. Useful for ignoring 'syntax' in the AST." } "Returns a parser that succeeds if the original parser succeeds, but does not "
{ $code "\"[\" token hide number \"]\" token hide 3array seq" } ; "put any result in the AST. Useful for ignoring 'syntax' in the AST." }
{ $code "\"[\" token hide number \"]\" token hide 3array seq" } ;
HELP: delay
{ $values HELP: delay
{ "parser" "a parser" } { $values
} { "parser" "a parser" }
{ $description }
"Delays the construction of a parser until it is actually required to parse. This " { $description
"allows for calling a parser that results in a recursive call to itself. The quotation " "Delays the construction of a parser until it is actually required to parse. This "
"allows for calling a parser that results in a recursive call to itself. The quotation "
"should return the constructed parser." } ; "should return the constructed parser." } ;

2
extra/random-tester/random-tester.factor
View File

@ -22,7 +22,7 @@ TUPLE: random-tester-error ;
datastack clone after set datastack clone after set
clear clear
before get [ ] each before get [ ] each
quot get [ compile-1 ] [ errored on ] recover ; quot get [ compile-call ] [ errored on ] recover ;
: do-test ! ( data... quot -- ) : do-test ! ( data... quot -- )
.s flush test-compiler .s flush test-compiler

2
extra/random-weighted/random-weighted.factor
View File

@ -4,7 +4,7 @@ USING: kernel namespaces arrays quotations sequences assocs combinators
IN: random-weighted IN: random-weighted
: probabilities ( weights -- probabilities ) dup sum [ / ] curry map ; : probabilities ( weights -- probabilities ) dup sum v/n ;
: layers ( probabilities -- layers ) : layers ( probabilities -- layers )
dup length 1+ [ head ] with map 1 tail [ sum ] map ; dup length 1+ [ head ] with map 1 tail [ sum ] map ;

2
extra/random/random.factor
View File

@ -36,7 +36,7 @@ SYMBOL: mt
: set-mt-ith ( y i-get i-set -- ) : set-mt-ith ( y i-get i-set -- )
>r mt-nth >r >r mt-nth >r
[ -1 shift ] keep odd? mt-a 0 ? r> bitxor bitxor r> [ 2/ ] keep odd? mt-a 0 ? r> bitxor bitxor r>
mt-seq set-nth ; inline mt-seq set-nth ; inline
: mt-y ( y1 y2 -- y ) : mt-y ( y1 y2 -- y )

2
extra/sequences/lib/lib.factor
View File

@ -59,7 +59,7 @@ IN: sequences.lib
] { } make ; ] { } make ;
: singleton? ( seq -- ? ) : singleton? ( seq -- ? )
length 1 = ; length 1 = ; foldable
: delete-random ( seq -- value ) : delete-random ( seq -- value )
[ length random ] keep [ nth ] 2keep delete-nth ; [ length random ] keep [ nth ] 2keep delete-nth ;

2
extra/slides/slides.factor
View File

@ -85,7 +85,7 @@ TUPLE: slides ;
>r first3 r> head 3array ; >r first3 r> head 3array ;
: strip-tease ( data -- seq ) : strip-tease ( data -- seq )
dup third length 1 - [ dup third length 1- [
2 + (strip-tease) 2 + (strip-tease)
] with map ; ] with map ;

6
extra/tar/tar.factor
View File

@ -35,7 +35,7 @@ linkname magic version uname gname devmajor devminor prefix ;
: header-checksum ( seq -- x ) : header-checksum ( seq -- x )
148 cut-slice 8 tail-slice 148 cut-slice 8 tail-slice
[ 0 [ + ] reduce ] 2apply + 256 + ; [ sum ] 2apply + 256 + ;
TUPLE: checksum-error ; TUPLE: checksum-error ;
TUPLE: malformed-block-error ; TUPLE: malformed-block-error ;
@ -164,7 +164,7 @@ TUPLE: unimplemented-typeflag header ;
! Long file name ! Long file name
: typeflag-L ( header -- ) : typeflag-L ( header -- )
<string-writer> [ read-data-blocks ] keep <string-writer> [ read-data-blocks ] keep
>string [ CHAR: \0 = ] right-trim filename set >string [ zero? ] right-trim filename set
global [ "long filename: " write filename get . flush ] bind global [ "long filename: " write filename get . flush ] bind
filename get tar-path+ make-directories ; filename get tar-path+ make-directories ;
@ -196,7 +196,7 @@ TUPLE: unimplemented-typeflag header ;
! global [ dup tar-header-name [ print flush ] when* ] bind ! global [ dup tar-header-name [ print flush ] when* ] bind
dup tar-header-typeflag dup tar-header-typeflag
{ {
{ CHAR: \0 [ typeflag-0 ] } { 0 [ typeflag-0 ] }
{ CHAR: 0 [ typeflag-0 ] } { CHAR: 0 [ typeflag-0 ] }
{ CHAR: 1 [ typeflag-1 ] } { CHAR: 1 [ typeflag-1 ] }
{ CHAR: 2 [ typeflag-2 ] } { CHAR: 2 [ typeflag-2 ] }

1
extra/visitor/authors.txt
View File

@ -1 +0,0 @@
Daniel Ehrenberg

1
extra/visitor/summary.txt
View File

@ -1 +0,0 @@
Double-dispatch generic words

1
extra/visitor/tags.txt
View File

@ -1 +0,0 @@
extensions

18
extra/visitor/visitor-tests.factor
View File

@ -1,18 +0,0 @@
USING: visitor math sequences math.parser strings tools.test kernel ;
VISITOR: ++ ( object object -- object )
! acts like +, coercing string arguments to a number, unless both arguments are strings, in which case it appends them
V: number string ++
string>number + ;
V: string number ++
>r string>number r> + ;
V: number number ++
+ ;
V: string string ++
append ;
[ 3 ] [ 1 2 ++ ] unit-test
[ 3 ] [ "1" 2 ++ ] unit-test
[ 3 ] [ 1 "2" ++ ] unit-test
[ "12" ] [ "1" "2" ++ ] unit-test

63
extra/visitor/visitor.factor
View File

@ -1,63 +0,0 @@
USING: kernel generic.standard syntax words parser assocs
generic quotations sequences effects arrays classes definitions
prettyprint sorting prettyprint.backend shuffle ;
IN: visitor
: define-visitor ( word -- )
dup dup reset-word define-simple-generic
dup H{ } clone "visitor-methods" set-word-prop
H{ } clone "visitors" set-word-prop ;
: VISITOR:
CREATE define-visitor ; parsing
: record-visitor ( top-class generic method-word -- )
swap "visitors" word-prop swapd set-at ;
: define-1generic ( word -- )
1 <standard-combination> define-generic ;
: copy-effect ( from to -- )
swap stack-effect "declared-effect" set-word-prop ;
: new-vmethod ( method bottom-class top-class generic -- )
gensym dup define-1generic
2dup copy-effect
3dup 1quotation -rot define-method
[ record-visitor ] keep
define-method ;
: define-visitor-method ( method bottom-class top-class generic -- )
4dup >r 2array r> "visitor-methods" word-prop set-at
2dup "visitors" word-prop at
[ nip define-method ] [ new-vmethod ] ?if ;
: V:
! syntax: V: bottom-class top-class generic body... ;
f set-word scan-word scan-word scan-word
parse-definition -roll define-visitor-method ; parsing
! see instance:
! see must be redone because "methods" doesn't show methods
PREDICATE: standard-generic visitor "visitors" word-prop ;
PREDICATE: array triple length 3 = ;
PREDICATE: triple visitor-spec
first3 visitor? >r [ class? ] 2apply and r> and ;
M: visitor-spec definer drop \ V: \ ; ;
M: visitor definer drop \ VISITOR: f ;
M: visitor-spec synopsis*
! same as method-spec#synopsis*
dup definer drop pprint-word
[ pprint-word ] each ;
M: visitor-spec definition
first3 >r 2array r> "visitor-methods" word-prop at ;
M: visitor see
dup (see)
dup see-class
dup "visitor-methods" word-prop keys natural-sort swap
[ >r first2 r> 3array ] curry map see-all ;