diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 5079420b54..799a6eb367 100644 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -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 diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 27ed277c6c..278264c17d 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -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 ) [ diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 1104915a9e..d3e33c46bd 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -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 ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 7bd9599e4d..6e4648b590 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -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* ; diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index 0b4378aa8a..b7eb5be8c9 100644 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -68,7 +68,7 @@ C: 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 diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 7a67d1b531..ee136654df 100644 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -32,7 +32,7 @@ PRIVATE> : stop ( -- ) walker-hook [ - f swap continue-with + continue ] [ run-queue pop-back dup array? [ first2 continue-with ] [ continue ] if diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 476cf4fa38..9c7b5c960a 100644 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -15,7 +15,7 @@ M: tuple class class-of-tuple ; r over r> array-nth >r array-nth r> = ] 2curry all-integers? diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 910410c84c..8db65e2eac 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -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 ; diff --git a/extra/benchmark/nsieve-bits/nsieve-bits.factor b/extra/benchmark/nsieve-bits/nsieve-bits.factor index 46ebc6595e..fe70246cb5 100644 --- a/extra/benchmark/nsieve-bits/nsieve-bits.factor +++ b/extra/benchmark/nsieve-bits/nsieve-bits.factor @@ -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 ; diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 9a54608126..c9b62ce7aa 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -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 ( --
) 0 0 0 0 0 0
; : 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 ; @@ -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 ) [ diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index 85381ec499..e1e3585813 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -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 diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor index e98f0cd959..3ac551d114 100644 --- a/extra/crypto/common/common.factor +++ b/extra/crypto/common/common.factor @@ -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 diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index e7ecc4e151..6906ce2b9a 100644 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -126,7 +126,7 @@ SYMBOL: K : string>sha1-bignum ( string -- n ) string>sha1 be> ; : file>sha1 ( file -- sha1 ) 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 diff --git a/extra/editors/gvim/backend/backend.factor b/extra/editors/gvim/backend/backend.factor new file mode 100644 index 0000000000..e2e2f0626e --- /dev/null +++ b/extra/editors/gvim/backend/backend.factor @@ -0,0 +1,4 @@ +USING: io.backend ; +IN: editors.gvim.backend + +HOOK: gvim-path io-backend ( -- path ) diff --git a/extra/editors/gvim/gvim.factor b/extra/editors/gvim/gvim.factor index 8b3573d03e..775d008963 100755 --- a/extra/editors/gvim/gvim.factor +++ b/extra/editors/gvim/gvim.factor @@ -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 ; diff --git a/extra/editors/gvim/unix/unix.factor b/extra/editors/gvim/unix/unix.factor index fd295cc9e9..a7de09c013 100644 --- a/extra/editors/gvim/unix/unix.factor +++ b/extra/editors/gvim/unix/unix.factor @@ -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 diff --git a/extra/editors/vim/vim-docs.factor b/extra/editors/vim/vim-docs.factor index 9f141f524f..2e2583cc7f 100644 --- a/extra/editors/vim/vim-docs.factor +++ b/extra/editors/vim/vim-docs.factor @@ -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\"" } "." diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 08c5185cd2..f117a4fda1 100644 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -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 -- ) diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 583ae610c0..cade645dde 100644 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -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 < [ % ] [ diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor index a76e0e5f81..1979819dd1 100644 --- a/extra/lazy-lists/lazy-lists.factor +++ b/extra/lazy-lists/lazy-lists.factor @@ -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 ; diff --git a/extra/lint/lint.factor b/extra/lint/lint.factor index 9299e6075e..44b234b254 100644 --- a/extra/lint/lint.factor +++ b/extra/lint/lint.factor @@ -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. ; diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor index cd20216ff9..de5a262268 100644 --- a/extra/math/miller-rabin/miller-rabin.factor +++ b/extra/math/miller-rabin/miller-rabin.factor @@ -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 ; - diff --git a/extra/openal/other/other.factor b/extra/openal/other/other.factor index 08b12426b3..e32b007973 100644 --- a/extra/openal/other/other.factor +++ b/extra/openal/other/other.factor @@ -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 f 0 0 [ 0 alutLoadWAVFile ] 4keep >r >r >r *int r> *void* r> *int r> *int ; diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index dd9d6b8ccd..80c9b80ea7 100644 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -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 diff --git a/extra/pack/pack.factor b/extra/pack/pack.factor index c9d05c19d7..b9b1f6f314 100644 --- a/extra/pack/pack.factor +++ b/extra/pack/pack.factor @@ -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 *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 diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index e55ee9d852..5343bb513b 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -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 -C: ebnf-terminal -C: ebnf-choice -C: ebnf-sequence -C: ebnf-repeat0 -C: ebnf-optional -C: ebnf-rule -C: ebnf-action -C: 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 ] action ; - -: 'terminal' ( -- parser ) - "'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string ] 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 ] action ; - -: 'optional' ( -- parser ) - "[" token sp hide - [ 'choice' sp ] delay - "]" token sp hide - 3array seq [ first ] action ; - -: 'sequence' ( -- parser ) - [ - 'element' sp , - 'group' sp , - 'repeat0' sp , - 'optional' sp , - ] { } make choice - repeat1 [ - dup length 1 = [ first ] [ ] if - ] action ; - -: 'choice' ( -- parser ) - 'sequence' sp "|" token sp list-of [ - dup length 1 = [ first ] [ ] if - ] action ; - -: 'action' ( -- parser ) - "=>" token hide - [ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp - 2array seq [ first ] 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 ] action ; - -: 'ebnf' ( -- parser ) - 'rule' sp "." token sp hide list-of [ ] 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 +C: ebnf-terminal +C: ebnf-choice +C: ebnf-sequence +C: ebnf-repeat0 +C: ebnf-optional +C: ebnf-rule +C: ebnf-action +C: 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 ] action ; + +: 'terminal' ( -- parser ) + "'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string ] 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 ] action ; + +: 'optional' ( -- parser ) + "[" token sp hide + [ 'choice' sp ] delay + "]" token sp hide + 3array seq [ first ] action ; + +: 'sequence' ( -- parser ) + [ + 'element' sp , + 'group' sp , + 'repeat0' sp , + 'optional' sp , + ] { } make choice + repeat1 [ + dup length 1 = [ first ] [ ] if + ] action ; + +: 'choice' ( -- parser ) + 'sequence' sp "|" token sp list-of [ + dup length 1 = [ first ] [ ] if + ] action ; + +: 'action' ( -- parser ) + "=>" token hide + [ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp + 2array seq [ first ] 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 ] action ; + +: 'ebnf' ( -- parser ) + 'rule' sp "." token sp hide list-of [ ] 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* ; + : " parse-tokens " " join ebnf>quot call ; parsing \ No newline at end of file diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor index 41463d85a0..6dff95c829 100644 --- a/extra/peg/peg-docs.factor +++ b/extra/peg/peg-docs.factor @@ -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 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 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." } ; \ No newline at end of file diff --git a/extra/random-tester/random-tester.factor b/extra/random-tester/random-tester.factor index f8aa0f29b5..c3a1ecbec4 100644 --- a/extra/random-tester/random-tester.factor +++ b/extra/random-tester/random-tester.factor @@ -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 diff --git a/extra/random-weighted/random-weighted.factor b/extra/random-weighted/random-weighted.factor index e3c71ec807..1e9e35d0bf 100644 --- a/extra/random-weighted/random-weighted.factor +++ b/extra/random-weighted/random-weighted.factor @@ -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 ; diff --git a/extra/random/random.factor b/extra/random/random.factor index 6045da72d8..db2aacd2b0 100755 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -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 ) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index e46ce3b107..37b00042d2 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -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 ; diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor index 70a08cdced..ba423699c3 100755 --- a/extra/slides/slides.factor +++ b/extra/slides/slides.factor @@ -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 ; diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 01a50566b4..4a737f06c2 100644 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -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 -- ) [ 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 ] } diff --git a/extra/visitor/authors.txt b/extra/visitor/authors.txt deleted file mode 100644 index f990dd0ed2..0000000000 --- a/extra/visitor/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Daniel Ehrenberg diff --git a/extra/visitor/summary.txt b/extra/visitor/summary.txt deleted file mode 100644 index 3093ae9a9c..0000000000 --- a/extra/visitor/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Double-dispatch generic words diff --git a/extra/visitor/tags.txt b/extra/visitor/tags.txt deleted file mode 100644 index f4274299b1..0000000000 --- a/extra/visitor/tags.txt +++ /dev/null @@ -1 +0,0 @@ -extensions diff --git a/extra/visitor/visitor-tests.factor b/extra/visitor/visitor-tests.factor deleted file mode 100644 index 8248affaf7..0000000000 --- a/extra/visitor/visitor-tests.factor +++ /dev/null @@ -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 diff --git a/extra/visitor/visitor.factor b/extra/visitor/visitor.factor deleted file mode 100644 index dd6bad7d97..0000000000 --- a/extra/visitor/visitor.factor +++ /dev/null @@ -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 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 ;