Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
a808ce5325
core
assocs
continuations
cpu/x86/32
io/files
math/intervals
threads
tuples
vocabs
extra
benchmark/nsieve-bits
calendar
combinators/cleave
crypto
common
sha1
editors
gvim
http/client
inverse
lazy-lists
lint
math/miller-rabin
openal/other
opengl
pack
peg
random-tester
random-weighted
random
sequences/lib
slides
tar
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ PRIVATE>
|
|||
|
||||
: stop ( -- )
|
||||
walker-hook [
|
||||
f swap continue-with
|
||||
continue
|
||||
] [
|
||||
run-queue pop-back dup array?
|
||||
[ first2 continue-with ] [ continue ] if
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,4 @@
|
|||
USING: io.backend ;
|
||||
IN: editors.gvim.backend
|
||||
|
||||
HOOK: gvim-path io-backend ( -- path )
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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\"" } "."
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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 < [ % ] [
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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. ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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." } ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 +0,0 @@
|
|||
Daniel Ehrenberg
|
||||
|
|
@ -1 +0,0 @@
|
|||
Double-dispatch generic words
|
||||
|
|
@ -1 +0,0 @@
|
|||
extensions
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
Loading…
Reference in New Issue