Fix comments to be ! not #!.
parent
75e50ec5e0
commit
e477f6996f
|
@ -112,7 +112,7 @@ SYMBOL: special-objects
|
||||||
[ length test-quot call ] [ % ] bi ; inline
|
[ length test-quot call ] [ % ] bi ; inline
|
||||||
|
|
||||||
: make-jit ( quot -- parameters literals code )
|
: make-jit ( quot -- parameters literals code )
|
||||||
#! code is a { relocation insns } pair
|
! code is a { relocation insns } pair
|
||||||
[
|
[
|
||||||
0 extra-offset set
|
0 extra-offset set
|
||||||
init-relocation
|
init-relocation
|
||||||
|
@ -212,7 +212,7 @@ GENERIC: prepare-object ( obj -- ptr )
|
||||||
: bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
|
: bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
|
||||||
|
|
||||||
: bignum>sequence ( n -- seq )
|
: bignum>sequence ( n -- seq )
|
||||||
#! n is positive or zero.
|
! n is positive or zero.
|
||||||
[ dup 0 > ]
|
[ dup 0 > ]
|
||||||
[ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
|
[ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
|
||||||
produce nip ;
|
produce nip ;
|
||||||
|
@ -232,8 +232,8 @@ M: bignum prepare-object
|
||||||
! Fixnums
|
! Fixnums
|
||||||
|
|
||||||
M: fixnum prepare-object
|
M: fixnum prepare-object
|
||||||
#! When generating a 32-bit image on a 64-bit system,
|
! When generating a 32-bit image on a 64-bit system,
|
||||||
#! some fixnums should be bignums.
|
! some fixnums should be bignums.
|
||||||
dup
|
dup
|
||||||
bootstrap-most-negative-fixnum
|
bootstrap-most-negative-fixnum
|
||||||
bootstrap-most-positive-fixnum between?
|
bootstrap-most-positive-fixnum between?
|
||||||
|
@ -346,8 +346,8 @@ M: wrapper prepare-object
|
||||||
] emit-object ;
|
] emit-object ;
|
||||||
|
|
||||||
M: string prepare-object
|
M: string prepare-object
|
||||||
#! We pool strings so that each string is only written once
|
! We pool strings so that each string is only written once
|
||||||
#! to the image
|
! to the image
|
||||||
[ emit-string ] cache-eql-object ;
|
[ emit-string ] cache-eql-object ;
|
||||||
|
|
||||||
: assert-empty ( seq -- )
|
: assert-empty ( seq -- )
|
||||||
|
|
|
@ -35,10 +35,10 @@ ERROR: cairo-error n message ;
|
||||||
ubyte-components >>component-type ; inline
|
ubyte-components >>component-type ; inline
|
||||||
|
|
||||||
: dummy-cairo ( -- cr )
|
: dummy-cairo ( -- cr )
|
||||||
#! Sometimes we want a dummy context; eg with Pango, we want
|
! Sometimes we want a dummy context; eg with Pango, we want
|
||||||
#! to measure text dimensions to create a new image context with,
|
! to measure text dimensions to create a new image context with,
|
||||||
#! but we need an existing context to measure text dimensions
|
! but we need an existing context to measure text dimensions
|
||||||
#! with so we use the dummy.
|
! with so we use the dummy.
|
||||||
\ dummy-cairo [
|
\ dummy-cairo [
|
||||||
CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
|
CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
|
||||||
cairo_create
|
cairo_create
|
||||||
|
|
|
@ -123,8 +123,8 @@ CONSTANT: minutes-per-year 5259492/10
|
||||||
CONSTANT: seconds-per-year 31556952
|
CONSTANT: seconds-per-year 31556952
|
||||||
|
|
||||||
:: julian-day-number ( year month day -- n )
|
:: julian-day-number ( year month day -- n )
|
||||||
#! Returns a composite date number
|
! Returns a composite date number
|
||||||
#! Not valid before year -4800
|
! Not valid before year -4800
|
||||||
14 month - 12 /i :> a
|
14 month - 12 /i :> a
|
||||||
year 4800 + a - :> y
|
year 4800 + a - :> y
|
||||||
month 12 a * + 3 - :> m
|
month 12 a * + 3 - :> m
|
||||||
|
@ -133,7 +133,7 @@ CONSTANT: seconds-per-year 31556952
|
||||||
y 4 /i + y 100 /i - y 400 /i + 32045 - ;
|
y 4 /i + y 100 /i - y 400 /i + 32045 - ;
|
||||||
|
|
||||||
:: julian-day-number>date ( n -- year month day )
|
:: julian-day-number>date ( n -- year month day )
|
||||||
#! Inverse of julian-day-number
|
! Inverse of julian-day-number
|
||||||
n 32044 + :> a
|
n 32044 + :> a
|
||||||
4 a * 3 + 146097 /i :> b
|
4 a * 3 + 146097 /i :> b
|
||||||
a 146097 b * 4 /i - :> c
|
a 146097 b * 4 /i - :> c
|
||||||
|
@ -204,7 +204,7 @@ GENERIC: +minute ( timestamp x -- timestamp )
|
||||||
GENERIC: +second ( timestamp x -- timestamp )
|
GENERIC: +second ( timestamp x -- timestamp )
|
||||||
|
|
||||||
: /rem ( f n -- q r )
|
: /rem ( f n -- q r )
|
||||||
#! q is positive or negative, r is positive from 0 <= r < n
|
! q is positive or negative, r is positive from 0 <= r < n
|
||||||
[ / floor >integer ] 2keep rem ;
|
[ / floor >integer ] 2keep rem ;
|
||||||
|
|
||||||
: float>whole-part ( float -- int float )
|
: float>whole-part ( float -- int float )
|
||||||
|
@ -295,8 +295,8 @@ M: duration time+
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: duration>years ( duration -- x )
|
: duration>years ( duration -- x )
|
||||||
#! Uses average month/year length since duration loses calendar
|
! Uses average month/year length since duration loses calendar
|
||||||
#! data
|
! data
|
||||||
0 swap
|
0 swap
|
||||||
{
|
{
|
||||||
[ year>> + ]
|
[ year>> + ]
|
||||||
|
@ -351,7 +351,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
||||||
[ >time< [ [ 3600 * ] [ 60 * ] bi* ] dip + + ] bi@ - + ;
|
[ >time< [ [ 3600 * ] [ 60 * ] bi* ] dip + + ] bi@ - + ;
|
||||||
|
|
||||||
M: timestamp time-
|
M: timestamp time-
|
||||||
#! Exact calendar-time difference
|
! Exact calendar-time difference
|
||||||
(time-) seconds ;
|
(time-) seconds ;
|
||||||
|
|
||||||
: time* ( obj1 obj2 -- obj3 )
|
: time* ( obj1 obj2 -- obj3 )
|
||||||
|
@ -420,9 +420,9 @@ M: duration time-
|
||||||
: ago ( duration -- timestamp ) now swap time- ;
|
: ago ( duration -- timestamp ) now swap time- ;
|
||||||
|
|
||||||
: zeller-congruence ( year month day -- n )
|
: zeller-congruence ( year month day -- n )
|
||||||
#! Zeller Congruence
|
! Zeller Congruence
|
||||||
#! http://web.textfiles.com/computers/formulas.txt
|
! http://web.textfiles.com/computers/formulas.txt
|
||||||
#! good for any date since October 15, 1582
|
! good for any date since October 15, 1582
|
||||||
[
|
[
|
||||||
dup 2 <= [ [ 1 - ] [ 12 + ] bi* ] when
|
dup 2 <= [ [ 1 - ] [ 12 + ] bi* ] when
|
||||||
[ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
|
[ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
|
||||||
|
|
|
@ -111,8 +111,8 @@ M: timestamp year. ( timestamp -- )
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
: timestamp>rfc822 ( timestamp -- str )
|
: timestamp>rfc822 ( timestamp -- str )
|
||||||
#! RFC822 timestamp format
|
! RFC822 timestamp format
|
||||||
#! Example: Tue, 15 Nov 1994 08:12:31 +0200
|
! Example: Tue, 15 Nov 1994 08:12:31 +0200
|
||||||
[
|
[
|
||||||
[ (timestamp>string) bl ]
|
[ (timestamp>string) bl ]
|
||||||
[ gmt-offset>> write-gmt-offset ]
|
[ gmt-offset>> write-gmt-offset ]
|
||||||
|
@ -126,8 +126,8 @@ M: timestamp year. ( timestamp -- )
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
||||||
: timestamp>http-string ( timestamp -- str )
|
: timestamp>http-string ( timestamp -- str )
|
||||||
#! http timestamp format
|
! http timestamp format
|
||||||
#! Example: Tue, 15 Nov 1994 08:12:31 GMT
|
! Example: Tue, 15 Nov 1994 08:12:31 GMT
|
||||||
>gmt timestamp>rfc822 ;
|
>gmt timestamp>rfc822 ;
|
||||||
|
|
||||||
: (timestamp>cookie-string) ( timestamp -- )
|
: (timestamp>cookie-string) ( timestamp -- )
|
||||||
|
|
|
@ -17,9 +17,9 @@ IN: channels.examples
|
||||||
[ from ] keep [ from ] keep from ;
|
[ from ] keep [ from ] keep from ;
|
||||||
|
|
||||||
: filter ( send prime recv -- )
|
: filter ( send prime recv -- )
|
||||||
#! Receives numbers from the 'send' channel,
|
! Receives numbers from the 'send' channel,
|
||||||
#! filters out all those divisible by 'prime',
|
! filters out all those divisible by 'prime',
|
||||||
#! and sends to the 'recv' channel.
|
! and sends to the 'recv' channel.
|
||||||
[
|
[
|
||||||
from swap dupd mod zero? not [ swap to ] [ 2drop ] if
|
from swap dupd mod zero? not [ swap to ] [ 2drop ] if
|
||||||
] 3keep filter ;
|
] 3keep filter ;
|
||||||
|
@ -32,7 +32,7 @@ IN: channels.examples
|
||||||
prime newc (sieve) ;
|
prime newc (sieve) ;
|
||||||
|
|
||||||
: sieve ( prime -- )
|
: sieve ( prime -- )
|
||||||
#! Send prime numbers to 'prime' channel
|
! Send prime numbers to 'prime' channel
|
||||||
<channel> dup [ counter ] curry "Counter" spawn drop
|
<channel> dup [ counter ] curry "Counter" spawn drop
|
||||||
(sieve) ;
|
(sieve) ;
|
||||||
|
|
||||||
|
|
|
@ -4,11 +4,11 @@ USING: assocs checksums grouping kernel locals math sequences ;
|
||||||
IN: checksums.interleave
|
IN: checksums.interleave
|
||||||
|
|
||||||
: seq>2seq ( seq -- seq1 seq2 )
|
: seq>2seq ( seq -- seq1 seq2 )
|
||||||
#! { abcdefgh } -> { aceg } { bdfh }
|
! { abcdefgh } -> { aceg } { bdfh }
|
||||||
2 group flip [ { } { } ] [ first2 ] if-empty ;
|
2 group flip [ { } { } ] [ first2 ] if-empty ;
|
||||||
|
|
||||||
: 2seq>seq ( seq1 seq2 -- seq )
|
: 2seq>seq ( seq1 seq2 -- seq )
|
||||||
#! { aceg } { bdfh } -> { abcdefgh }
|
! { aceg } { bdfh } -> { abcdefgh }
|
||||||
[ zip concat ] keep like ;
|
[ zip concat ] keep like ;
|
||||||
|
|
||||||
:: interleaved-checksum ( bytes checksum -- seq )
|
:: interleaved-checksum ( bytes checksum -- seq )
|
||||||
|
|
|
@ -34,19 +34,19 @@ CONSTANT: T $[
|
||||||
]
|
]
|
||||||
|
|
||||||
:: F ( X Y Z -- FXYZ )
|
:: F ( X Y Z -- FXYZ )
|
||||||
#! F(X,Y,Z) = XY v not(X) Z
|
! F(X,Y,Z) = XY v not(X) Z
|
||||||
X Y bitand X bitnot Z bitand bitor ; inline
|
X Y bitand X bitnot Z bitand bitor ; inline
|
||||||
|
|
||||||
:: G ( X Y Z -- GXYZ )
|
:: G ( X Y Z -- GXYZ )
|
||||||
#! G(X,Y,Z) = XZ v Y not(Z)
|
! G(X,Y,Z) = XZ v Y not(Z)
|
||||||
X Z bitand Y Z bitnot bitand bitor ; inline
|
X Z bitand Y Z bitnot bitand bitor ; inline
|
||||||
|
|
||||||
: H ( X Y Z -- HXYZ )
|
: H ( X Y Z -- HXYZ )
|
||||||
#! H(X,Y,Z) = X xor Y xor Z
|
! H(X,Y,Z) = X xor Y xor Z
|
||||||
bitxor bitxor ; inline
|
bitxor bitxor ; inline
|
||||||
|
|
||||||
:: I ( X Y Z -- IXYZ )
|
:: I ( X Y Z -- IXYZ )
|
||||||
#! I(X,Y,Z) = Y xor (X v not(Z))
|
! I(X,Y,Z) = Y xor (X v not(Z))
|
||||||
Z bitnot X bitor Y bitxor ; inline
|
Z bitnot X bitor Y bitxor ; inline
|
||||||
|
|
||||||
CONSTANT: S11 7
|
CONSTANT: S11 7
|
||||||
|
@ -72,7 +72,7 @@ CONSTANT: c 2
|
||||||
CONSTANT: d 3
|
CONSTANT: d 3
|
||||||
|
|
||||||
:: (ABCD) ( x state a b c d k s i quot -- )
|
:: (ABCD) ( x state a b c d k s i quot -- )
|
||||||
#! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
|
! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
|
||||||
a state [
|
a state [
|
||||||
b state nth-unsafe
|
b state nth-unsafe
|
||||||
c state nth-unsafe
|
c state nth-unsafe
|
||||||
|
|
|
@ -24,7 +24,7 @@ M: circular virtual@ circular-wrap seq>> ; inline
|
||||||
M: circular virtual-exemplar seq>> ; inline
|
M: circular virtual-exemplar seq>> ; inline
|
||||||
|
|
||||||
: change-circular-start ( n circular -- )
|
: change-circular-start ( n circular -- )
|
||||||
#! change start to (start + n) mod length
|
! change start to (start + n) mod length
|
||||||
circular-wrap start<< ; inline
|
circular-wrap start<< ; inline
|
||||||
|
|
||||||
: rotate-circular ( circular -- )
|
: rotate-circular ( circular -- )
|
||||||
|
|
|
@ -39,7 +39,7 @@ FUNCTION: void NSBeep ( )
|
||||||
-> alloc -> init -> setDelegate: ;
|
-> alloc -> init -> setDelegate: ;
|
||||||
|
|
||||||
: running.app? ( -- ? )
|
: running.app? ( -- ? )
|
||||||
#! Test if we're running a .app.
|
! Test if we're running a .app.
|
||||||
".app"
|
".app"
|
||||||
NSBundle -> mainBundle -> bundlePath CF>string
|
NSBundle -> mainBundle -> bundlePath CF>string
|
||||||
subseq? ;
|
subseq? ;
|
||||||
|
|
|
@ -30,14 +30,14 @@ SYMBOL: heap-ac
|
||||||
acs>vregs get [ drop V{ } clone ] cache ;
|
acs>vregs get [ drop V{ } clone ] cache ;
|
||||||
|
|
||||||
: vreg>ac ( vreg -- ac )
|
: vreg>ac ( vreg -- ac )
|
||||||
#! Only vregs produced by ##allot, ##peek and ##slot can
|
! Only vregs produced by ##allot, ##peek and ##slot can
|
||||||
#! ever be used as valid inputs to ##slot and ##set-slot,
|
! ever be used as valid inputs to ##slot and ##set-slot,
|
||||||
#! so we assert this fact by not giving alias classes to
|
! so we assert this fact by not giving alias classes to
|
||||||
#! other vregs.
|
! other vregs.
|
||||||
vregs>acs get [ heap-ac get [ ac>vregs push ] keep ] cache ;
|
vregs>acs get [ heap-ac get [ ac>vregs push ] keep ] cache ;
|
||||||
|
|
||||||
: aliases ( vreg -- vregs )
|
: aliases ( vreg -- vregs )
|
||||||
#! All vregs which may contain the same value as vreg.
|
! All vregs which may contain the same value as vreg.
|
||||||
vreg>ac ac>vregs ;
|
vreg>ac ac>vregs ;
|
||||||
|
|
||||||
: each-alias ( vreg quot -- )
|
: each-alias ( vreg quot -- )
|
||||||
|
@ -66,14 +66,14 @@ SYMBOL: dead-stores
|
||||||
ERROR: vreg-not-new vreg ;
|
ERROR: vreg-not-new vreg ;
|
||||||
|
|
||||||
:: set-ac ( vreg ac -- )
|
:: set-ac ( vreg ac -- )
|
||||||
#! Set alias class of newly-seen vreg.
|
! Set alias class of newly-seen vreg.
|
||||||
vreg vregs>acs get key? [ vreg vreg-not-new ] when
|
vreg vregs>acs get key? [ vreg vreg-not-new ] when
|
||||||
ac vreg vregs>acs get set-at
|
ac vreg vregs>acs get set-at
|
||||||
vreg ac ac>vregs push ;
|
vreg ac ac>vregs push ;
|
||||||
|
|
||||||
: live-slot ( slot#/f vreg -- vreg' )
|
: live-slot ( slot#/f vreg -- vreg' )
|
||||||
#! If the slot number is unknown, we never reuse a previous
|
! If the slot number is unknown, we never reuse a previous
|
||||||
#! value.
|
! value.
|
||||||
over [ live-slots get at at ] [ 2drop f ] if ;
|
over [ live-slots get at at ] [ 2drop f ] if ;
|
||||||
|
|
||||||
: load-constant-slot ( value slot# vreg -- )
|
: load-constant-slot ( value slot# vreg -- )
|
||||||
|
@ -83,12 +83,12 @@ ERROR: vreg-not-new vreg ;
|
||||||
over [ load-constant-slot ] [ 3drop ] if ;
|
over [ load-constant-slot ] [ 3drop ] if ;
|
||||||
|
|
||||||
: record-constant-slot ( slot# vreg -- )
|
: record-constant-slot ( slot# vreg -- )
|
||||||
#! A load can potentially read every store of this slot#
|
! A load can potentially read every store of this slot#
|
||||||
#! in that alias class.
|
! in that alias class.
|
||||||
[ recent-stores get at delete-at ] with each-alias ;
|
[ recent-stores get at delete-at ] with each-alias ;
|
||||||
|
|
||||||
: record-computed-slot ( vreg -- )
|
: record-computed-slot ( vreg -- )
|
||||||
#! Computed load is like a load of every slot touched so far
|
! Computed load is like a load of every slot touched so far
|
||||||
[ recent-stores get at clear-assoc ] each-alias ;
|
[ recent-stores get at clear-assoc ] each-alias ;
|
||||||
|
|
||||||
:: remember-slot ( value slot# vreg -- )
|
:: remember-slot ( value slot# vreg -- )
|
||||||
|
@ -171,8 +171,8 @@ M: vreg-insn analyze-aliases
|
||||||
def-acs ;
|
def-acs ;
|
||||||
|
|
||||||
M: allocation-insn analyze-aliases
|
M: allocation-insn analyze-aliases
|
||||||
#! A freshly allocated object is distinct from any other
|
! A freshly allocated object is distinct from any other
|
||||||
#! object.
|
! object.
|
||||||
dup dst>> set-new-ac ;
|
dup dst>> set-new-ac ;
|
||||||
|
|
||||||
M: ##box-displaced-alien analyze-aliases
|
M: ##box-displaced-alien analyze-aliases
|
||||||
|
@ -188,8 +188,8 @@ M: read-insn analyze-aliases
|
||||||
if ;
|
if ;
|
||||||
|
|
||||||
: idempotent? ( value slot#/f vreg -- ? )
|
: idempotent? ( value slot#/f vreg -- ? )
|
||||||
#! Are we storing a value back to the same slot it was read
|
! Are we storing a value back to the same slot it was read
|
||||||
#! from?
|
! from?
|
||||||
live-slot = ;
|
live-slot = ;
|
||||||
|
|
||||||
M:: write-insn analyze-aliases ( insn -- insn )
|
M:: write-insn analyze-aliases ( insn -- insn )
|
||||||
|
@ -207,8 +207,8 @@ M:: write-insn analyze-aliases ( insn -- insn )
|
||||||
insn ;
|
insn ;
|
||||||
|
|
||||||
M: ##copy analyze-aliases
|
M: ##copy analyze-aliases
|
||||||
#! The output vreg gets the same alias class as the input
|
! The output vreg gets the same alias class as the input
|
||||||
#! vreg, since they both contain the same value.
|
! vreg, since they both contain the same value.
|
||||||
dup record-copy ;
|
dup record-copy ;
|
||||||
|
|
||||||
: useless-compare? ( insn -- ? )
|
: useless-compare? ( insn -- ? )
|
||||||
|
|
|
@ -14,7 +14,7 @@ IN: compiler
|
||||||
SYMBOL: compiled
|
SYMBOL: compiled
|
||||||
|
|
||||||
: compile? ( word -- ? )
|
: compile? ( word -- ? )
|
||||||
#! Don't attempt to compile certain words.
|
! Don't attempt to compile certain words.
|
||||||
{
|
{
|
||||||
[ "forgotten" word-prop ]
|
[ "forgotten" word-prop ]
|
||||||
[ inlined-block? ]
|
[ inlined-block? ]
|
||||||
|
@ -46,17 +46,17 @@ M: predicate-engine-word combinator? "owner-generic" word-prop combinator? ;
|
||||||
M: word combinator? inline? ;
|
M: word combinator? inline? ;
|
||||||
|
|
||||||
: ignore-error? ( word error -- ? )
|
: ignore-error? ( word error -- ? )
|
||||||
#! Ignore some errors on inline combinators, macros, and special
|
! Ignore some errors on inline combinators, macros, and special
|
||||||
#! words such as 'call'.
|
! words such as 'call'.
|
||||||
{
|
{
|
||||||
[ drop no-compile? ]
|
[ drop no-compile? ]
|
||||||
[ [ combinator? ] [ unknown-macro-input? ] bi* and ]
|
[ [ combinator? ] [ unknown-macro-input? ] bi* and ]
|
||||||
} 2|| ;
|
} 2|| ;
|
||||||
|
|
||||||
: finish ( word -- )
|
: finish ( word -- )
|
||||||
#! Recompile callers if the word's stack effect changed, then
|
! Recompile callers if the word's stack effect changed, then
|
||||||
#! save the word's dependencies so that if they change, the
|
! save the word's dependencies so that if they change, the
|
||||||
#! word can get recompiled too.
|
! word can get recompiled too.
|
||||||
[ compiled-unxref ]
|
[ compiled-unxref ]
|
||||||
[
|
[
|
||||||
dup crossref? [
|
dup crossref? [
|
||||||
|
@ -67,8 +67,8 @@ M: word combinator? inline? ;
|
||||||
] bi ;
|
] bi ;
|
||||||
|
|
||||||
: deoptimize-with ( word def -- * )
|
: deoptimize-with ( word def -- * )
|
||||||
#! If the word failed to infer, compile it with the
|
! If the word failed to infer, compile it with the
|
||||||
#! non-optimizing compiler.
|
! non-optimizing compiler.
|
||||||
swap [ finish ] [ compiled get set-at ] bi return ;
|
swap [ finish ] [ compiled get set-at ] bi return ;
|
||||||
|
|
||||||
: not-compiled-def ( word error -- def )
|
: not-compiled-def ( word error -- def )
|
||||||
|
@ -86,10 +86,10 @@ M: word combinator? inline? ;
|
||||||
2bi ;
|
2bi ;
|
||||||
|
|
||||||
: deoptimize ( word error -- * )
|
: deoptimize ( word error -- * )
|
||||||
#! If the error is ignorable, compile the word with the
|
! If the error is ignorable, compile the word with the
|
||||||
#! non-optimizing compiler, using its definition. Otherwise,
|
! non-optimizing compiler, using its definition. Otherwise,
|
||||||
#! if the compiler error is not ignorable, use a dummy
|
! if the compiler error is not ignorable, use a dummy
|
||||||
#! definition from 'not-compiled-def' which throws an error.
|
! definition from 'not-compiled-def' which throws an error.
|
||||||
{
|
{
|
||||||
{ [ dup inference-error? not ] [ rethrow ] }
|
{ [ dup inference-error? not ] [ rethrow ] }
|
||||||
{ [ 2dup ignore-error? ] [ ignore-error ] }
|
{ [ 2dup ignore-error? ] [ ignore-error ] }
|
||||||
|
@ -106,8 +106,8 @@ M: word combinator? inline? ;
|
||||||
dependencies get keys [ "break?" word-prop ] any? ;
|
dependencies get keys [ "break?" word-prop ] any? ;
|
||||||
|
|
||||||
: frontend ( word -- tree )
|
: frontend ( word -- tree )
|
||||||
#! If the word contains breakpoints, don't optimize it, since
|
! If the word contains breakpoints, don't optimize it, since
|
||||||
#! the walker does not support this.
|
! the walker does not support this.
|
||||||
dup optimize? [
|
dup optimize? [
|
||||||
[ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
|
[ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
|
||||||
contains-breakpoints? [ nip deoptimize* ] [ drop ] if
|
contains-breakpoints? [ nip deoptimize* ] [ drop ] if
|
||||||
|
@ -124,8 +124,8 @@ M: word combinator? inline? ;
|
||||||
] each ;
|
] each ;
|
||||||
|
|
||||||
: compile-word ( word -- )
|
: compile-word ( word -- )
|
||||||
#! We return early if the word has breakpoints or if it
|
! We return early if the word has breakpoints or if it
|
||||||
#! failed to infer.
|
! failed to infer.
|
||||||
'[
|
'[
|
||||||
_ {
|
_ {
|
||||||
[ start ]
|
[ start ]
|
||||||
|
@ -138,8 +138,8 @@ M: word combinator? inline? ;
|
||||||
SINGLETON: optimizing-compiler
|
SINGLETON: optimizing-compiler
|
||||||
|
|
||||||
M: optimizing-compiler update-call-sites ( class generic -- words )
|
M: optimizing-compiler update-call-sites ( class generic -- words )
|
||||||
#! Words containing call sites with inferred type 'class'
|
! Words containing call sites with inferred type 'class'
|
||||||
#! which inlined a method on 'generic'
|
! which inlined a method on 'generic'
|
||||||
generic-call-sites-of keys swap '[
|
generic-call-sites-of keys swap '[
|
||||||
_ 2dup [ valid-classoid? ] both?
|
_ 2dup [ valid-classoid? ] both?
|
||||||
[ classes-intersect? ] [ 2drop f ] if
|
[ classes-intersect? ] [ 2drop f ] if
|
||||||
|
|
|
@ -24,8 +24,8 @@ M: node delete-node drop ;
|
||||||
GENERIC: cleanup-tree* ( node -- node/nodes )
|
GENERIC: cleanup-tree* ( node -- node/nodes )
|
||||||
|
|
||||||
: cleanup-tree ( nodes -- nodes' )
|
: cleanup-tree ( nodes -- nodes' )
|
||||||
#! We don't recurse into children here, instead the methods
|
! We don't recurse into children here, instead the methods
|
||||||
#! do it since the logic is a bit more involved
|
! do it since the logic is a bit more involved
|
||||||
[ cleanup-tree* ] map-flat ;
|
[ cleanup-tree* ] map-flat ;
|
||||||
|
|
||||||
! Constant folding
|
! Constant folding
|
||||||
|
@ -34,8 +34,8 @@ GENERIC: cleanup-tree* ( node -- node/nodes )
|
||||||
[ f ] [ [ literal?>> ] all? ] if-empty ;
|
[ f ] [ [ literal?>> ] all? ] if-empty ;
|
||||||
|
|
||||||
: (cleanup-folding) ( #call -- nodes )
|
: (cleanup-folding) ( #call -- nodes )
|
||||||
#! Replace a #call having a known result with a #drop of its
|
! Replace a #call having a known result with a #drop of its
|
||||||
#! inputs followed by #push nodes for the outputs.
|
! inputs followed by #push nodes for the outputs.
|
||||||
[
|
[
|
||||||
[ node-output-infos ] [ out-d>> ] bi
|
[ node-output-infos ] [ out-d>> ] bi
|
||||||
[ [ literal>> ] dip <#push> ] 2map
|
[ [ literal>> ] dip <#push> ] 2map
|
||||||
|
@ -114,8 +114,8 @@ M: #call cleanup-tree*
|
||||||
] change-children drop ;
|
] change-children drop ;
|
||||||
|
|
||||||
: fold-only-branch ( #branch -- node/nodes )
|
: fold-only-branch ( #branch -- node/nodes )
|
||||||
#! If only one branch is live we don't need to branch at
|
! If only one branch is live we don't need to branch at
|
||||||
#! all; just drop the condition value.
|
! all; just drop the condition value.
|
||||||
dup live-children sift dup length {
|
dup live-children sift dup length {
|
||||||
{ 0 [ drop in-d>> <#drop> ] }
|
{ 0 [ drop in-d>> <#drop> ] }
|
||||||
{ 1 [ first swap in-d>> <#drop> prefix ] }
|
{ 1 [ first swap in-d>> <#drop> prefix ] }
|
||||||
|
@ -152,7 +152,7 @@ M: #branch cleanup-tree*
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
M: #phi cleanup-tree*
|
M: #phi cleanup-tree*
|
||||||
#! Remove #phi function inputs which no longer exist.
|
! Remove #phi function inputs which no longer exist.
|
||||||
live-branches get
|
live-branches get
|
||||||
[ '[ _ sift-children ] change-phi-in-d ]
|
[ '[ _ sift-children ] change-phi-in-d ]
|
||||||
[ '[ _ sift-children ] change-phi-info-d ]
|
[ '[ _ sift-children ] change-phi-info-d ]
|
||||||
|
@ -163,14 +163,14 @@ M: #phi cleanup-tree*
|
||||||
: >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi <#copy> ;
|
: >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi <#copy> ;
|
||||||
|
|
||||||
: flatten-recursive ( #recursive -- nodes )
|
: flatten-recursive ( #recursive -- nodes )
|
||||||
#! convert #enter-recursive and #return-recursive into
|
! convert #enter-recursive and #return-recursive into
|
||||||
#! #copy nodes.
|
! #copy nodes.
|
||||||
child>>
|
child>>
|
||||||
unclip >copy prefix
|
unclip >copy prefix
|
||||||
unclip-last >copy suffix ;
|
unclip-last >copy suffix ;
|
||||||
|
|
||||||
M: #recursive cleanup-tree*
|
M: #recursive cleanup-tree*
|
||||||
#! Inline bodies of #recursive blocks with no calls left.
|
! Inline bodies of #recursive blocks with no calls left.
|
||||||
[ cleanup-tree ] change-child
|
[ cleanup-tree ] change-child
|
||||||
dup label>> calls>> empty? [ flatten-recursive ] when ;
|
dup label>> calls>> empty? [ flatten-recursive ] when ;
|
||||||
|
|
||||||
|
|
|
@ -14,8 +14,8 @@ M: #dispatch mark-live-values* look-at-inputs ;
|
||||||
[ index ] dip swap [ <column> look-at-values ] [ drop ] if* ;
|
[ index ] dip swap [ <column> look-at-values ] [ drop ] if* ;
|
||||||
|
|
||||||
M: #phi compute-live-values*
|
M: #phi compute-live-values*
|
||||||
#! If any of the outputs of a #phi are live, then the
|
! If any of the outputs of a #phi are live, then the
|
||||||
#! corresponding inputs are live too.
|
! corresponding inputs are live too.
|
||||||
[ out-d>> ] [ phi-in-d>> ] bi look-at-phi ;
|
[ out-d>> ] [ phi-in-d>> ] bi look-at-phi ;
|
||||||
|
|
||||||
SYMBOL: if-node
|
SYMBOL: if-node
|
||||||
|
|
|
@ -8,16 +8,16 @@ stack-checker.backend ;
|
||||||
IN: compiler.tree.dead-code.recursive
|
IN: compiler.tree.dead-code.recursive
|
||||||
|
|
||||||
M: #enter-recursive compute-live-values*
|
M: #enter-recursive compute-live-values*
|
||||||
#! If the output of an #enter-recursive is live, then the
|
! If the output of an #enter-recursive is live, then the
|
||||||
#! corresponding inputs to the #call-recursive are live also.
|
! corresponding inputs to the #call-recursive are live also.
|
||||||
[ out-d>> ] [ recursive-phi-in ] bi look-at-phi ;
|
[ out-d>> ] [ recursive-phi-in ] bi look-at-phi ;
|
||||||
|
|
||||||
M: #return-recursive compute-live-values*
|
M: #return-recursive compute-live-values*
|
||||||
[ out-d>> ] [ in-d>> ] bi look-at-mapping ;
|
[ out-d>> ] [ in-d>> ] bi look-at-mapping ;
|
||||||
|
|
||||||
M: #call-recursive compute-live-values*
|
M: #call-recursive compute-live-values*
|
||||||
#! If the output of a #call-recursive is live, then the
|
! If the output of a #call-recursive is live, then the
|
||||||
#! corresponding inputs to #return nodes are live also.
|
! corresponding inputs to #return nodes are live also.
|
||||||
[ out-d>> ] [ label>> return>> in-d>> ] bi look-at-mapping ;
|
[ out-d>> ] [ label>> return>> in-d>> ] bi look-at-mapping ;
|
||||||
|
|
||||||
:: drop-dead-inputs ( inputs outputs -- #shuffle )
|
:: drop-dead-inputs ( inputs outputs -- #shuffle )
|
||||||
|
|
|
@ -26,8 +26,8 @@ M: #return mark-live-values* look-at-inputs ;
|
||||||
[ index ] dip over [ nth look-at-value ] [ 2drop ] if ;
|
[ index ] dip over [ nth look-at-value ] [ 2drop ] if ;
|
||||||
|
|
||||||
M: #copy compute-live-values*
|
M: #copy compute-live-values*
|
||||||
#! If the output of a copy is live, then the corresponding
|
! If the output of a copy is live, then the corresponding
|
||||||
#! input is live also.
|
! input is live also.
|
||||||
[ out-d>> ] [ in-d>> ] bi look-at-mapping ;
|
[ out-d>> ] [ in-d>> ] bi look-at-mapping ;
|
||||||
|
|
||||||
M: #call compute-live-values* nip look-at-inputs ;
|
M: #call compute-live-values* nip look-at-inputs ;
|
||||||
|
@ -41,8 +41,8 @@ M: #alien-node compute-live-values* nip look-at-inputs ;
|
||||||
live-values get '[ drop _ key? ] assoc-filter ;
|
live-values get '[ drop _ key? ] assoc-filter ;
|
||||||
|
|
||||||
: filter-corresponding ( new old -- old' )
|
: filter-corresponding ( new old -- old' )
|
||||||
#! Remove elements from 'old' if the element with the same
|
! Remove elements from 'old' if the element with the same
|
||||||
#! index in 'new' is dead.
|
! index in 'new' is dead.
|
||||||
zip filter-mapping values ;
|
zip filter-mapping values ;
|
||||||
|
|
||||||
: filter-live ( values -- values' )
|
: filter-live ( values -- values' )
|
||||||
|
|
|
@ -53,7 +53,7 @@ M: #recursive escape-analysis* ( #recursive -- )
|
||||||
] bi ;
|
] bi ;
|
||||||
|
|
||||||
M: #enter-recursive escape-analysis* ( #enter-recursive -- )
|
M: #enter-recursive escape-analysis* ( #enter-recursive -- )
|
||||||
#! Handled by #recursive
|
! Handled by #recursive
|
||||||
drop ;
|
drop ;
|
||||||
|
|
||||||
M: #call-recursive escape-analysis* ( #call-label -- )
|
M: #call-recursive escape-analysis* ( #call-label -- )
|
||||||
|
|
|
@ -9,9 +9,9 @@ SYMBOL: introductions
|
||||||
GENERIC: count-introductions* ( node -- )
|
GENERIC: count-introductions* ( node -- )
|
||||||
|
|
||||||
: count-introductions ( nodes -- n )
|
: count-introductions ( nodes -- n )
|
||||||
#! Note: we use each, not each-node, since the #branch
|
! Note: we use each, not each-node, since the #branch
|
||||||
#! method recurses into children directly and we don't
|
! method recurses into children directly and we don't
|
||||||
#! recurse into #recursive at all.
|
! recurse into #recursive at all.
|
||||||
[
|
[
|
||||||
0 introductions set
|
0 introductions set
|
||||||
[ count-introductions* ] each
|
[ count-introductions* ] each
|
||||||
|
|
|
@ -34,8 +34,8 @@ CONSTANT: null-info T{ value-info-state f null empty-interval }
|
||||||
CONSTANT: object-info T{ value-info-state f object full-interval }
|
CONSTANT: object-info T{ value-info-state f object full-interval }
|
||||||
|
|
||||||
: interval>literal ( class interval -- literal literal? )
|
: interval>literal ( class interval -- literal literal? )
|
||||||
#! If interval has zero length and the class is sufficiently
|
! If interval has zero length and the class is sufficiently
|
||||||
#! precise, we can turn it into a literal
|
! precise, we can turn it into a literal
|
||||||
dup special-interval? [
|
dup special-interval? [
|
||||||
2drop f f
|
2drop f f
|
||||||
] [
|
] [
|
||||||
|
@ -60,7 +60,7 @@ DEFER: <literal-info>
|
||||||
UNION: fixed-length array byte-array string ;
|
UNION: fixed-length array byte-array string ;
|
||||||
|
|
||||||
: literal-class ( obj -- class )
|
: literal-class ( obj -- class )
|
||||||
#! Handle forgotten tuples and singleton classes properly
|
! Handle forgotten tuples and singleton classes properly
|
||||||
dup singleton-class? [
|
dup singleton-class? [
|
||||||
class-of dup class? [
|
class-of dup class? [
|
||||||
drop tuple
|
drop tuple
|
||||||
|
|
|
@ -42,9 +42,9 @@ M: anonymous-intersection add-depends-on-class
|
||||||
participants>> [ add-depends-on-class ] each ;
|
participants>> [ add-depends-on-class ] each ;
|
||||||
|
|
||||||
M: #declare propagate-before
|
M: #declare propagate-before
|
||||||
#! We need to force the caller word to recompile when the
|
! We need to force the caller word to recompile when the
|
||||||
#! classes mentioned in the declaration are redefined, since
|
! classes mentioned in the declaration are redefined, since
|
||||||
#! now we're making assumptions about their definitions.
|
! now we're making assumptions about their definitions.
|
||||||
declaration>> [
|
declaration>> [
|
||||||
[ add-depends-on-class ]
|
[ add-depends-on-class ]
|
||||||
[ <class-info> swap refine-value-info ]
|
[ <class-info> swap refine-value-info ]
|
||||||
|
@ -121,9 +121,9 @@ ERROR: invalid-outputs #call infos ;
|
||||||
if ;
|
if ;
|
||||||
|
|
||||||
: propagate-predicate ( #call word -- infos )
|
: propagate-predicate ( #call word -- infos )
|
||||||
#! We need to force the caller word to recompile when the class
|
! We need to force the caller word to recompile when the class
|
||||||
#! is redefined, since now we're making assumptions but the
|
! is redefined, since now we're making assumptions but the
|
||||||
#! class definition itself.
|
! class definition itself.
|
||||||
[ in-d>> first value-info ]
|
[ in-d>> first value-info ]
|
||||||
[ "predicating" word-prop ] bi*
|
[ "predicating" word-prop ] bi*
|
||||||
[ nip add-depends-on-conditionally ]
|
[ nip add-depends-on-conditionally ]
|
||||||
|
|
|
@ -51,13 +51,13 @@ IN: compiler.tree.propagation.slots
|
||||||
dup [ read-only>> ] when ;
|
dup [ read-only>> ] when ;
|
||||||
|
|
||||||
: literal-info-slot ( slot object -- info/f )
|
: literal-info-slot ( slot object -- info/f )
|
||||||
#! literal-info-slot makes an unsafe call to 'slot'.
|
! literal-info-slot makes an unsafe call to 'slot'.
|
||||||
#! Check that the layout is up to date to avoid accessing the
|
! Check that the layout is up to date to avoid accessing the
|
||||||
#! wrong slot during a compilation unit where reshaping took
|
! wrong slot during a compilation unit where reshaping took
|
||||||
#! place. This could happen otherwise because the "slots" word
|
! place. This could happen otherwise because the "slots" word
|
||||||
#! property would reflect the new layout, but instances in the
|
! property would reflect the new layout, but instances in the
|
||||||
#! heap would use the old layout since instances are updated
|
! heap would use the old layout since instances are updated
|
||||||
#! immediately after compilation.
|
! immediately after compilation.
|
||||||
{
|
{
|
||||||
[ class-of read-only-slot? ]
|
[ class-of read-only-slot? ]
|
||||||
[ nip layout-up-to-date? ]
|
[ nip layout-up-to-date? ]
|
||||||
|
|
|
@ -246,7 +246,7 @@ ERROR: bad-partial-eval quot word ;
|
||||||
CONSTANT: lookup-table-at-max 256
|
CONSTANT: lookup-table-at-max 256
|
||||||
|
|
||||||
: lookup-table-at? ( assoc -- ? )
|
: lookup-table-at? ( assoc -- ? )
|
||||||
#! Can we use a fast byte array test here?
|
! Can we use a fast byte array test here?
|
||||||
{
|
{
|
||||||
[ assoc-size 4 > ]
|
[ assoc-size 4 > ]
|
||||||
[ values [ ] all? ]
|
[ values [ ] all? ]
|
||||||
|
|
|
@ -67,7 +67,7 @@ M: #call unbox-tuples*
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
M: #declare unbox-tuples*
|
M: #declare unbox-tuples*
|
||||||
#! We don't look at declarations after escape analysis anyway.
|
! We don't look at declarations after escape analysis anyway.
|
||||||
drop f ;
|
drop f ;
|
||||||
|
|
||||||
M: #copy unbox-tuples*
|
M: #copy unbox-tuples*
|
||||||
|
|
|
@ -10,8 +10,8 @@ IN: concurrency.conditions
|
||||||
[ resume-now ] slurp-deque ; inline
|
[ resume-now ] slurp-deque ; inline
|
||||||
|
|
||||||
: queue-timeout ( queue timeout -- timer )
|
: queue-timeout ( queue timeout -- timer )
|
||||||
#! Add an timer which removes the current thread from the
|
! Add an timer which removes the current thread from the
|
||||||
#! queue, and resumes it, passing it a value of t.
|
! queue, and resumes it, passing it a value of t.
|
||||||
[
|
[
|
||||||
[ self swap push-front* ] keep '[
|
[ self swap push-front* ] keep '[
|
||||||
_ _
|
_ _
|
||||||
|
|
|
@ -85,14 +85,14 @@ TUPLE: rw-lock readers writers reader# writer ;
|
||||||
[ notify-writer ] [ readers>> notify-all ] if ;
|
[ notify-writer ] [ readers>> notify-all ] if ;
|
||||||
|
|
||||||
: reentrant-read-lock-ok? ( lock -- ? )
|
: reentrant-read-lock-ok? ( lock -- ? )
|
||||||
#! If we already have a write lock, then we can grab a read
|
! If we already have a write lock, then we can grab a read
|
||||||
#! lock too.
|
! lock too.
|
||||||
writer>> self eq? ;
|
writer>> self eq? ;
|
||||||
|
|
||||||
: reentrant-write-lock-ok? ( lock -- ? )
|
: reentrant-write-lock-ok? ( lock -- ? )
|
||||||
#! The only case where we have a writer and > 1 reader is
|
! The only case where we have a writer and > 1 reader is
|
||||||
#! write -> read re-entrancy, and in this case we prohibit
|
! write -> read re-entrancy, and in this case we prohibit
|
||||||
#! a further write -> read -> write re-entrancy.
|
! a further write -> read -> write re-entrancy.
|
||||||
{ [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;
|
{ [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
|
@ -189,16 +189,16 @@ M: x86.32 %end-callback ( -- )
|
||||||
"end_callback" f f %c-invoke ;
|
"end_callback" f f %c-invoke ;
|
||||||
|
|
||||||
: funny-large-struct-return? ( return abi -- ? )
|
: funny-large-struct-return? ( return abi -- ? )
|
||||||
#! MINGW ABI incompatibility disaster
|
! MINGW ABI incompatibility disaster
|
||||||
[ large-struct? ] [ mingw eq? os windows? not or ] bi* and ;
|
[ large-struct? ] [ mingw eq? os windows? not or ] bi* and ;
|
||||||
|
|
||||||
M: x86.32 %prepare-var-args ( -- ) ;
|
M: x86.32 %prepare-var-args ( -- ) ;
|
||||||
|
|
||||||
M:: x86.32 stack-cleanup ( stack-size return abi -- n )
|
M:: x86.32 stack-cleanup ( stack-size return abi -- n )
|
||||||
#! a) Functions which are stdcall/fastcall/thiscall have to
|
! a) Functions which are stdcall/fastcall/thiscall have to
|
||||||
#! clean up the caller's stack frame.
|
! clean up the caller's stack frame.
|
||||||
#! b) Functions returning large structs on MINGW have to
|
! b) Functions returning large structs on MINGW have to
|
||||||
#! fix ESP.
|
! fix ESP.
|
||||||
{
|
{
|
||||||
{ [ abi callee-cleanup? ] [ stack-size ] }
|
{ [ abi callee-cleanup? ] [ stack-size ] }
|
||||||
{ [ return abi funny-large-struct-return? ] [ 4 ] }
|
{ [ return abi funny-large-struct-return? ] [ 4 ] }
|
||||||
|
|
|
@ -116,7 +116,7 @@ M: register displacement, drop ;
|
||||||
and and ;
|
and and ;
|
||||||
|
|
||||||
:: rex-prefix ( reg r/m rex.w -- )
|
:: rex-prefix ( reg r/m rex.w -- )
|
||||||
#! Compile an AMD64 REX prefix.
|
! Compile an AMD64 REX prefix.
|
||||||
rex.w reg r/m rex.w? 0b01001000 0b01000000 ?
|
rex.w reg r/m rex.w? 0b01001000 0b01000000 ?
|
||||||
reg rex.r
|
reg rex.r
|
||||||
r/m rex.b
|
r/m rex.b
|
||||||
|
@ -129,8 +129,8 @@ M: register displacement, drop ;
|
||||||
[ drop 16-prefix ] [ [ f ] 2dip rex-prefix ] 2bi ;
|
[ drop 16-prefix ] [ [ f ] 2dip rex-prefix ] 2bi ;
|
||||||
|
|
||||||
: short-operand ( reg rex.w n -- )
|
: short-operand ( reg rex.w n -- )
|
||||||
#! Some instructions encode their single operand as part of
|
! Some instructions encode their single operand as part of
|
||||||
#! the opcode.
|
! the opcode.
|
||||||
[ dupd prefix-1 reg-code ] dip + , ;
|
[ dupd prefix-1 reg-code ] dip + , ;
|
||||||
|
|
||||||
: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
|
: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
|
||||||
|
@ -145,8 +145,8 @@ M: register displacement, drop ;
|
||||||
[ [ unclip-last ] dip bitor suffix ] [ bitor ] if ;
|
[ [ unclip-last ] dip bitor suffix ] [ bitor ] if ;
|
||||||
|
|
||||||
: 1-operand ( operand reg,rex.w,opcode -- )
|
: 1-operand ( operand reg,rex.w,opcode -- )
|
||||||
#! The 'reg' is not really a register, but a value for the
|
! The 'reg' is not really a register, but a value for the
|
||||||
#! 'reg' field of the mod-r/m byte.
|
! 'reg' field of the mod-r/m byte.
|
||||||
first3 [ [ over ] dip prefix-1 ] dip opcode, swap addressing ;
|
first3 [ [ over ] dip prefix-1 ] dip opcode, swap addressing ;
|
||||||
|
|
||||||
: immediate-operand-size-bit ( dst imm reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
|
: immediate-operand-size-bit ( dst imm reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
|
||||||
|
@ -165,10 +165,10 @@ M: register displacement, drop ;
|
||||||
over integer? [ first3 0b10 opcode-or 3array ] when ;
|
over integer? [ first3 0b10 opcode-or 3array ] when ;
|
||||||
|
|
||||||
: immediate-1/4 ( dst imm reg,rex.w,opcode -- )
|
: immediate-1/4 ( dst imm reg,rex.w,opcode -- )
|
||||||
#! If imm is a byte, compile the opcode and the byte.
|
! If imm is a byte, compile the opcode and the byte.
|
||||||
#! Otherwise, set the 8-bit operand flag in the opcode, and
|
! Otherwise, set the 8-bit operand flag in the opcode, and
|
||||||
#! compile the cell. The 'reg' is not really a register, but
|
! compile the cell. The 'reg' is not really a register, but
|
||||||
#! a value for the 'reg' field of the mod-r/m byte.
|
! a value for the 'reg' field of the mod-r/m byte.
|
||||||
over fits-in-byte? [
|
over fits-in-byte? [
|
||||||
immediate-fits-in-size-bit immediate-1
|
immediate-fits-in-size-bit immediate-1
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -59,7 +59,7 @@ M: indirect extended? base>> extended? ;
|
||||||
[ f >>displacement ] when ;
|
[ f >>displacement ] when ;
|
||||||
|
|
||||||
: canonicalize-EBP ( indirect -- indirect )
|
: canonicalize-EBP ( indirect -- indirect )
|
||||||
#! { EBP } ==> { EBP 0 }
|
! { EBP } ==> { EBP 0 }
|
||||||
dup [ base>> { EBP RBP R13 } member? ] [ displacement>> not ] bi and
|
dup [ base>> { EBP RBP R13 } member? ] [ displacement>> not ] bi and
|
||||||
[ 0 >>displacement ] when ;
|
[ 0 >>displacement ] when ;
|
||||||
|
|
||||||
|
@ -69,8 +69,8 @@ ERROR: bad-index indirect ;
|
||||||
dup index>> { ESP RSP } member-eq? [ bad-index ] when ;
|
dup index>> { ESP RSP } member-eq? [ bad-index ] when ;
|
||||||
|
|
||||||
: canonicalize ( indirect -- indirect )
|
: canonicalize ( indirect -- indirect )
|
||||||
#! Modify the indirect to work around certain addressing mode
|
! Modify the indirect to work around certain addressing mode
|
||||||
#! quirks.
|
! quirks.
|
||||||
canonicalize-displacement canonicalize-EBP check-ESP ;
|
canonicalize-displacement canonicalize-EBP check-ESP ;
|
||||||
|
|
||||||
! Utilities
|
! Utilities
|
||||||
|
|
|
@ -104,7 +104,7 @@ M: x86 %inc ( loc -- )
|
||||||
M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
|
M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
|
||||||
|
|
||||||
: xt-tail-pic-offset ( -- n )
|
: xt-tail-pic-offset ( -- n )
|
||||||
#! See the comment in vm/cpu-x86.hpp
|
! See the comment in vm/cpu-x86.hpp
|
||||||
4 1 + ; inline
|
4 1 + ; inline
|
||||||
|
|
||||||
HOOK: %prepare-jump cpu ( -- )
|
HOOK: %prepare-jump cpu ( -- )
|
||||||
|
@ -617,10 +617,10 @@ M:: x86 %local-allot ( dst size align offset -- )
|
||||||
dst offset local-allot-offset special-offset stack@ LEA ;
|
dst offset local-allot-offset special-offset stack@ LEA ;
|
||||||
|
|
||||||
: next-stack@ ( n -- operand )
|
: next-stack@ ( n -- operand )
|
||||||
#! nth parameter from the next stack frame. Used to box
|
! nth parameter from the next stack frame. Used to box
|
||||||
#! input values to callbacks; the callback has its own
|
! input values to callbacks; the callback has its own
|
||||||
#! stack frame set up, and we want to read the frame
|
! stack frame set up, and we want to read the frame
|
||||||
#! set up by the caller.
|
! set up by the caller.
|
||||||
[ frame-reg ] dip 2 cells + reserved-stack-space + [+] ;
|
[ frame-reg ] dip 2 cells + reserved-stack-space + [+] ;
|
||||||
|
|
||||||
: return-reg ( rep -- reg )
|
: return-reg ( rep -- reg )
|
||||||
|
@ -686,9 +686,9 @@ M: x86 %callback-outputs ( reg-inputs -- )
|
||||||
M: x86 %loop-entry 16 alignment [ NOP ] times ;
|
M: x86 %loop-entry 16 alignment [ NOP ] times ;
|
||||||
|
|
||||||
M:: x86 %save-context ( temp1 temp2 -- )
|
M:: x86 %save-context ( temp1 temp2 -- )
|
||||||
#! Save Factor stack pointers in case the C code calls a
|
! Save Factor stack pointers in case the C code calls a
|
||||||
#! callback which does a GC, which must reliably trace
|
! callback which does a GC, which must reliably trace
|
||||||
#! all roots.
|
! all roots.
|
||||||
temp1 %context
|
temp1 %context
|
||||||
temp2 stack-reg cell neg [+] LEA
|
temp2 stack-reg cell neg [+] LEA
|
||||||
temp1 "callstack-top" context-field-offset [+] temp2 MOV
|
temp1 "callstack-top" context-field-offset [+] temp2 MOV
|
||||||
|
|
|
@ -47,7 +47,7 @@ M: retryable execute-statement* ( statement type -- )
|
||||||
[ db-columns ] [ db-table-name ] bi ;
|
[ db-columns ] [ db-table-name ] bi ;
|
||||||
|
|
||||||
: query-make ( class quot -- statements )
|
: query-make ( class quot -- statements )
|
||||||
#! query, input, outputs, secondary queries
|
! query, input, outputs, secondary queries
|
||||||
over db-table-name "table-name" set
|
over db-table-name "table-name" set
|
||||||
[ sql-props ] dip
|
[ sql-props ] dip
|
||||||
[ 0 sql-counter rot with-variable ] curry
|
[ 0 sql-counter rot with-variable ] curry
|
||||||
|
|
|
@ -117,7 +117,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
: sqlite-bind-type ( handle key value type -- )
|
: sqlite-bind-type ( handle key value type -- )
|
||||||
#! null and empty values need to be set by sqlite-bind-null-by-name
|
! null and empty values need to be set by sqlite-bind-null-by-name
|
||||||
over [
|
over [
|
||||||
NULL = [ 2drop NULL NULL ] when
|
NULL = [ 2drop NULL NULL ] when
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -55,7 +55,7 @@ CHLOE: atom
|
||||||
CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
|
CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
|
||||||
|
|
||||||
: compile-link-attrs ( tag -- )
|
: compile-link-attrs ( tag -- )
|
||||||
#! Side-effects current namespace.
|
! Side-effects current namespace.
|
||||||
'[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
|
'[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
|
||||||
|
|
||||||
: process-attrs ( assoc -- newassoc )
|
: process-attrs ( assoc -- newassoc )
|
||||||
|
|
|
@ -92,7 +92,7 @@ M: object modify-form drop f ;
|
||||||
CONSTANT: nested-forms-key "__n"
|
CONSTANT: nested-forms-key "__n"
|
||||||
|
|
||||||
: referrer ( -- referrer/f )
|
: referrer ( -- referrer/f )
|
||||||
#! Typo is intentional, it's in the HTTP spec!
|
! Typo is intentional, it's in the HTTP spec!
|
||||||
request get "referer" header
|
request get "referer" header
|
||||||
dup [ >url ensure-port [ remap-port ] change-port ] when ;
|
dup [ >url ensure-port [ remap-port ] change-port ] when ;
|
||||||
|
|
||||||
|
|
|
@ -136,7 +136,7 @@ ALIAS: $slot $snippet
|
||||||
] ($code) ;
|
] ($code) ;
|
||||||
|
|
||||||
: $unchecked-example ( element -- )
|
: $unchecked-example ( element -- )
|
||||||
#! help-lint ignores these.
|
! help-lint ignores these.
|
||||||
$example ;
|
$example ;
|
||||||
|
|
||||||
: $markup-example ( element -- )
|
: $markup-example ( element -- )
|
||||||
|
|
|
@ -65,7 +65,7 @@ TUPLE: password size ;
|
||||||
password new ;
|
password new ;
|
||||||
|
|
||||||
M: password render*
|
M: password render*
|
||||||
#! Don't send passwords back to the user
|
! Don't send passwords back to the user
|
||||||
[ drop "" ] 2dip size>> "password" render-field ;
|
[ drop "" ] 2dip size>> "password" render-field ;
|
||||||
|
|
||||||
! Text areas
|
! Text areas
|
||||||
|
|
|
@ -32,7 +32,7 @@ CONSTANT: max-redirects 10
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: check-header-string ( str -- str )
|
: check-header-string ( str -- str )
|
||||||
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
|
! http://en.wikipedia.org/wiki/HTTP_Header_Injection
|
||||||
dup "\r\n" intersects?
|
dup "\r\n" intersects?
|
||||||
[ "Header injection attack" throw ] when ;
|
[ "Header injection attack" throw ] when ;
|
||||||
|
|
||||||
|
|
|
@ -67,7 +67,7 @@ IN: http.parsers
|
||||||
] seq* [ "1.0" suffix! ] action ;
|
] seq* [ "1.0" suffix! ] action ;
|
||||||
|
|
||||||
PEG: parse-request-line ( string -- triple )
|
PEG: parse-request-line ( string -- triple )
|
||||||
#! Triple is { method url version }
|
! Triple is { method url version }
|
||||||
full-request-parser simple-request-parser 2array choice ;
|
full-request-parser simple-request-parser 2array choice ;
|
||||||
|
|
||||||
: text-parser ( -- parser )
|
: text-parser ( -- parser )
|
||||||
|
@ -80,7 +80,7 @@ PEG: parse-request-line ( string -- triple )
|
||||||
text-parser repeat0 case-sensitive ;
|
text-parser repeat0 case-sensitive ;
|
||||||
|
|
||||||
PEG: parse-response-line ( string -- triple )
|
PEG: parse-response-line ( string -- triple )
|
||||||
#! Triple is { version code message }
|
! Triple is { version code message }
|
||||||
[
|
[
|
||||||
space-parser ,
|
space-parser ,
|
||||||
http-version-parser ,
|
http-version-parser ,
|
||||||
|
@ -120,8 +120,8 @@ PEG: parse-response-line ( string -- triple )
|
||||||
2choice ;
|
2choice ;
|
||||||
|
|
||||||
PEG: parse-header-line ( string -- pair )
|
PEG: parse-header-line ( string -- pair )
|
||||||
#! Pair is either { name value } or { f value }. If f, its a
|
! Pair is either { name value } or { f value }. If f, its a
|
||||||
#! continuation of the previous header line.
|
! continuation of the previous header line.
|
||||||
[
|
[
|
||||||
field-name-parser ,
|
field-name-parser ,
|
||||||
space-parser ,
|
space-parser ,
|
||||||
|
|
|
@ -7,7 +7,7 @@ math.parser fry urls urls.encoding calendar make ;
|
||||||
IN: http.server.cgi
|
IN: http.server.cgi
|
||||||
|
|
||||||
: cgi-variables ( script-path -- assoc )
|
: cgi-variables ( script-path -- assoc )
|
||||||
#! This needs some work.
|
! This needs some work.
|
||||||
[
|
[
|
||||||
"CGI/1.0" "GATEWAY_INTERFACE" ,,
|
"CGI/1.0" "GATEWAY_INTERFACE" ,,
|
||||||
"HTTP/" request get version>> append "SERVER_PROTOCOL" ,,
|
"HTTP/" request get version>> append "SERVER_PROTOCOL" ,,
|
||||||
|
|
|
@ -57,8 +57,8 @@ GENERIC: write-full-response ( request response -- )
|
||||||
] change-domain ;
|
] change-domain ;
|
||||||
|
|
||||||
: write-response-header ( response -- response )
|
: write-response-header ( response -- response )
|
||||||
#! We send one set-cookie header per cookie, because that's
|
! We send one set-cookie header per cookie, because that's
|
||||||
#! what Firefox expects.
|
! what Firefox expects.
|
||||||
dup header>> >alist >vector
|
dup header>> >alist >vector
|
||||||
over unparse-content-type "content-type" pick set-at
|
over unparse-content-type "content-type" pick set-at
|
||||||
over cookies>> [
|
over cookies>> [
|
||||||
|
|
|
@ -100,7 +100,7 @@ PRIVATE>
|
||||||
: &rename ( key n -- ) key@ mirror get rename-at &push reinspect ;
|
: &rename ( key n -- ) key@ mirror get rename-at &push reinspect ;
|
||||||
|
|
||||||
: &help ( -- )
|
: &help ( -- )
|
||||||
#! A tribute to Slate:
|
! A tribute to Slate:
|
||||||
"You are in a twisty little maze of objects, all alike." print
|
"You are in a twisty little maze of objects, all alike." print
|
||||||
nl
|
nl
|
||||||
"'n' is a slot number in the following:" print
|
"'n' is a slot number in the following:" print
|
||||||
|
|
|
@ -197,7 +197,7 @@ CONSTANT: ALL-EXECUTE 0o0000111
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: set-file-times ( path timestamps -- )
|
: set-file-times ( path timestamps -- )
|
||||||
#! set access, write
|
! set access, write
|
||||||
[ normalize-path ] dip
|
[ normalize-path ] dip
|
||||||
timestamps>byte-array [ utimes ] unix-system-call drop ;
|
timestamps>byte-array [ utimes ] unix-system-call drop ;
|
||||||
|
|
||||||
|
|
|
@ -224,7 +224,7 @@ M: windows file-systems ( -- array )
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
|
: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
|
||||||
#! timestamp order: creation access write
|
! timestamp order: creation access write
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
normalize-path open-existing &dispose handle>>
|
normalize-path open-existing &dispose handle>>
|
||||||
|
|
|
@ -253,7 +253,7 @@ M: windows init-stdio
|
||||||
f CreateFileW dup win32-error=0/f <win32-file> ;
|
f CreateFileW dup win32-error=0/f <win32-file> ;
|
||||||
|
|
||||||
: maybe-create-file ( path -- win32-file ? )
|
: maybe-create-file ( path -- win32-file ? )
|
||||||
#! return true if file was just created
|
! return true if file was just created
|
||||||
flags{ GENERIC_READ GENERIC_WRITE }
|
flags{ GENERIC_READ GENERIC_WRITE }
|
||||||
share-mode
|
share-mode
|
||||||
f
|
f
|
||||||
|
|
|
@ -148,8 +148,8 @@ M: windows (kill-process) ( process -- )
|
||||||
handle>> hProcess>> 255 TerminateProcess win32-error=0/f ;
|
handle>> hProcess>> 255 TerminateProcess win32-error=0/f ;
|
||||||
|
|
||||||
: dispose-process ( process-information -- )
|
: dispose-process ( process-information -- )
|
||||||
#! From MSDN: "Handles in PROCESS_INFORMATION must be closed
|
! From MSDN: "Handles in PROCESS_INFORMATION must be closed
|
||||||
#! with CloseHandle when they are no longer needed."
|
! with CloseHandle when they are no longer needed."
|
||||||
[ hProcess>> [ CloseHandle drop ] when* ]
|
[ hProcess>> [ CloseHandle drop ] when* ]
|
||||||
[ hThread>> [ CloseHandle drop ] when* ] bi ;
|
[ hThread>> [ CloseHandle drop ] when* ] bi ;
|
||||||
|
|
||||||
|
|
|
@ -19,7 +19,7 @@ DEFER: add-child-monitor
|
||||||
monitor tget path>> prepend-path ;
|
monitor tget path>> prepend-path ;
|
||||||
|
|
||||||
: add-child-monitors ( path -- )
|
: add-child-monitors ( path -- )
|
||||||
#! We yield since this directory scan might take a while.
|
! We yield since this directory scan might take a while.
|
||||||
dup [
|
dup [
|
||||||
[ append-path ] with map
|
[ append-path ] with map
|
||||||
[ add-child-monitor ] each yield
|
[ add-child-monitor ] each yield
|
||||||
|
|
|
@ -32,10 +32,10 @@ M: secure (accept)
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
: check-shutdown-response ( handle r -- event )
|
: check-shutdown-response ( handle r -- event )
|
||||||
#! We don't do two-step shutdown here because I couldn't
|
! We don't do two-step shutdown here because I couldn't
|
||||||
#! figure out how to do it with non-blocking BIOs. Also, it
|
! figure out how to do it with non-blocking BIOs. Also, it
|
||||||
#! seems that SSL_shutdown always returns 0 -- this sounds
|
! seems that SSL_shutdown always returns 0 -- this sounds
|
||||||
#! like a bug
|
! like a bug
|
||||||
over handle>> over SSL_get_error
|
over handle>> over SSL_get_error
|
||||||
{
|
{
|
||||||
{ SSL_ERROR_NONE [ 2drop f ] }
|
{ SSL_ERROR_NONE [ 2drop f ] }
|
||||||
|
|
|
@ -27,9 +27,9 @@ M: duplex-stream set-timeout
|
||||||
>duplex-stream< [ set-timeout ] bi-curry@ bi ;
|
>duplex-stream< [ set-timeout ] bi-curry@ bi ;
|
||||||
|
|
||||||
M: duplex-stream dispose
|
M: duplex-stream dispose
|
||||||
#! The output stream is closed first, in case both streams
|
! The output stream is closed first, in case both streams
|
||||||
#! are attached to the same file descriptor, the output
|
! are attached to the same file descriptor, the output
|
||||||
#! buffer needs to be flushed before we close the fd.
|
! buffer needs to be flushed before we close the fd.
|
||||||
[ >duplex-stream< [ &dispose drop ] bi@ ] with-destructors ;
|
[ >duplex-stream< [ &dispose drop ] bi@ ] with-destructors ;
|
||||||
|
|
||||||
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
|
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
|
||||||
|
|
|
@ -28,7 +28,7 @@ GENERIC# stream-json-print 1 ( obj stream -- )
|
||||||
output-stream get stream-json-print ;
|
output-stream get stream-json-print ;
|
||||||
|
|
||||||
: >json ( obj -- string )
|
: >json ( obj -- string )
|
||||||
#! Returns a string representing the factor object in JSON format
|
! Returns a string representing the factor object in JSON format
|
||||||
[ json-print ] with-string-writer ;
|
[ json-print ] with-string-writer ;
|
||||||
|
|
||||||
M: f stream-json-print
|
M: f stream-json-print
|
||||||
|
|
|
@ -5,8 +5,8 @@ prettyprint.custom prettyprint.sections sequences words ;
|
||||||
IN: locals.prettyprint
|
IN: locals.prettyprint
|
||||||
|
|
||||||
: pprint-var ( var -- )
|
: pprint-var ( var -- )
|
||||||
#! Prettyprint a read/write local as its writer, just like
|
! Prettyprint a read/write local as its writer, just like
|
||||||
#! in the input syntax: [| x! | ... x 3 + x! ]
|
! in the input syntax: [| x! | ... x 3 + x! ]
|
||||||
dup local-reader? [
|
dup local-reader? [
|
||||||
"local-writer" word-prop
|
"local-writer" word-prop
|
||||||
] when pprint-word ;
|
] when pprint-word ;
|
||||||
|
|
|
@ -44,8 +44,8 @@ M: quotation uses-vars* [ uses-vars* ] each ;
|
||||||
[ uses-vars ] [ defs-vars ] bi diff ;
|
[ uses-vars ] [ defs-vars ] bi diff ;
|
||||||
|
|
||||||
M: callable rewrite-closures*
|
M: callable rewrite-closures*
|
||||||
#! Turn free variables into bound variables, curry them
|
! Turn free variables into bound variables, curry them
|
||||||
#! onto the body
|
! onto the body
|
||||||
dup free-vars [ <quote> ] map
|
dup free-vars [ <quote> ] map
|
||||||
[ % ]
|
[ % ]
|
||||||
[ var-defs prepend (rewrite-closures) point-free , ]
|
[ var-defs prepend (rewrite-closures) point-free , ]
|
||||||
|
|
|
@ -29,7 +29,7 @@ C: <multi-def> multi-def
|
||||||
PREDICATE: local < word "local?" word-prop ;
|
PREDICATE: local < word "local?" word-prop ;
|
||||||
|
|
||||||
: <local> ( name -- word )
|
: <local> ( name -- word )
|
||||||
#! Create a local variable identifier
|
! Create a local variable identifier
|
||||||
f <word>
|
f <word>
|
||||||
dup t "local?" set-word-prop ;
|
dup t "local?" set-word-prop ;
|
||||||
|
|
||||||
|
|
|
@ -137,7 +137,7 @@ PRIVATE>
|
||||||
(define-logging) ;
|
(define-logging) ;
|
||||||
|
|
||||||
SYNTAX: LOG:
|
SYNTAX: LOG:
|
||||||
#! Syntax: name level
|
! Syntax: name level
|
||||||
scan-new-word dup scan-word
|
scan-new-word dup scan-word
|
||||||
'[ 1array stack>message _ _ log-message ]
|
'[ 1array stack>message _ _ log-message ]
|
||||||
( message -- ) define-declared ;
|
( message -- ) define-declared ;
|
||||||
|
|
|
@ -52,7 +52,7 @@ SYMBOL: log-files
|
||||||
] unless-empty ;
|
] unless-empty ;
|
||||||
|
|
||||||
: (log-message) ( msg -- )
|
: (log-message) ( msg -- )
|
||||||
#! msg: { msg word-name level service }
|
! msg: { msg word-name level service }
|
||||||
first4 log-stream [ write-message flush ] with-output-stream* ;
|
first4 log-stream [ write-message flush ] with-output-stream* ;
|
||||||
|
|
||||||
: try-dispose ( obj -- )
|
: try-dispose ( obj -- )
|
||||||
|
|
|
@ -11,7 +11,7 @@ M: real sqrt
|
||||||
[ neg fsqrt [ 0.0 ] dip rect> ] [ fsqrt ] if ; inline
|
[ neg fsqrt [ 0.0 ] dip rect> ] [ fsqrt ] if ; inline
|
||||||
|
|
||||||
: factor-2s ( n -- r s )
|
: factor-2s ( n -- r s )
|
||||||
#! factor an integer into 2^r * s
|
! factor an integer into 2^r * s
|
||||||
dup 0 = [ 1 ] [
|
dup 0 = [ 1 ] [
|
||||||
[ 0 ] dip [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
|
[ 0 ] dip [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
|
@ -221,7 +221,7 @@ MEMO: array-capacity-interval ( -- interval )
|
||||||
] dip [ 2drop [-inf,inf] ] if ; inline
|
] dip [ 2drop [-inf,inf] ] if ; inline
|
||||||
|
|
||||||
: interval-shift ( i1 i2 -- i3 )
|
: interval-shift ( i1 i2 -- i3 )
|
||||||
#! Inaccurate; could be tighter
|
! Inaccurate; could be tighter
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
[ interval-closure ] bi@
|
[ interval-closure ] bi@
|
||||||
|
@ -274,8 +274,8 @@ MEMO: array-capacity-interval ( -- interval )
|
||||||
[ [ [ / ] interval-op nan-not-ok ] interval-division-op ] do-empty-interval ;
|
[ [ [ / ] interval-op nan-not-ok ] interval-division-op ] do-empty-interval ;
|
||||||
|
|
||||||
: interval/-safe ( i1 i2 -- i3 )
|
: interval/-safe ( i1 i2 -- i3 )
|
||||||
#! Just a hack to make the compiler work if bootstrap.math
|
! Just a hack to make the compiler work if bootstrap.math
|
||||||
#! is not loaded.
|
! is not loaded.
|
||||||
\ integer \ / ?lookup-method [ interval/ ] [ 2drop f ] if ;
|
\ integer \ / ?lookup-method [ interval/ ] [ 2drop f ] if ;
|
||||||
|
|
||||||
: interval/i ( i1 i2 -- i3 )
|
: interval/i ( i1 i2 -- i3 )
|
||||||
|
@ -387,7 +387,7 @@ SYMBOL: incomparable
|
||||||
from>> first 0 >= ;
|
from>> first 0 >= ;
|
||||||
|
|
||||||
: interval-bitand ( i1 i2 -- i3 )
|
: interval-bitand ( i1 i2 -- i3 )
|
||||||
#! Inaccurate.
|
! Inaccurate.
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
{
|
{
|
||||||
|
@ -403,7 +403,7 @@ SYMBOL: incomparable
|
||||||
] do-empty-interval ;
|
] do-empty-interval ;
|
||||||
|
|
||||||
: interval-bitor ( i1 i2 -- i3 )
|
: interval-bitor ( i1 i2 -- i3 )
|
||||||
#! Inaccurate.
|
! Inaccurate.
|
||||||
[
|
[
|
||||||
2dup [ interval-nonnegative? ] both?
|
2dup [ interval-nonnegative? ] both?
|
||||||
[
|
[
|
||||||
|
@ -413,7 +413,7 @@ SYMBOL: incomparable
|
||||||
] do-empty-interval ;
|
] do-empty-interval ;
|
||||||
|
|
||||||
: interval-bitxor ( i1 i2 -- i3 )
|
: interval-bitxor ( i1 i2 -- i3 )
|
||||||
#! Inaccurate.
|
! Inaccurate.
|
||||||
interval-bitor ;
|
interval-bitor ;
|
||||||
|
|
||||||
: interval-log2 ( i1 -- i2 )
|
: interval-log2 ( i1 -- i2 )
|
||||||
|
|
|
@ -24,7 +24,7 @@ SYMBOL: matrix
|
||||||
over [ find-from drop ] dip swap [ nip ] [ length ] if* ; inline
|
over [ find-from drop ] dip swap [ nip ] [ length ] if* ; inline
|
||||||
|
|
||||||
: first-col ( row# -- n )
|
: first-col ( row# -- n )
|
||||||
#! First non-zero column
|
! First non-zero column
|
||||||
0 swap nth-row [ zero? not ] skip ;
|
0 swap nth-row [ zero? not ] skip ;
|
||||||
|
|
||||||
: clear-scale ( col# pivot-row i-row -- n )
|
: clear-scale ( col# pivot-row i-row -- n )
|
||||||
|
|
|
@ -61,7 +61,7 @@ PRIVATE>
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
:: ((kth-object)) ( seq k nth-quot exchange-quot quot: ( x y -- ? ) -- elt )
|
:: ((kth-object)) ( seq k nth-quot exchange-quot quot: ( x y -- ? ) -- elt )
|
||||||
#! Wirth's method, Algorithm's + Data structues = Programs p. 84
|
! Wirth's method, Algorithm's + Data structues = Programs p. 84
|
||||||
k seq bounds-check 2drop
|
k seq bounds-check 2drop
|
||||||
0 :> i!
|
0 :> i!
|
||||||
0 :> j!
|
0 :> j!
|
||||||
|
@ -90,7 +90,7 @@ PRIVATE>
|
||||||
k seq nth-unsafe ; inline
|
k seq nth-unsafe ; inline
|
||||||
|
|
||||||
: (kth-object) ( seq k nth-quot exchange-quot quot: ( x y -- ? ) -- elt )
|
: (kth-object) ( seq k nth-quot exchange-quot quot: ( x y -- ? ) -- elt )
|
||||||
#! The algorithm modifiers seq, so we clone it
|
! The algorithm modifiers seq, so we clone it
|
||||||
[ >array ] 4dip ((kth-object)) ; inline
|
[ >array ] 4dip ((kth-object)) ; inline
|
||||||
|
|
||||||
: kth-object-unsafe ( seq k quot: ( x y -- ? ) -- elt )
|
: kth-object-unsafe ( seq k quot: ( x y -- ? ) -- elt )
|
||||||
|
|
|
@ -139,13 +139,13 @@ TUPLE: simd-test-failure
|
||||||
--
|
--
|
||||||
failures
|
failures
|
||||||
)
|
)
|
||||||
#! Use test-quot to generate a bunch of test cases from the
|
! Use test-quot to generate a bunch of test cases from the
|
||||||
#! given inputs. Run each test case optimized and
|
! given inputs. Run each test case optimized and
|
||||||
#! unoptimized. Compare results with eq-quot.
|
! unoptimized. Compare results with eq-quot.
|
||||||
#!
|
!
|
||||||
#! seq: sequence of inputs
|
! seq: sequence of inputs
|
||||||
#! test-quot: ( input -- input-quot: ( -- ..v ) code-quot: ( ..v -- result ) )
|
! test-quot: ( input -- input-quot: ( -- ..v ) code-quot: ( ..v -- result ) )
|
||||||
#! eq-quot: ( result1 result2 -- ? )
|
! eq-quot: ( result1 result2 -- ? )
|
||||||
seq [| input |
|
seq [| input |
|
||||||
input test-quot call :> ( input-quot code-quot )
|
input test-quot call :> ( input-quot code-quot )
|
||||||
input-quot [ class-of ] { } map-as :> input-classes
|
input-quot [ class-of ] { } map-as :> input-classes
|
||||||
|
|
|
@ -104,9 +104,9 @@ MACRO: all-enabled-client-state ( seq quot -- quot )
|
||||||
line-vertices GL_LINES 0 2 glDrawArrays ;
|
line-vertices GL_LINES 0 2 glDrawArrays ;
|
||||||
|
|
||||||
:: (rect-vertices) ( loc dim -- vertices )
|
:: (rect-vertices) ( loc dim -- vertices )
|
||||||
#! We use GL_LINE_STRIP with a duplicated first vertex
|
! We use GL_LINE_STRIP with a duplicated first vertex
|
||||||
#! instead of GL_LINE_LOOP to work around a bug in Apple's
|
! instead of GL_LINE_LOOP to work around a bug in Apple's
|
||||||
#! X3100 driver.
|
! X3100 driver.
|
||||||
loc first2 [ 0.3 + ] bi@ :> ( x y )
|
loc first2 [ 0.3 + ] bi@ :> ( x y )
|
||||||
dim first2 [ 0.6 - ] bi@ :> ( w h )
|
dim first2 [ 0.6 - ] bi@ :> ( w h )
|
||||||
[
|
[
|
||||||
|
@ -226,7 +226,7 @@ MACRO: set-draw-buffers ( buffers -- quot )
|
||||||
fix-coordinates glViewport ;
|
fix-coordinates glViewport ;
|
||||||
|
|
||||||
: init-matrices ( -- )
|
: init-matrices ( -- )
|
||||||
#! Leaves with matrix mode GL_MODELVIEW
|
! Leaves with matrix mode GL_MODELVIEW
|
||||||
GL_PROJECTION glMatrixMode
|
GL_PROJECTION glMatrixMode
|
||||||
glLoadIdentity
|
glLoadIdentity
|
||||||
GL_MODELVIEW glMatrixMode
|
GL_MODELVIEW glMatrixMode
|
||||||
|
|
|
@ -12,8 +12,8 @@ IN: opengl.textures
|
||||||
SYMBOL: non-power-of-2-textures?
|
SYMBOL: non-power-of-2-textures?
|
||||||
|
|
||||||
: check-extensions ( -- )
|
: check-extensions ( -- )
|
||||||
#! ATI frglx driver doesn't implement GL_ARB_texture_non_power_of_two properly.
|
! ATI frglx driver doesn't implement GL_ARB_texture_non_power_of_two properly.
|
||||||
#! See thread 'Linux font display problem' April 2009 on Factor-talk
|
! See thread 'Linux font display problem' April 2009 on Factor-talk
|
||||||
gl-vendor "ATI Technologies Inc." = not os macosx? or [
|
gl-vendor "ATI Technologies Inc." = not os macosx? or [
|
||||||
"2.0" { "GL_ARB_texture_non_power_of_two" }
|
"2.0" { "GL_ARB_texture_non_power_of_two" }
|
||||||
has-gl-version-or-extensions?
|
has-gl-version-or-extensions?
|
||||||
|
@ -409,8 +409,8 @@ CONSTANT: max-texture-size { 512 512 }
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: make-texture ( image -- id )
|
: make-texture ( image -- id )
|
||||||
#! We use glTexSubImage2D to work around the power of 2 texture size
|
! We use glTexSubImage2D to work around the power of 2 texture size
|
||||||
#! limitation
|
! limitation
|
||||||
gen-texture [
|
gen-texture [
|
||||||
GL_TEXTURE_BIT [
|
GL_TEXTURE_BIT [
|
||||||
GL_TEXTURE_2D swap glBindTexture
|
GL_TEXTURE_2D swap glBindTexture
|
||||||
|
|
|
@ -266,20 +266,20 @@ IN: peg.ebnf.tests
|
||||||
] must-fail
|
] must-fail
|
||||||
|
|
||||||
{ V{ V{ 49 } "+" V{ 49 } } } [
|
{ V{ V{ 49 } "+" V{ 49 } } } [
|
||||||
#! Test direct left recursion.
|
! Test direct left recursion.
|
||||||
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
|
! Using packrat, so first part of expr fails, causing 2nd choice to be used
|
||||||
"1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF]
|
"1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF]
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
{ V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [
|
{ V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [
|
||||||
#! Test direct left recursion.
|
! Test direct left recursion.
|
||||||
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
|
! Using packrat, so first part of expr fails, causing 2nd choice to be used
|
||||||
"1+1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF]
|
"1+1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF]
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
{ V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [
|
{ V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [
|
||||||
#! Test indirect left recursion.
|
! Test indirect left recursion.
|
||||||
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
|
! Using packrat, so first part of expr fails, causing 2nd choice to be used
|
||||||
"1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF]
|
"1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF]
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -511,8 +511,8 @@ foo=<foreign any-char> 'd'
|
||||||
] must-fail
|
] must-fail
|
||||||
|
|
||||||
{ t } [
|
{ t } [
|
||||||
#! Rule lookup occurs in a namespace. This causes an incorrect duplicate rule
|
! Rule lookup occurs in a namespace. This causes an incorrect duplicate rule
|
||||||
#! if a var in a namespace is set. This unit test is to remind me to fix this.
|
! if a var in a namespace is set. This unit test is to remind me to fix this.
|
||||||
[ "fail" "foo" set "foo='a'" ebnf-parser parse transform drop t ] with-scope
|
[ "fail" "foo" set "foo='a'" ebnf-parser parse transform drop t ] with-scope
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -10,7 +10,7 @@ FROM: peg.search => replace ;
|
||||||
IN: peg.ebnf
|
IN: peg.ebnf
|
||||||
|
|
||||||
: rule ( name word -- parser )
|
: rule ( name word -- parser )
|
||||||
#! Given an EBNF word produced from EBNF: return the EBNF rule
|
! Given an EBNF word produced from EBNF: return the EBNF rule
|
||||||
"ebnf-parser" word-prop at ;
|
"ebnf-parser" word-prop at ;
|
||||||
|
|
||||||
ERROR: no-rule rule parser ;
|
ERROR: no-rule rule parser ;
|
||||||
|
@ -85,17 +85,17 @@ C: <ebnf-semantic> ebnf-semantic
|
||||||
C: <ebnf> ebnf
|
C: <ebnf> ebnf
|
||||||
|
|
||||||
: filter-hidden ( seq -- seq )
|
: filter-hidden ( seq -- seq )
|
||||||
#! Remove elements that produce no AST from sequence
|
! Remove elements that produce no AST from sequence
|
||||||
[ ebnf-ensure-not? ] reject [ ebnf-ensure? not ] filter ;
|
[ ebnf-ensure-not? ] reject [ ebnf-ensure? not ] filter ;
|
||||||
|
|
||||||
: syntax ( string -- parser )
|
: syntax ( string -- parser )
|
||||||
#! Parses the string, ignoring white space, and
|
! Parses the string, ignoring white space, and
|
||||||
#! does not put the result in the AST.
|
! does not put the result in the AST.
|
||||||
token sp hide ;
|
token sp hide ;
|
||||||
|
|
||||||
: syntax-pack ( begin parser end -- parser )
|
: syntax-pack ( begin parser end -- parser )
|
||||||
#! Parse parser-parser surrounded by syntax elements
|
! Parse parser-parser surrounded by syntax elements
|
||||||
#! begin and end.
|
! begin and end.
|
||||||
[ syntax ] 2dip syntax pack ;
|
[ syntax ] 2dip syntax pack ;
|
||||||
|
|
||||||
: insert-escapes ( string -- string )
|
: insert-escapes ( string -- string )
|
||||||
|
@ -106,10 +106,10 @@ C: <ebnf> ebnf
|
||||||
] choice* replace ;
|
] choice* replace ;
|
||||||
|
|
||||||
: identifier-parser ( -- parser )
|
: identifier-parser ( -- parser )
|
||||||
#! Return a parser that parses an identifer delimited by
|
! Return a parser that parses an identifer delimited by
|
||||||
#! a quotation character. The quotation can be single
|
! a quotation character. The quotation can be single
|
||||||
#! or double quotes. The AST produced is the identifier
|
! or double quotes. The AST produced is the identifier
|
||||||
#! between the quotes.
|
! between the quotes.
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
[ CHAR: \ = ] satisfy
|
[ CHAR: \ = ] satisfy
|
||||||
|
@ -120,9 +120,9 @@ C: <ebnf> ebnf
|
||||||
] choice* [ "" flatten-as unescape-string ] action ;
|
] choice* [ "" flatten-as unescape-string ] action ;
|
||||||
|
|
||||||
: non-terminal-parser ( -- parser )
|
: non-terminal-parser ( -- parser )
|
||||||
#! A non-terminal is the name of another rule. It can
|
! A non-terminal is the name of another rule. It can
|
||||||
#! be any non-blank character except for characters used
|
! be any non-blank character except for characters used
|
||||||
#! in the EBNF syntax itself.
|
! in the EBNF syntax itself.
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
[ blank? ]
|
[ blank? ]
|
||||||
|
@ -131,12 +131,12 @@ C: <ebnf> ebnf
|
||||||
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
|
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
|
||||||
|
|
||||||
: terminal-parser ( -- parser )
|
: terminal-parser ( -- parser )
|
||||||
#! A terminal is an identifier enclosed in quotations
|
! A terminal is an identifier enclosed in quotations
|
||||||
#! and it represents the literal value of the identifier.
|
! and it represents the literal value of the identifier.
|
||||||
identifier-parser [ <ebnf-terminal> ] action ;
|
identifier-parser [ <ebnf-terminal> ] action ;
|
||||||
|
|
||||||
: foreign-name-parser ( -- parser )
|
: foreign-name-parser ( -- parser )
|
||||||
#! Parse a valid foreign parser name
|
! Parse a valid foreign parser name
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
[ blank? ]
|
[ blank? ]
|
||||||
|
@ -145,7 +145,7 @@ C: <ebnf> ebnf
|
||||||
] satisfy repeat1 [ >string ] action ;
|
] satisfy repeat1 [ >string ] action ;
|
||||||
|
|
||||||
: foreign-parser ( -- parser )
|
: foreign-parser ( -- parser )
|
||||||
#! A foreign call is a call to a rule in another ebnf grammar
|
! A foreign call is a call to a rule in another ebnf grammar
|
||||||
[
|
[
|
||||||
"<foreign" syntax ,
|
"<foreign" syntax ,
|
||||||
foreign-name-parser sp ,
|
foreign-name-parser sp ,
|
||||||
|
@ -154,11 +154,11 @@ C: <ebnf> ebnf
|
||||||
] seq* [ first2 <ebnf-foreign> ] action ;
|
] seq* [ first2 <ebnf-foreign> ] action ;
|
||||||
|
|
||||||
: any-character-parser ( -- parser )
|
: any-character-parser ( -- parser )
|
||||||
#! A parser to match the symbol for any character match.
|
! A parser to match the symbol for any character match.
|
||||||
[ CHAR: . = ] satisfy [ drop <ebnf-any-character> ] action ;
|
[ CHAR: . = ] satisfy [ drop <ebnf-any-character> ] action ;
|
||||||
|
|
||||||
: range-parser-parser ( -- parser )
|
: range-parser-parser ( -- parser )
|
||||||
#! Match the syntax for declaring character ranges
|
! Match the syntax for declaring character ranges
|
||||||
[
|
[
|
||||||
[ "[" syntax , "[" token ensure-not , ] seq* hide ,
|
[ "[" syntax , "[" token ensure-not , ] seq* hide ,
|
||||||
[ CHAR: ] = not ] satisfy repeat1 ,
|
[ CHAR: ] = not ] satisfy repeat1 ,
|
||||||
|
@ -166,10 +166,10 @@ C: <ebnf> ebnf
|
||||||
] seq* [ first >string unescape-string <ebnf-range> ] action ;
|
] seq* [ first >string unescape-string <ebnf-range> ] action ;
|
||||||
|
|
||||||
: (element-parser) ( -- parser )
|
: (element-parser) ( -- parser )
|
||||||
#! An element of a rule. It can be a terminal or a
|
! An element of a rule. It can be a terminal or a
|
||||||
#! non-terminal but must not be followed by a "=".
|
! non-terminal but must not be followed by a "=".
|
||||||
#! The latter indicates that it is the beginning of a
|
! The latter indicates that it is the beginning of a
|
||||||
#! new rule.
|
! new rule.
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
|
@ -206,9 +206,9 @@ DEFER: action-parser
|
||||||
DEFER: choice-parser
|
DEFER: choice-parser
|
||||||
|
|
||||||
: grouped ( quot suffix -- parser )
|
: grouped ( quot suffix -- parser )
|
||||||
#! Parse a group of choices, with a suffix indicating
|
! Parse a group of choices, with a suffix indicating
|
||||||
#! the type of group (repeat0, repeat1, etc) and
|
! the type of group (repeat0, repeat1, etc) and
|
||||||
#! an quot that is the action that produces the AST.
|
! an quot that is the action that produces the AST.
|
||||||
2dup
|
2dup
|
||||||
[
|
[
|
||||||
"(" [ choice-parser sp ] delay ")" syntax-pack
|
"(" [ choice-parser sp ] delay ")" syntax-pack
|
||||||
|
@ -220,7 +220,7 @@ DEFER: choice-parser
|
||||||
] choice* ;
|
] choice* ;
|
||||||
|
|
||||||
: group-parser ( -- parser )
|
: group-parser ( -- parser )
|
||||||
#! A grouping with no suffix. Used for precedence.
|
! A grouping with no suffix. Used for precedence.
|
||||||
[ ] [
|
[ ] [
|
||||||
"~" token sp ensure-not ,
|
"~" token sp ensure-not ,
|
||||||
"*" token sp ensure-not ,
|
"*" token sp ensure-not ,
|
||||||
|
@ -248,26 +248,26 @@ DEFER: choice-parser
|
||||||
] seq* repeat0 [ "" concat-as ] action ;
|
] seq* repeat0 [ "" concat-as ] action ;
|
||||||
|
|
||||||
: ensure-not-parser ( -- parser )
|
: ensure-not-parser ( -- parser )
|
||||||
#! Parses the '!' syntax to ensure that
|
! Parses the '!' syntax to ensure that
|
||||||
#! something that matches the following elements do
|
! something that matches the following elements do
|
||||||
#! not exist in the parse stream.
|
! not exist in the parse stream.
|
||||||
[
|
[
|
||||||
"!" syntax ,
|
"!" syntax ,
|
||||||
group-parser sp ,
|
group-parser sp ,
|
||||||
] seq* [ first <ebnf-ensure-not> ] action ;
|
] seq* [ first <ebnf-ensure-not> ] action ;
|
||||||
|
|
||||||
: ensure-parser ( -- parser )
|
: ensure-parser ( -- parser )
|
||||||
#! Parses the '&' syntax to ensure that
|
! Parses the '&' syntax to ensure that
|
||||||
#! something that matches the following elements does
|
! something that matches the following elements does
|
||||||
#! exist in the parse stream.
|
! exist in the parse stream.
|
||||||
[
|
[
|
||||||
"&" syntax ,
|
"&" syntax ,
|
||||||
group-parser sp ,
|
group-parser sp ,
|
||||||
] seq* [ first <ebnf-ensure> ] action ;
|
] seq* [ first <ebnf-ensure> ] action ;
|
||||||
|
|
||||||
: (sequence-parser) ( -- parser )
|
: (sequence-parser) ( -- parser )
|
||||||
#! A sequence of terminals and non-terminals, including
|
! A sequence of terminals and non-terminals, including
|
||||||
#! groupings of those.
|
! groupings of those.
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
ensure-not-parser sp ,
|
ensure-not-parser sp ,
|
||||||
|
@ -290,8 +290,8 @@ DEFER: choice-parser
|
||||||
"?[" factor-code-parser "]?" syntax-pack ;
|
"?[" factor-code-parser "]?" syntax-pack ;
|
||||||
|
|
||||||
: sequence-parser ( -- parser )
|
: sequence-parser ( -- parser )
|
||||||
#! A sequence of terminals and non-terminals, including
|
! A sequence of terminals and non-terminals, including
|
||||||
#! groupings of those.
|
! groupings of those.
|
||||||
[
|
[
|
||||||
[ (sequence-parser) , action-parser , ] seq*
|
[ (sequence-parser) , action-parser , ] seq*
|
||||||
[ first2 <ebnf-action> ] action ,
|
[ first2 <ebnf-action> ] action ,
|
||||||
|
@ -375,9 +375,9 @@ M: ebnf-rule (transform) ( ast -- parser )
|
||||||
] keep ;
|
] keep ;
|
||||||
|
|
||||||
M: ebnf-sequence (transform) ( ast -- parser )
|
M: ebnf-sequence (transform) ( ast -- parser )
|
||||||
#! If ignore-ws is set then each element of the sequence
|
! If ignore-ws is set then each element of the sequence
|
||||||
#! ignores leading whitespace. This is not inherited by
|
! ignores leading whitespace. This is not inherited by
|
||||||
#! subelements of the sequence.
|
! subelements of the sequence.
|
||||||
elements>> [
|
elements>> [
|
||||||
f ignore-ws [ (transform) ] with-variable
|
f ignore-ws [ (transform) ] with-variable
|
||||||
ignore-ws get [ sp ] when
|
ignore-ws get [ sp ] when
|
||||||
|
@ -393,7 +393,7 @@ M: ebnf-range (transform) ( ast -- parser )
|
||||||
pattern>> range-pattern ;
|
pattern>> range-pattern ;
|
||||||
|
|
||||||
: transform-group ( ast -- parser )
|
: transform-group ( ast -- parser )
|
||||||
#! convert a ast node with groups to a parser for that group
|
! convert a ast node with groups to a parser for that group
|
||||||
group>> (transform) ;
|
group>> (transform) ;
|
||||||
|
|
||||||
M: ebnf-ensure (transform) ( ast -- parser )
|
M: ebnf-ensure (transform) ( ast -- parser )
|
||||||
|
@ -420,8 +420,8 @@ M: ebnf-whitespace (transform) ( ast -- parser )
|
||||||
GENERIC: build-locals ( code ast -- code )
|
GENERIC: build-locals ( code ast -- code )
|
||||||
|
|
||||||
M: ebnf-sequence build-locals ( code ast -- code )
|
M: ebnf-sequence build-locals ( code ast -- code )
|
||||||
#! Note the need to filter out this ebnf items that
|
! Note the need to filter out this ebnf items that
|
||||||
#! leave nothing in the AST
|
! leave nothing in the AST
|
||||||
elements>> filter-hidden dup length 1 = [
|
elements>> filter-hidden dup length 1 = [
|
||||||
first build-locals
|
first build-locals
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -81,8 +81,8 @@ PRIVATE>
|
||||||
] seq* [ first >string ] action ;
|
] seq* [ first >string ] action ;
|
||||||
|
|
||||||
: (range-pattern) ( pattern -- string )
|
: (range-pattern) ( pattern -- string )
|
||||||
#! Given a range pattern, produce a string containing
|
! Given a range pattern, produce a string containing
|
||||||
#! all characters within that range.
|
! all characters within that range.
|
||||||
[
|
[
|
||||||
any-char ,
|
any-char ,
|
||||||
[ CHAR: - = ] satisfy hide ,
|
[ CHAR: - = ] satisfy hide ,
|
||||||
|
@ -93,14 +93,14 @@ PRIVATE>
|
||||||
replace ;
|
replace ;
|
||||||
|
|
||||||
: range-pattern ( pattern -- parser )
|
: range-pattern ( pattern -- parser )
|
||||||
#! 'pattern' is a set of characters describing the
|
! 'pattern' is a set of characters describing the
|
||||||
#! parser to be produced. Any single character in
|
! parser to be produced. Any single character in
|
||||||
#! the pattern matches that character. If the pattern
|
! the pattern matches that character. If the pattern
|
||||||
#! begins with a ^ then the set is negated (the element
|
! begins with a ^ then the set is negated (the element
|
||||||
#! matches any character not in the set). Any pair of
|
! matches any character not in the set). Any pair of
|
||||||
#! characters separated with a dash (-) represents the
|
! characters separated with a dash (-) represents the
|
||||||
#! range of characters from the first to the second,
|
! range of characters from the first to the second,
|
||||||
#! inclusive.
|
! inclusive.
|
||||||
dup first CHAR: ^ = [
|
dup first CHAR: ^ = [
|
||||||
rest (range-pattern) [ member? not ] curry satisfy
|
rest (range-pattern) [ member? not ] curry satisfy
|
||||||
] [
|
] [
|
||||||
|
|
|
@ -172,8 +172,8 @@ IN: peg.tests
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
: expr ( -- parser )
|
: expr ( -- parser )
|
||||||
#! Test direct left recursion. Currently left recursion should cause a
|
! Test direct left recursion. Currently left recursion should cause a
|
||||||
#! failure of that parser.
|
! failure of that parser.
|
||||||
[ expr ] delay "+" token "1" token 3seq "1" token 2choice ;
|
[ expr ] delay "+" token "1" token 3seq "1" token 2choice ;
|
||||||
|
|
||||||
{ V{ V{ "1" "+" "1" } "+" "1" } } [
|
{ V{ V{ "1" "+" "1" } "+" "1" } } [
|
||||||
|
@ -181,7 +181,7 @@ IN: peg.tests
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
{ t } [
|
{ t } [
|
||||||
#! Ensure a circular parser doesn't loop infinitely
|
! Ensure a circular parser doesn't loop infinitely
|
||||||
[ f , "a" token , ] seq*
|
[ f , "a" token , ] seq*
|
||||||
dup peg>> parsers>>
|
dup peg>> parsers>>
|
||||||
dupd 0 swap set-nth compile word?
|
dupd 0 swap set-nth compile word?
|
||||||
|
|
|
@ -49,12 +49,12 @@ SYMBOL: error-stack
|
||||||
SYMBOL: ignore
|
SYMBOL: ignore
|
||||||
|
|
||||||
: packrat ( id -- cache )
|
: packrat ( id -- cache )
|
||||||
#! The packrat cache is a mapping of parser-id->cache.
|
! The packrat cache is a mapping of parser-id->cache.
|
||||||
#! For each parser it maps to a cache holding a mapping
|
! For each parser it maps to a cache holding a mapping
|
||||||
#! of position->result. The packrat cache therefore keeps
|
! of position->result. The packrat cache therefore keeps
|
||||||
#! track of all parses that have occurred at each position
|
! track of all parses that have occurred at each position
|
||||||
#! of the input string and the results obtained from that
|
! of the input string and the results obtained from that
|
||||||
#! parser.
|
! parser.
|
||||||
\ packrat get [ drop H{ } clone ] cache ;
|
\ packrat get [ drop H{ } clone ] cache ;
|
||||||
|
|
||||||
SYMBOL: pos
|
SYMBOL: pos
|
||||||
|
@ -63,20 +63,20 @@ SYMBOL: fail
|
||||||
SYMBOL: lrstack
|
SYMBOL: lrstack
|
||||||
|
|
||||||
: heads ( -- cache )
|
: heads ( -- cache )
|
||||||
#! A mapping from position->peg-head. It maps a
|
! A mapping from position->peg-head. It maps a
|
||||||
#! position in the input string being parsed to
|
! position in the input string being parsed to
|
||||||
#! the head of the left recursion which is currently
|
! the head of the left recursion which is currently
|
||||||
#! being grown. It is 'f' at any position where
|
! being grown. It is 'f' at any position where
|
||||||
#! left recursion growth is not underway.
|
! left recursion growth is not underway.
|
||||||
\ heads get ;
|
\ heads get ;
|
||||||
|
|
||||||
: failed? ( obj -- ? )
|
: failed? ( obj -- ? )
|
||||||
fail = ;
|
fail = ;
|
||||||
|
|
||||||
: peg-cache ( -- cache )
|
: peg-cache ( -- cache )
|
||||||
#! Holds a hashtable mapping a peg tuple to
|
! Holds a hashtable mapping a peg tuple to
|
||||||
#! the parser tuple for that peg. The parser tuple
|
! the parser tuple for that peg. The parser tuple
|
||||||
#! holds a unique id and the compiled form of that peg.
|
! holds a unique id and the compiled form of that peg.
|
||||||
\ peg-cache get-global [
|
\ peg-cache get-global [
|
||||||
H{ } clone dup \ peg-cache set-global
|
H{ } clone dup \ peg-cache set-global
|
||||||
] unless* ;
|
] unless* ;
|
||||||
|
@ -97,17 +97,17 @@ TUPLE: left-recursion seed rule-id head next ;
|
||||||
TUPLE: peg-head rule-id involved-set eval-set ;
|
TUPLE: peg-head rule-id involved-set eval-set ;
|
||||||
|
|
||||||
: rule-id ( word -- id )
|
: rule-id ( word -- id )
|
||||||
#! A rule is the parser compiled down to a word. It has
|
! A rule is the parser compiled down to a word. It has
|
||||||
#! a "peg-id" property containing the id of the original parser.
|
! a "peg-id" property containing the id of the original parser.
|
||||||
"peg-id" word-prop ;
|
"peg-id" word-prop ;
|
||||||
|
|
||||||
: input-slice ( -- slice )
|
: input-slice ( -- slice )
|
||||||
#! Return a slice of the input from the current parse position
|
! Return a slice of the input from the current parse position
|
||||||
input get pos get tail-slice ;
|
input get pos get tail-slice ;
|
||||||
|
|
||||||
: input-from ( input -- n )
|
: input-from ( input -- n )
|
||||||
#! Return the index from the original string that the
|
! Return the index from the original string that the
|
||||||
#! input slice is based on.
|
! input slice is based on.
|
||||||
dup slice? [ from>> ] [ drop 0 ] if ;
|
dup slice? [ from>> ] [ drop 0 ] if ;
|
||||||
|
|
||||||
: process-rule-result ( p result -- result )
|
: process-rule-result ( p result -- result )
|
||||||
|
@ -118,17 +118,17 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
||||||
] if* ;
|
] if* ;
|
||||||
|
|
||||||
: eval-rule ( rule -- ast )
|
: eval-rule ( rule -- ast )
|
||||||
#! Evaluate a rule, return an ast resulting from it.
|
! Evaluate a rule, return an ast resulting from it.
|
||||||
#! Return fail if the rule failed. The rule has
|
! Return fail if the rule failed. The rule has
|
||||||
#! stack effect ( -- parse-result )
|
! stack effect ( -- parse-result )
|
||||||
pos get swap execute( -- parse-result ) process-rule-result ; inline
|
pos get swap execute( -- parse-result ) process-rule-result ; inline
|
||||||
|
|
||||||
: memo ( pos id -- memo-entry )
|
: memo ( pos id -- memo-entry )
|
||||||
#! Return the result from the memo cache.
|
! Return the result from the memo cache.
|
||||||
packrat at ;
|
packrat at ;
|
||||||
|
|
||||||
: set-memo ( memo-entry pos id -- )
|
: set-memo ( memo-entry pos id -- )
|
||||||
#! Store an entry in the cache
|
! Store an entry in the cache
|
||||||
packrat set-at ;
|
packrat set-at ;
|
||||||
|
|
||||||
: update-m ( ast m -- )
|
: update-m ( ast m -- )
|
||||||
|
@ -239,7 +239,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
|
||||||
] if* ; inline
|
] if* ; inline
|
||||||
|
|
||||||
: with-packrat ( input quot -- result )
|
: with-packrat ( input quot -- result )
|
||||||
#! Run the quotation with a packrat cache active.
|
! Run the quotation with a packrat cache active.
|
||||||
[
|
[
|
||||||
swap input ,,
|
swap input ,,
|
||||||
0 pos ,,
|
0 pos ,,
|
||||||
|
@ -265,18 +265,18 @@ GENERIC: (compile) ( peg -- quot )
|
||||||
gensym [ >>compiled ] keep ;
|
gensym [ >>compiled ] keep ;
|
||||||
|
|
||||||
: define-parser-word ( parser word -- )
|
: define-parser-word ( parser word -- )
|
||||||
#! Return the body of the word that is the compiled version
|
! Return the body of the word that is the compiled version
|
||||||
#! of the parser.
|
! of the parser.
|
||||||
2dup swap peg>> (compile) ( -- result ) define-declared
|
2dup swap peg>> (compile) ( -- result ) define-declared
|
||||||
swap id>> "peg-id" set-word-prop ;
|
swap id>> "peg-id" set-word-prop ;
|
||||||
|
|
||||||
: compile-parser ( parser -- word )
|
: compile-parser ( parser -- word )
|
||||||
#! Look to see if the given parser has been compiled.
|
! Look to see if the given parser has been compiled.
|
||||||
#! If not, compile it to a temporary word, cache it,
|
! If not, compile it to a temporary word, cache it,
|
||||||
#! and return it. Otherwise return the existing one.
|
! and return it. Otherwise return the existing one.
|
||||||
#! Circular parsers are supported by getting the word
|
! Circular parsers are supported by getting the word
|
||||||
#! name and storing it in the cache, before compiling,
|
! name and storing it in the cache, before compiling,
|
||||||
#! so it is picked up when re-entered.
|
! so it is picked up when re-entered.
|
||||||
dup compiled>> [
|
dup compiled>> [
|
||||||
nip
|
nip
|
||||||
] [
|
] [
|
||||||
|
@ -289,8 +289,8 @@ GENERIC: (compile) ( peg -- quot )
|
||||||
SYMBOL: delayed
|
SYMBOL: delayed
|
||||||
|
|
||||||
: fixup-delayed ( -- )
|
: fixup-delayed ( -- )
|
||||||
#! Work through all delayed parsers and recompile their
|
! Work through all delayed parsers and recompile their
|
||||||
#! words to have the correct bodies.
|
! words to have the correct bodies.
|
||||||
delayed get [
|
delayed get [
|
||||||
call( -- parser ) compile-parser-quot ( -- result ) define-declared
|
call( -- parser ) compile-parser-quot ( -- result ) define-declared
|
||||||
] assoc-each ;
|
] assoc-each ;
|
||||||
|
@ -314,13 +314,13 @@ SYMBOL: delayed
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: next-id ( -- n )
|
: next-id ( -- n )
|
||||||
#! Return the next unique id for a parser
|
! Return the next unique id for a parser
|
||||||
\ next-id counter ;
|
\ next-id counter ;
|
||||||
|
|
||||||
: wrap-peg ( peg -- parser )
|
: wrap-peg ( peg -- parser )
|
||||||
#! Wrap a parser tuple around the peg object.
|
! Wrap a parser tuple around the peg object.
|
||||||
#! Look for an existing parser tuple for that
|
! Look for an existing parser tuple for that
|
||||||
#! peg object.
|
! peg object.
|
||||||
peg-cache [
|
peg-cache [
|
||||||
f next-id parser boa
|
f next-id parser boa
|
||||||
] cache ;
|
] cache ;
|
||||||
|
@ -328,7 +328,7 @@ SYMBOL: delayed
|
||||||
TUPLE: token-parser symbol ;
|
TUPLE: token-parser symbol ;
|
||||||
|
|
||||||
: parse-token ( input string -- result )
|
: parse-token ( input string -- result )
|
||||||
#! Parse the string, returning a parse result
|
! Parse the string, returning a parse result
|
||||||
[ ?head-slice ] keep swap [
|
[ ?head-slice ] keep swap [
|
||||||
<parse-result> f f f add-error
|
<parse-result> f f f add-error
|
||||||
] [
|
] [
|
||||||
|
@ -503,18 +503,18 @@ M: sp-parser (compile)
|
||||||
TUPLE: delay-parser quot ;
|
TUPLE: delay-parser quot ;
|
||||||
|
|
||||||
M: delay-parser (compile)
|
M: delay-parser (compile)
|
||||||
#! For efficiency we memoize the quotation.
|
! For efficiency we memoize the quotation.
|
||||||
#! This way it is run only once and the
|
! This way it is run only once and the
|
||||||
#! parser constructed once at run time.
|
! parser constructed once at run time.
|
||||||
quot>> gensym [ delayed get set-at ] keep 1quotation ;
|
quot>> gensym [ delayed get set-at ] keep 1quotation ;
|
||||||
|
|
||||||
TUPLE: box-parser quot ;
|
TUPLE: box-parser quot ;
|
||||||
|
|
||||||
M: box-parser (compile)
|
M: box-parser (compile)
|
||||||
#! Calls the quotation at compile time
|
! Calls the quotation at compile time
|
||||||
#! to produce the parser to be compiled.
|
! to produce the parser to be compiled.
|
||||||
#! This differs from 'delay' which calls
|
! This differs from 'delay' which calls
|
||||||
#! it at run time.
|
! it at run time.
|
||||||
quot>> call( -- parser ) compile-parser-quot ;
|
quot>> call( -- parser ) compile-parser-quot ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
@ -589,17 +589,17 @@ PRIVATE>
|
||||||
delay-parser boa wrap-peg ;
|
delay-parser boa wrap-peg ;
|
||||||
|
|
||||||
: box ( quot -- parser )
|
: box ( quot -- parser )
|
||||||
#! because a box has its quotation run at compile time
|
! because a box has its quotation run at compile time
|
||||||
#! it must always have a new parser wrapper created,
|
! it must always have a new parser wrapper created,
|
||||||
#! not a cached one. This is because the same box,
|
! not a cached one. This is because the same box,
|
||||||
#! compiled twice can have a different compiled word
|
! compiled twice can have a different compiled word
|
||||||
#! due to running at compile time.
|
! due to running at compile time.
|
||||||
#! Why the [ ] action at the end? Box parsers don't get
|
! Why the [ ] action at the end? Box parsers don't get
|
||||||
#! memoized during parsing due to all box parsers being
|
! memoized during parsing due to all box parsers being
|
||||||
#! unique. This breaks left recursion detection during the
|
! unique. This breaks left recursion detection during the
|
||||||
#! parse. The action adds an indirection with a parser type
|
! parse. The action adds an indirection with a parser type
|
||||||
#! that gets memoized and fixes this. Need to rethink how
|
! that gets memoized and fixes this. Need to rethink how
|
||||||
#! to fix boxes so this isn't needed...
|
! to fix boxes so this isn't needed...
|
||||||
box-parser boa f next-id parser boa [ ] action ;
|
box-parser boa f next-id parser boa [ ] action ;
|
||||||
|
|
||||||
ERROR: parse-failed input word ;
|
ERROR: parse-failed input word ;
|
||||||
|
|
|
@ -262,9 +262,9 @@ TUPLE: flow < block ;
|
||||||
flow new-block ;
|
flow new-block ;
|
||||||
|
|
||||||
M: flow short-section? ( section -- ? )
|
M: flow short-section? ( section -- ? )
|
||||||
#! If we can make room for this entire block by inserting
|
! If we can make room for this entire block by inserting
|
||||||
#! a newline, do it; otherwise, don't bother, print it as
|
! a newline, do it; otherwise, don't bother, print it as
|
||||||
#! a short section
|
! a short section
|
||||||
{
|
{
|
||||||
[ section-fits? ]
|
[ section-fits? ]
|
||||||
[ [ end>> 1 - ] [ start>> ] bi - text-fits? not ]
|
[ [ end>> 1 - ] [ start>> ] bi - text-fits? not ]
|
||||||
|
|
|
@ -21,12 +21,12 @@ GENERIC: (serialize) ( obj -- )
|
||||||
SYMBOL: serialized
|
SYMBOL: serialized
|
||||||
|
|
||||||
: add-object ( obj -- )
|
: add-object ( obj -- )
|
||||||
#! Add an object to the sequence of already serialized
|
! Add an object to the sequence of already serialized
|
||||||
#! objects.
|
! objects.
|
||||||
serialized get [ assoc-size swap ] keep set-at ;
|
serialized get [ assoc-size swap ] keep set-at ;
|
||||||
|
|
||||||
: object-id ( obj -- id )
|
: object-id ( obj -- id )
|
||||||
#! Return the id of an already serialized object
|
! Return the id of an already serialized object
|
||||||
serialized get at ;
|
serialized get at ;
|
||||||
|
|
||||||
! Positive numbers are serialized as follows:
|
! Positive numbers are serialized as follows:
|
||||||
|
@ -231,8 +231,8 @@ SYMBOL: deserialized
|
||||||
[ set-array-nth ] curry each-index ;
|
[ set-array-nth ] curry each-index ;
|
||||||
|
|
||||||
: deserialize-tuple ( -- array )
|
: deserialize-tuple ( -- array )
|
||||||
#! Ugly because we have to intern the tuple before reading
|
! Ugly because we have to intern the tuple before reading
|
||||||
#! slots
|
! slots
|
||||||
(deserialize) new
|
(deserialize) new
|
||||||
[ intern-object ]
|
[ intern-object ]
|
||||||
[
|
[
|
||||||
|
|
|
@ -71,7 +71,7 @@ SYMBOL: data-mode
|
||||||
} cond nip [ process ] when ;
|
} cond nip [ process ] when ;
|
||||||
|
|
||||||
:: mock-smtp-server ( promise -- )
|
:: mock-smtp-server ( promise -- )
|
||||||
#! Store the port we are running on in the promise.
|
! Store the port we are running on in the promise.
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
"127.0.0.1" 0 <inet4> ascii <server> [
|
"127.0.0.1" 0 <inet4> ascii <server> [
|
||||||
|
|
|
@ -67,7 +67,7 @@ TUPLE: email
|
||||||
ERROR: bad-email-address email ;
|
ERROR: bad-email-address email ;
|
||||||
|
|
||||||
: validate-address ( string -- string' )
|
: validate-address ( string -- string' )
|
||||||
#! Make sure we send funky stuff to the server by accident.
|
! Make sure we send funky stuff to the server by accident.
|
||||||
dup "\r\n>" intersects?
|
dup "\r\n>" intersects?
|
||||||
[ bad-email-address ] when ;
|
[ bad-email-address ] when ;
|
||||||
|
|
||||||
|
|
|
@ -10,7 +10,7 @@ IN: sorting.slots
|
||||||
'[ _ execute( tuple -- value ) ] bi@ ;
|
'[ _ execute( tuple -- value ) ] bi@ ;
|
||||||
|
|
||||||
: compare-slots ( obj1 obj2 sort-specs -- <=> )
|
: compare-slots ( obj1 obj2 sort-specs -- <=> )
|
||||||
#! sort-spec: { accessors comparator }
|
! sort-spec: { accessors comparator }
|
||||||
[
|
[
|
||||||
dup array? [
|
dup array? [
|
||||||
unclip-last-slice
|
unclip-last-slice
|
||||||
|
|
|
@ -9,8 +9,8 @@ TR: soundex-tr
|
||||||
"00000000111122222222334556" ;
|
"00000000111122222222334556" ;
|
||||||
|
|
||||||
: remove-duplicates ( seq -- seq' )
|
: remove-duplicates ( seq -- seq' )
|
||||||
#! Remove _consecutive_ duplicates (unlike prune which removes
|
! Remove _consecutive_ duplicates (unlike prune which removes
|
||||||
#! all duplicates).
|
! all duplicates).
|
||||||
[ 2 <clumps> [ = ] assoc-reject values ] [ first ] bi prefix ;
|
[ 2 <clumps> [ = ] assoc-reject values ] [ first ] bi prefix ;
|
||||||
|
|
||||||
: first>upper ( seq -- seq' ) 1 head >upper ;
|
: first>upper ( seq -- seq' ) 1 head >upper ;
|
||||||
|
|
|
@ -14,5 +14,5 @@ M: callable infer ( quot -- effect )
|
||||||
(infer) ;
|
(infer) ;
|
||||||
|
|
||||||
: infer. ( quot -- )
|
: infer. ( quot -- )
|
||||||
#! Safe to call from inference transforms.
|
! Safe to call from inference transforms.
|
||||||
infer effect>string print ;
|
infer effect>string print ;
|
||||||
|
|
|
@ -3,8 +3,8 @@ calendar urls xml.writer ;
|
||||||
IN: syndication.tests
|
IN: syndication.tests
|
||||||
|
|
||||||
: load-news-file ( filename -- feed )
|
: load-news-file ( filename -- feed )
|
||||||
#! Load an news syndication file and process it, returning
|
! Load an news syndication file and process it, returning
|
||||||
#! it as an feed tuple.
|
! it as an feed tuple.
|
||||||
binary file-contents parse-feed ;
|
binary file-contents parse-feed ;
|
||||||
|
|
||||||
{ T{
|
{ T{
|
||||||
|
|
|
@ -107,7 +107,7 @@ M: string parse-feed [ string>xml xml>feed ] with-html-entities ;
|
||||||
M: byte-array parse-feed [ bytes>xml xml>feed ] with-html-entities ;
|
M: byte-array parse-feed [ bytes>xml xml>feed ] with-html-entities ;
|
||||||
|
|
||||||
: download-feed ( url -- feed )
|
: download-feed ( url -- feed )
|
||||||
#! Retrieve an news syndication file, return as a feed tuple.
|
! Retrieve an news syndication file, return as a feed tuple.
|
||||||
http-get nip parse-feed ;
|
http-get nip parse-feed ;
|
||||||
|
|
||||||
! Atom generation
|
! Atom generation
|
||||||
|
|
|
@ -92,8 +92,8 @@ M: object add-breakpoint ;
|
||||||
] when ; inline
|
] when ; inline
|
||||||
|
|
||||||
: change-frame ( continuation quot -- continuation' )
|
: change-frame ( continuation quot -- continuation' )
|
||||||
#! Applies quot to innermost call frame of the
|
! Applies quot to innermost call frame of the
|
||||||
#! continuation.
|
! continuation.
|
||||||
[ clone ] dip '[ _ (change-frame) ] change-call ; inline
|
[ clone ] dip '[ _ (change-frame) ] change-call ; inline
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
|
@ -45,7 +45,7 @@ ERROR: can't-deploy-library-file library ;
|
||||||
utf8 [ copy-lines ] with-process-reader ;
|
utf8 [ copy-lines ] with-process-reader ;
|
||||||
|
|
||||||
: make-boot-image ( -- )
|
: make-boot-image ( -- )
|
||||||
#! If stage1 image doesn't exist, create one.
|
! If stage1 image doesn't exist, create one.
|
||||||
my-boot-image-name resource-path exists?
|
my-boot-image-name resource-path exists?
|
||||||
[ make-my-image ] unless ;
|
[ make-my-image ] unless ;
|
||||||
|
|
||||||
|
|
|
@ -599,11 +599,11 @@ SYMBOL: deploy-vocab
|
||||||
clear-megamorphic-caches ;
|
clear-megamorphic-caches ;
|
||||||
|
|
||||||
: die-with ( error original-error -- * )
|
: die-with ( error original-error -- * )
|
||||||
#! We don't want DCE to drop the error before the die call!
|
! We don't want DCE to drop the error before the die call!
|
||||||
[ die 1 exit ] ( a -- * ) call-effect-unsafe ;
|
[ die 1 exit ] ( a -- * ) call-effect-unsafe ;
|
||||||
|
|
||||||
: die-with2 ( error original-error -- * )
|
: die-with2 ( error original-error -- * )
|
||||||
#! We don't want DCE to drop the error before the die call!
|
! We don't want DCE to drop the error before the die call!
|
||||||
[ die 1 exit ] ( a b -- * ) call-effect-unsafe ;
|
[ die 1 exit ] ( a b -- * ) call-effect-unsafe ;
|
||||||
|
|
||||||
: deploy-error-handler ( quot -- )
|
: deploy-error-handler ( quot -- )
|
||||||
|
@ -617,8 +617,8 @@ SYMBOL: deploy-vocab
|
||||||
] recover ; inline
|
] recover ; inline
|
||||||
|
|
||||||
: (deploy) ( final-image vocab-manifest-out vocab config -- )
|
: (deploy) ( final-image vocab-manifest-out vocab config -- )
|
||||||
#! Does the actual work of a deployment in the slave
|
! Does the actual work of a deployment in the slave
|
||||||
#! stage2 image
|
! stage2 image
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
strip-debugger? [
|
strip-debugger? [
|
||||||
|
|
|
@ -80,9 +80,9 @@ M: pasteboard set-clipboard-contents
|
||||||
[ 0 0 ] dip dim>> first2 <CGRect> ;
|
[ 0 0 ] dip dim>> first2 <CGRect> ;
|
||||||
|
|
||||||
: auto-position ( window loc -- )
|
: auto-position ( window loc -- )
|
||||||
#! Note: if this is the initial window, the length of the windows
|
! Note: if this is the initial window, the length of the windows
|
||||||
#! vector should be 1, since (open-window) calls auto-position
|
! vector should be 1, since (open-window) calls auto-position
|
||||||
#! after register-window.
|
! after register-window.
|
||||||
dup { 0 0 } = [
|
dup { 0 0 } = [
|
||||||
drop
|
drop
|
||||||
ui-windows get-global length 1 <= [ -> center ] [
|
ui-windows get-global length 1 <= [ -> center ] [
|
||||||
|
|
|
@ -16,7 +16,7 @@ IN: ui.backend.cocoa.views
|
||||||
|
|
||||||
! Issue #1453
|
! Issue #1453
|
||||||
: button ( event -- n )
|
: button ( event -- n )
|
||||||
#! Cocoa -> Factor UI button mapping
|
! Cocoa -> Factor UI button mapping
|
||||||
-> buttonNumber {
|
-> buttonNumber {
|
||||||
{ 0 [ 1 ] }
|
{ 0 [ 1 ] }
|
||||||
{ 1 [ 3 ] }
|
{ 1 [ 3 ] }
|
||||||
|
|
|
@ -271,8 +271,8 @@ CONSTANT: window-control>ex-style
|
||||||
[ get-RECT-top-left ] [ get-RECT-width/height ] bi ;
|
[ get-RECT-top-left ] [ get-RECT-width/height ] bi ;
|
||||||
|
|
||||||
: handle-wm-paint ( hWnd uMsg wParam lParam -- )
|
: handle-wm-paint ( hWnd uMsg wParam lParam -- )
|
||||||
#! wParam and lParam are unused
|
! wParam and lParam are unused
|
||||||
#! only paint if width/height both > 0
|
! only paint if width/height both > 0
|
||||||
3drop window relayout-1 yield ;
|
3drop window relayout-1 yield ;
|
||||||
|
|
||||||
: handle-wm-size ( hWnd uMsg wParam lParam -- )
|
: handle-wm-size ( hWnd uMsg wParam lParam -- )
|
||||||
|
@ -531,11 +531,11 @@ SYMBOL: nc-buttons
|
||||||
wParam mouse-scroll hand-loc get-global hWnd window send-scroll ;
|
wParam mouse-scroll hand-loc get-global hWnd window send-scroll ;
|
||||||
|
|
||||||
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
|
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
|
||||||
#! message sent if windows needs application to stop dragging
|
! message sent if windows needs application to stop dragging
|
||||||
4drop release-capture ;
|
4drop release-capture ;
|
||||||
|
|
||||||
: handle-wm-mouseleave ( hWnd uMsg wParam lParam -- )
|
: handle-wm-mouseleave ( hWnd uMsg wParam lParam -- )
|
||||||
#! message sent if mouse leaves main application
|
! message sent if mouse leaves main application
|
||||||
4drop forget-rollover ;
|
4drop forget-rollover ;
|
||||||
|
|
||||||
: system-background-color ( -- color )
|
: system-background-color ( -- color )
|
||||||
|
|
|
@ -152,8 +152,8 @@ repeat-button H{
|
||||||
} set-gestures
|
} set-gestures
|
||||||
|
|
||||||
: <repeat-button> ( label quot: ( button -- ) -- button )
|
: <repeat-button> ( label quot: ( button -- ) -- button )
|
||||||
#! Button that calls the quotation every 100ms as long as
|
! Button that calls the quotation every 100ms as long as
|
||||||
#! the mouse is held down.
|
! the mouse is held down.
|
||||||
repeat-button new-button border-button-theme ;
|
repeat-button new-button border-button-theme ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
|
@ -140,9 +140,9 @@ SYMBOL: ui-notify-flag
|
||||||
: layout-queue ( -- queue ) \ layout-queue get ;
|
: layout-queue ( -- queue ) \ layout-queue get ;
|
||||||
|
|
||||||
: layout-later ( gadget -- )
|
: layout-later ( gadget -- )
|
||||||
#! When unit testing gadgets without the UI running, the
|
! When unit testing gadgets without the UI running, the
|
||||||
#! invalid queue is not initialized and we simply ignore
|
! invalid queue is not initialized and we simply ignore
|
||||||
#! invalidation requests.
|
! invalidation requests.
|
||||||
layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
|
layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
|
||||||
|
|
||||||
: invalidate* ( gadget -- )
|
: invalidate* ( gadget -- )
|
||||||
|
|
|
@ -196,7 +196,7 @@ M: pane-control model-changed ( model pane-control -- )
|
||||||
! Character styles
|
! Character styles
|
||||||
|
|
||||||
MEMO:: specified-font ( name style size foreground background -- font )
|
MEMO:: specified-font ( name style size foreground background -- font )
|
||||||
#! We memoize here to avoid creating lots of duplicate font objects.
|
! We memoize here to avoid creating lots of duplicate font objects.
|
||||||
monospace-font
|
monospace-font
|
||||||
name [ >>name ] when*
|
name [ >>name ] when*
|
||||||
style {
|
style {
|
||||||
|
|
|
@ -49,9 +49,9 @@ CONSTANT: min-thumb-dim 30
|
||||||
[ elevator-length ] bi min ;
|
[ elevator-length ] bi min ;
|
||||||
|
|
||||||
: slider-scale ( slider -- n )
|
: slider-scale ( slider -- n )
|
||||||
#! A scaling factor such that if x is a slider co-ordinate,
|
! A scaling factor such that if x is a slider co-ordinate,
|
||||||
#! x*n is the screen position of the thumb, and conversely
|
! x*n is the screen position of the thumb, and conversely
|
||||||
#! for x/n. The '1 max' calls avoid division by zero.
|
! for x/n. The '1 max' calls avoid division by zero.
|
||||||
[ [ elevator-length ] [ thumb-dim ] bi - 1 max ]
|
[ [ elevator-length ] [ thumb-dim ] bi - 1 max ]
|
||||||
[ slider-length* 1 max ]
|
[ slider-length* 1 max ]
|
||||||
bi / ;
|
bi / ;
|
||||||
|
|
|
@ -197,8 +197,8 @@ M: world draw-world*
|
||||||
} cleave ;
|
} cleave ;
|
||||||
|
|
||||||
: draw-world? ( world -- ? )
|
: draw-world? ( world -- ? )
|
||||||
#! We don't draw deactivated worlds, or those with 0 size.
|
! We don't draw deactivated worlds, or those with 0 size.
|
||||||
#! On Windows, the latter case results in GL errors.
|
! On Windows, the latter case results in GL errors.
|
||||||
{ [ active?>> ] [ handle>> ] [ dim>> [ 0 > ] all? ] } 1&& ;
|
{ [ active?>> ] [ handle>> ] [ dim>> [ 0 > ] all? ] } 1&& ;
|
||||||
|
|
||||||
TUPLE: world-error error world ;
|
TUPLE: world-error error world ;
|
||||||
|
|
|
@ -67,13 +67,13 @@ SYMBOL: dpi
|
||||||
layout>> 0 pango_layout_get_line_readonly ;
|
layout>> 0 pango_layout_get_line_readonly ;
|
||||||
|
|
||||||
: line-offset>x ( layout n -- x )
|
: line-offset>x ( layout n -- x )
|
||||||
#! n is an index into the UTF8 encoding of the text
|
! n is an index into the UTF8 encoding of the text
|
||||||
[ drop first-line ] [ swap string>> >utf8-index ] 2bi
|
[ drop first-line ] [ swap string>> >utf8-index ] 2bi
|
||||||
f { int } [ pango_layout_line_index_to_x ] with-out-parameters
|
f { int } [ pango_layout_line_index_to_x ] with-out-parameters
|
||||||
pango>float ;
|
pango>float ;
|
||||||
|
|
||||||
: x>line-offset ( layout x -- n )
|
: x>line-offset ( layout x -- n )
|
||||||
#! n is an index into the UTF8 encoding of the text
|
! n is an index into the UTF8 encoding of the text
|
||||||
[
|
[
|
||||||
[ first-line ] dip
|
[ first-line ] dip
|
||||||
float>pango
|
float>pango
|
||||||
|
@ -118,8 +118,8 @@ SYMBOL: dpi
|
||||||
] make-bitmap-image ;
|
] make-bitmap-image ;
|
||||||
|
|
||||||
: escape-nulls ( str -- str' )
|
: escape-nulls ( str -- str' )
|
||||||
#! Replace nulls with something else since Pango uses null-terminated
|
! Replace nulls with something else since Pango uses null-terminated
|
||||||
#! strings
|
! strings
|
||||||
H{ { 0 CHAR: zero-width-no-break-space } } substitute ;
|
H{ { 0 CHAR: zero-width-no-break-space } } substitute ;
|
||||||
|
|
||||||
: unpack-selection ( layout string/selection -- layout )
|
: unpack-selection ( layout string/selection -- layout )
|
||||||
|
@ -140,8 +140,8 @@ SYMBOL: dpi
|
||||||
swap <PangoLayout> &g_object_unref layout-extents drop dim>> second ;
|
swap <PangoLayout> &g_object_unref layout-extents drop dim>> second ;
|
||||||
|
|
||||||
MEMO: missing-font-metrics ( font -- metrics )
|
MEMO: missing-font-metrics ( font -- metrics )
|
||||||
#! Pango doesn't provide x-height and cap-height but Core Text does, so we
|
! Pango doesn't provide x-height and cap-height but Core Text does, so we
|
||||||
#! simulate them on Pango.
|
! simulate them on Pango.
|
||||||
[
|
[
|
||||||
[ metrics new ] dip
|
[ metrics new ] dip
|
||||||
[ "x" glyph-height >>x-height ]
|
[ "x" glyph-height >>x-height ]
|
||||||
|
|
|
@ -57,7 +57,7 @@ M: debugger focusable-child*
|
||||||
dup restart-hook>> [ restart-list>> ] [ drop t ] if ;
|
dup restart-hook>> [ restart-list>> ] [ drop t ] if ;
|
||||||
|
|
||||||
: debugger-window ( error continuation -- )
|
: debugger-window ( error continuation -- )
|
||||||
#! No restarts for the debugger window
|
! No restarts for the debugger window
|
||||||
f f <debugger> "Error" open-status-window ;
|
f f <debugger> "Error" open-status-window ;
|
||||||
|
|
||||||
GENERIC: error-in-debugger? ( error -- ? )
|
GENERIC: error-in-debugger? ( error -- ? )
|
||||||
|
|
|
@ -25,7 +25,7 @@ MEMO: error-icon ( type -- image-name )
|
||||||
[ swap <checkbox> add-gadget ] assoc-each ;
|
[ swap <checkbox> add-gadget ] assoc-each ;
|
||||||
|
|
||||||
: <error-toggle> ( -- model gadget )
|
: <error-toggle> ( -- model gadget )
|
||||||
#! Linkage errors are not shown by default.
|
! Linkage errors are not shown by default.
|
||||||
error-types get [ fatal?>> <model> ] assoc-map
|
error-types get [ fatal?>> <model> ] assoc-map
|
||||||
[ [ [ error-icon ] dip ] assoc-map <checkboxes> ]
|
[ [ [ error-icon ] dip ] assoc-map <checkboxes> ]
|
||||||
[ <mapping> ] bi ;
|
[ <mapping> ] bi ;
|
||||||
|
|
|
@ -34,7 +34,7 @@ INSTANCE: interactor input-stream
|
||||||
thread>> thread-continuation ;
|
thread>> thread-continuation ;
|
||||||
|
|
||||||
: interactor-busy? ( interactor -- ? )
|
: interactor-busy? ( interactor -- ? )
|
||||||
#! We're busy if there's no thread to resume.
|
! We're busy if there's no thread to resume.
|
||||||
{
|
{
|
||||||
[ waiting>> ]
|
[ waiting>> ]
|
||||||
[ thread>> dup [ thread-registered? ] when ]
|
[ thread>> dup [ thread-registered? ] when ]
|
||||||
|
@ -233,7 +233,7 @@ M: listener-gadget focusable-child*
|
||||||
input>> dup popup>> or ;
|
input>> dup popup>> or ;
|
||||||
|
|
||||||
: wait-for-listener ( listener -- )
|
: wait-for-listener ( listener -- )
|
||||||
#! Wait for the listener to start.
|
! Wait for the listener to start.
|
||||||
input>> flag>> wait-for-flag ;
|
input>> flag>> wait-for-flag ;
|
||||||
|
|
||||||
: listener-busy? ( listener -- ? )
|
: listener-busy? ( listener -- ? )
|
||||||
|
@ -420,7 +420,7 @@ interactor "completion" f {
|
||||||
] "Listener" spawn drop ;
|
] "Listener" spawn drop ;
|
||||||
|
|
||||||
: restart-listener ( listener -- )
|
: restart-listener ( listener -- )
|
||||||
#! Returns when listener is ready to receive input.
|
! Returns when listener is ready to receive input.
|
||||||
{
|
{
|
||||||
[ com-end ]
|
[ com-end ]
|
||||||
[ clear-output ]
|
[ clear-output ]
|
||||||
|
|
|
@ -17,12 +17,12 @@ SYMBOL: ui-windows
|
||||||
: window ( handle -- world ) ui-windows get-global at ;
|
: window ( handle -- world ) ui-windows get-global at ;
|
||||||
|
|
||||||
: register-window ( world handle -- )
|
: register-window ( world handle -- )
|
||||||
#! Add the new window just below the topmost window. Why?
|
! Add the new window just below the topmost window. Why?
|
||||||
#! So that if the new window doesn't actually receive focus
|
! So that if the new window doesn't actually receive focus
|
||||||
#! (eg, we're using focus follows mouse and the mouse is not
|
! (eg, we're using focus follows mouse and the mouse is not
|
||||||
#! in the new window when it appears) Factor doesn't get
|
! in the new window when it appears) Factor doesn't get
|
||||||
#! confused and send workspace operations to the new window,
|
! confused and send workspace operations to the new window,
|
||||||
#! etc.
|
! etc.
|
||||||
swap 2array ui-windows get-global push
|
swap 2array ui-windows get-global push
|
||||||
ui-windows get-global dup length 1 >
|
ui-windows get-global dup length 1 >
|
||||||
[ [ length 1 - dup 1 - ] keep exchange ] [ drop ] if ;
|
[ [ length 1 - dup 1 - ] keep exchange ] [ drop ] if ;
|
||||||
|
@ -156,10 +156,10 @@ PRIVATE>
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: update-ui-loop ( -- )
|
: update-ui-loop ( -- )
|
||||||
#! Note the logic: if update-ui fails, we open an error window
|
! Note the logic: if update-ui fails, we open an error window
|
||||||
#! and run one iteration of update-ui. If that also fails, well,
|
! and run one iteration of update-ui. If that also fails, well,
|
||||||
#! the whole UI subsystem is broken so we exit out of the
|
! the whole UI subsystem is broken so we exit out of the
|
||||||
#! update-ui-loop.
|
! update-ui-loop.
|
||||||
[ { [ ui-running? ] [ ui-thread get-global self eq? ] } 0&& ]
|
[ { [ ui-running? ] [ ui-thread get-global self eq? ] } 0&& ]
|
||||||
[
|
[
|
||||||
ui-notify-flag get lower-flag
|
ui-notify-flag get lower-flag
|
||||||
|
|
|
@ -59,7 +59,7 @@ IN: validators
|
||||||
[ 2drop ] [ drop "invalid " prepend throw ] if ;
|
[ 2drop ] [ drop "invalid " prepend throw ] if ;
|
||||||
|
|
||||||
: v-email ( str -- str )
|
: v-email ( str -- str )
|
||||||
#! From http://www.regular-expressions.info/email.html
|
! From http://www.regular-expressions.info/email.html
|
||||||
320 v-max-length
|
320 v-max-length
|
||||||
"e-mail"
|
"e-mail"
|
||||||
R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
|
R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
|
||||||
|
|
|
@ -75,7 +75,7 @@ PRIVATE>
|
||||||
[ dup vocab-prefix? [ name>> <vocab-link> ] when ] map ;
|
[ dup vocab-prefix? [ name>> <vocab-link> ] when ] map ;
|
||||||
|
|
||||||
: remove-redundant-prefixes ( seq -- seq' )
|
: remove-redundant-prefixes ( seq -- seq' )
|
||||||
#! Hack.
|
! Hack.
|
||||||
[ vocab-prefix? ] partition
|
[ vocab-prefix? ] partition
|
||||||
[
|
[
|
||||||
[ vocab-name ] map fast-set
|
[ vocab-name ] map fast-set
|
||||||
|
|
|
@ -29,8 +29,8 @@ TR: convert-separators "/\\" ".." ;
|
||||||
chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
|
chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
|
||||||
|
|
||||||
: monitor-loop ( monitor -- )
|
: monitor-loop ( monitor -- )
|
||||||
#! On OS X, monitors give us the full path, so we chop it
|
! On OS X, monitors give us the full path, so we chop it
|
||||||
#! off if its there.
|
! off if its there.
|
||||||
[
|
[
|
||||||
next-change path>> path>vocab
|
next-change path>> path>vocab
|
||||||
[ changed-vocab ] [ reset-cache ] bi
|
[ changed-vocab ] [ reset-cache ] bi
|
||||||
|
|
|
@ -18,11 +18,11 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
|
||||||
with-out-parameters ;
|
with-out-parameters ;
|
||||||
|
|
||||||
: open-process-token ( -- handle )
|
: open-process-token ( -- handle )
|
||||||
#! remember to CloseHandle
|
! remember to CloseHandle
|
||||||
GetCurrentProcess (open-process-token) ;
|
GetCurrentProcess (open-process-token) ;
|
||||||
|
|
||||||
: with-process-token ( quot -- )
|
: with-process-token ( quot -- )
|
||||||
#! quot: ( token-handle -- token-handle )
|
! quot: ( token-handle -- token-handle )
|
||||||
[ open-process-token ] dip
|
[ open-process-token ] dip
|
||||||
[ keep ] curry
|
[ keep ] curry
|
||||||
[ CloseHandle drop ] [ ] cleanup ; inline
|
[ CloseHandle drop ] [ ] cleanup ; inline
|
||||||
|
|
|
@ -21,7 +21,7 @@ IN: windows.time
|
||||||
FILETIME>windows-time ;
|
FILETIME>windows-time ;
|
||||||
|
|
||||||
: timestamp>windows-time ( timestamp -- n )
|
: timestamp>windows-time ( timestamp -- n )
|
||||||
#! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC)
|
! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC)
|
||||||
>gmt windows-1601 (time-) 10,000,000 * >integer ;
|
>gmt windows-1601 (time-) 10,000,000 * >integer ;
|
||||||
|
|
||||||
: windows-time>FILETIME ( n -- FILETIME )
|
: windows-time>FILETIME ( n -- FILETIME )
|
||||||
|
|
|
@ -436,7 +436,7 @@ ERROR: winsock-exception n string ;
|
||||||
${ ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING } member? ;
|
${ ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING } member? ;
|
||||||
|
|
||||||
: (maybe-winsock-exception) ( n -- winsock-exception/f )
|
: (maybe-winsock-exception) ( n -- winsock-exception/f )
|
||||||
! #! WSAStartup returns the error code 'n' directly
|
! ! WSAStartup returns the error code 'n' directly
|
||||||
dup winsock-expected-error?
|
dup winsock-expected-error?
|
||||||
[ drop f ] [ [ ] [ n>win32-error-string ] bi \ winsock-exception boa ] if ;
|
[ drop f ] [ [ ] [ n>win32-error-string ] bi \ winsock-exception boa ] if ;
|
||||||
|
|
||||||
|
|
|
@ -18,7 +18,7 @@ IN: xml.elements
|
||||||
[ quoteless-attr ] take-interpolated ;
|
[ quoteless-attr ] take-interpolated ;
|
||||||
|
|
||||||
: start-tag ( -- name ? )
|
: start-tag ( -- name ? )
|
||||||
#! Outputs the name and whether this is a closing tag
|
! Outputs the name and whether this is a closing tag
|
||||||
get-char CHAR: / eq? dup [ next ] when
|
get-char CHAR: / eq? dup [ next ] when
|
||||||
parse-name swap ;
|
parse-name swap ;
|
||||||
|
|
||||||
|
|
|
@ -20,7 +20,7 @@ CONSTANT: quoted-entities-out
|
||||||
}
|
}
|
||||||
|
|
||||||
: escape-string-by ( str table -- escaped )
|
: escape-string-by ( str table -- escaped )
|
||||||
#! Convert <, >, &, ' and " to HTML entities.
|
! Convert <, >, &, ' and " to HTML entities.
|
||||||
[ '[ dup _ at [ % ] [ , ] ?if ] each ] "" make ;
|
[ '[ dup _ at [ % ] [ , ] ?if ] each ] "" make ;
|
||||||
|
|
||||||
: escape-string ( str -- newstr )
|
: escape-string ( str -- newstr )
|
||||||
|
|
|
@ -72,9 +72,9 @@ HINTS: next* { spot } ;
|
||||||
spot get (skip-until) ; inline
|
spot get (skip-until) ; inline
|
||||||
|
|
||||||
: take-until ( ... quot: ( ... char -- ... ? ) -- ... string )
|
: take-until ( ... quot: ( ... char -- ... ? ) -- ... string )
|
||||||
#! Take the substring of a string starting at spot
|
! Take the substring of a string starting at spot
|
||||||
#! from code until the quotation given is true and
|
! from code until the quotation given is true and
|
||||||
#! advance spot to after the substring.
|
! advance spot to after the substring.
|
||||||
10 <sbuf> [
|
10 <sbuf> [
|
||||||
'[ _ keep over [ drop ] [ _ push ] if ] skip-until
|
'[ _ keep over [ drop ] [ _ push ] if ] skip-until
|
||||||
] keep "" like ; inline
|
] keep "" like ; inline
|
||||||
|
@ -83,7 +83,7 @@ HINTS: next* { spot } ;
|
||||||
'[ _ member? ] take-until ; inline
|
'[ _ member? ] take-until ; inline
|
||||||
|
|
||||||
: pass-blank ( -- )
|
: pass-blank ( -- )
|
||||||
#! Advance code past any whitespace, including newlines
|
! Advance code past any whitespace, including newlines
|
||||||
[ blank? not ] skip-until ;
|
[ blank? not ] skip-until ;
|
||||||
|
|
||||||
: next-matching ( pos ch str -- pos' )
|
: next-matching ( pos ch str -- pos' )
|
||||||
|
|
|
@ -29,10 +29,10 @@ M: byte-vector equal?
|
||||||
M: byte-vector contract 2drop ; inline
|
M: byte-vector contract 2drop ; inline
|
||||||
|
|
||||||
M: byte-array like
|
M: byte-array like
|
||||||
#! If we have an byte-array, we're done.
|
! If we have an byte-array, we're done.
|
||||||
#! If we have a byte-vector, and it's at full capacity,
|
! If we have a byte-vector, and it's at full capacity,
|
||||||
#! we're done. Otherwise, call resize-byte-array, which is a
|
! we're done. Otherwise, call resize-byte-array, which is a
|
||||||
#! relatively fast primitive.
|
! relatively fast primitive.
|
||||||
drop dup byte-array? [
|
drop dup byte-array? [
|
||||||
dup byte-vector? [
|
dup byte-vector? [
|
||||||
[ length ] [ underlying>> ] bi
|
[ length ] [ underlying>> ] bi
|
||||||
|
|
|
@ -58,9 +58,9 @@ M: checksum checksum-lines
|
||||||
[ B{ CHAR: \n } join ] dip checksum-bytes ;
|
[ B{ CHAR: \n } join ] dip checksum-bytes ;
|
||||||
|
|
||||||
: checksum-file ( path checksum -- value )
|
: checksum-file ( path checksum -- value )
|
||||||
#! normalize-path (file-reader) is equivalent to
|
! normalize-path (file-reader) is equivalent to
|
||||||
#! binary <file-reader>. We use the lower-level form
|
! binary <file-reader>. We use the lower-level form
|
||||||
#! so that we can move io.encodings.binary to basis/.
|
! so that we can move io.encodings.binary to basis/.
|
||||||
[ normalize-path (file-reader) ] dip checksum-stream ;
|
[ normalize-path (file-reader) ] dip checksum-stream ;
|
||||||
|
|
||||||
: hex-string ( seq -- str )
|
: hex-string ( seq -- str )
|
||||||
|
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue