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

2
core/continuations/continuations.factor
View File

@ -128,7 +128,7 @@ PRIVATE>
: cleanup ( try cleanup-always cleanup-error -- )
over >r compose [ dip rethrow ] curry
>r (catch) r> ifcc r> call ; inline
recover r> call ; inline
: 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 ;
: 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 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 )
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 ;
@ -52,10 +56,6 @@ M: object root-directory? ( path -- ? ) path-separator? ;
: directory ( path -- seq )
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 ? )
[ 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 )
2over >r >r
>r [ first ] 2apply r> call
r> r> [ second ] 2apply and 2array ; inline
r> r> [ second ] both? 2array ; inline
: interval-op ( i1 i2 quot -- i3 )
pick interval-from pick interval-from pick (interval-op) >r

2
core/threads/threads.factor
View File

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

2
core/tuples/tuples.factor
View File

@ -15,7 +15,7 @@ M: tuple class class-of-tuple ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
over array-capacity over array-capacity dup -rot number= [
over array-capacity over array-capacity tuck number= [
-rot
[ >r over r> array-nth >r array-nth r> = ] 2curry
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 ;
: forget-vocab ( vocab -- )
dup vocab-words values forget-all
dup words forget-all
vocab-name dictionary get delete-at ;
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 -- )
dup 2^ 10000 * nsieve-bits.
dup 1 - 2^ 10000 * nsieve-bits.
dup 1- 2^ 10000 * nsieve-bits.
2 - 2^ 10000 * nsieve-bits. ;
: 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
math.vectors math.functions math.parser namespaces sequences
strings tuples system debugger combinators vocabs.loader
calendar.backend structs alien.c-types ;
calendar.backend structs alien.c-types math.vectors ;
IN: calendar
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> ;
: years ( n -- dt ) zero-dt [ set-dt-year ] 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 ;
: weeks ( n -- dt ) 7 * days ;
: hours ( n -- dt ) zero-dt [ set-dt-hour ] keep ;
: minutes ( n -- dt ) zero-dt [ set-dt-minute ] 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>date 0 0 0 0 <timestamp> ;
@ -186,7 +186,8 @@ M: number +second ( timestamp n -- timestamp )
#! data
tuple-slots
{ 1 12 365.2425 8765.82 525949.2 31556952.0 }
[ / ] 2map sum ;
v/ sum ;
: dt>months ( dt -- x ) dt>years 12 * ;
: dt>days ( dt -- x ) dt>years 365.2425 * ;
: dt>hours ( dt -- x ) dt>years 8765.82 * ;
@ -235,7 +236,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
unix-1970 millis 1000 /f seconds +dt ;
: 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 ;
: ago ( dt -- timestamp ) before from-now ;
@ -258,10 +259,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
1+ + 7 mod ;
: day-of-week ( timestamp -- n )
[ timestamp-year ] keep
[ timestamp-month ] keep
timestamp-day
zeller-congruence ;
>date< zeller-congruence ;
: day-of-year ( timestamp -- n )
[

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

@ -7,7 +7,7 @@ IN: combinators.cleave
! 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 )
>r pick >r bi r> r> call ; inline
@ -23,7 +23,7 @@ IN: combinators.cleave
! 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 )
>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 ;
: 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 -- )
[ 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> ;
: file>sha1 ( file -- sha1 ) <file-reader> stream>sha1 ;
: string>sha1-interleave ( string -- )
: string>sha1-interleave ( string -- seq )
[ zero? ] left-trim
dup length odd? [ 1 tail ] when
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
namespaces editors.vim sequences system combinators
vocabs.loader ;
namespaces sequences system combinators
editors.vim editors.gvim.backend vocabs.loader ;
IN: editors.gvim
TUPLE: gvim ;
HOOK: gvim-path io-backend ( -- path )
M: gvim vim-command ( file line -- string )
[ "\"" % 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
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 ;
IN: editors.vim
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\"" } "."

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

@ -29,7 +29,7 @@ IN: http.client
: crlf "\r\n" write ;
: 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 ;
: 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 ;
: math-exp? ( n n word -- ? )
{ + - * / ^ } member? -rot [ number? ] 2apply and and ;
{ + - * / ^ } member? -rot [ number? ] both? and ;
: (fold-constants) ( quot -- )
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 )
: lfrom ( n -- list )
[ 1 + ] lfrom-by ;
[ 1+ ] lfrom-by ;
M: lazy-from-by car ( lazy-from-by -- car )
lazy-from-by-n ;

43
extra/lint/lint.factor
View File

@ -83,7 +83,8 @@ def-hash get-global [
! Remove n m shift defs
[
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
] assoc-subset
@ -120,7 +121,7 @@ M: word lint ( word -- seq )
: word-path. ( word -- )
[ word-vocabulary ":" ] keep unparse 3append write nl ;
: lint. ( array -- )
: (lint.) ( pair -- )
first2 >r word-path. r> [
bl bl bl bl
dup .
@ -128,32 +129,46 @@ M: word lint ( word -- seq )
def-hash get at [ bl bl bl bl word-path. ] each
nl
] each nl nl ;
: lint. ( alist -- )
[ (lint.) ] each ;
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) ] subset ] assoc-map ;
: filter-symbols ( alist -- alist )
[
first2 [
def-hash get-global at* [
dupd remove empty? not
] [
drop f
] if
] subset 2array
] map ;
nip first dup def-hash get at
[ first ] 2apply literalize = not
] assoc-subset ;
M: sequence run-lint ( seq -- seq )
[
global [ dup . flush ] bind
dup lint 2array
] map
dup lint
] { } map>assoc
trim-self
[ second empty? not ] subset ;
[ second empty? not ] subset
filter-symbols ;
M: word run-lint ( word -- seq )
1array run-lint ;
: 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 )
dup even? [ 1+ ] [ 2 + ] if ;
: random-bits ( m -- n )
#! Top bit is always set
2^ [ random ] keep -1 shift bitor ; foldable
: random-bits ( m -- n ) 2^ random ; 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 ;
: 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 [
"input must be positive and even" throw
positive-even-expected construct-boa throw
] unless 0 swap (factor-2s) ;
:: (miller-rabin) | n prime?! |
n dup 1 = over even? or [
drop f
] [
1- factor-2s s set r set
trials get [
n 1- [1,b] random a set
a get s get n ^mod 1 = [
0 count set
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 +
n 1- factor-2s s set r set
trials get [
n 1- [1,b] random a set
a get s get n ^mod 1 = [
0 count set
r get [
2^ s get * a get swap n ^mod n - -1 = [
count [ 1+ ] change
r get +
] when
] unless
drop
] each
prime?
] if ;
] each
count get zero? [
f prime?!
trials get +
] when
] unless
drop
] each prime? ;
TUPLE: miller-rabin-bounds ;
@ -62,6 +57,7 @@ TUPLE: miller-rabin-bounds ;
over {
{ [ dup 1 <= ] [ 3drop f ] }
{ [ dup 2 = ] [ 3drop t ] }
{ [ dup even? ] [ 3drop f ] }
{ [ t ] [ [ drop trials set t (miller-rabin) ] with-scope ] }
} cond ;
@ -81,10 +77,9 @@ TUPLE: miller-rabin-bounds ;
>odd (find-relative-prime) ;
: find-relative-prime ( n -- p )
dup random >odd (find-relative-prime) ;
dup random find-relative-prime* ;
: unique-primes ( numbits n -- seq )
#! generate two primes
over 5 < [ "not enough primes below 5 bits" throw ] when
[ [ 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.
!
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
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 <char> alutLoadWAVFile ] 4keep
>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
: do-enabled ( what quot -- )
over glEnable swap slip glDisable ; inline
over glEnable dip glDisable ; inline
: do-matrix ( mode quot -- )
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
math math.parser namespaces parser prettyprint
quotations sequences strings threads vectors
words macros ;
words macros math.functions ;
IN: pack
SYMBOL: big-endian
@ -10,9 +10,6 @@ SYMBOL: big-endian
: big-endian? ( -- ? )
1 <int> *char zero? ;
: clear-bit ( m n -- o )
2^ bitnot bitand ;
: >endian ( obj n -- str )
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 ;
: 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 )
1 read first

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

@ -1,184 +1,184 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
TUPLE: ebnf-terminal symbol ;
TUPLE: ebnf-choice options ;
TUPLE: ebnf-sequence elements ;
TUPLE: ebnf-repeat0 group ;
TUPLE: ebnf-optional elements ;
TUPLE: ebnf-rule symbol elements ;
TUPLE: ebnf-action word ;
TUPLE: ebnf rules ;
C: <ebnf-non-terminal> ebnf-non-terminal
C: <ebnf-terminal> ebnf-terminal
C: <ebnf-choice> ebnf-choice
C: <ebnf-sequence> ebnf-sequence
C: <ebnf-repeat0> ebnf-repeat0
C: <ebnf-optional> ebnf-optional
C: <ebnf-rule> ebnf-rule
C: <ebnf-action> ebnf-action
C: <ebnf> ebnf
SYMBOL: parsers
SYMBOL: non-terminals
SYMBOL: last-parser
: reset-parser-generation ( -- )
V{ } clone parsers set
H{ } clone non-terminals set
f last-parser set ;
: store-parser ( parser -- number )
parsers get [ push ] keep length 1- ;
: get-parser ( index -- parser )
parsers get nth ;
: non-terminal-index ( name -- number )
dup non-terminals get at [
nip
] [
f store-parser [ swap non-terminals get set-at ] keep
] if* ;
GENERIC: (generate-parser) ( ast -- id )
: generate-parser ( ast -- id )
(generate-parser) dup last-parser set ;
M: ebnf-terminal (generate-parser) ( ast -- id )
ebnf-terminal-symbol token sp store-parser ;
M: ebnf-non-terminal (generate-parser) ( ast -- id )
[
ebnf-non-terminal-symbol dup non-terminal-index ,
parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or ,
] [ ] make delay sp store-parser ;
M: ebnf-choice (generate-parser) ( ast -- id )
ebnf-choice-options [
generate-parser get-parser
] map choice store-parser ;
M: ebnf-sequence (generate-parser) ( ast -- id )
ebnf-sequence-elements [
generate-parser get-parser
] map seq store-parser ;
M: ebnf-repeat0 (generate-parser) ( ast -- id )
ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;
M: ebnf-optional (generate-parser) ( ast -- id )
ebnf-optional-elements generate-parser get-parser optional store-parser ;
M: ebnf-rule (generate-parser) ( ast -- id )
dup ebnf-rule-symbol non-terminal-index swap
ebnf-rule-elements generate-parser get-parser ! nt-id body
swap [ parsers get set-nth ] keep ;
M: ebnf-action (generate-parser) ( ast -- id )
ebnf-action-word search 1quotation
last-parser get get-parser swap action store-parser ;
M: vector (generate-parser) ( ast -- id )
[ generate-parser ] map peek ;
M: f (generate-parser) ( ast -- id )
drop last-parser get ;
M: ebnf (generate-parser) ( ast -- id )
ebnf-rules [
generate-parser
] map peek ;
DEFER: 'rhs'
: 'non-terminal' ( -- parser )
CHAR: a CHAR: z range repeat1 [ >string <ebnf-non-terminal> ] action ;
: 'terminal' ( -- parser )
"'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string <ebnf-terminal> ] action ;
: 'element' ( -- parser )
'non-terminal' 'terminal' 2array choice ;
DEFER: 'choice'
: 'group' ( -- parser )
"(" token sp hide
[ 'choice' sp ] delay
")" token sp hide
3array seq [ first ] action ;
: 'repeat0' ( -- parser )
"{" token sp hide
[ 'choice' sp ] delay
"}" token sp hide
3array seq [ first <ebnf-repeat0> ] action ;
: 'optional' ( -- parser )
"[" token sp hide
[ 'choice' sp ] delay
"]" token sp hide
3array seq [ first <ebnf-optional> ] action ;
: 'sequence' ( -- parser )
[
'element' sp ,
'group' sp ,
'repeat0' sp ,
'optional' sp ,
] { } make choice
repeat1 [
dup length 1 = [ first ] [ <ebnf-sequence> ] if
] action ;
: 'choice' ( -- parser )
'sequence' sp "|" token sp list-of [
dup length 1 = [ first ] [ <ebnf-choice> ] if
] action ;
: 'action' ( -- parser )
"=>" token hide
[ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp
2array seq [ first <ebnf-action> ] action ;
: 'rhs' ( -- parser )
'choice' 'action' sp optional 2array seq ;
: 'rule' ( -- parser )
'non-terminal' [ ebnf-non-terminal-symbol ] action
"=" token sp hide
'rhs'
3array seq [ first2 <ebnf-rule> ] action ;
: 'ebnf' ( -- parser )
'rule' sp "." token sp hide list-of [ <ebnf> ] action ;
: ebnf>quot ( string -- quot )
'ebnf' parse [
parse-result-ast [
reset-parser-generation
generate-parser drop
[
non-terminals get
[
get-parser [
swap , \ in , \ get , \ create ,
1quotation , \ define-compound ,
] [
drop
] if*
] assoc-each
] [ ] make
] with-scope
] [
f
] if* ;
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
TUPLE: ebnf-terminal symbol ;
TUPLE: ebnf-choice options ;
TUPLE: ebnf-sequence elements ;
TUPLE: ebnf-repeat0 group ;
TUPLE: ebnf-optional elements ;
TUPLE: ebnf-rule symbol elements ;
TUPLE: ebnf-action word ;
TUPLE: ebnf rules ;
C: <ebnf-non-terminal> ebnf-non-terminal
C: <ebnf-terminal> ebnf-terminal
C: <ebnf-choice> ebnf-choice
C: <ebnf-sequence> ebnf-sequence
C: <ebnf-repeat0> ebnf-repeat0
C: <ebnf-optional> ebnf-optional
C: <ebnf-rule> ebnf-rule
C: <ebnf-action> ebnf-action
C: <ebnf> ebnf
SYMBOL: parsers
SYMBOL: non-terminals
SYMBOL: last-parser
: reset-parser-generation ( -- )
V{ } clone parsers set
H{ } clone non-terminals set
f last-parser set ;
: store-parser ( parser -- number )
parsers get [ push ] keep length 1- ;
: get-parser ( index -- parser )
parsers get nth ;
: non-terminal-index ( name -- number )
dup non-terminals get at [
nip
] [
f store-parser [ swap non-terminals get set-at ] keep
] if* ;
GENERIC: (generate-parser) ( ast -- id )
: generate-parser ( ast -- id )
(generate-parser) dup last-parser set ;
M: ebnf-terminal (generate-parser) ( ast -- id )
ebnf-terminal-symbol token sp store-parser ;
M: ebnf-non-terminal (generate-parser) ( ast -- id )
[
ebnf-non-terminal-symbol dup non-terminal-index ,
parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or ,
] [ ] make delay sp store-parser ;
M: ebnf-choice (generate-parser) ( ast -- id )
ebnf-choice-options [
generate-parser get-parser
] map choice store-parser ;
M: ebnf-sequence (generate-parser) ( ast -- id )
ebnf-sequence-elements [
generate-parser get-parser
] map seq store-parser ;
M: ebnf-repeat0 (generate-parser) ( ast -- id )
ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;
M: ebnf-optional (generate-parser) ( ast -- id )
ebnf-optional-elements generate-parser get-parser optional store-parser ;
M: ebnf-rule (generate-parser) ( ast -- id )
dup ebnf-rule-symbol non-terminal-index swap
ebnf-rule-elements generate-parser get-parser ! nt-id body
swap [ parsers get set-nth ] keep ;
M: ebnf-action (generate-parser) ( ast -- id )
ebnf-action-word search 1quotation
last-parser get get-parser swap action store-parser ;
M: vector (generate-parser) ( ast -- id )
[ generate-parser ] map peek ;
M: f (generate-parser) ( ast -- id )
drop last-parser get ;
M: ebnf (generate-parser) ( ast -- id )
ebnf-rules [
generate-parser
] map peek ;
DEFER: 'rhs'
: 'non-terminal' ( -- parser )
CHAR: a CHAR: z range repeat1 [ >string <ebnf-non-terminal> ] action ;
: 'terminal' ( -- parser )
"'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string <ebnf-terminal> ] action ;
: 'element' ( -- parser )
'non-terminal' 'terminal' 2array choice ;
DEFER: 'choice'
: 'group' ( -- parser )
"(" token sp hide
[ 'choice' sp ] delay
")" token sp hide
3array seq [ first ] action ;
: 'repeat0' ( -- parser )
"{" token sp hide
[ 'choice' sp ] delay
"}" token sp hide
3array seq [ first <ebnf-repeat0> ] action ;
: 'optional' ( -- parser )
"[" token sp hide
[ 'choice' sp ] delay
"]" token sp hide
3array seq [ first <ebnf-optional> ] action ;
: 'sequence' ( -- parser )
[
'element' sp ,
'group' sp ,
'repeat0' sp ,
'optional' sp ,
] { } make choice
repeat1 [
dup length 1 = [ first ] [ <ebnf-sequence> ] if
] action ;
: 'choice' ( -- parser )
'sequence' sp "|" token sp list-of [
dup length 1 = [ first ] [ <ebnf-choice> ] if
] action ;
: 'action' ( -- parser )
"=>" token hide
[ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp
2array seq [ first <ebnf-action> ] action ;
: 'rhs' ( -- parser )
'choice' 'action' sp optional 2array seq ;
: 'rule' ( -- parser )
'non-terminal' [ ebnf-non-terminal-symbol ] action
"=" token sp hide
'rhs'
3array seq [ first2 <ebnf-rule> ] action ;
: 'ebnf' ( -- parser )
'rule' sp "." token sp hide list-of [ <ebnf> ] action ;
: ebnf>quot ( string -- quot )
'ebnf' parse [
parse-result-ast [
reset-parser-generation
generate-parser drop
[
non-terminals get
[
get-parser [
swap , \ in , \ get , \ create ,
1quotation , \ define ,
] [
drop
] if*
] assoc-each
] [ ] make
] with-scope
] [
f
] if* ;
: <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.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax peg ;
HELP: parse
{ $values
{ "input" "a string" }
{ "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 "
"the parse was successful, otherwise it is f." } ;
HELP: token
{ $values
{ "string" "a string" }
{ "parser" "a parser" }
}
{ $description
"Returns a parser that matches the given string." } ;
HELP: satisfy
{ $values
{ "quot" "a quotation" }
{ "parser" "a parser" }
}
{ $description
"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
{ "min" "a character" }
{ "max" "a character" }
{ "parser" "a parser" }
}
{ $description
"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
{ "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 "
"all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by "
"the individual parsers." } ;
HELP: choice
{ $values
{ "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. "
"The resulting AST is that produced by the successful parser." } ;
HELP: repeat0
{ $values
{ "parser" "a parser" }
}
{ $description
"Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is "
"an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were "
"parsed." } ;
HELP: repeat1
{ $values
{ "parser" "a parser" }
}
{ $description
"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
{ "parser" "a parser" }
}
{ $description
"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
{ "parser" "a parser" }
}
{ $description
"Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the "
"AST and does not move the location in the input string. This can be used for lookahead and "
"disambiguation, along with the " { $link ensure-not } " word." }
{ $examples { $code "\"0\" token ensure octal-parser" } } ;
HELP: ensure-not
{ $values
{ "parser" "a parser" }
}
{ $description
"Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the "
"AST and does not move the location in the input string. This can be used for lookahead and "
"disambiguation, along with the " { $link ensure } " word." }
{ $code "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ;
HELP: action
{ $values
{ "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 "
"from that parse. The result of the quotation is then used as the final AST. This can be used "
"for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
"the default AST." }
{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
HELP: sp
{ $values
{ "parser" "a parser" }
}
{ $description
"Returns a parser that calls the original parser 'p1' after stripping any whitespace "
" from the left of the input string." } ;
HELP: hide
{ $values
{ "parser" "a parser" }
}
{ $description
"Returns a parser that succeeds if the original parser succeeds, but does not "
"put any result in the AST. Useful for ignoring 'syntax' in the AST." }
{ $code "\"[\" token hide number \"]\" token hide 3array seq" } ;
HELP: delay
{ $values
{ "parser" "a parser" }
}
{ $description
"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 "
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax ;
IN: peg
HELP: parse
{ $values
{ "input" "a string" }
{ "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 "
"the parse was successful, otherwise it is f." } ;
HELP: token
{ $values
{ "string" "a string" }
{ "parser" "a parser" }
}
{ $description
"Returns a parser that matches the given string." } ;
HELP: satisfy
{ $values
{ "quot" "a quotation" }
{ "parser" "a parser" }
}
{ $description
"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
{ "min" "a character" }
{ "max" "a character" }
{ "parser" "a parser" }
}
{ $description
"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
{ "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 "
"all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by "
"the individual parsers." } ;
HELP: choice
{ $values
{ "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. "
"The resulting AST is that produced by the successful parser." } ;
HELP: repeat0
{ $values
{ "parser" "a parser" }
}
{ $description
"Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is "
"an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were "
"parsed." } ;
HELP: repeat1
{ $values
{ "parser" "a parser" }
}
{ $description
"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
{ "parser" "a parser" }
}
{ $description
"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
{ "parser" "a parser" }
}
{ $description
"Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the "
"AST and does not move the location in the input string. This can be used for lookahead and "
"disambiguation, along with the " { $link ensure-not } " word." }
{ $examples { $code "\"0\" token ensure octal-parser" } } ;
HELP: ensure-not
{ $values
{ "parser" "a parser" }
}
{ $description
"Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the "
"AST and does not move the location in the input string. This can be used for lookahead and "
"disambiguation, along with the " { $link ensure } " word." }
{ $code "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ;
HELP: action
{ $values
{ "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 "
"from that parse. The result of the quotation is then used as the final AST. This can be used "
"for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
"the default AST." }
{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
HELP: sp
{ $values
{ "parser" "a parser" }
}
{ $description
"Returns a parser that calls the original parser 'p1' after stripping any whitespace "
" from the left of the input string." } ;
HELP: hide
{ $values
{ "parser" "a parser" }
}
{ $description
"Returns a parser that succeeds if the original parser succeeds, but does not "
"put any result in the AST. Useful for ignoring 'syntax' in the AST." }
{ $code "\"[\" token hide number \"]\" token hide 3array seq" } ;
HELP: delay
{ $values
{ "parser" "a parser" }
}
{ $description
"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." } ;

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

@ -22,7 +22,7 @@ TUPLE: random-tester-error ;
datastack clone after set
clear
before get [ ] each
quot get [ compile-1 ] [ errored on ] recover ;
quot get [ compile-call ] [ errored on ] recover ;
: do-test ! ( data... quot -- )
.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
: probabilities ( weights -- probabilities ) dup sum [ / ] curry map ;
: probabilities ( weights -- probabilities ) dup sum v/n ;
: layers ( probabilities -- layers )
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 -- )
>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-y ( y1 y2 -- y )

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

@ -59,7 +59,7 @@ IN: sequences.lib
] { } make ;
: singleton? ( seq -- ? )
length 1 = ;
length 1 = ; foldable
: delete-random ( seq -- value )
[ 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 ;
: strip-tease ( data -- seq )
dup third length 1 - [
dup third length 1- [
2 + (strip-tease)
] 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 )
148 cut-slice 8 tail-slice
[ 0 [ + ] reduce ] 2apply + 256 + ;
[ sum ] 2apply + 256 + ;
TUPLE: checksum-error ;
TUPLE: malformed-block-error ;
@ -164,7 +164,7 @@ TUPLE: unimplemented-typeflag header ;
! Long file name
: typeflag-L ( header -- )
<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
filename get tar-path+ make-directories ;
@ -196,7 +196,7 @@ TUPLE: unimplemented-typeflag header ;
! global [ dup tar-header-name [ print flush ] when* ] bind
dup tar-header-typeflag
{
{ CHAR: \0 [ typeflag-0 ] }
{ 0 [ typeflag-0 ] }
{ CHAR: 0 [ typeflag-0 ] }
{ CHAR: 1 [ typeflag-1 ] }
{ 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 ;