Fixing everything for mandatory stack effects
Slava Pestov
parent
2793d9b195
commit
ba8f1388ab
|
|
@ -31,6 +31,7 @@ crossref off
|
|||
! Bring up a bare cross-compiling vocabulary.
|
||||
"syntax" vocab vocab-words bootstrap-syntax set
|
||||
H{ } clone dictionary set
|
||||
H{ } clone new-classes set
|
||||
H{ } clone changed-definitions set
|
||||
H{ } clone forgotten-definitions set
|
||||
H{ } clone root-cache set
|
||||
|
|
|
|||
|
|
@ -67,8 +67,6 @@ GENERIC: reset-class ( class -- )
|
|||
|
||||
M: word reset-class drop ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! update-map
|
||||
: class-uses ( class -- seq )
|
||||
[
|
||||
|
|
@ -81,6 +79,8 @@ M: word reset-class drop ;
|
|||
: class-usages ( class -- assoc )
|
||||
[ update-map get at ] closure ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: update-map+ ( class -- )
|
||||
dup class-uses update-map get add-vertex ;
|
||||
|
||||
|
|
@ -100,6 +100,7 @@ M: word reset-class drop ;
|
|||
: (define-class) ( word props -- )
|
||||
>r
|
||||
dup reset-class
|
||||
dup class? [ dup new-class ] unless
|
||||
dup deferred? [ dup define-symbol ] when
|
||||
dup word-props
|
||||
r> assoc-union over set-word-props
|
||||
|
|
@ -115,13 +116,13 @@ GENERIC: update-class ( class -- )
|
|||
|
||||
M: class update-class drop ;
|
||||
|
||||
GENERIC: update-methods ( assoc -- )
|
||||
GENERIC: update-methods ( class assoc -- )
|
||||
|
||||
: update-classes ( class -- )
|
||||
class-usages
|
||||
[ [ drop update-class ] assoc-each ]
|
||||
dup class-usages
|
||||
[ nip keys [ update-class ] each ]
|
||||
[ update-methods ]
|
||||
bi ;
|
||||
2bi ;
|
||||
|
||||
: define-class ( word superclass members participants metaclass -- )
|
||||
#! If it was already a class, update methods after.
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes classes.union words kernel sequences
|
||||
definitions combinators arrays accessors ;
|
||||
definitions combinators arrays assocs generic accessors ;
|
||||
IN: classes.mixin
|
||||
|
||||
PREDICATE: mixin-class < union-class "mixin" word-prop ;
|
||||
|
|
@ -12,8 +12,9 @@ M: mixin-class reset-class
|
|||
M: mixin-class rank-class drop 3 ;
|
||||
|
||||
: redefine-mixin-class ( class members -- )
|
||||
dupd define-union-class
|
||||
t "mixin" set-word-prop ;
|
||||
[ (define-union-class) ]
|
||||
[ drop t "mixin" set-word-prop ]
|
||||
2bi ;
|
||||
|
||||
: define-mixin-class ( class -- )
|
||||
dup mixin-class? [
|
||||
|
|
@ -30,17 +31,36 @@ TUPLE: check-mixin-class mixin ;
|
|||
] unless ;
|
||||
|
||||
: if-mixin-member? ( class mixin true false -- )
|
||||
>r >r check-mixin-class 2dup members memq? r> r> if ; inline
|
||||
[ check-mixin-class 2dup members memq? ] 2dip if ; inline
|
||||
|
||||
: change-mixin-class ( class mixin quot -- )
|
||||
[ members swap bootstrap-word ] prepose keep
|
||||
[ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
|
||||
swap redefine-mixin-class ; inline
|
||||
|
||||
: update-classes/new ( mixin -- )
|
||||
class-usages
|
||||
[ keys [ update-class ] each ]
|
||||
[ implementors [ make-generic ] each ] bi ;
|
||||
|
||||
: add-mixin-instance ( class mixin -- )
|
||||
[ 2drop ] [ [ suffix ] change-mixin-class ] if-mixin-member? ;
|
||||
#! Note: we call update-classes on the new member, not the
|
||||
#! mixin. This ensures that we only have to update the
|
||||
#! methods whose specializer intersects the new member, not
|
||||
#! the entire mixin (since the other mixin members are not
|
||||
#! affected at all). Also, all usages of the mixin will get
|
||||
#! updated by transitivity; the mixins usages appear in
|
||||
#! class-usages of the member, now that it's been added.
|
||||
[ 2drop ] [
|
||||
[ [ suffix ] change-mixin-class ] 2keep
|
||||
nip update-classes
|
||||
! over new-class? [ nip update-classes/new ] [ drop update-classes ] if
|
||||
] if-mixin-member? ;
|
||||
|
||||
: remove-mixin-instance ( class mixin -- )
|
||||
[ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;
|
||||
[
|
||||
[ [ swap remove ] change-mixin-class ] keep
|
||||
update-classes
|
||||
] [ 2drop ] if-mixin-member? ;
|
||||
|
||||
! Definition protocol implementation ensures that removing an
|
||||
! INSTANCE: declaration from a source file updates the mixin.
|
||||
|
|
|
|||
|
|
@ -176,7 +176,7 @@ M: tuple-class update-class
|
|||
2drop
|
||||
[
|
||||
[ update-tuples-after ]
|
||||
[ changed-definition ]
|
||||
[ +inlined+ changed-definition ]
|
||||
[ redefined ]
|
||||
tri
|
||||
] each-subclass
|
||||
|
|
|
|||
|
|
@ -22,10 +22,11 @@ PREDICATE: union-class < class
|
|||
|
||||
M: union-class update-class define-union-predicate ;
|
||||
|
||||
: (define-union-class) ( class members -- )
|
||||
f swap f union-class define-class ;
|
||||
|
||||
: define-union-class ( class members -- )
|
||||
[ f swap f union-class define-class ]
|
||||
[ drop update-classes ]
|
||||
2bi ;
|
||||
[ (define-union-class) ] [ drop update-classes ] 2bi ;
|
||||
|
||||
M: union-class reset-class
|
||||
{ "class" "metaclass" "members" } reset-props ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,14 @@
|
|||
IN: compiler.tests
|
||||
USING: compiler tools.test math parser ;
|
||||
|
||||
GENERIC: method-redefine-test ( a -- b )
|
||||
|
||||
M: integer method-redefine-test 3 + ;
|
||||
|
||||
: method-redefine-test-1 ( -- b ) 3 method-redefine-test ;
|
||||
|
||||
[ 6 ] [ method-redefine-test-1 ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test
|
||||
|
||||
[ 7 ] [ method-redefine-test-1 ] unit-test
|
||||
|
|
@ -81,11 +81,11 @@ IN: compiler.tests
|
|||
|
||||
[ ] [ dummy-if-2 ] unit-test
|
||||
|
||||
: dummy-if-3 ( -- ) t [ 1 ] [ 2 ] if ;
|
||||
: dummy-if-3 ( -- n ) t [ 1 ] [ 2 ] if ;
|
||||
|
||||
[ 1 ] [ dummy-if-3 ] unit-test
|
||||
|
||||
: dummy-if-4 ( -- ) f [ 1 ] [ 2 ] if ;
|
||||
: dummy-if-4 ( -- n ) f [ 1 ] [ 2 ] if ;
|
||||
|
||||
[ 2 ] [ dummy-if-4 ] unit-test
|
||||
|
||||
|
|
@ -140,12 +140,12 @@ DEFER: countdown-b
|
|||
[ 16 ] [ 4 dummy-when-3 ] unit-test
|
||||
[ f ] [ f dummy-when-3 ] unit-test
|
||||
|
||||
: dummy-when-4 ( a -- b c ) dup [ dup dup fixnum* fixnum* ] when swap ;
|
||||
: dummy-when-4 ( a b -- a b ) dup [ dup dup fixnum* fixnum* ] when swap ;
|
||||
|
||||
[ 64 f ] [ f 4 dummy-when-4 ] unit-test
|
||||
[ f t ] [ t f dummy-when-4 ] unit-test
|
||||
|
||||
: dummy-when-5 ( -- ) f [ dup fixnum* ] when ;
|
||||
: dummy-when-5 ( a -- b ) f [ dup fixnum* ] when ;
|
||||
|
||||
[ f ] [ f dummy-when-5 ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -73,7 +73,7 @@ SYMBOL: outdated-tuples
|
|||
SYMBOL: update-tuples-hook
|
||||
|
||||
: call-recompile-hook ( -- )
|
||||
changed-definitions get keys [ word? ] filter
|
||||
changed-definitions get [ drop word? ] assoc-filter
|
||||
compiled-usages recompile-hook get call ;
|
||||
|
||||
: call-update-tuples-hook ( -- )
|
||||
|
|
@ -82,8 +82,7 @@ SYMBOL: update-tuples-hook
|
|||
: finish-compilation-unit ( -- )
|
||||
call-recompile-hook
|
||||
call-update-tuples-hook
|
||||
dup [ drop crossref? ] assoc-contains? modify-code-heap
|
||||
;
|
||||
dup [ drop crossref? ] assoc-contains? modify-code-heap ;
|
||||
|
||||
: with-nested-compilation-unit ( quot -- )
|
||||
[
|
||||
|
|
@ -97,6 +96,7 @@ SYMBOL: update-tuples-hook
|
|||
H{ } clone changed-definitions set
|
||||
H{ } clone forgotten-definitions set
|
||||
H{ } clone outdated-tuples set
|
||||
H{ } clone new-classes set
|
||||
<definitions> new-definitions set
|
||||
<definitions> old-definitions set
|
||||
[
|
||||
|
|
|
|||
|
|
@ -7,10 +7,21 @@ ERROR: no-compilation-unit definition ;
|
|||
|
||||
SYMBOL: changed-definitions
|
||||
|
||||
: changed-definition ( defspec -- )
|
||||
dup changed-definitions get
|
||||
[ no-compilation-unit ] unless*
|
||||
set-at ;
|
||||
SYMBOL: +inlined+
|
||||
SYMBOL: +called+
|
||||
|
||||
: changed-definition ( defspec how -- )
|
||||
swap changed-definitions get
|
||||
[ set-at ] [ no-compilation-unit ] if* ;
|
||||
|
||||
SYMBOL: new-classes
|
||||
|
||||
: new-class ( word -- )
|
||||
dup new-classes get
|
||||
[ set-at ] [ no-compilation-unit ] if* ;
|
||||
|
||||
: new-class? ( word -- ? )
|
||||
new-classes get key? ;
|
||||
|
||||
GENERIC: where ( defspec -- loc )
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,9 @@ USING: help.markup help.syntax math strings words ;
|
|||
IN: effects
|
||||
|
||||
ARTICLE: "effect-declaration" "Stack effect declaration"
|
||||
"It is good practice to declare the stack effects of words using the following syntax:"
|
||||
"Stack effects of words must be declared, with the exception of words which only push literals on the stack."
|
||||
$nl
|
||||
"Stack effects are declared with the following syntax:"
|
||||
{ $code ": sq ( x -- y ) dup * ;" }
|
||||
"A stack effect declaration is written in parentheses and lists word inputs and outputs, separated by " { $snippet "--" } ". Stack effect declarations are read in using a parsing word:"
|
||||
{ $subsection POSTPONE: ( }
|
||||
|
|
@ -28,18 +30,21 @@ $nl
|
|||
ARTICLE: "effects" "Stack effects"
|
||||
"A " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that an operation takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output."
|
||||
$nl
|
||||
"Stack effects of words can be declared."
|
||||
{ $subsection "effect-declaration" }
|
||||
"Stack effects are first-class, and words for working with them are found in the " { $vocab-link "effects" } " vocabulary."
|
||||
{ $subsection effect }
|
||||
{ $subsection effect? }
|
||||
"Stack effects of words can be declared."
|
||||
{ $subsection "effect-declaration" }
|
||||
"There is a literal syntax for stack objects. It is most often used with " { $link define-declared } "."
|
||||
{ $subsection POSTPONE: (( }
|
||||
"Getting a word's declared stack effect:"
|
||||
{ $subsection stack-effect }
|
||||
"Converting a stack effect to a string form:"
|
||||
{ $subsection effect>string }
|
||||
"Comparing effects:"
|
||||
{ $subsection effect-height }
|
||||
{ $subsection effect<= } ;
|
||||
{ $subsection effect<= }
|
||||
{ $see-also "inference" } ;
|
||||
|
||||
ABOUT: "effects"
|
||||
|
||||
|
|
|
|||
|
|
@ -8,4 +8,10 @@ USING: effects tools.test prettyprint accessors sequences ;
|
|||
[ f ] [ 2 3 <effect> 2 2 <effect> effect<= ] unit-test
|
||||
[ 2 ] [ (( a b -- c )) in>> length ] unit-test
|
||||
[ 1 ] [ (( a b -- c )) out>> length ] unit-test
|
||||
|
||||
|
||||
[ "(( a b -- c d ))" ] [ { "a" "b" } { "c" "d" } <effect> unparse ] unit-test
|
||||
[ "(( -- c d ))" ] [ { } { "c" "d" } <effect> unparse ] unit-test
|
||||
[ "(( a b -- ))" ] [ { "a" "b" } { } <effect> unparse ] unit-test
|
||||
[ "(( -- ))" ] [ { } { } <effect> unparse ] unit-test
|
||||
[ "(( a b -- c ))" ] [ (( a b -- c )) unparse ] unit-test
|
||||
|
|
|
|||
|
|
@ -56,8 +56,19 @@ TUPLE: check-method class generic ;
|
|||
\ check-method boa throw
|
||||
] unless ; inline
|
||||
|
||||
: with-methods ( generic quot -- )
|
||||
swap [ "methods" word-prop swap call ] keep make-generic ;
|
||||
: affected-methods ( class generic -- seq )
|
||||
"methods" word-prop swap
|
||||
[ nip classes-intersect? ] curry assoc-filter
|
||||
values ;
|
||||
|
||||
: update-generic ( class generic -- )
|
||||
[ affected-methods [ +called+ changed-definition ] each ]
|
||||
[ make-generic ]
|
||||
bi ;
|
||||
|
||||
: with-methods ( class generic quot -- )
|
||||
[ [ "methods" word-prop ] dip call ]
|
||||
[ drop update-generic ] 3bi ;
|
||||
inline
|
||||
|
||||
: method-word-name ( class word -- string )
|
||||
|
|
@ -140,15 +151,17 @@ M: method-body forget*
|
|||
M: method-body smart-usage
|
||||
"method-generic" word-prop smart-usage ;
|
||||
|
||||
: implementors* ( classes -- words )
|
||||
GENERIC: implementors ( class/classes -- seq )
|
||||
|
||||
M: class implementors
|
||||
all-words [ "methods" word-prop key? ] with filter ;
|
||||
|
||||
M: assoc implementors
|
||||
all-words [
|
||||
"methods" word-prop keys
|
||||
"methods" word-prop keys
|
||||
swap [ key? ] curry contains?
|
||||
] with filter ;
|
||||
|
||||
: implementors ( class -- seq )
|
||||
dup associate implementors* ;
|
||||
|
||||
: forget-methods ( class -- )
|
||||
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
|
||||
|
||||
|
|
@ -164,8 +177,8 @@ M: class forget* ( class -- )
|
|||
]
|
||||
[ call-next-method ] bi ;
|
||||
|
||||
M: assoc update-methods ( assoc -- )
|
||||
implementors* [ make-generic ] each ;
|
||||
M: assoc update-methods ( class assoc -- )
|
||||
implementors [ update-generic ] with each ;
|
||||
|
||||
: define-generic ( word combination -- )
|
||||
over "combination" word-prop over = [
|
||||
|
|
|
|||
|
|
@ -62,7 +62,7 @@ HELP: effect-error
|
|||
{ $error-description "Thrown when a word's inferred stack effect does not match its declared stack effect." } ;
|
||||
|
||||
HELP: missing-effect
|
||||
{ $error-description "Thrown when inference encounters a word lacking a stack effect declaration. Words not declared " { $link POSTPONE: inline } " must declare a stack effect in order to compile." } ;
|
||||
{ $error-description "Thrown when inference encounters a word lacking a stack effect declaration. Stack effects of words must be declared, with the exception of words which only push literals on the stack." } ;
|
||||
|
||||
HELP: recursive-quotation-error
|
||||
{ $error-description "Thrown when a quotation calls itself, directly or indirectly, within the same word. Stack effect inference becomes equivalent to the halting problem if quotation recursion has to be taken into account, hence it is not permitted." }
|
||||
|
|
|
|||
|
|
@ -5,14 +5,14 @@ USING: inference.backend inference.dataflow kernel generic
|
|||
sequences prettyprint io words arrays inspector effects debugger
|
||||
assocs accessors ;
|
||||
|
||||
M: inference-error error-help error>> error-help ;
|
||||
|
||||
M: inference-error error.
|
||||
dup rstate>>
|
||||
keys [ dup value? [ value-literal ] when ] map
|
||||
dup empty? [ "Word: " write dup peek . ] unless
|
||||
swap error>> error. "Nesting: " write . ;
|
||||
|
||||
M: inference-error error-help drop f ;
|
||||
|
||||
M: unbalanced-branches-error error.
|
||||
"Unbalanced branches:" print
|
||||
[ quots>> ] [ in>> ] [ out>> [ length ] map ] tri 3array flip
|
||||
|
|
|
|||
|
|
@ -108,7 +108,8 @@ $nl
|
|||
{ $subsection "inference-limitations" }
|
||||
{ $subsection "inference-errors" }
|
||||
{ $subsection "dataflow-graphs" }
|
||||
{ $subsection "compiler-transforms" } ;
|
||||
{ $subsection "compiler-transforms" }
|
||||
{ $see-also "effects" } ;
|
||||
|
||||
ABOUT: "inference"
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
IN: inference.state.tests
|
||||
USING: tools.test inference.state words kernel namespaces ;
|
||||
USING: tools.test inference.state words kernel namespaces
|
||||
definitions ;
|
||||
|
||||
: computing-dependencies ( quot -- dependencies )
|
||||
H{ } clone [ dependencies rot with-variable ] keep ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs namespaces sequences kernel words ;
|
||||
USING: assocs namespaces sequences kernel definitions ;
|
||||
IN: inference.state
|
||||
|
||||
! Nesting state to solve recursion
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ classes ;
|
|||
: compose-n-quot ( word -- quot' ) <repetition> >quotation ;
|
||||
: compose-n ( quot -- ) compose-n-quot call ;
|
||||
\ compose-n [ compose-n-quot ] 2 define-transform
|
||||
: compose-n-test ( -- x ) 2 \ + compose-n ;
|
||||
: compose-n-test ( a b c -- x ) 2 \ + compose-n ;
|
||||
|
||||
[ 6 ] [ 1 2 3 compose-n-test ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: arrays kernel words sequences generic math namespaces
|
||||
quotations assocs combinators math.bitfields inference.backend
|
||||
inference.dataflow inference.state classes.tuple.private effects
|
||||
inspector hashtables classes generic sets ;
|
||||
inspector hashtables classes generic sets definitions ;
|
||||
IN: inference.transforms
|
||||
|
||||
: pop-literals ( n -- rstate seq )
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ combinators classes classes.algebra generic.math
|
|||
optimizer.math.partial continuations optimizer.def-use
|
||||
optimizer.backend generic.standard optimizer.specializers
|
||||
optimizer.def-use optimizer.pattern-match generic.standard
|
||||
optimizer.control kernel.private ;
|
||||
optimizer.control kernel.private definitions ;
|
||||
IN: optimizer.inlining
|
||||
|
||||
: remember-inlining ( node history -- )
|
||||
|
|
@ -61,12 +61,8 @@ DEFER: (flat-length)
|
|||
[ dispatch# node-class# ] keep specific-method ;
|
||||
|
||||
: inline-standard-method ( node word -- node )
|
||||
2dup dispatching-class dup [
|
||||
over +inlined+ depends-on
|
||||
swap method 1quotation f splice-quot
|
||||
] [
|
||||
3drop t
|
||||
] if ;
|
||||
2dup dispatching-class dup
|
||||
[ swap method 1quotation f splice-quot ] [ 3drop t ] if ;
|
||||
|
||||
! Partial dispatch of math-generic words
|
||||
: normalize-math-class ( class -- class' )
|
||||
|
|
|
|||
|
|
@ -359,9 +359,8 @@ M: staging-violation summary
|
|||
"A parsing word cannot be used in the same file it is defined in." ;
|
||||
|
||||
: execute-parsing ( word -- )
|
||||
[ changed-definitions get key? [ staging-violation ] when ]
|
||||
[ execute ]
|
||||
bi ;
|
||||
dup changed-definitions get key? [ staging-violation ] when
|
||||
execute ;
|
||||
|
||||
: parse-step ( accum end -- accum ? )
|
||||
scan-word {
|
||||
|
|
|
|||
|
|
@ -34,23 +34,6 @@ unit-test
|
|||
|
||||
[ "SBUF\" hello world\"" ] [ SBUF" hello world" unparse ] unit-test
|
||||
|
||||
|
||||
[ "( a b -- c d )" ] [
|
||||
{ "a" "b" } { "c" "d" } <effect> effect>string
|
||||
] unit-test
|
||||
|
||||
[ "( -- c d )" ] [
|
||||
{ } { "c" "d" } <effect> effect>string
|
||||
] unit-test
|
||||
|
||||
[ "( a b -- )" ] [
|
||||
{ "a" "b" } { } <effect> effect>string
|
||||
] unit-test
|
||||
|
||||
[ "( -- )" ] [
|
||||
{ } { } <effect> effect>string
|
||||
] unit-test
|
||||
|
||||
[ "W{ \\ + }" ] [ [ W{ \ + } ] first unparse ] unit-test
|
||||
|
||||
[ ] [ \ fixnum see ] unit-test
|
||||
|
|
|
|||
|
|
@ -53,11 +53,13 @@ M: compose length
|
|||
[ compose-first length ]
|
||||
[ compose-second length ] bi + ;
|
||||
|
||||
M: compose nth
|
||||
M: compose virtual-seq compose-first ;
|
||||
|
||||
M: compose virtual@
|
||||
2dup compose-first length < [
|
||||
compose-first
|
||||
] [
|
||||
[ compose-first length - ] [ compose-second ] bi
|
||||
] if nth ;
|
||||
] if ;
|
||||
|
||||
INSTANCE: compose immutable-sequence
|
||||
INSTANCE: compose virtual-sequence
|
||||
|
|
|
|||
|
|
@ -118,19 +118,11 @@ HELP: define-slot-word
|
|||
{ $description "Defines " { $snippet "word" } " to be a simple type-checking generic word that receives the slot number on the stack as a fixnum." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: reader-effect
|
||||
{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
|
||||
{ $description "The stack effect of slot reader words is " { $snippet "( object -- value )" } "." } ;
|
||||
|
||||
HELP: define-reader
|
||||
{ $values { "class" class } { "name" string } { "slot" integer } }
|
||||
{ $description "Defines a reader word to read a slot from instances of " { $snippet "class" } "." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: writer-effect
|
||||
{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
|
||||
{ $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ;
|
||||
|
||||
HELP: define-writer
|
||||
{ $values { "class" class } { "name" string } { "slot" integer } }
|
||||
{ $description "Defines a generic word " { $snippet "writer" } " to write a new value to a slot in instances of " { $snippet "class" } "." }
|
||||
|
|
|
|||
|
|
@ -319,9 +319,9 @@ HELP: POSTPONE:
|
|||
{ $notes "This word is used inside parsing words to delegate further action to another parsing word, and to refer to parsing words literally from literal arrays and such." } ;
|
||||
|
||||
HELP: :
|
||||
{ $syntax ": word definition... ;" }
|
||||
{ $syntax ": word ( stack -- effect ) definition... ;" }
|
||||
{ $values { "word" "a new word to define" } { "definition" "a word definition" } }
|
||||
{ $description "Defines a word in the current vocabulary." }
|
||||
{ $description "Defines a word with the given stack effect in the current vocabulary. The stack effect is optional for words which only push literals on the stack." }
|
||||
{ $examples { $code ": ask-name ( -- name )\n \"What is your name? \" write readln ;\n: greet ( name -- )\n \"Greetings, \" write print ;\n: friend ( -- )\n ask-name greet ;" } } ;
|
||||
|
||||
{ POSTPONE: : POSTPONE: ; define } related-words
|
||||
|
|
@ -413,13 +413,21 @@ HELP: (
|
|||
{ $syntax "( inputs -- outputs )" }
|
||||
{ $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } }
|
||||
{ $description "Declares the stack effect of the most recently defined word, storing a new " { $link effect } " instance in the " { $snippet "\"declared-effect\"" } " word property." }
|
||||
{ $notes "Words must have a declared stack effect to compile. See " { $link "effect-declaration" } " for details." } ;
|
||||
{ $notes "All words except those only pushing literals on the stack must have a stack effect declaration. See " { $link "effect-declaration" } " for details." } ;
|
||||
|
||||
HELP: ((
|
||||
{ $syntax "(( inputs -- outputs ))" }
|
||||
{ $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } }
|
||||
{ $description "Literal stack effect syntax." }
|
||||
{ $notes "Useful for meta-programming with " { $link define-declared } "." } ;
|
||||
{ $notes "Useful for meta-programming with " { $link define-declared } "." }
|
||||
{ $examples
|
||||
{ $code
|
||||
"SYMBOL: my-dynamic-word"
|
||||
"USING: math random words ;"
|
||||
"3 { [ + ] [ - ] [ * ] [ / ] } random curry"
|
||||
"(( x -- y )) define-declared"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: !
|
||||
{ $syntax "! comment..." }
|
||||
|
|
|
|||
|
|
@ -114,16 +114,20 @@ compiled-crossref global [ H{ } assoc-like ] change-at
|
|||
dup compiled-unxref
|
||||
compiled-crossref get delete-at ;
|
||||
|
||||
SYMBOL: +inlined+
|
||||
SYMBOL: +called+
|
||||
|
||||
: compiled-usage ( word -- assoc )
|
||||
compiled-crossref get at ;
|
||||
|
||||
: compiled-usages ( words -- seq )
|
||||
[ unique dup ] keep [
|
||||
compiled-usage [ nip +inlined+ eq? ] assoc-filter update
|
||||
] with each keys ;
|
||||
: compiled-usages ( assoc -- seq )
|
||||
clone [
|
||||
dup [
|
||||
[
|
||||
[ compiled-usage ] dip
|
||||
+inlined+ eq? [
|
||||
[ nip +inlined+ eq? ] assoc-filter
|
||||
] when
|
||||
] dip swap update
|
||||
] curry assoc-each
|
||||
] keep keys ;
|
||||
|
||||
GENERIC: redefined ( word -- )
|
||||
|
||||
|
|
@ -134,7 +138,7 @@ M: object redefined drop ;
|
|||
over unxref
|
||||
over redefined
|
||||
over set-word-def
|
||||
dup changed-definition
|
||||
dup +inlined+ changed-definition
|
||||
dup crossref? [ dup xref ] when drop ;
|
||||
|
||||
: define-declared ( word def effect -- )
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ SYMBOL: elements
|
|||
|
||||
TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
|
||||
|
||||
: <element> element new ;
|
||||
: <element> ( -- element ) element new ;
|
||||
|
||||
: set-id ( -- boolean )
|
||||
read1 dup elements get set-element-id ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: math kernel continuations ;
|
||||
IN: benchmark.continuations
|
||||
|
||||
: continuations-main
|
||||
: continuations-main ( -- )
|
||||
100000 [ drop [ continue ] callcc0 ] each-integer ;
|
||||
|
||||
MAIN: continuations-main
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: namespaces math sequences splitting kernel columns ;
|
||||
IN: benchmark.dispatch2
|
||||
|
||||
: sequences
|
||||
: sequences ( -- seq )
|
||||
[
|
||||
1 ,
|
||||
10 >bignum ,
|
||||
|
|
@ -21,9 +21,9 @@ IN: benchmark.dispatch2
|
|||
1 [ + ] curry ,
|
||||
] { } make ;
|
||||
|
||||
: don't-flush-me drop ;
|
||||
: don't-flush-me ( obj -- ) drop ;
|
||||
|
||||
: dispatch-test
|
||||
: dispatch-test ( -- )
|
||||
1000000 sequences
|
||||
[ [ 0 swap nth don't-flush-me ] each ] curry times ;
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ M: number g drop "number" ;
|
|||
|
||||
M: object g drop "object" ;
|
||||
|
||||
: objects
|
||||
: objects ( -- seq )
|
||||
[
|
||||
H{ } ,
|
||||
\ + <mirror> ,
|
||||
|
|
@ -42,7 +42,7 @@ M: object g drop "object" ;
|
|||
ALIEN: 1234 ,
|
||||
] { } make ;
|
||||
|
||||
: dispatch-test
|
||||
: dispatch-test ( -- )
|
||||
2000000 objects [ [ g drop ] each ] curry times ;
|
||||
|
||||
MAIN: dispatch-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: kernel.private kernel sequences math combinators
|
|||
sequences.private ;
|
||||
IN: benchmark.dispatch4
|
||||
|
||||
: foobar-1
|
||||
: foobar-1 ( n -- val )
|
||||
dup {
|
||||
[ 0 eq? [ 0 ] [ "x" ] if ]
|
||||
[ 1 eq? [ 1 ] [ "x" ] if ]
|
||||
|
|
@ -26,7 +26,7 @@ IN: benchmark.dispatch4
|
|||
[ 19 eq? [ 19 ] [ "x" ] if ]
|
||||
} dispatch ;
|
||||
|
||||
: foobar-2
|
||||
: foobar-2 ( n -- val )
|
||||
{
|
||||
{ [ dup 0 eq? ] [ drop 0 ] }
|
||||
{ [ dup 1 eq? ] [ drop 1 ] }
|
||||
|
|
@ -50,14 +50,14 @@ IN: benchmark.dispatch4
|
|||
{ [ dup 19 eq? ] [ drop 19 ] }
|
||||
} cond ;
|
||||
|
||||
: foobar-test-1
|
||||
: foobar-test-1 ( -- )
|
||||
20000000 [
|
||||
20 [
|
||||
foobar-1 drop
|
||||
] each
|
||||
] times ;
|
||||
|
||||
: foobar-test-2
|
||||
: foobar-test-2 ( -- )
|
||||
20000000 [
|
||||
20 [
|
||||
foobar-2 drop
|
||||
|
|
|
|||
|
|
@ -105,6 +105,6 @@ HINTS: random fixnum ;
|
|||
|
||||
] ;
|
||||
|
||||
: run-fasta 2500000 reverse-complement-in fasta ;
|
||||
: run-fasta ( -- ) 2500000 reverse-complement-in fasta ;
|
||||
|
||||
MAIN: run-fasta
|
||||
|
|
|
|||
|
|
@ -9,6 +9,6 @@ IN: benchmark.fib1
|
|||
swap 1 fixnum-fast fast-fixnum-fib fixnum+fast
|
||||
] if ;
|
||||
|
||||
: fib-main 34 fast-fixnum-fib 9227465 assert= ;
|
||||
: fib-main ( -- ) 34 fast-fixnum-fib 9227465 assert= ;
|
||||
|
||||
MAIN: fib-main
|
||||
|
|
|
|||
|
|
@ -8,6 +8,6 @@ IN: benchmark.fib2
|
|||
1 fixnum- dup fixnum-fib swap 1 fixnum- fixnum-fib fixnum+
|
||||
] if ;
|
||||
|
||||
: fib-main 34 fixnum-fib 9227465 assert= ;
|
||||
: fib-main ( -- ) 34 fixnum-fib 9227465 assert= ;
|
||||
|
||||
MAIN: fib-main
|
||||
|
|
|
|||
|
|
@ -4,6 +4,6 @@ IN: benchmark.fib3
|
|||
: fib ( m -- n )
|
||||
dup 1 <= [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
|
||||
|
||||
: fib-main 34 fib 9227465 assert= ;
|
||||
: fib-main ( -- ) 34 fib 9227465 assert= ;
|
||||
|
||||
MAIN: fib-main
|
||||
|
|
|
|||
|
|
@ -17,6 +17,6 @@ C: <box> box
|
|||
swap box-i swap box-i + <box>
|
||||
] if ;
|
||||
|
||||
: fib-main T{ box f 34 } tuple-fib T{ box f 9227465 } assert= ;
|
||||
: fib-main ( -- ) T{ box f 34 } tuple-fib T{ box f 9227465 } assert= ;
|
||||
|
||||
MAIN: fib-main
|
||||
|
|
|
|||
|
|
@ -14,6 +14,6 @@ SYMBOL: n
|
|||
] if
|
||||
] with-scope ;
|
||||
|
||||
: fib-main 30 namespace-fib 1346269 assert= ;
|
||||
: fib-main ( -- ) 30 namespace-fib 1346269 assert= ;
|
||||
|
||||
MAIN: fib-main
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: benchmark.fib6
|
||||
USING: math kernel alien ;
|
||||
|
||||
: fib
|
||||
: fib ( x -- y )
|
||||
"int" { "int" } "cdecl" [
|
||||
dup 1 <= [ drop 1 ] [
|
||||
1- dup fib swap 1- fib +
|
||||
|
|
@ -9,6 +9,6 @@ USING: math kernel alien ;
|
|||
] alien-callback
|
||||
"int" { "int" } "cdecl" alien-indirect ;
|
||||
|
||||
: fib-main 25 fib drop ;
|
||||
: fib-main ( -- ) 25 fib drop ;
|
||||
|
||||
MAIN: fib-main
|
||||
|
|
|
|||
|
|
@ -4,14 +4,14 @@ kernel ;
|
|||
|
||||
: <range> ( from to -- seq ) dup <slice> ; inline
|
||||
|
||||
: vector-iter 100 [ 0 100000 <range> >vector [ ] map drop ] times ;
|
||||
: array-iter 100 [ 0 100000 <range> >array [ ] map drop ] times ;
|
||||
: string-iter 100 [ 0 100000 <range> >string [ ] map drop ] times ;
|
||||
: sbuf-iter 100 [ 0 100000 <range> >sbuf [ ] map drop ] times ;
|
||||
: reverse-iter 100 [ 0 100000 <range> >vector <reversed> [ ] map drop ] times ;
|
||||
: dot-iter 100 [ 0 100000 <range> dup v. drop ] times ;
|
||||
: vector-iter ( -- ) 100 [ 0 100000 <range> >vector [ ] map drop ] times ;
|
||||
: array-iter ( -- ) 100 [ 0 100000 <range> >array [ ] map drop ] times ;
|
||||
: string-iter ( -- ) 100 [ 0 100000 <range> >string [ ] map drop ] times ;
|
||||
: sbuf-iter ( -- ) 100 [ 0 100000 <range> >sbuf [ ] map drop ] times ;
|
||||
: reverse-iter ( -- ) 100 [ 0 100000 <range> >vector <reversed> [ ] map drop ] times ;
|
||||
: dot-iter ( -- ) 100 [ 0 100000 <range> dup v. drop ] times ;
|
||||
|
||||
: iter-main
|
||||
: iter-main ( -- )
|
||||
vector-iter
|
||||
array-iter
|
||||
string-iter
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ SYMBOL: cols
|
|||
: ppm-header ( w h -- )
|
||||
"P6\n" % swap # " " % # "\n255\n" % ;
|
||||
|
||||
: buf-size width height * 3 * 100 + ;
|
||||
: buf-size ( -- n ) width height * 3 * 100 + ;
|
||||
|
||||
: mandel ( -- data )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -31,6 +31,6 @@ bit-arrays namespaces io ;
|
|||
dup 1- 2^ 10000 * nsieve-bits.
|
||||
2 - 2^ 10000 * nsieve-bits. ;
|
||||
|
||||
: nsieve-bits-main* 11 nsieve-bits-main ;
|
||||
: nsieve-bits-main* ( -- ) 11 nsieve-bits-main ;
|
||||
|
||||
MAIN: nsieve-bits-main*
|
||||
|
|
|
|||
|
|
@ -30,6 +30,6 @@ arrays namespaces io ;
|
|||
dup 1 - 2^ 10000 * nsieve.
|
||||
2 - 2^ 10000 * nsieve. ;
|
||||
|
||||
: nsieve-main* 9 nsieve-main ;
|
||||
: nsieve-main* ( -- ) 9 nsieve-main ;
|
||||
|
||||
MAIN: nsieve-main*
|
||||
|
|
|
|||
|
|
@ -58,6 +58,6 @@ HINTS: gregory fixnum ;
|
|||
] with each
|
||||
] tabular-output ;
|
||||
|
||||
: partial-sums-main 2500000 partial-sums ;
|
||||
: partial-sums-main ( -- ) 2500000 partial-sums ;
|
||||
|
||||
MAIN: partial-sums-main
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
USING: io.files io.encodings.ascii random math.parser io math ;
|
||||
IN: benchmark.random
|
||||
|
||||
: random-numbers-path "random-numbers.txt" temp-file ;
|
||||
: random-numbers-path ( -- path )
|
||||
"random-numbers.txt" temp-file ;
|
||||
|
||||
: write-random-numbers ( n -- )
|
||||
random-numbers-path ascii [
|
||||
|
|
|
|||
|
|
@ -169,7 +169,7 @@ DEFER: create ( level c r -- scene )
|
|||
[ [ oversampling sq / pgm-pixel ] each ] each
|
||||
] B{ } make ;
|
||||
|
||||
: raytracer-main
|
||||
: raytracer-main ( -- )
|
||||
run "raytracer.pnm" temp-file binary set-file-contents ;
|
||||
|
||||
MAIN: raytracer-main
|
||||
|
|
|
|||
|
|
@ -32,6 +32,6 @@ IN: benchmark.recursive
|
|||
|
||||
HINTS: recursive fixnum ;
|
||||
|
||||
: recursive-main 11 recursive ;
|
||||
: recursive-main ( -- ) 11 recursive ;
|
||||
|
||||
MAIN: recursive-main
|
||||
|
|
|
|||
|
|
@ -38,10 +38,10 @@ HINTS: do-line vector string ;
|
|||
] with-file-reader
|
||||
] with-file-writer ;
|
||||
|
||||
: reverse-complement-in
|
||||
: reverse-complement-in ( -- path )
|
||||
"reverse-complement-in.txt" temp-file ;
|
||||
|
||||
: reverse-complement-out
|
||||
: reverse-complement-out ( -- path )
|
||||
"reverse-complement-out.txt" temp-file ;
|
||||
|
||||
: reverse-complement-main ( -- )
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ SYMBOL: counter
|
|||
|
||||
: number-of-requests 1 ;
|
||||
|
||||
: server-addr "127.0.0.1" 7777 <inet4> ;
|
||||
: server-addr ( -- addr ) "127.0.0.1" 7777 <inet4> ;
|
||||
|
||||
: server-loop ( server -- )
|
||||
dup accept drop [
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: kernel sequences sorting benchmark.random math.parser
|
|||
io.files io.encodings.ascii ;
|
||||
IN: benchmark.sort
|
||||
|
||||
: sort-benchmark
|
||||
: sort-benchmark ( -- )
|
||||
random-numbers-path
|
||||
ascii file-lines [ string>number ] map
|
||||
natural-sort drop ;
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@ IN: benchmark.typecheck1
|
|||
|
||||
TUPLE: hello n ;
|
||||
|
||||
: foo 0 100000000 [ over hello-n + ] times ;
|
||||
: foo ( obj -- obj n ) 0 100000000 [ over hello-n + ] times ;
|
||||
|
||||
: typecheck-main 0 hello boa foo 2drop ;
|
||||
: typecheck-main ( -- ) 0 hello boa foo 2drop ;
|
||||
|
||||
MAIN: typecheck-main
|
||||
|
|
|
|||
|
|
@ -3,10 +3,10 @@ IN: benchmark.typecheck2
|
|||
|
||||
TUPLE: hello n ;
|
||||
|
||||
: hello-n* dup tuple? [ 3 slot ] [ 3 throw ] if ;
|
||||
: hello-n* ( obj -- value ) dup tuple? [ 3 slot ] [ 3 throw ] if ;
|
||||
|
||||
: foo 0 100000000 [ over hello-n* + ] times ;
|
||||
: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
|
||||
|
||||
: typecheck-main 0 hello boa foo 2drop ;
|
||||
: typecheck-main ( -- ) 0 hello boa foo 2drop ;
|
||||
|
||||
MAIN: typecheck-main
|
||||
|
|
|
|||
|
|
@ -3,10 +3,10 @@ IN: benchmark.typecheck3
|
|||
|
||||
TUPLE: hello n ;
|
||||
|
||||
: hello-n* dup tag 2 eq? [ 3 slot ] [ 3 throw ] if ;
|
||||
: hello-n* ( obj -- val ) dup tag 2 eq? [ 3 slot ] [ 3 throw ] if ;
|
||||
|
||||
: foo 0 100000000 [ over hello-n* + ] times ;
|
||||
: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
|
||||
|
||||
: typecheck-main 0 hello boa foo 2drop ;
|
||||
: typecheck-main ( -- ) 0 hello boa foo 2drop ;
|
||||
|
||||
MAIN: typecheck-main
|
||||
|
|
|
|||
|
|
@ -3,10 +3,10 @@ IN: benchmark.typecheck4
|
|||
|
||||
TUPLE: hello n ;
|
||||
|
||||
: hello-n* 3 slot ;
|
||||
: hello-n* ( obj -- val ) 3 slot ;
|
||||
|
||||
: foo 0 100000000 [ over hello-n* + ] times ;
|
||||
: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
|
||||
|
||||
: typecheck-main 0 hello boa foo 2drop ;
|
||||
: typecheck-main ( -- ) 0 hello boa foo 2drop ;
|
||||
|
||||
MAIN: typecheck-main
|
||||
|
|
|
|||
|
|
@ -101,7 +101,7 @@ M: check< summary drop "Number exceeds upper bound" ;
|
|||
>ranges filter-pad [ define-setters ] 2keep define-accessors
|
||||
] with-compilation-unit ;
|
||||
|
||||
: parse-bitfield
|
||||
: parse-bitfield ( -- )
|
||||
scan ";" parse-tokens parse-slots define-bitfield ;
|
||||
|
||||
: BITFIELD:
|
||||
|
|
|
|||
|
|
@ -12,9 +12,9 @@ SYMBOL: upload-images-destination
|
|||
"slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
|
||||
or ;
|
||||
|
||||
: checksums "checksums.txt" temp-file ;
|
||||
: checksums ( -- temp ) "checksums.txt" temp-file ;
|
||||
|
||||
: boot-image-names images [ boot-image-name ] map ;
|
||||
: boot-image-names ( -- seq ) images [ boot-image-name ] map ;
|
||||
|
||||
: compute-checksums ( -- )
|
||||
checksums ascii [
|
||||
|
|
|
|||
|
|
@ -38,9 +38,9 @@ IN: bunny.model
|
|||
ascii [ parse-model ] with-file-reader
|
||||
[ normals ] 2keep 3array ;
|
||||
|
||||
: model-path "bun_zipper.ply" temp-file ;
|
||||
: model-path ( -- path ) "bun_zipper.ply" temp-file ;
|
||||
|
||||
: model-url "http://factorcode.org/bun_zipper.ply" ;
|
||||
: model-url ( -- url ) "http://factorcode.org/bun_zipper.ply" ;
|
||||
|
||||
: maybe-download ( -- path )
|
||||
model-path dup exists? [
|
||||
|
|
|
|||
|
|
@ -4,46 +4,46 @@ combinators accessors debugger
|
|||
calendar calendar.format.macros ;
|
||||
IN: calendar.format
|
||||
|
||||
: pad-00 number>string 2 CHAR: 0 pad-left ;
|
||||
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ;
|
||||
|
||||
: pad-0000 number>string 4 CHAR: 0 pad-left ;
|
||||
: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-left ;
|
||||
|
||||
: pad-00000 number>string 5 CHAR: 0 pad-left ;
|
||||
: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-left ;
|
||||
|
||||
: write-00 pad-00 write ;
|
||||
: write-00 ( n -- ) pad-00 write ;
|
||||
|
||||
: write-0000 pad-0000 write ;
|
||||
: write-0000 ( n -- ) pad-0000 write ;
|
||||
|
||||
: write-00000 pad-00000 write ;
|
||||
: write-00000 ( n -- ) pad-00000 write ;
|
||||
|
||||
: hh hour>> write-00 ;
|
||||
: hh ( time -- ) hour>> write-00 ;
|
||||
|
||||
: mm minute>> write-00 ;
|
||||
: mm ( time -- ) minute>> write-00 ;
|
||||
|
||||
: ss second>> >integer write-00 ;
|
||||
: ss ( time -- ) second>> >integer write-00 ;
|
||||
|
||||
: D day>> number>string write ;
|
||||
: D ( time -- ) day>> number>string write ;
|
||||
|
||||
: DD day>> write-00 ;
|
||||
: DD ( time -- ) day>> write-00 ;
|
||||
|
||||
: DAY day-of-week day-abbreviations3 nth write ;
|
||||
: DAY ( time -- ) day-of-week day-abbreviations3 nth write ;
|
||||
|
||||
: MM month>> write-00 ;
|
||||
: MM ( time -- ) month>> write-00 ;
|
||||
|
||||
: MONTH month>> month-abbreviations nth write ;
|
||||
: MONTH ( time -- ) month>> month-abbreviations nth write ;
|
||||
|
||||
: YYYY year>> write-0000 ;
|
||||
: YYYY ( time -- ) year>> write-0000 ;
|
||||
|
||||
: YYYYY year>> write-00000 ;
|
||||
: YYYYY ( time -- ) year>> write-00000 ;
|
||||
|
||||
: expect ( str -- )
|
||||
read1 swap member? [ "Parse error" throw ] unless ;
|
||||
|
||||
: read-00 2 read string>number ;
|
||||
: read-00 ( -- n ) 2 read string>number ;
|
||||
|
||||
: read-000 3 read string>number ;
|
||||
: read-000 ( -- n ) 3 read string>number ;
|
||||
|
||||
: read-0000 4 read string>number ;
|
||||
: read-0000 ( -- n ) 4 read string>number ;
|
||||
|
||||
GENERIC: day. ( obj -- )
|
||||
|
||||
|
|
@ -261,7 +261,7 @@ ERROR: invalid-timestamp-format ;
|
|||
: timestamp>ymd ( timestamp -- str )
|
||||
[ (timestamp>ymd) ] with-string-writer ;
|
||||
|
||||
: (timestamp>hms)
|
||||
: (timestamp>hms) ( timestamp -- )
|
||||
{ hh ":" mm ":" ss } formatted ;
|
||||
|
||||
: timestamp>hms ( timestamp -- str )
|
||||
|
|
|
|||
|
|
@ -74,7 +74,7 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
|
|||
: S43 15 ; inline
|
||||
: S44 21 ; inline
|
||||
|
||||
: (process-md5-block-F)
|
||||
: (process-md5-block-F) ( block -- block )
|
||||
dup S11 1 0 [ F ] ABCD
|
||||
dup S12 2 1 [ F ] DABC
|
||||
dup S13 3 2 [ F ] CDAB
|
||||
|
|
@ -92,7 +92,7 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
|
|||
dup S13 15 14 [ F ] CDAB
|
||||
dup S14 16 15 [ F ] BCDA ;
|
||||
|
||||
: (process-md5-block-G)
|
||||
: (process-md5-block-G) ( block -- block )
|
||||
dup S21 17 1 [ G ] ABCD
|
||||
dup S22 18 6 [ G ] DABC
|
||||
dup S23 19 11 [ G ] CDAB
|
||||
|
|
@ -110,7 +110,7 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
|
|||
dup S23 31 7 [ G ] CDAB
|
||||
dup S24 32 12 [ G ] BCDA ;
|
||||
|
||||
: (process-md5-block-H)
|
||||
: (process-md5-block-H) ( block -- block )
|
||||
dup S31 33 5 [ H ] ABCD
|
||||
dup S32 34 8 [ H ] DABC
|
||||
dup S33 35 11 [ H ] CDAB
|
||||
|
|
@ -128,7 +128,7 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
|
|||
dup S33 47 15 [ H ] CDAB
|
||||
dup S34 48 2 [ H ] BCDA ;
|
||||
|
||||
: (process-md5-block-I)
|
||||
: (process-md5-block-I) ( block -- block )
|
||||
dup S41 49 0 [ I ] ABCD
|
||||
dup S42 50 7 [ I ] DABC
|
||||
dup S43 51 14 [ I ] CDAB
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
!
|
||||
USING: kernel math sequences words arrays io io.files namespaces
|
||||
math.parser assocs quotations parser parser-combinators
|
||||
tools.time io.encodings.binary ;
|
||||
tools.time io.encodings.binary sequences.deep symbols combinators ;
|
||||
IN: cpu.8080.emulator
|
||||
|
||||
TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
|
||||
|
|
@ -563,29 +563,18 @@ SYMBOL: rom-root
|
|||
{ "M" { flag-m? } }
|
||||
} at ;
|
||||
|
||||
SYMBOL: $1
|
||||
SYMBOL: $2
|
||||
SYMBOL: $3
|
||||
SYMBOL: $4
|
||||
SYMBOLS: $1 $2 $3 $4 ;
|
||||
|
||||
: replace-patterns ( vector tree -- tree )
|
||||
#! Copy the tree, replacing each occurence of
|
||||
#! $1, $2, etc with the relevant item from the
|
||||
#! given index.
|
||||
dup quotation? over [ ] = not and [ ! vector tree
|
||||
dup first swap rest ! vector car cdr
|
||||
>r dupd replace-patterns ! vector v R: cdr
|
||||
swap r> replace-patterns >r 1quotation r> append
|
||||
] [ ! vector value
|
||||
dup $1 = [ drop 0 over nth ] when
|
||||
dup $2 = [ drop 1 over nth ] when
|
||||
dup $3 = [ drop 2 over nth ] when
|
||||
dup $4 = [ drop 3 over nth ] when
|
||||
nip
|
||||
] if ;
|
||||
|
||||
: test-rp
|
||||
{ 4 5 3 } [ 1 $2 [ $1 4 ] ] replace-patterns ;
|
||||
[
|
||||
{
|
||||
{ $1 [ first ] }
|
||||
{ $2 [ second ] }
|
||||
{ $3 [ third ] }
|
||||
{ $4 [ fourth ] }
|
||||
[ nip ]
|
||||
} case
|
||||
] with deep-map ;
|
||||
|
||||
: (emulate-RST) ( n cpu -- )
|
||||
#! RST nn
|
||||
|
|
@ -766,7 +755,7 @@ SYMBOL: $4
|
|||
"H" token <|>
|
||||
"L" token <|> [ register-lookup ] <@ ;
|
||||
|
||||
: all-flags
|
||||
: all-flags ( -- parser )
|
||||
#! A parser for 16-bit flags.
|
||||
"NZ" token
|
||||
"NC" token <|>
|
||||
|
|
@ -777,7 +766,7 @@ SYMBOL: $4
|
|||
"P" token <|>
|
||||
"M" token <|> [ flag-lookup ] <@ ;
|
||||
|
||||
: 16-bit-registers
|
||||
: 16-bit-registers ( -- parser )
|
||||
#! A parser for 16-bit registers. On a successfull parse the
|
||||
#! parse tree contains a vector. The first item in the vector
|
||||
#! is the getter word for that register with stack effect
|
||||
|
|
@ -1098,27 +1087,27 @@ SYMBOL: $4
|
|||
16-bit-registers indirect <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: LD-RR,NN-instruction
|
||||
: LD-RR,NN-instruction ( -- parser )
|
||||
#! LD BC,nn
|
||||
"LD-RR,NN" "LD" complex-instruction
|
||||
16-bit-registers sp <&>
|
||||
",nn" token <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
|
||||
: LD-R,N-instruction
|
||||
: LD-R,N-instruction ( -- parser )
|
||||
#! LD B,n
|
||||
"LD-R,N" "LD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
",n" token <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
|
||||
: LD-(RR),N-instruction
|
||||
: LD-(RR),N-instruction ( -- parser )
|
||||
"LD-(RR),N" "LD" complex-instruction
|
||||
16-bit-registers indirect sp <&>
|
||||
",n" token <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
|
||||
: LD-(RR),R-instruction
|
||||
: LD-(RR),R-instruction ( -- parser )
|
||||
#! LD (BC),A
|
||||
"LD-(RR),R" "LD" complex-instruction
|
||||
16-bit-registers indirect sp <&>
|
||||
|
|
@ -1126,84 +1115,84 @@ SYMBOL: $4
|
|||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: LD-R,R-instruction
|
||||
: LD-R,R-instruction ( -- parser )
|
||||
"LD-R,R" "LD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: LD-RR,RR-instruction
|
||||
: LD-RR,RR-instruction ( -- parser )
|
||||
"LD-RR,RR" "LD" complex-instruction
|
||||
16-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: LD-R,(RR)-instruction
|
||||
: LD-R,(RR)-instruction ( -- parser )
|
||||
"LD-R,(RR)" "LD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers indirect <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: LD-(NN),RR-instruction
|
||||
: LD-(NN),RR-instruction ( -- parser )
|
||||
"LD-(NN),RR" "LD" complex-instruction
|
||||
"nn" token indirect sp <&
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap curry ] <@ ;
|
||||
|
||||
: LD-(NN),R-instruction
|
||||
: LD-(NN),R-instruction ( -- parser )
|
||||
"LD-(NN),R" "LD" complex-instruction
|
||||
"nn" token indirect sp <&
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap curry ] <@ ;
|
||||
|
||||
: LD-RR,(NN)-instruction
|
||||
: LD-RR,(NN)-instruction ( -- parser )
|
||||
"LD-RR,(NN)" "LD" complex-instruction
|
||||
16-bit-registers sp <&>
|
||||
"," token <&
|
||||
"nn" token indirect <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
|
||||
: LD-R,(NN)-instruction
|
||||
: LD-R,(NN)-instruction ( -- parser )
|
||||
"LD-R,(NN)" "LD" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
"nn" token indirect <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
|
||||
: OUT-(N),R-instruction
|
||||
: OUT-(N),R-instruction ( -- parser )
|
||||
"OUT-(N),R" "OUT" complex-instruction
|
||||
"n" token indirect sp <&
|
||||
"," token <&
|
||||
8-bit-registers <&>
|
||||
just [ first2 swap curry ] <@ ;
|
||||
|
||||
: IN-R,(N)-instruction
|
||||
: IN-R,(N)-instruction ( -- parser )
|
||||
"IN-R,(N)" "IN" complex-instruction
|
||||
8-bit-registers sp <&>
|
||||
"," token <&
|
||||
"n" token indirect <&
|
||||
just [ first2 swap curry ] <@ ;
|
||||
|
||||
: EX-(RR),RR-instruction
|
||||
: EX-(RR),RR-instruction ( -- parser )
|
||||
"EX-(RR),RR" "EX" complex-instruction
|
||||
16-bit-registers indirect sp <&>
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: EX-RR,RR-instruction
|
||||
: EX-RR,RR-instruction ( -- parser )
|
||||
"EX-RR,RR" "EX" complex-instruction
|
||||
16-bit-registers sp <&>
|
||||
"," token <&
|
||||
16-bit-registers <&>
|
||||
just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
|
||||
|
||||
: 8080-generator-parser
|
||||
: 8080-generator-parser ( -- parser )
|
||||
NOP-instruction
|
||||
RST-0-instruction <|>
|
||||
RST-8-instruction <|>
|
||||
|
|
@ -1296,7 +1285,7 @@ SYMBOL: last-opcode
|
|||
#! that would implement that instruction.
|
||||
dup " " join instruction-quotations
|
||||
>r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at
|
||||
r> define ;
|
||||
r> (( cpu -- )) define-declared ;
|
||||
|
||||
: INSTRUCTION: ";" parse-tokens parse-instructions ; parsing
|
||||
|
||||
|
|
|
|||
|
|
@ -281,7 +281,7 @@ FUNCTION: void PQclear ( PGresult* res ) ;
|
|||
FUNCTION: void PQfreemem ( void* ptr ) ;
|
||||
|
||||
! Exists for backward compatibility.
|
||||
: PQfreeNotify PQfreemem ;
|
||||
: PQfreeNotify ( ptr -- ) PQfreemem ;
|
||||
|
||||
!
|
||||
! Make an empty PGresult with given status (some apps find this
|
||||
|
|
|
|||
|
|
@ -66,10 +66,10 @@ M: postgresql-result-null summary ( obj -- str )
|
|||
: param-types ( statement -- seq )
|
||||
in-params>> [ type>> type>oid ] map >c-uint-array ;
|
||||
|
||||
: malloc-byte-array/length
|
||||
: malloc-byte-array/length ( byte-array -- alien length )
|
||||
[ malloc-byte-array &free ] [ length ] bi ;
|
||||
|
||||
: default-param-value
|
||||
: default-param-value ( obj -- alien n )
|
||||
number>string* dup [ utf8 malloc-string &free ] when 0 ;
|
||||
|
||||
: param-values ( statement -- seq seq2 )
|
||||
|
|
|
|||
|
|
@ -7,10 +7,10 @@ SYMBOLS: insert update delete select distinct columns from as
|
|||
where group-by having order-by limit offset is-null desc all
|
||||
any count avg table values ;
|
||||
|
||||
: input-spec, 1, ;
|
||||
: output-spec, 2, ;
|
||||
: input, 3, ;
|
||||
: output, 4, ;
|
||||
: input-spec, ( obj -- ) 1, ;
|
||||
: output-spec, ( obj -- ) 2, ;
|
||||
: input, ( obj -- ) 3, ;
|
||||
: output, ( obj -- ) 4, ;
|
||||
|
||||
DEFER: sql%
|
||||
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ user "USERS"
|
|||
{ "deleted" "DELETED" INTEGER +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
: init-users-table user ensure-table ;
|
||||
: init-users-table ( -- ) user ensure-table ;
|
||||
|
||||
SINGLETON: users-in-db
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: furnace.boilerplate
|
|||
|
||||
TUPLE: boilerplate < filter-responder template ;
|
||||
|
||||
: <boilerplate> f boilerplate boa ;
|
||||
: <boilerplate> ( responder -- boilerplate ) f boilerplate boa ;
|
||||
|
||||
M:: boilerplate call-responder* ( path responder -- )
|
||||
path responder call-next-method
|
||||
|
|
|
|||
|
|
@ -86,7 +86,8 @@ M: object modify-form drop ;
|
|||
|
||||
SYMBOL: exit-continuation
|
||||
|
||||
: exit-with exit-continuation get continue-with ;
|
||||
: exit-with ( value -- )
|
||||
exit-continuation get continue-with ;
|
||||
|
||||
: with-exit-continuation ( quot -- )
|
||||
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ session "SESSIONS"
|
|||
: get-session ( id -- session )
|
||||
dup [ <session> select-tuple ] when ;
|
||||
|
||||
: init-sessions-table session ensure-table ;
|
||||
: init-sessions-table ( -- ) session ensure-table ;
|
||||
|
||||
: start-expiring-sessions ( db seq -- )
|
||||
'[
|
||||
|
|
|
|||
|
|
@ -4,9 +4,9 @@ math.parser math.vectors math.intervals interval-maps memoize
|
|||
csv accessors assocs strings math splitting ;
|
||||
IN: geo-ip
|
||||
|
||||
: db-path "IpToCountry.csv" temp-file ;
|
||||
: db-path ( -- path ) "IpToCountry.csv" temp-file ;
|
||||
|
||||
: db-url "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download" ;
|
||||
: db-url ( -- url ) "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download" ;
|
||||
|
||||
: download-db ( -- path )
|
||||
db-path dup exists? [
|
||||
|
|
|
|||
|
|
@ -6,13 +6,17 @@ IN: globs
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: 'char' [ ",*?" member? not ] satisfy ;
|
||||
: 'char' ( -- parser )
|
||||
[ ",*?" member? not ] satisfy ;
|
||||
|
||||
: 'string' 'char' <+> [ >lower token ] <@ ;
|
||||
: 'string' ( -- parser )
|
||||
'char' <+> [ >lower token ] <@ ;
|
||||
|
||||
: 'escaped-char' "\\" token any-char-parser &> [ 1token ] <@ ;
|
||||
: 'escaped-char' ( -- parser )
|
||||
"\\" token any-char-parser &> [ 1token ] <@ ;
|
||||
|
||||
: 'escaped-string' 'string' 'escaped-char' <|> ;
|
||||
: 'escaped-string' ( -- parser )
|
||||
'string' 'escaped-char' <|> ;
|
||||
|
||||
DEFER: 'term'
|
||||
|
||||
|
|
@ -23,7 +27,7 @@ DEFER: 'term'
|
|||
'glob' "," token nonempty-list-of "{" "}" surrounded-by
|
||||
[ <or-parser> ] <@ ;
|
||||
|
||||
LAZY: 'term'
|
||||
LAZY: 'term' ( -- parser )
|
||||
'union'
|
||||
'character-class' <|>
|
||||
"?" token [ drop any-char-parser ] <@ <|>
|
||||
|
|
@ -32,7 +36,7 @@ LAZY: 'term'
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: <glob> 'glob' just parse-1 just ;
|
||||
: <glob> ( string -- glob ) 'glob' just parse-1 just ;
|
||||
|
||||
: glob-matches? ( input glob -- ? )
|
||||
[ >lower ] [ <glob> ] bi* parse nil? not ;
|
||||
|
|
|
|||
|
|
@ -35,7 +35,8 @@ M: winnt total-virtual-mem ( -- n )
|
|||
M: winnt available-virtual-mem ( -- n )
|
||||
memory-status MEMORYSTATUSEX-ullAvailVirtual ;
|
||||
|
||||
: pull-win32-string [ utf16n alien>string ] keep free ;
|
||||
: pull-win32-string ( alien -- string )
|
||||
[ utf16n alien>string ] keep free ;
|
||||
|
||||
: computer-name ( -- string )
|
||||
MAX_COMPUTERNAME_LENGTH 1+ [ malloc ] keep
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USE: io
|
||||
IN: hello-world
|
||||
|
||||
: hello "Hello world" print ;
|
||||
: hello ( -- ) "Hello world" print ;
|
||||
|
||||
MAIN: hello
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ $nl
|
|||
$nl
|
||||
"Factor evaluates code left to right, and stores intermediate values on a " { $emphasis "stack" } ". If you think of the stack as a pile of papers, then " { $emphasis "pushing" } " a value on the stack corresponds to placing a piece of paper at the top of the pile, while " { $emphasis "popping" } " a value corresponds to removing the topmost piece."
|
||||
$nl
|
||||
"Most words have a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effect declarations can be viewed by browsing source code, or using tools such as " { $link see } ". See " { $link "effect-declaration" } "."
|
||||
"All words except those which only push literals on the stack must have a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effect declarations can be viewed by browsing source code, or using tools such as " { $link see } "; they are also checked by the compiler. See " { $link "effect-declaration" } "."
|
||||
$nl
|
||||
"Coming back to the example in the beginning of this article, the following series of steps occurs as the code is evaluated:"
|
||||
{ $table
|
||||
|
|
@ -41,7 +41,7 @@ ARTICLE: "cookbook-colon-defs" "Shuffle word and definition cookbook"
|
|||
"The " { $link dup } " word makes a copy of the value at the top of the stack:"
|
||||
{ $example "5 dup * ." "25" }
|
||||
"The " { $link sq } " word is actually defined as follows:"
|
||||
{ $code ": sq dup * ;" }
|
||||
{ $code ": sq ( x -- y ) dup * ;" }
|
||||
"(You could have looked this up yourself by clicking on the " { $link sq } " word itself.)"
|
||||
$nl
|
||||
"Note the key elements in a word definition: The colon " { $link POSTPONE: : } " denotes the start of a word definition. The name of the new word must immediately follow. The word definition then continues on until the " { $link POSTPONE: ; } " token signifies the end of the definition. This type of word definition is called a " { $emphasis "compound definition." }
|
||||
|
|
@ -60,11 +60,13 @@ $nl
|
|||
"This syntax will be familiar to anybody who has used Forth before. However the behavior is slightly different. In most Forth systems, the below code prints 2, because the definition of " { $snippet "b" } " still refers to the previous definition of " { $snippet "a" } ":"
|
||||
{ $code
|
||||
": a 1 ;"
|
||||
": b a 1 + ;"
|
||||
": b ( -- x ) a 1 + ;"
|
||||
": a 2 ;"
|
||||
"b ."
|
||||
}
|
||||
"In Factor, this example will print 3 since word redefinition is explicitly supported."
|
||||
$nl
|
||||
"Indeed, redefining a word twice in the same source file is an error; this is almost always a mistake since there's no way to call the first definition. See " { $link "definition-checking" } "."
|
||||
}
|
||||
{ $references
|
||||
{ "A whole slew of shuffle words can be used to rearrange the stack. There are forms of word definition other than colon definition, words can be defined entirely at runtime, and word definitions can be " { $emphasis "annotated" } " with tracing calls and breakpoints without modifying the source code." }
|
||||
|
|
|
|||
|
|
@ -127,7 +127,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
|
|||
":vars - list all variables at error time" print ;
|
||||
|
||||
: :help ( -- )
|
||||
error get error-help [ help ] [ "No help for this error. " print ] if
|
||||
error get error-help [ help ] [ "No help for this error. " print ] if*
|
||||
:help-debugger ;
|
||||
|
||||
: remove-article ( name -- )
|
||||
|
|
|
|||
|
|
@ -18,5 +18,5 @@ IN: help.syntax
|
|||
: ABOUT:
|
||||
scan-object
|
||||
in get vocab
|
||||
dup changed-definition
|
||||
dup +inlined+ changed-definition
|
||||
set-vocab-help ; parsing
|
||||
|
|
|
|||
|
|
@ -10,11 +10,11 @@ IN: html.components
|
|||
|
||||
SYMBOL: values
|
||||
|
||||
: value values get at ;
|
||||
: value ( name -- value ) values get at ;
|
||||
|
||||
: set-value values get set-at ;
|
||||
: set-value ( value name -- ) values get set-at ;
|
||||
|
||||
: blank-values H{ } clone values set ;
|
||||
: blank-values ( -- ) H{ } clone values set ;
|
||||
|
||||
: prepare-value ( name object -- value name object )
|
||||
[ [ value ] keep ] dip ; inline
|
||||
|
|
|
|||
|
|
@ -65,7 +65,7 @@ SYMBOL: html
|
|||
#! dynamically creating words.
|
||||
>r >r elements-vocab create r> r> define-declared ;
|
||||
|
||||
: <foo> "<" swap ">" 3append ;
|
||||
: <foo> ( str -- <str> ) "<" swap ">" 3append ;
|
||||
|
||||
: def-for-html-word-<foo> ( name -- )
|
||||
#! Return the name and code for the <foo> patterned
|
||||
|
|
@ -73,7 +73,7 @@ SYMBOL: html
|
|||
dup <foo> swap [ <foo> write-html ] curry
|
||||
(( -- )) html-word ;
|
||||
|
||||
: <foo "<" prepend ;
|
||||
: <foo ( str -- <str ) "<" prepend ;
|
||||
|
||||
: def-for-html-word-<foo ( name -- )
|
||||
#! Return the name and code for the <foo patterned
|
||||
|
|
@ -81,21 +81,21 @@ SYMBOL: html
|
|||
<foo dup [ write-html ] curry
|
||||
(( -- )) html-word ;
|
||||
|
||||
: foo> ">" append ;
|
||||
: foo> ( str -- foo> ) ">" append ;
|
||||
|
||||
: def-for-html-word-foo> ( name -- )
|
||||
#! Return the name and code for the foo> patterned
|
||||
#! word.
|
||||
foo> [ ">" write-html ] (( -- )) html-word ;
|
||||
|
||||
: </foo> "</" swap ">" 3append ;
|
||||
: </foo> ( str -- </str> ) "</" swap ">" 3append ;
|
||||
|
||||
: def-for-html-word-</foo> ( name -- )
|
||||
#! Return the name and code for the </foo> patterned
|
||||
#! word.
|
||||
</foo> dup [ write-html ] curry (( -- )) html-word ;
|
||||
|
||||
: <foo/> "<" swap "/>" 3append ;
|
||||
: <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
|
||||
|
||||
: def-for-html-word-<foo/> ( name -- )
|
||||
#! Return the name and code for the <foo/> patterned
|
||||
|
|
@ -103,7 +103,7 @@ SYMBOL: html
|
|||
dup <foo/> swap [ <foo/> write-html ] curry
|
||||
(( -- )) html-word ;
|
||||
|
||||
: foo/> "/>" append ;
|
||||
: foo/> ( str -- str/> ) "/>" append ;
|
||||
|
||||
: def-for-html-word-foo/> ( name -- )
|
||||
#! Return the name and code for the foo/> patterned
|
||||
|
|
|
|||
|
|
@ -135,7 +135,7 @@ TUPLE: html-block-stream < html-sub-stream ;
|
|||
M: html-block-stream dispose ( quot style stream -- )
|
||||
end-sub-stream a-div format-html-div ;
|
||||
|
||||
: border-spacing-css,
|
||||
: border-spacing-css, ( pair -- )
|
||||
"padding: " % first2 max 2 /i # "px; " % ;
|
||||
|
||||
: table-style ( style -- str )
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ EXCLUDE: fry => , ;
|
|||
|
||||
IN: http
|
||||
|
||||
: crlf "\r\n" write ;
|
||||
: crlf ( -- ) "\r\n" write ;
|
||||
|
||||
: add-header ( value key assoc -- )
|
||||
[ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ;
|
||||
|
|
@ -135,7 +135,7 @@ cookies ;
|
|||
: set-header ( request/response value key -- request/response )
|
||||
pick header>> set-at ;
|
||||
|
||||
: <request>
|
||||
: <request> ( -- request )
|
||||
request new
|
||||
"1.1" >>version
|
||||
<url>
|
||||
|
|
@ -293,7 +293,7 @@ content-type
|
|||
content-charset
|
||||
body ;
|
||||
|
||||
: <response>
|
||||
: <response> ( -- response )
|
||||
response new
|
||||
"1.1" >>version
|
||||
H{ } clone >>header
|
||||
|
|
@ -301,21 +301,21 @@ body ;
|
|||
now timestamp>http-string "date" set-header
|
||||
V{ } clone >>cookies ;
|
||||
|
||||
: read-response-version
|
||||
: read-response-version ( response -- response )
|
||||
" \t" read-until
|
||||
[ "Bad response: version" throw ] unless
|
||||
parse-version
|
||||
>>version ;
|
||||
|
||||
: read-response-code
|
||||
: read-response-code ( response -- response )
|
||||
" \t" read-until [ "Bad response: code" throw ] unless
|
||||
string>number [ "Bad response: code" throw ] unless*
|
||||
>>code ;
|
||||
|
||||
: read-response-message
|
||||
: read-response-message ( response -- response )
|
||||
read-crlf >>message ;
|
||||
|
||||
: read-response-header
|
||||
: read-response-header ( response -- response )
|
||||
read-header >>header
|
||||
dup "set-cookie" header parse-cookies >>cookies
|
||||
dup "content-type" header [
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ combinators arrays io.launcher io http.server.static http.server
|
|||
http accessors sequences strings math.parser fry urls ;
|
||||
IN: http.server.cgi
|
||||
|
||||
: post? request get method>> "POST" = ;
|
||||
: post? ( -- ? ) request get method>> "POST" = ;
|
||||
|
||||
: cgi-variables ( script-path -- assoc )
|
||||
#! This needs some work.
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ splitting sorting shuffle symbols sets math.order ;
|
|||
IN: koszul
|
||||
|
||||
! Utilities
|
||||
: -1^ odd? -1 1 ? ;
|
||||
: -1^ ( m -- n ) odd? -1 1 ? ;
|
||||
|
||||
: >alt ( obj -- vec )
|
||||
{
|
||||
|
|
@ -18,7 +18,7 @@ IN: koszul
|
|||
[ 1array >alt ]
|
||||
} cond ;
|
||||
|
||||
: canonicalize
|
||||
: canonicalize ( assoc -- assoc' )
|
||||
[ nip zero? not ] assoc-filter ;
|
||||
|
||||
SYMBOL: terms
|
||||
|
|
@ -207,8 +207,8 @@ DEFER: (d)
|
|||
[ v- ] 2map ;
|
||||
|
||||
! Laplacian
|
||||
: m.m' dup flip m. ;
|
||||
: m'.m dup flip swap m. ;
|
||||
: m.m' ( matrix -- matrix' ) dup flip m. ;
|
||||
: m'.m ( matrix -- matrix' ) dup flip swap m. ;
|
||||
|
||||
: empty-matrix? ( matrix -- ? )
|
||||
dup empty? [ drop t ] [ first empty? ] if ;
|
||||
|
|
|
|||
|
|
@ -5,11 +5,11 @@
|
|||
USING: lists.lazy math kernel sequences quotations ;
|
||||
IN: lists.lazy.examples
|
||||
|
||||
: naturals 0 lfrom ;
|
||||
: positives 1 lfrom ;
|
||||
: evens 0 [ 2 + ] lfrom-by ;
|
||||
: odds 1 lfrom [ 2 mod 1 = ] lfilter ;
|
||||
: powers-of-2 1 [ 2 * ] lfrom-by ;
|
||||
: ones 1 [ ] lfrom-by ;
|
||||
: squares naturals [ dup * ] lazy-map ;
|
||||
: first-five-squares 5 squares ltake list>array ;
|
||||
: naturals ( -- list ) 0 lfrom ;
|
||||
: positives ( -- list ) 1 lfrom ;
|
||||
: evens ( -- list ) 0 [ 2 + ] lfrom-by ;
|
||||
: odds ( -- list ) 1 lfrom [ 2 mod 1 = ] lfilter ;
|
||||
: powers-of-2 ( -- list ) 1 [ 2 * ] lfrom-by ;
|
||||
: ones ( -- list ) 1 [ ] lfrom-by ;
|
||||
: squares ( -- list ) naturals [ dup * ] lazy-map ;
|
||||
: first-five-squares ( -- list ) 5 squares ltake list>array ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences namespaces words assocs logging sorting
|
||||
prettyprint io io.styles strings logging.parser calendar.format ;
|
||||
prettyprint io io.styles strings logging.parser calendar.format
|
||||
combinators ;
|
||||
IN: logging.analysis
|
||||
|
||||
SYMBOL: word-names
|
||||
|
|
@ -41,12 +42,14 @@ SYMBOL: message-histogram
|
|||
] curry assoc-each
|
||||
] tabular-output ;
|
||||
|
||||
: log-entry.
|
||||
: log-entry. ( entry -- )
|
||||
"====== " write
|
||||
dup first (timestamp>string) bl
|
||||
dup second pprint bl
|
||||
dup third write nl
|
||||
fourth "\n" join print ;
|
||||
{
|
||||
[ first (timestamp>string) bl ]
|
||||
[ second pprint bl ]
|
||||
[ third write nl ]
|
||||
[ fourth "\n" join print ]
|
||||
} cleave ;
|
||||
|
||||
: errors. ( errors -- )
|
||||
[ log-entry. ] each ;
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@ SYMBOL: log-service
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: one-string?
|
||||
: one-string? ( obj -- ? )
|
||||
{
|
||||
[ dup array? ]
|
||||
[ dup length 1 = ]
|
||||
|
|
@ -77,7 +77,7 @@ PRIVATE>
|
|||
3drop
|
||||
] if ; inline
|
||||
|
||||
: input# stack-effect in>> length ;
|
||||
: input# ( word -- n ) stack-effect in>> length ;
|
||||
|
||||
: input-logging-quot ( quot word level -- quot' )
|
||||
rot [ [ input# ] keep ] 2dip '[ , , , log-stack @ ] ;
|
||||
|
|
@ -85,7 +85,7 @@ PRIVATE>
|
|||
: add-input-logging ( word level -- )
|
||||
[ input-logging-quot ] (define-logging) ;
|
||||
|
||||
: output# stack-effect out>> length ;
|
||||
: output# ( word -- n ) stack-effect out>> length ;
|
||||
|
||||
: output-logging-quot ( quot word level -- quot' )
|
||||
[ [ output# ] keep ] dip '[ @ , , , log-stack ] ;
|
||||
|
|
@ -121,4 +121,4 @@ PRIVATE>
|
|||
#! Syntax: name level
|
||||
CREATE-WORD dup scan-word
|
||||
'[ 1array stack>message , , log-message ]
|
||||
define ; parsing
|
||||
(( message -- )) define-declared ; parsing
|
||||
|
|
|
|||
|
|
@ -6,31 +6,31 @@ namespaces combinators combinators.lib logging.server
|
|||
calendar calendar.format ;
|
||||
IN: logging.parser
|
||||
|
||||
: string-of satisfy <!*> [ >string ] <@ ;
|
||||
: string-of ( quot -- parser ) satisfy <!*> [ >string ] <@ ;
|
||||
|
||||
SYMBOL: multiline
|
||||
|
||||
: 'date'
|
||||
: 'date' ( -- parser )
|
||||
[ "]" member? not ] string-of [
|
||||
dup multiline-header =
|
||||
[ drop multiline ] [ rfc3339>timestamp ] if
|
||||
] <@
|
||||
"[" "]" surrounded-by ;
|
||||
|
||||
: 'log-level'
|
||||
: 'log-level' ( -- parser )
|
||||
log-levels [
|
||||
[ word-name token ] keep [ nip ] curry <@
|
||||
] map <or-parser> ;
|
||||
|
||||
: 'word-name'
|
||||
: 'word-name' ( -- parser )
|
||||
[ " :" member? not ] string-of ;
|
||||
|
||||
SYMBOL: malformed
|
||||
|
||||
: 'malformed-line'
|
||||
: 'malformed-line' ( -- parser )
|
||||
[ drop t ] string-of [ malformed swap 2array ] <@ ;
|
||||
|
||||
: 'log-message'
|
||||
: 'log-message' ( -- parser )
|
||||
[ drop t ] string-of [ 1vector ] <@ ;
|
||||
|
||||
MEMO: 'log-line' ( -- parser )
|
||||
|
|
@ -49,7 +49,7 @@ MEMO: 'log-line' ( -- parser )
|
|||
: multiline? ( line -- ? )
|
||||
first multiline eq? ;
|
||||
|
||||
: malformed-line
|
||||
: malformed-line ( line -- )
|
||||
"Warning: malformed log line:" print
|
||||
second print ;
|
||||
|
||||
|
|
|
|||
|
|
@ -67,7 +67,7 @@ SYMBOL: log-files
|
|||
: ?delete-file ( path -- )
|
||||
dup exists? [ delete-file ] [ drop ] if ;
|
||||
|
||||
: delete-oldest keep-logs log# ?delete-file ;
|
||||
: delete-oldest ( service -- ) keep-logs log# ?delete-file ;
|
||||
|
||||
: ?move-file ( old new -- )
|
||||
over exists? [ move-file ] [ 2drop ] if ;
|
||||
|
|
|
|||
|
|
@ -69,7 +69,8 @@ SYMBOL: matrix
|
|||
: echelon ( matrix -- matrix' )
|
||||
[ 0 0 (echelon) ] with-matrix ;
|
||||
|
||||
: nonzero-rows [ [ zero? ] all? not ] filter ;
|
||||
: nonzero-rows ( matrix -- matrix' )
|
||||
[ [ zero? ] all? not ] filter ;
|
||||
|
||||
: null/rank ( matrix -- null rank )
|
||||
echelon dup length swap nonzero-rows length [ - ] keep ;
|
||||
|
|
|
|||
|
|
@ -35,13 +35,13 @@ IN: math.matrices
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: x first ; inline
|
||||
: y second ; inline
|
||||
: z third ; inline
|
||||
: x ( seq -- elt ) first ; inline
|
||||
: y ( seq -- elt ) second ; inline
|
||||
: z ( seq -- elt ) third ; inline
|
||||
|
||||
: i [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
|
||||
: j [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
|
||||
: k [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
|
||||
: i ( seq1 seq2 -- n ) [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
|
||||
: j ( seq1 seq2 -- n ) [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
|
||||
: k ( seq1 seq2 -- n ) [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ PRIVATE>
|
|||
#! divide the last two numbers in the sequences
|
||||
[ peek ] bi@ / ;
|
||||
|
||||
: (p/mod)
|
||||
: (p/mod) ( p p -- p p )
|
||||
2dup /-last
|
||||
2dup , n*p swapd
|
||||
p- >vector
|
||||
|
|
|
|||
|
|
@ -177,6 +177,6 @@ IN: minneapolis-talk
|
|||
{ $slide "Questions?" }
|
||||
} ;
|
||||
|
||||
: minneapolis-talk minneapolis-slides slides-window ;
|
||||
: minneapolis-talk ( -- ) minneapolis-slides slides-window ;
|
||||
|
||||
MAIN: minneapolis-talk
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ GENERIC# fmap 1 ( functor quot -- functor' ) inline
|
|||
MIXIN: monad
|
||||
|
||||
GENERIC: monad-of ( mvalue -- singleton )
|
||||
GENERIC: return ( string singleton -- mvalue )
|
||||
GENERIC: return ( value singleton -- mvalue )
|
||||
GENERIC: fail ( value singleton -- mvalue )
|
||||
GENERIC: >>= ( mvalue -- quot )
|
||||
|
||||
|
|
@ -62,7 +62,7 @@ INSTANCE: maybe-monad monad
|
|||
SINGLETON: nothing
|
||||
|
||||
TUPLE: just value ;
|
||||
: just \ just boa ;
|
||||
: just ( value -- just ) \ just boa ;
|
||||
|
||||
UNION: maybe just nothing ;
|
||||
INSTANCE: maybe monad
|
||||
|
|
@ -83,10 +83,10 @@ SINGLETON: either-monad
|
|||
INSTANCE: either-monad monad
|
||||
|
||||
TUPLE: left value ;
|
||||
: left \ left boa ;
|
||||
: left ( value -- left ) \ left boa ;
|
||||
|
||||
TUPLE: right value ;
|
||||
: right \ right boa ;
|
||||
: right ( value -- right ) \ right boa ;
|
||||
|
||||
UNION: either left right ;
|
||||
INSTANCE: either monad
|
||||
|
|
@ -131,7 +131,7 @@ SINGLETON: state-monad
|
|||
INSTANCE: state-monad monad
|
||||
|
||||
TUPLE: state quot ;
|
||||
: state \ state boa ;
|
||||
: state ( quot -- state ) \ state boa ;
|
||||
|
||||
INSTANCE: state monad
|
||||
|
||||
|
|
@ -140,7 +140,7 @@ M: state monad-of drop state-monad ;
|
|||
M: state-monad return drop '[ , 2array ] state ;
|
||||
M: state-monad fail "Fail" throw ;
|
||||
|
||||
: mcall quot>> call ;
|
||||
: mcall ( state -- ) quot>> call ;
|
||||
|
||||
M: state >>= '[ , _ '[ , mcall first2 @ mcall ] state ] ;
|
||||
|
||||
|
|
@ -149,14 +149,14 @@ M: state >>= '[ , _ '[ , mcall first2 @ mcall ] state ] ;
|
|||
|
||||
: run-st ( state initial -- ) swap mcall second ;
|
||||
|
||||
: return-st state-monad return ;
|
||||
: return-st ( value -- mvalue ) state-monad return ;
|
||||
|
||||
! Reader
|
||||
SINGLETON: reader-monad
|
||||
INSTANCE: reader-monad monad
|
||||
|
||||
TUPLE: reader quot ;
|
||||
: reader \ reader boa ;
|
||||
: reader ( quot -- reader ) \ reader boa ;
|
||||
INSTANCE: reader monad
|
||||
|
||||
M: reader monad-of drop reader-monad ;
|
||||
|
|
@ -176,7 +176,7 @@ SINGLETON: writer-monad
|
|||
INSTANCE: writer-monad monad
|
||||
|
||||
TUPLE: writer value log ;
|
||||
: writer \ writer boa ;
|
||||
: writer ( value log -- writer ) \ writer boa ;
|
||||
|
||||
M: writer monad-of drop writer-monad ;
|
||||
|
||||
|
|
|
|||
|
|
@ -187,7 +187,8 @@ M: method-body crossref?
|
|||
drop [ <method> dup ] 2keep reveal-method
|
||||
] if ;
|
||||
|
||||
: niceify-method [ dup \ f eq? [ drop f ] when ] map ;
|
||||
: niceify-method ( seq -- seq )
|
||||
[ dup \ f eq? [ drop f ] when ] map ;
|
||||
|
||||
M: no-method error.
|
||||
"Type check error" print
|
||||
|
|
@ -229,10 +230,10 @@ M: no-method error.
|
|||
: create-method-in ( specializer generic -- method )
|
||||
create-method dup save-location f set-word ;
|
||||
|
||||
: CREATE-METHOD
|
||||
: CREATE-METHOD ( -- method )
|
||||
scan-word scan-object swap create-method-in ;
|
||||
|
||||
: (METHOD:) CREATE-METHOD parse-definition ;
|
||||
: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
|
||||
|
||||
: METHOD: (METHOD:) define ; parsing
|
||||
|
||||
|
|
|
|||
|
|
@ -22,25 +22,25 @@ SYMBOL: building-seq
|
|||
: get-building-seq ( n -- seq )
|
||||
building-seq get nth ;
|
||||
|
||||
: n, get-building-seq push ;
|
||||
: n% get-building-seq push-all ;
|
||||
: n# >r number>string r> n% ;
|
||||
: n, ( obj n -- ) get-building-seq push ;
|
||||
: n% ( seq n -- ) get-building-seq push-all ;
|
||||
: n# ( num n -- ) >r number>string r> n% ;
|
||||
|
||||
: 0, 0 n, ;
|
||||
: 0% 0 n% ;
|
||||
: 0# 0 n# ;
|
||||
: 1, 1 n, ;
|
||||
: 1% 1 n% ;
|
||||
: 1# 1 n# ;
|
||||
: 2, 2 n, ;
|
||||
: 2% 2 n% ;
|
||||
: 2# 2 n# ;
|
||||
: 3, 3 n, ;
|
||||
: 3% 3 n% ;
|
||||
: 3# 3 n# ;
|
||||
: 4, 4 n, ;
|
||||
: 4% 4 n% ;
|
||||
: 4# 4 n# ;
|
||||
: 0, ( obj -- ) 0 n, ;
|
||||
: 0% ( seq -- ) 0 n% ;
|
||||
: 0# ( num -- ) 0 n# ;
|
||||
: 1, ( obj -- ) 1 n, ;
|
||||
: 1% ( seq -- ) 1 n% ;
|
||||
: 1# ( num -- ) 1 n# ;
|
||||
: 2, ( obj -- ) 2 n, ;
|
||||
: 2% ( seq -- ) 2 n% ;
|
||||
: 2# ( num -- ) 2 n# ;
|
||||
: 3, ( obj -- ) 3 n, ;
|
||||
: 3% ( seq -- ) 3 n% ;
|
||||
: 3# ( num -- ) 3 n# ;
|
||||
: 4, ( obj -- ) 4 n, ;
|
||||
: 4% ( seq -- ) 4 n% ;
|
||||
: 4# ( num -- ) 4 n# ;
|
||||
|
||||
MACRO:: nmake ( quot exemplars -- )
|
||||
[let | n [ exemplars length ] |
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: ui.gadgets.buttons ui.gadgets.packs ui.gadgets ui
|
|||
nehe.2 nehe.3 nehe.4 nehe.5 kernel ;
|
||||
IN: nehe
|
||||
|
||||
: nehe-window
|
||||
: nehe-window ( -- )
|
||||
[
|
||||
[
|
||||
"Nehe 2" [ drop run2 ] <bevel-button> gadget,
|
||||
|
|
|
|||
|
|
@ -3,12 +3,12 @@ IN: numbers-game
|
|||
|
||||
: read-number ( -- n ) readln string>number ;
|
||||
|
||||
: guess-banner
|
||||
: guess-banner ( -- )
|
||||
"I'm thinking of a number between 0 and 100." print ;
|
||||
: guess-prompt "Enter your guess: " write ;
|
||||
: too-high "Too high" print ;
|
||||
: too-low "Too low" print ;
|
||||
: correct "Correct - you win!" print ;
|
||||
: guess-prompt ( -- ) "Enter your guess: " write ;
|
||||
: too-high ( -- ) "Too high" print ;
|
||||
: too-low ( -- ) "Too low" print ;
|
||||
: correct ( -- ) "Correct - you win!" print ;
|
||||
|
||||
: inexact-guess ( actual guess -- )
|
||||
< [ too-high ] [ too-low ] if ;
|
||||
|
|
@ -22,6 +22,6 @@ IN: numbers-game
|
|||
dup guess-prompt read-number judge-guess
|
||||
[ numbers-game-loop ] [ drop ] if ;
|
||||
|
||||
: numbers-game number-to-guess numbers-game-loop ;
|
||||
: numbers-game ( -- ) number-to-guess numbers-game-loop ;
|
||||
|
||||
MAIN: numbers-game
|
||||
|
|
|
|||
|
|
@ -245,7 +245,7 @@ SYMBOL: init
|
|||
f init set-global
|
||||
] unless ;
|
||||
|
||||
: <uint-array> "ALuint" <c-array> ;
|
||||
: <uint-array> ( n -- byte-array ) "ALuint" <c-array> ;
|
||||
|
||||
: gen-sources ( size -- seq )
|
||||
dup <uint-array> 2dup alGenSources swap c-uint-array> ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: optimizer.report
|
|||
>r optimize-1
|
||||
[ r> 1+ count-optimization-passes ] [ drop r> ] if ;
|
||||
|
||||
: results
|
||||
: results ( seq -- )
|
||||
[ [ second ] prepose compare ] curry sort 20 tail*
|
||||
print
|
||||
standard-table-style
|
||||
|
|
@ -15,7 +15,7 @@ IN: optimizer.report
|
|||
[ [ [ pprint-cell ] each ] with-row ] each
|
||||
] tabular-output ;
|
||||
|
||||
: optimizer-report
|
||||
: optimizer-report ( -- )
|
||||
all-words [ compiled? ] filter
|
||||
[
|
||||
dup [
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: math math.parser calendar calendar.format strings words
|
||||
kernel ;
|
||||
kernel effects ;
|
||||
IN: present
|
||||
|
||||
GENERIC: present ( object -- string )
|
||||
|
|
|
|||
|
|
@ -23,9 +23,9 @@ SYMBOL: ignore-case?
|
|||
: or-predicates ( quots -- quot )
|
||||
[ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
|
||||
|
||||
: <@literal [ nip ] curry <@ ;
|
||||
: <@literal ( parser obj -- action ) [ nip ] curry <@ ;
|
||||
|
||||
: <@delay [ curry ] curry <@ ;
|
||||
: <@delay ( parser quot -- action ) [ curry ] curry <@ ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -135,10 +135,10 @@ PRIVATE>
|
|||
'posix-character-class' <|>
|
||||
'simple-escape' <|> &> ;
|
||||
|
||||
: 'any-char'
|
||||
: 'any-char' ( -- parser )
|
||||
"." token [ drop t ] <@literal ;
|
||||
|
||||
: 'char'
|
||||
: 'char' ( -- parser )
|
||||
'any-char' 'escape' 'ordinary-char' <|> <|> [ satisfy ] <@ ;
|
||||
|
||||
DEFER: 'regexp'
|
||||
|
|
|
|||
|
|
@ -1,5 +0,0 @@
|
|||
USING: kernel peg regexp2 sequences tools.test ;
|
||||
IN: regexp2.tests
|
||||
|
||||
[ T{ parse-result f T{ slice f 3 3 "056" } 46 } ]
|
||||
[ "056" 'octal' parse ] unit-test
|
||||
|
|
@ -1,262 +0,0 @@
|
|||
USING: assocs combinators.lib kernel math math.parser
|
||||
namespaces peg unicode.case sequences unicode.categories
|
||||
memoize peg.parsers math.order ;
|
||||
USE: io
|
||||
USE: tools.walker
|
||||
IN: regexp2
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: ignore-case?
|
||||
|
||||
: char=-quot ( ch -- quot )
|
||||
ignore-case? get
|
||||
[ ch>upper [ swap ch>upper = ] ] [ [ = ] ] if
|
||||
curry ;
|
||||
|
||||
: char-between?-quot ( ch1 ch2 -- quot )
|
||||
ignore-case? get
|
||||
[ [ ch>upper ] bi@ [ >r >r ch>upper r> r> between? ] ]
|
||||
[ [ between? ] ]
|
||||
if 2curry ;
|
||||
|
||||
: or-predicates ( quots -- quot )
|
||||
[ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
|
||||
|
||||
: literal-action [ nip ] curry action ;
|
||||
|
||||
: delay-action [ curry ] curry action ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: ascii? ( n -- ? )
|
||||
0 HEX: 7f between? ;
|
||||
|
||||
: octal-digit? ( n -- ? )
|
||||
CHAR: 0 CHAR: 7 between? ;
|
||||
|
||||
: hex-digit? ( n -- ? )
|
||||
{
|
||||
[ dup digit? ]
|
||||
[ dup CHAR: a CHAR: f between? ]
|
||||
[ dup CHAR: A CHAR: F between? ]
|
||||
} || nip ;
|
||||
|
||||
: control-char? ( n -- ? )
|
||||
{ [ dup 0 HEX: 1f between? ] [ dup HEX: 7f = ] } || nip ;
|
||||
|
||||
: punct? ( n -- ? )
|
||||
"!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
|
||||
|
||||
: c-identifier-char? ( ch -- ? )
|
||||
{ [ dup alpha? ] [ dup CHAR: _ = ] } || nip ;
|
||||
|
||||
: java-blank? ( n -- ? )
|
||||
{
|
||||
CHAR: \s
|
||||
CHAR: \t CHAR: \n CHAR: \r
|
||||
HEX: c HEX: 7 HEX: 1b
|
||||
} member? ;
|
||||
|
||||
: java-printable? ( n -- ? )
|
||||
{ [ dup alpha? ] [ dup punct? ] } || nip ;
|
||||
|
||||
MEMO: 'ordinary-char' ( -- parser )
|
||||
[ "\\^*+?|(){}[$" member? not ] satisfy
|
||||
[ char=-quot ] action ;
|
||||
|
||||
MEMO: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ;
|
||||
|
||||
MEMO: 'octal' ( -- parser )
|
||||
"0" token hide 'octal-digit' 1 3 from-m-to-n 2seq
|
||||
[ first oct> ] action ;
|
||||
|
||||
MEMO: 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ;
|
||||
|
||||
MEMO: 'hex' ( -- parser )
|
||||
"x" token hide 'hex-digit' 2 exactly-n 2seq
|
||||
"u" token hide 'hex-digit' 6 exactly-n 2seq 2choice
|
||||
[ first hex> ] action ;
|
||||
|
||||
: satisfy-tokens ( assoc -- parser )
|
||||
[ >r token r> literal-action ] { } assoc>map choice ;
|
||||
|
||||
MEMO: 'simple-escape-char' ( -- parser )
|
||||
{
|
||||
{ "\\" CHAR: \\ }
|
||||
{ "t" CHAR: \t }
|
||||
{ "n" CHAR: \n }
|
||||
{ "r" CHAR: \r }
|
||||
{ "f" HEX: c }
|
||||
{ "a" HEX: 7 }
|
||||
{ "e" HEX: 1b }
|
||||
} [ char=-quot ] assoc-map satisfy-tokens ;
|
||||
|
||||
MEMO: 'predefined-char-class' ( -- parser )
|
||||
{
|
||||
{ "d" [ digit? ] }
|
||||
{ "D" [ digit? not ] }
|
||||
{ "s" [ java-blank? ] }
|
||||
{ "S" [ java-blank? not ] }
|
||||
{ "w" [ c-identifier-char? ] }
|
||||
{ "W" [ c-identifier-char? not ] }
|
||||
} satisfy-tokens ;
|
||||
|
||||
MEMO: 'posix-character-class' ( -- parser )
|
||||
{
|
||||
{ "Lower" [ letter? ] }
|
||||
{ "Upper" [ LETTER? ] }
|
||||
{ "ASCII" [ ascii? ] }
|
||||
{ "Alpha" [ Letter? ] }
|
||||
{ "Digit" [ digit? ] }
|
||||
{ "Alnum" [ alpha? ] }
|
||||
{ "Punct" [ punct? ] }
|
||||
{ "Graph" [ java-printable? ] }
|
||||
{ "Print" [ java-printable? ] }
|
||||
{ "Blank" [ " \t" member? ] }
|
||||
{ "Cntrl" [ control-char? ] }
|
||||
{ "XDigit" [ hex-digit? ] }
|
||||
{ "Space" [ java-blank? ] }
|
||||
} satisfy-tokens "p{" "}" surrounded-by ;
|
||||
|
||||
MEMO: 'simple-escape' ( -- parser )
|
||||
[
|
||||
'octal' ,
|
||||
'hex' ,
|
||||
"c" token hide [ LETTER? ] satisfy 2seq ,
|
||||
any-char ,
|
||||
] choice* [ char=-quot ] action ;
|
||||
|
||||
MEMO: 'escape' ( -- parser )
|
||||
"\\" token hide [
|
||||
'simple-escape-char' ,
|
||||
'predefined-char-class' ,
|
||||
'posix-character-class' ,
|
||||
'simple-escape' ,
|
||||
] choice* 2seq ;
|
||||
|
||||
MEMO: 'any-char' ( -- parser )
|
||||
"." token [ drop t ] literal-action ;
|
||||
|
||||
MEMO: 'char' ( -- parser )
|
||||
'any-char' 'escape' 'ordinary-char' 3choice [ satisfy ] action ;
|
||||
|
||||
DEFER: 'regexp'
|
||||
|
||||
TUPLE: group-result str ;
|
||||
|
||||
C: <group-result> group-result
|
||||
|
||||
MEMO: 'non-capturing-group' ( -- parser )
|
||||
"?:" token hide 'regexp' ;
|
||||
|
||||
MEMO: 'positive-lookahead-group' ( -- parser )
|
||||
"?=" token hide 'regexp' [ ensure ] action ;
|
||||
|
||||
MEMO: 'negative-lookahead-group' ( -- parser )
|
||||
"?!" token hide 'regexp' [ ensure-not ] action ;
|
||||
|
||||
MEMO: 'simple-group' ( -- parser )
|
||||
'regexp' [ [ <group-result> ] action ] action ;
|
||||
|
||||
MEMO: 'group' ( -- parser )
|
||||
[
|
||||
'non-capturing-group' ,
|
||||
'positive-lookahead-group' ,
|
||||
'negative-lookahead-group' ,
|
||||
'simple-group' ,
|
||||
] choice* "(" ")" surrounded-by ;
|
||||
|
||||
MEMO: 'range' ( -- parser )
|
||||
any-char "-" token hide any-char 3seq
|
||||
[ first2 char-between?-quot ] action ;
|
||||
|
||||
MEMO: 'character-class-term' ( -- parser )
|
||||
'range'
|
||||
'escape'
|
||||
[ "\\]" member? not ] satisfy [ char=-quot ] action
|
||||
3choice ;
|
||||
|
||||
MEMO: 'positive-character-class' ( -- parser )
|
||||
! todo
|
||||
"]" token [ CHAR: ] = ] literal-action 'character-class-term' repeat0 2seq
|
||||
'character-class-term' repeat1 2choice [ or-predicates ] action ;
|
||||
|
||||
MEMO: 'negative-character-class' ( -- parser )
|
||||
"^" token hide 'positive-character-class' 2seq
|
||||
[ [ not ] append ] action ;
|
||||
|
||||
MEMO: 'character-class' ( -- parser )
|
||||
'negative-character-class' 'positive-character-class' 2choice
|
||||
"[" "]" surrounded-by [ satisfy ] action ;
|
||||
|
||||
MEMO: 'escaped-seq' ( -- parser )
|
||||
any-char repeat1
|
||||
[ ignore-case? get token ] action "\\Q" "\\E" surrounded-by ;
|
||||
|
||||
MEMO: 'break' ( quot -- parser )
|
||||
satisfy ensure
|
||||
epsilon just 2choice ;
|
||||
|
||||
MEMO: 'break-escape' ( -- parser )
|
||||
"$" token [ "\r\n" member? ] 'break' literal-action
|
||||
"\\b" token [ blank? ] 'break' literal-action
|
||||
"\\B" token [ blank? not ] 'break' literal-action
|
||||
"\\z" token epsilon just literal-action 4choice ;
|
||||
|
||||
MEMO: 'simple' ( -- parser )
|
||||
[
|
||||
'escaped-seq' ,
|
||||
'break-escape' ,
|
||||
'group' ,
|
||||
'character-class' ,
|
||||
'char' ,
|
||||
] choice* ;
|
||||
|
||||
MEMO: 'exactly-n' ( -- parser )
|
||||
'integer' [ exactly-n ] delay-action ;
|
||||
|
||||
MEMO: 'at-least-n' ( -- parser )
|
||||
'integer' "," token hide 2seq [ at-least-n ] delay-action ;
|
||||
|
||||
MEMO: 'at-most-n' ( -- parser )
|
||||
"," token hide 'integer' 2seq [ at-most-n ] delay-action ;
|
||||
|
||||
MEMO: 'from-m-to-n' ( -- parser )
|
||||
'integer' "," token hide 'integer' 3seq
|
||||
[ first2 from-m-to-n ] delay-action ;
|
||||
|
||||
MEMO: 'greedy-interval' ( -- parser )
|
||||
'exactly-n' 'at-least-n' 'at-most-n' 'from-m-to-n' 4choice ;
|
||||
|
||||
MEMO: 'interval' ( -- parser )
|
||||
'greedy-interval'
|
||||
'greedy-interval' "?" token hide 2seq [ "reluctant {}" print ] action
|
||||
'greedy-interval' "+" token hide 2seq [ "possessive {}" print ] action
|
||||
3choice "{" "}" surrounded-by ;
|
||||
|
||||
MEMO: 'repetition' ( -- parser )
|
||||
[
|
||||
! Possessive
|
||||
! "*+" token [ <!*> ] literal-action ,
|
||||
! "++" token [ <!+> ] literal-action ,
|
||||
! "?+" token [ <!?> ] literal-action ,
|
||||
! Reluctant
|
||||
! "*?" token [ <(*)> ] literal-action ,
|
||||
! "+?" token [ <(+)> ] literal-action ,
|
||||
! "??" token [ <(?)> ] literal-action ,
|
||||
! Greedy
|
||||
"*" token [ repeat0 ] literal-action ,
|
||||
"+" token [ repeat1 ] literal-action ,
|
||||
"?" token [ optional ] literal-action ,
|
||||
] choice* ;
|
||||
|
||||
MEMO: 'dummy' ( -- parser )
|
||||
epsilon [ ] literal-action ;
|
||||
|
||||
! todo -- check the action
|
||||
! MEMO: 'term' ( -- parser )
|
||||
! 'simple'
|
||||
! 'repetition' 'interval' 'dummy' 3choice 2seq [ first2 call ] action
|
||||
! <!+> [ <and-parser> ] action ;
|
||||
|
||||
|
|
@ -85,7 +85,7 @@ IN: reports.noise
|
|||
{ spread 2 }
|
||||
} at 0 or ;
|
||||
|
||||
: vsum { 0 0 } [ v+ ] reduce ;
|
||||
: vsum ( pairs -- pair ) { 0 0 } [ v+ ] reduce ;
|
||||
|
||||
GENERIC: noise ( obj -- pair )
|
||||
|
||||
|
|
@ -105,7 +105,7 @@ M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ;
|
|||
|
||||
M: array noise [ noise ] map vsum ;
|
||||
|
||||
: noise-factor / 100 * >integer ;
|
||||
: noise-factor ( x y -- z ) / 100 * >integer ;
|
||||
|
||||
: quot-noise-factor ( quot -- n )
|
||||
#! For very short words, noise doesn't count so much
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue