steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix comments to be ! not #!.

db4
John Benediktsson 2015-09-08 16:15:10 -07:00
parent 75e50ec5e0
commit e477f6996f
171 changed files with 965 additions and 965 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
basis/bootstrap/image/image.factor
View File

@ -112,7 +112,7 @@ SYMBOL: special-objects
[ length test-quot call ] [ % ] bi ; inline
: make-jit ( quot -- parameters literals code )
#! code is a { relocation insns } pair
! code is a { relocation insns } pair
[
0 extra-offset set
init-relocation
@ -212,7 +212,7 @@ GENERIC: prepare-object ( obj -- ptr )
: bignum-radix ( -- n ) bignum-bits 2^ 1 - ;
: bignum>sequence ( n -- seq )
#! n is positive or zero.
! n is positive or zero.
[ dup 0 > ]
[ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
produce nip ;
@ -232,8 +232,8 @@ M: bignum prepare-object
! Fixnums
M: fixnum prepare-object
#! When generating a 32-bit image on a 64-bit system,
#! some fixnums should be bignums.
! When generating a 32-bit image on a 64-bit system,
! some fixnums should be bignums.
dup
bootstrap-most-negative-fixnum
bootstrap-most-positive-fixnum between?
@ -346,8 +346,8 @@ M: wrapper prepare-object
] emit-object ;
M: string prepare-object
#! We pool strings so that each string is only written once
#! to the image
! We pool strings so that each string is only written once
! to the image
[ emit-string ] cache-eql-object ;
: assert-empty ( seq -- )

8
basis/cairo/cairo.factor
View File

@ -35,10 +35,10 @@ ERROR: cairo-error n message ;
ubyte-components >>component-type ; inline
: dummy-cairo ( -- cr )
#! Sometimes we want a dummy context; eg with Pango, we want
#! to measure text dimensions to create a new image context with,
#! but we need an existing context to measure text dimensions
#! with so we use the dummy.
! Sometimes we want a dummy context; eg with Pango, we want
! to measure text dimensions to create a new image context with,
! but we need an existing context to measure text dimensions
! with so we use the dummy.
\ dummy-cairo [
CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
cairo_create

20
basis/calendar/calendar.factor
View File

@ -123,8 +123,8 @@ CONSTANT: minutes-per-year 5259492/10
CONSTANT: seconds-per-year 31556952
:: julian-day-number ( year month day -- n )
#! Returns a composite date number
#! Not valid before year -4800
! Returns a composite date number
! Not valid before year -4800
14 month - 12 /i :> a
year 4800 + a - :> y
month 12 a * + 3 - :> m
@ -133,7 +133,7 @@ CONSTANT: seconds-per-year 31556952
y 4 /i + y 100 /i - y 400 /i + 32045 - ;
:: julian-day-number>date ( n -- year month day )
#! Inverse of julian-day-number
! Inverse of julian-day-number
n 32044 + :> a
4 a * 3 + 146097 /i :> b
a 146097 b * 4 /i - :> c
@ -204,7 +204,7 @@ GENERIC: +minute ( timestamp x -- timestamp )
GENERIC: +second ( timestamp x -- timestamp )
: /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 ;
: float>whole-part ( float -- int float )
@ -295,8 +295,8 @@ M: duration time+
] if ;
: duration>years ( duration -- x )
#! Uses average month/year length since duration loses calendar
#! data
! Uses average month/year length since duration loses calendar
! data
0 swap
{
[ year>> + ]
@ -351,7 +351,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
[ >time< [ [ 3600 * ] [ 60 * ] bi* ] dip + + ] bi@ - + ;
M: timestamp time-
#! Exact calendar-time difference
! Exact calendar-time difference
(time-) seconds ;
: time* ( obj1 obj2 -- obj3 )
@ -420,9 +420,9 @@ M: duration time-
: ago ( duration -- timestamp ) now swap time- ;
: zeller-congruence ( year month day -- n )
#! Zeller Congruence
#! http://web.textfiles.com/computers/formulas.txt
#! good for any date since October 15, 1582
! Zeller Congruence
! http://web.textfiles.com/computers/formulas.txt
! good for any date since October 15, 1582
[
dup 2 <= [ [ 1 - ] [ 12 + ] bi* ] when
[ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip

8
basis/calendar/format/format.factor
View File

@ -111,8 +111,8 @@ M: timestamp year. ( timestamp -- )
} case ;
: timestamp>rfc822 ( timestamp -- str )
#! RFC822 timestamp format
#! Example: Tue, 15 Nov 1994 08:12:31 +0200
! RFC822 timestamp format
! Example: Tue, 15 Nov 1994 08:12:31 +0200
[
[ (timestamp>string) bl ]
[ gmt-offset>> write-gmt-offset ]
@ -126,8 +126,8 @@ M: timestamp year. ( timestamp -- )
] with-string-writer ;
: timestamp>http-string ( timestamp -- str )
#! http timestamp format
#! Example: Tue, 15 Nov 1994 08:12:31 GMT
! http timestamp format
! Example: Tue, 15 Nov 1994 08:12:31 GMT
>gmt timestamp>rfc822 ;
: (timestamp>cookie-string) ( timestamp -- )

8
basis/channels/examples/examples.factor
View File

@ -17,9 +17,9 @@ IN: channels.examples
[ from ] keep [ from ] keep from ;
: filter ( send prime recv -- )
#! Receives numbers from the 'send' channel,
#! filters out all those divisible by 'prime',
#! and sends to the 'recv' channel.
! Receives numbers from the 'send' channel,
! filters out all those divisible by 'prime',
! and sends to the 'recv' channel.
[
from swap dupd mod zero? not [ swap to ] [ 2drop ] if
] 3keep filter ;
@ -32,7 +32,7 @@ IN: channels.examples
prime newc (sieve) ;
: sieve ( prime -- )
#! Send prime numbers to 'prime' channel
! Send prime numbers to 'prime' channel
<channel> dup [ counter ] curry "Counter" spawn drop
(sieve) ;

4
basis/checksums/interleave/interleave.factor
View File

@ -4,11 +4,11 @@ USING: assocs checksums grouping kernel locals math sequences ;
IN: checksums.interleave
: seq>2seq ( seq -- seq1 seq2 )
#! { abcdefgh } -> { aceg } { bdfh }
! { abcdefgh } -> { aceg } { bdfh }
2 group flip [ { } { } ] [ first2 ] if-empty ;
: 2seq>seq ( seq1 seq2 -- seq )
#! { aceg } { bdfh } -> { abcdefgh }
! { aceg } { bdfh } -> { abcdefgh }
[ zip concat ] keep like ;
:: interleaved-checksum ( bytes checksum -- seq )

10
basis/checksums/md5/md5.factor
View File

@ -34,19 +34,19 @@ CONSTANT: T $[
]
:: 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
:: 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
: 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
:: 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
CONSTANT: S11 7
@ -72,7 +72,7 @@ CONSTANT: c 2
CONSTANT: d 3
:: (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 [
b state nth-unsafe
c state nth-unsafe

2
basis/circular/circular.factor
View File

@ -24,7 +24,7 @@ M: circular virtual@ circular-wrap seq>> ; inline
M: circular virtual-exemplar seq>> ; inline
: change-circular-start ( n circular -- )
#! change start to (start + n) mod length
! change start to (start + n) mod length
circular-wrap start<< ; inline
: rotate-circular ( circular -- )

2
basis/cocoa/application/application.factor
View File

@ -39,7 +39,7 @@ FUNCTION: void NSBeep ( )
-> alloc -> init -> setDelegate: ;
: running.app? ( -- ? )
#! Test if we're running a .app.
! Test if we're running a .app.
".app"
NSBundle -> mainBundle -> bundlePath CF>string
subseq? ;

34
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -30,14 +30,14 @@ SYMBOL: heap-ac
acs>vregs get [ drop V{ } clone ] cache ;
: vreg>ac ( vreg -- ac )
#! Only vregs produced by ##allot, ##peek and ##slot can
#! ever be used as valid inputs to ##slot and ##set-slot,
#! so we assert this fact by not giving alias classes to
#! other vregs.
! Only vregs produced by ##allot, ##peek and ##slot can
! ever be used as valid inputs to ##slot and ##set-slot,
! so we assert this fact by not giving alias classes to
! other vregs.
vregs>acs get [ heap-ac get [ ac>vregs push ] keep ] cache ;
: 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 ;
: each-alias ( vreg quot -- )
@ -66,14 +66,14 @@ SYMBOL: dead-stores
ERROR: vreg-not-new vreg ;
:: 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
ac vreg vregs>acs get set-at
vreg ac ac>vregs push ;
: live-slot ( slot#/f vreg -- vreg' )
#! If the slot number is unknown, we never reuse a previous
#! value.
! If the slot number is unknown, we never reuse a previous
! value.
over [ live-slots get at at ] [ 2drop f ] if ;
: load-constant-slot ( value slot# vreg -- )
@ -83,12 +83,12 @@ ERROR: vreg-not-new vreg ;
over [ load-constant-slot ] [ 3drop ] if ;
: record-constant-slot ( slot# vreg -- )
#! A load can potentially read every store of this slot#
#! in that alias class.
! A load can potentially read every store of this slot#
! in that alias class.
[ recent-stores get at delete-at ] with each-alias ;
: 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 ;
:: remember-slot ( value slot# vreg -- )
@ -171,8 +171,8 @@ M: vreg-insn analyze-aliases
def-acs ;
M: allocation-insn analyze-aliases
#! A freshly allocated object is distinct from any other
#! object.
! A freshly allocated object is distinct from any other
! object.
dup dst>> set-new-ac ;
M: ##box-displaced-alien analyze-aliases
@ -188,8 +188,8 @@ M: read-insn analyze-aliases
if ;
: idempotent? ( value slot#/f vreg -- ? )
#! Are we storing a value back to the same slot it was read
#! from?
! Are we storing a value back to the same slot it was read
! from?
live-slot = ;
M:: write-insn analyze-aliases ( insn -- insn )
@ -207,8 +207,8 @@ M:: write-insn analyze-aliases ( insn -- insn )
insn ;
M: ##copy analyze-aliases
#! The output vreg gets the same alias class as the input
#! vreg, since they both contain the same value.
! The output vreg gets the same alias class as the input
! vreg, since they both contain the same value.
dup record-copy ;
: useless-compare? ( insn -- ? )

36
basis/compiler/compiler.factor
View File

@ -14,7 +14,7 @@ IN: compiler
SYMBOL: compiled
: compile? ( word -- ? )
#! Don't attempt to compile certain words.
! Don't attempt to compile certain words.
{
[ "forgotten" word-prop ]
[ inlined-block? ]
@ -46,17 +46,17 @@ M: predicate-engine-word combinator? "owner-generic" word-prop combinator? ;
M: word combinator? inline? ;
: ignore-error? ( word error -- ? )
#! Ignore some errors on inline combinators, macros, and special
#! words such as 'call'.
! Ignore some errors on inline combinators, macros, and special
! words such as 'call'.
{
[ drop no-compile? ]
[ [ combinator? ] [ unknown-macro-input? ] bi* and ]
} 2|| ;
: finish ( word -- )
#! Recompile callers if the word's stack effect changed, then
#! save the word's dependencies so that if they change, the
#! word can get recompiled too.
! Recompile callers if the word's stack effect changed, then
! save the word's dependencies so that if they change, the
! word can get recompiled too.
[ compiled-unxref ]
[
dup crossref? [
@ -67,8 +67,8 @@ M: word combinator? inline? ;
] bi ;
: deoptimize-with ( word def -- * )
#! If the word failed to infer, compile it with the
#! non-optimizing compiler.
! If the word failed to infer, compile it with the
! non-optimizing compiler.
swap [ finish ] [ compiled get set-at ] bi return ;
: not-compiled-def ( word error -- def )
@ -86,10 +86,10 @@ M: word combinator? inline? ;
2bi ;
: deoptimize ( word error -- * )
#! If the error is ignorable, compile the word with the
#! non-optimizing compiler, using its definition. Otherwise,
#! if the compiler error is not ignorable, use a dummy
#! definition from 'not-compiled-def' which throws an error.
! If the error is ignorable, compile the word with the
! non-optimizing compiler, using its definition. Otherwise,
! if the compiler error is not ignorable, use a dummy
! definition from 'not-compiled-def' which throws an error.
{
{ [ dup inference-error? not ] [ rethrow ] }
{ [ 2dup ignore-error? ] [ ignore-error ] }
@ -106,8 +106,8 @@ M: word combinator? inline? ;
dependencies get keys [ "break?" word-prop ] any? ;
: frontend ( word -- tree )
#! If the word contains breakpoints, don't optimize it, since
#! the walker does not support this.
! If the word contains breakpoints, don't optimize it, since
! the walker does not support this.
dup optimize? [
[ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
contains-breakpoints? [ nip deoptimize* ] [ drop ] if
@ -124,8 +124,8 @@ M: word combinator? inline? ;
] each ;
: compile-word ( word -- )
#! We return early if the word has breakpoints or if it
#! failed to infer.
! We return early if the word has breakpoints or if it
! failed to infer.
'[
_ {
[ start ]
@ -138,8 +138,8 @@ M: word combinator? inline? ;
SINGLETON: optimizing-compiler
M: optimizing-compiler update-call-sites ( class generic -- words )
#! Words containing call sites with inferred type 'class'
#! which inlined a method on 'generic'
! Words containing call sites with inferred type 'class'
! which inlined a method on 'generic'
generic-call-sites-of keys swap '[
_ 2dup [ valid-classoid? ] both?
[ classes-intersect? ] [ 2drop f ] if

20
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -24,8 +24,8 @@ M: node delete-node drop ;
GENERIC: cleanup-tree* ( node -- node/nodes )
: cleanup-tree ( nodes -- nodes' )
#! We don't recurse into children here, instead the methods
#! do it since the logic is a bit more involved
! We don't recurse into children here, instead the methods
! do it since the logic is a bit more involved
[ cleanup-tree* ] map-flat ;
! Constant folding
@ -34,8 +34,8 @@ GENERIC: cleanup-tree* ( node -- node/nodes )
[ f ] [ [ literal?>> ] all? ] if-empty ;
: (cleanup-folding) ( #call -- nodes )
#! Replace a #call having a known result with a #drop of its
#! inputs followed by #push nodes for the outputs.
! Replace a #call having a known result with a #drop of its
! inputs followed by #push nodes for the outputs.
[
[ node-output-infos ] [ out-d>> ] bi
[ [ literal>> ] dip <#push> ] 2map
@ -114,8 +114,8 @@ M: #call cleanup-tree*
] change-children drop ;
: fold-only-branch ( #branch -- node/nodes )
#! If only one branch is live we don't need to branch at
#! all; just drop the condition value.
! If only one branch is live we don't need to branch at
! all; just drop the condition value.
dup live-children sift dup length {
{ 0 [ drop in-d>> <#drop> ] }
{ 1 [ first swap in-d>> <#drop> prefix ] }
@ -152,7 +152,7 @@ M: #branch cleanup-tree*
} case ;
M: #phi cleanup-tree*
#! Remove #phi function inputs which no longer exist.
! Remove #phi function inputs which no longer exist.
live-branches get
[ '[ _ sift-children ] change-phi-in-d ]
[ '[ _ sift-children ] change-phi-info-d ]
@ -163,14 +163,14 @@ M: #phi cleanup-tree*
: >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi <#copy> ;
: flatten-recursive ( #recursive -- nodes )
#! convert #enter-recursive and #return-recursive into
#! #copy nodes.
! convert #enter-recursive and #return-recursive into
! #copy nodes.
child>>
unclip >copy prefix
unclip-last >copy suffix ;
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
dup label>> calls>> empty? [ flatten-recursive ] when ;

4
basis/compiler/tree/dead-code/branches/branches.factor
View File

@ -14,8 +14,8 @@ M: #dispatch mark-live-values* look-at-inputs ;
[ index ] dip swap [ <column> look-at-values ] [ drop ] if* ;
M: #phi compute-live-values*
#! If any of the outputs of a #phi are live, then the
#! corresponding inputs are live too.
! If any of the outputs of a #phi are live, then the
! corresponding inputs are live too.
[ out-d>> ] [ phi-in-d>> ] bi look-at-phi ;
SYMBOL: if-node

8
basis/compiler/tree/dead-code/recursive/recursive.factor
View File

@ -8,16 +8,16 @@ stack-checker.backend ;
IN: compiler.tree.dead-code.recursive
M: #enter-recursive compute-live-values*
#! If the output of an #enter-recursive is live, then the
#! corresponding inputs to the #call-recursive are live also.
! If the output of an #enter-recursive is live, then the
! corresponding inputs to the #call-recursive are live also.
[ out-d>> ] [ recursive-phi-in ] bi look-at-phi ;
M: #return-recursive compute-live-values*
[ out-d>> ] [ in-d>> ] bi look-at-mapping ;
M: #call-recursive compute-live-values*
#! If the output of a #call-recursive is live, then the
#! corresponding inputs to #return nodes are live also.
! If the output of a #call-recursive is live, then the
! corresponding inputs to #return nodes are live also.
[ out-d>> ] [ label>> return>> in-d>> ] bi look-at-mapping ;
:: drop-dead-inputs ( inputs outputs -- #shuffle )

8
basis/compiler/tree/dead-code/simple/simple.factor
View File

@ -26,8 +26,8 @@ M: #return mark-live-values* look-at-inputs ;
[ index ] dip over [ nth look-at-value ] [ 2drop ] if ;
M: #copy compute-live-values*
#! If the output of a copy is live, then the corresponding
#! input is live also.
! If the output of a copy is live, then the corresponding
! input is live also.
[ out-d>> ] [ in-d>> ] bi look-at-mapping ;
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 ;
: filter-corresponding ( new old -- old' )
#! Remove elements from 'old' if the element with the same
#! index in 'new' is dead.
! Remove elements from 'old' if the element with the same
! index in 'new' is dead.
zip filter-mapping values ;
: filter-live ( values -- values' )

2
basis/compiler/tree/escape-analysis/recursive/recursive.factor
View File

@ -53,7 +53,7 @@ M: #recursive escape-analysis* ( #recursive -- )
] bi ;
M: #enter-recursive escape-analysis* ( #enter-recursive -- )
#! Handled by #recursive
! Handled by #recursive
drop ;
M: #call-recursive escape-analysis* ( #call-label -- )

6
basis/compiler/tree/normalization/introductions/introductions.factor
View File

@ -9,9 +9,9 @@ SYMBOL: introductions
GENERIC: count-introductions* ( node -- )
: count-introductions ( nodes -- n )
#! Note: we use each, not each-node, since the #branch
#! method recurses into children directly and we don't
#! recurse into #recursive at all.
! Note: we use each, not each-node, since the #branch
! method recurses into children directly and we don't
! recurse into #recursive at all.
[
0 introductions set
[ count-introductions* ] each

6
basis/compiler/tree/propagation/info/info.factor
View File

@ -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 }
: interval>literal ( class interval -- literal literal? )
#! If interval has zero length and the class is sufficiently
#! precise, we can turn it into a literal
! If interval has zero length and the class is sufficiently
! precise, we can turn it into a literal
dup special-interval? [
2drop f f
] [
@ -60,7 +60,7 @@ DEFER: <literal-info>
UNION: fixed-length array byte-array string ;
: literal-class ( obj -- class )
#! Handle forgotten tuples and singleton classes properly
! Handle forgotten tuples and singleton classes properly
dup singleton-class? [
class-of dup class? [
drop tuple

12
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -42,9 +42,9 @@ M: anonymous-intersection add-depends-on-class
participants>> [ add-depends-on-class ] each ;
M: #declare propagate-before
#! We need to force the caller word to recompile when the
#! classes mentioned in the declaration are redefined, since
#! now we're making assumptions about their definitions.
! We need to force the caller word to recompile when the
! classes mentioned in the declaration are redefined, since
! now we're making assumptions about their definitions.
declaration>> [
[ add-depends-on-class ]
[ <class-info> swap refine-value-info ]
@ -121,9 +121,9 @@ ERROR: invalid-outputs #call infos ;
if ;
: propagate-predicate ( #call word -- infos )
#! We need to force the caller word to recompile when the class
#! is redefined, since now we're making assumptions but the
#! class definition itself.
! We need to force the caller word to recompile when the class
! is redefined, since now we're making assumptions but the
! class definition itself.
[ in-d>> first value-info ]
[ "predicating" word-prop ] bi*
[ nip add-depends-on-conditionally ]

14
basis/compiler/tree/propagation/slots/slots.factor
View File

@ -51,13 +51,13 @@ IN: compiler.tree.propagation.slots
dup [ read-only>> ] when ;
: literal-info-slot ( slot object -- info/f )
#! literal-info-slot makes an unsafe call to 'slot'.
#! Check that the layout is up to date to avoid accessing the
#! wrong slot during a compilation unit where reshaping took
#! place. This could happen otherwise because the "slots" word
#! property would reflect the new layout, but instances in the
#! heap would use the old layout since instances are updated
#! immediately after compilation.
! literal-info-slot makes an unsafe call to 'slot'.
! Check that the layout is up to date to avoid accessing the
! wrong slot during a compilation unit where reshaping took
! place. This could happen otherwise because the "slots" word
! property would reflect the new layout, but instances in the
! heap would use the old layout since instances are updated
! immediately after compilation.
{
[ class-of read-only-slot? ]
[ nip layout-up-to-date? ]

2
basis/compiler/tree/propagation/transforms/transforms.factor
View File

@ -246,7 +246,7 @@ ERROR: bad-partial-eval quot word ;
CONSTANT: lookup-table-at-max 256
: 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 > ]
[ values [ ] all? ]

2
basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
View File

@ -67,7 +67,7 @@ M: #call unbox-tuples*
} case ;
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 ;
M: #copy unbox-tuples*

4
basis/concurrency/conditions/conditions.factor
View File

@ -10,8 +10,8 @@ IN: concurrency.conditions
[ resume-now ] slurp-deque ; inline
: queue-timeout ( queue timeout -- timer )
#! Add an timer which removes the current thread from the
#! queue, and resumes it, passing it a value of t.
! Add an timer which removes the current thread from the
! queue, and resumes it, passing it a value of t.
[
[ self swap push-front* ] keep '[
_ _

10
basis/concurrency/locks/locks.factor
View File

@ -85,14 +85,14 @@ TUPLE: rw-lock readers writers reader# writer ;
[ notify-writer ] [ readers>> notify-all ] if ;
: reentrant-read-lock-ok? ( lock -- ? )
#! If we already have a write lock, then we can grab a read
#! lock too.
! If we already have a write lock, then we can grab a read
! lock too.
writer>> self eq? ;
: reentrant-write-lock-ok? ( lock -- ? )
#! The only case where we have a writer and > 1 reader is
#! write -> read re-entrancy, and in this case we prohibit
#! a further write -> read -> write re-entrancy.
! The only case where we have a writer and > 1 reader is
! write -> read re-entrancy, and in this case we prohibit
! a further write -> read -> write re-entrancy.
{ [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;
PRIVATE>

10
basis/cpu/x86/32/32.factor
View File

@ -189,16 +189,16 @@ M: x86.32 %end-callback ( -- )
"end_callback" f f %c-invoke ;
: funny-large-struct-return? ( return abi -- ? )
#! MINGW ABI incompatibility disaster
! MINGW ABI incompatibility disaster
[ large-struct? ] [ mingw eq? os windows? not or ] bi* and ;
M: x86.32 %prepare-var-args ( -- ) ;
M:: x86.32 stack-cleanup ( stack-size return abi -- n )
#! a) Functions which are stdcall/fastcall/thiscall have to
#! clean up the caller's stack frame.
#! b) Functions returning large structs on MINGW have to
#! fix ESP.
! a) Functions which are stdcall/fastcall/thiscall have to
! clean up the caller's stack frame.
! b) Functions returning large structs on MINGW have to
! fix ESP.
{
{ [ abi callee-cleanup? ] [ stack-size ] }
{ [ return abi funny-large-struct-return? ] [ 4 ] }

18
basis/cpu/x86/assembler/assembler.factor
View File

@ -116,7 +116,7 @@ M: register displacement, drop ;
and and ;
:: 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 ?
reg rex.r
r/m rex.b
@ -129,8 +129,8 @@ M: register displacement, drop ;
[ drop 16-prefix ] [ [ f ] 2dip rex-prefix ] 2bi ;
: short-operand ( reg rex.w n -- )
#! Some instructions encode their single operand as part of
#! the opcode.
! Some instructions encode their single operand as part of
! the opcode.
[ dupd prefix-1 reg-code ] dip + , ;
: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
@ -145,8 +145,8 @@ M: register displacement, drop ;
[ [ unclip-last ] dip bitor suffix ] [ bitor ] if ;
: 1-operand ( operand reg,rex.w,opcode -- )
#! The 'reg' is not really a register, but a value for the
#! 'reg' field of the mod-r/m byte.
! The 'reg' is not really a register, but a value for the
! 'reg' field of the mod-r/m byte.
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 )
@ -165,10 +165,10 @@ M: register displacement, drop ;
over integer? [ first3 0b10 opcode-or 3array ] when ;
: immediate-1/4 ( dst imm reg,rex.w,opcode -- )
#! If imm is a byte, compile the opcode and the byte.
#! Otherwise, set the 8-bit operand flag in the opcode, and
#! compile the cell. The 'reg' is not really a register, but
#! a value for the 'reg' field of the mod-r/m byte.
! If imm is a byte, compile the opcode and the byte.
! Otherwise, set the 8-bit operand flag in the opcode, and
! compile the cell. The 'reg' is not really a register, but
! a value for the 'reg' field of the mod-r/m byte.
over fits-in-byte? [
immediate-fits-in-size-bit immediate-1
] [

6
basis/cpu/x86/assembler/operands/operands.factor
View File

@ -59,7 +59,7 @@ M: indirect extended? base>> extended? ;
[ f >>displacement ] when ;
: canonicalize-EBP ( indirect -- indirect )
#! { EBP } ==> { EBP 0 }
! { EBP } ==> { EBP 0 }
dup [ base>> { EBP RBP R13 } member? ] [ displacement>> not ] bi and
[ 0 >>displacement ] when ;
@ -69,8 +69,8 @@ ERROR: bad-index indirect ;
dup index>> { ESP RSP } member-eq? [ bad-index ] when ;
: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
#! quirks.
! Modify the indirect to work around certain addressing mode
! quirks.
canonicalize-displacement canonicalize-EBP check-ESP ;
! Utilities

16
basis/cpu/x86/x86.factor
View File

@ -104,7 +104,7 @@ M: x86 %inc ( loc -- )
M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
: xt-tail-pic-offset ( -- n )
#! See the comment in vm/cpu-x86.hpp
! See the comment in vm/cpu-x86.hpp
4 1 + ; inline
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 ;
: next-stack@ ( n -- operand )
#! nth parameter from the next stack frame. Used to box
#! input values to callbacks; the callback has its own
#! stack frame set up, and we want to read the frame
#! set up by the caller.
! nth parameter from the next stack frame. Used to box
! input values to callbacks; the callback has its own
! stack frame set up, and we want to read the frame
! set up by the caller.
[ frame-reg ] dip 2 cells + reserved-stack-space + [+] ;
: return-reg ( rep -- reg )
@ -686,9 +686,9 @@ M: x86 %callback-outputs ( reg-inputs -- )
M: x86 %loop-entry 16 alignment [ NOP ] times ;
M:: x86 %save-context ( temp1 temp2 -- )
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
! Save Factor stack pointers in case the C code calls a
! callback which does a GC, which must reliably trace
! all roots.
temp1 %context
temp2 stack-reg cell neg [+] LEA
temp1 "callstack-top" context-field-offset [+] temp2 MOV

2
basis/db/queries/queries.factor
View File

@ -47,7 +47,7 @@ M: retryable execute-statement* ( statement type -- )
[ db-columns ] [ db-table-name ] bi ;
: query-make ( class quot -- statements )
#! query, input, outputs, secondary queries
! query, input, outputs, secondary queries
over db-table-name "table-name" set
[ sql-props ] dip
[ 0 sql-counter rot with-variable ] curry

2
basis/db/sqlite/lib/lib.factor
View File

@ -117,7 +117,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
} case ;
: 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 [
NULL = [ 2drop NULL NULL ] when
] [

2
basis/furnace/chloe-tags/chloe-tags.factor
View File

@ -55,7 +55,7 @@ CHLOE: atom
CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
: compile-link-attrs ( tag -- )
#! Side-effects current namespace.
! Side-effects current namespace.
'[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
: process-attrs ( assoc -- newassoc )

2
basis/furnace/utilities/utilities.factor
View File

@ -92,7 +92,7 @@ M: object modify-form drop f ;
CONSTANT: nested-forms-key "__n"
: 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
dup [ >url ensure-port [ remap-port ] change-port ] when ;

2
basis/help/markup/markup.factor
View File

@ -136,7 +136,7 @@ ALIAS: $slot $snippet
] ($code) ;
: $unchecked-example ( element -- )
#! help-lint ignores these.
! help-lint ignores these.
$example ;
: $markup-example ( element -- )

2
basis/html/components/components.factor
View File

@ -65,7 +65,7 @@ TUPLE: password size ;
password new ;
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 ;
! Text areas

2
basis/http/http.factor
View File

@ -32,7 +32,7 @@ CONSTANT: max-redirects 10
} cond ;
: 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?
[ "Header injection attack" throw ] when ;

8
basis/http/parsers/parsers.factor
View File

@ -67,7 +67,7 @@ IN: http.parsers
] seq* [ "1.0" suffix! ] action ;
PEG: parse-request-line ( string -- triple )
#! Triple is { method url version }
! Triple is { method url version }
full-request-parser simple-request-parser 2array choice ;
: text-parser ( -- parser )
@ -80,7 +80,7 @@ PEG: parse-request-line ( string -- triple )
text-parser repeat0 case-sensitive ;
PEG: parse-response-line ( string -- triple )
#! Triple is { version code message }
! Triple is { version code message }
[
space-parser ,
http-version-parser ,
@ -120,8 +120,8 @@ PEG: parse-response-line ( string -- triple )
2choice ;
PEG: parse-header-line ( string -- pair )
#! Pair is either { name value } or { f value }. If f, its a
#! continuation of the previous header line.
! Pair is either { name value } or { f value }. If f, its a
! continuation of the previous header line.
[
field-name-parser ,
space-parser ,

2
basis/http/server/cgi/cgi.factor
View File

@ -7,7 +7,7 @@ math.parser fry urls urls.encoding calendar make ;
IN: http.server.cgi
: cgi-variables ( script-path -- assoc )
#! This needs some work.
! This needs some work.
[
"CGI/1.0" "GATEWAY_INTERFACE" ,,
"HTTP/" request get version>> append "SERVER_PROTOCOL" ,,

4
basis/http/server/server.factor
View File

@ -57,8 +57,8 @@ GENERIC: write-full-response ( request response -- )
] change-domain ;
: write-response-header ( response -- response )
#! We send one set-cookie header per cookie, because that's
#! what Firefox expects.
! We send one set-cookie header per cookie, because that's
! what Firefox expects.
dup header>> >alist >vector
over unparse-content-type "content-type" pick set-at
over cookies>> [

2
basis/inspector/inspector.factor
View File

@ -100,7 +100,7 @@ PRIVATE>
: &rename ( key n -- ) key@ mirror get rename-at &push reinspect ;
: &help ( -- )
#! A tribute to Slate:
! A tribute to Slate:
"You are in a twisty little maze of objects, all alike." print
nl
"'n' is a slot number in the following:" print

2
basis/io/files/info/unix/unix.factor
View File

@ -197,7 +197,7 @@ CONSTANT: ALL-EXECUTE 0o0000111
PRIVATE>
: set-file-times ( path timestamps -- )
#! set access, write
! set access, write
[ normalize-path ] dip
timestamps>byte-array [ utimes ] unix-system-call drop ;

2
basis/io/files/info/windows/windows.factor
View File

@ -224,7 +224,7 @@ M: windows file-systems ( -- array )
] with-destructors ;
: 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>>

2
basis/io/files/windows/windows.factor
View File

@ -253,7 +253,7 @@ M: windows init-stdio
f CreateFileW dup win32-error=0/f <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 }
share-mode
f

4
basis/io/launcher/windows/windows.factor
View File

@ -148,8 +148,8 @@ M: windows (kill-process) ( process -- )
handle>> hProcess>> 255 TerminateProcess win32-error=0/f ;
: dispose-process ( process-information -- )
#! From MSDN: "Handles in PROCESS_INFORMATION must be closed
#! with CloseHandle when they are no longer needed."
! From MSDN: "Handles in PROCESS_INFORMATION must be closed
! with CloseHandle when they are no longer needed."
[ hProcess>> [ CloseHandle drop ] when* ]
[ hThread>> [ CloseHandle drop ] when* ] bi ;

2
basis/io/monitors/recursive/recursive.factor
View File

@ -19,7 +19,7 @@ DEFER: add-child-monitor
monitor tget path>> prepend-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 [
[ append-path ] with map
[ add-child-monitor ] each yield

8
basis/io/sockets/secure/unix/unix.factor
View File

@ -32,10 +32,10 @@ M: secure (accept)
] with-destructors ;
: check-shutdown-response ( handle r -- event )
#! We don't do two-step shutdown here because I couldn't
#! figure out how to do it with non-blocking BIOs. Also, it
#! seems that SSL_shutdown always returns 0 -- this sounds
#! like a bug
! We don't do two-step shutdown here because I couldn't
! figure out how to do it with non-blocking BIOs. Also, it
! seems that SSL_shutdown always returns 0 -- this sounds
! like a bug
over handle>> over SSL_get_error
{
{ SSL_ERROR_NONE [ 2drop f ] }

6
basis/io/streams/duplex/duplex.factor
View File

@ -27,9 +27,9 @@ M: duplex-stream set-timeout
>duplex-stream< [ set-timeout ] bi-curry@ bi ;
M: duplex-stream dispose
#! The output stream is closed first, in case both streams
#! are attached to the same file descriptor, the output
#! buffer needs to be flushed before we close the fd.
! The output stream is closed first, in case both streams
! are attached to the same file descriptor, the output
! buffer needs to be flushed before we close the fd.
[ >duplex-stream< [ &dispose drop ] bi@ ] with-destructors ;
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )

2
basis/json/writer/writer.factor
View File

@ -28,7 +28,7 @@ GENERIC# stream-json-print 1 ( obj stream -- )
output-stream get stream-json-print ;
: >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 ;
M: f stream-json-print

4
basis/locals/prettyprint/prettyprint.factor
View File

@ -5,8 +5,8 @@ prettyprint.custom prettyprint.sections sequences words ;
IN: locals.prettyprint
: pprint-var ( var -- )
#! Prettyprint a read/write local as its writer, just like
#! in the input syntax: [| x! | ... x 3 + x! ]
! Prettyprint a read/write local as its writer, just like
! in the input syntax: [| x! | ... x 3 + x! ]
dup local-reader? [
"local-writer" word-prop
] when pprint-word ;

4
basis/locals/rewrite/closures/closures.factor
View File

@ -44,8 +44,8 @@ M: quotation uses-vars* [ uses-vars* ] each ;
[ uses-vars ] [ defs-vars ] bi diff ;
M: callable rewrite-closures*
#! Turn free variables into bound variables, curry them
#! onto the body
! Turn free variables into bound variables, curry them
! onto the body
dup free-vars [ <quote> ] map
[ % ]
[ var-defs prepend (rewrite-closures) point-free , ]

2
basis/locals/types/types.factor
View File

@ -29,7 +29,7 @@ C: <multi-def> multi-def
PREDICATE: local < word "local?" word-prop ;
: <local> ( name -- word )
#! Create a local variable identifier
! Create a local variable identifier
f <word>
dup t "local?" set-word-prop ;

2
basis/logging/logging.factor
View File

@ -137,7 +137,7 @@ PRIVATE>
(define-logging) ;
SYNTAX: LOG:
#! Syntax: name level
! Syntax: name level
scan-new-word dup scan-word
'[ 1array stack>message _ _ log-message ]
( message -- ) define-declared ;

2
basis/logging/server/server.factor
View File

@ -52,7 +52,7 @@ SYMBOL: log-files
] unless-empty ;
: (log-message) ( msg -- )
#! msg: { msg word-name level service }
! msg: { msg word-name level service }
first4 log-stream [ write-message flush ] with-output-stream* ;
: try-dispose ( obj -- )

2
basis/math/functions/functions.factor
View File

@ -11,7 +11,7 @@ M: real sqrt
[ neg fsqrt [ 0.0 ] dip rect> ] [ fsqrt ] if ; inline
: factor-2s ( n -- r s )
#! factor an integer into 2^r * s
! factor an integer into 2^r * s
dup 0 = [ 1 ] [
[ 0 ] dip [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
] if ; inline

12
basis/math/intervals/intervals.factor
View File

@ -221,7 +221,7 @@ MEMO: array-capacity-interval ( -- interval )
] dip [ 2drop [-inf,inf] ] if ; inline
: interval-shift ( i1 i2 -- i3 )
#! Inaccurate; could be tighter
! Inaccurate; could be tighter
[
[
[ interval-closure ] bi@
@ -274,8 +274,8 @@ MEMO: array-capacity-interval ( -- interval )
[ [ [ / ] interval-op nan-not-ok ] interval-division-op ] do-empty-interval ;
: interval/-safe ( i1 i2 -- i3 )
#! Just a hack to make the compiler work if bootstrap.math
#! is not loaded.
! Just a hack to make the compiler work if bootstrap.math
! is not loaded.
\ integer \ / ?lookup-method [ interval/ ] [ 2drop f ] if ;
: interval/i ( i1 i2 -- i3 )
@ -387,7 +387,7 @@ SYMBOL: incomparable
from>> first 0 >= ;
: interval-bitand ( i1 i2 -- i3 )
#! Inaccurate.
! Inaccurate.
[
{
{
@ -403,7 +403,7 @@ SYMBOL: incomparable
] do-empty-interval ;
: interval-bitor ( i1 i2 -- i3 )
#! Inaccurate.
! Inaccurate.
[
2dup [ interval-nonnegative? ] both?
[
@ -413,7 +413,7 @@ SYMBOL: incomparable
] do-empty-interval ;
: interval-bitxor ( i1 i2 -- i3 )
#! Inaccurate.
! Inaccurate.
interval-bitor ;
: interval-log2 ( i1 -- i2 )

2
basis/math/matrices/elimination/elimination.factor
View File

@ -24,7 +24,7 @@ SYMBOL: matrix
over [ find-from drop ] dip swap [ nip ] [ length ] if* ; inline
: first-col ( row# -- n )
#! First non-zero column
! First non-zero column
0 swap nth-row [ zero? not ] skip ;
: clear-scale ( col# pivot-row i-row -- n )

4
basis/math/statistics/statistics.factor
View File

@ -61,7 +61,7 @@ PRIVATE>
<PRIVATE
:: ((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
0 :> i!
0 :> j!
@ -90,7 +90,7 @@ PRIVATE>
k seq nth-unsafe ; inline
: (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
: kth-object-unsafe ( seq k quot: ( x y -- ? ) -- elt )

14
basis/math/vectors/simd/simd-tests.factor
View File

@ -139,13 +139,13 @@ TUPLE: simd-test-failure
--
failures
)
#! Use test-quot to generate a bunch of test cases from the
#! given inputs. Run each test case optimized and
#! unoptimized. Compare results with eq-quot.
#!
#! seq: sequence of inputs
#! test-quot: ( input -- input-quot: ( -- ..v ) code-quot: ( ..v -- result ) )
#! eq-quot: ( result1 result2 -- ? )
! Use test-quot to generate a bunch of test cases from the
! given inputs. Run each test case optimized and
! unoptimized. Compare results with eq-quot.
!
! seq: sequence of inputs
! test-quot: ( input -- input-quot: ( -- ..v ) code-quot: ( ..v -- result ) )
! eq-quot: ( result1 result2 -- ? )
seq [| input |
input test-quot call :> ( input-quot code-quot )
input-quot [ class-of ] { } map-as :> input-classes

8
basis/opengl/opengl.factor
View File

@ -104,9 +104,9 @@ MACRO: all-enabled-client-state ( seq quot -- quot )
line-vertices GL_LINES 0 2 glDrawArrays ;
:: (rect-vertices) ( loc dim -- vertices )
#! We use GL_LINE_STRIP with a duplicated first vertex
#! instead of GL_LINE_LOOP to work around a bug in Apple's
#! X3100 driver.
! We use GL_LINE_STRIP with a duplicated first vertex
! instead of GL_LINE_LOOP to work around a bug in Apple's
! X3100 driver.
loc first2 [ 0.3 + ] bi@ :> ( x y )
dim first2 [ 0.6 - ] bi@ :> ( w h )
[
@ -226,7 +226,7 @@ MACRO: set-draw-buffers ( buffers -- quot )
fix-coordinates glViewport ;
: init-matrices ( -- )
#! Leaves with matrix mode GL_MODELVIEW
! Leaves with matrix mode GL_MODELVIEW
GL_PROJECTION glMatrixMode
glLoadIdentity
GL_MODELVIEW glMatrixMode

8
basis/opengl/textures/textures.factor
View File

@ -12,8 +12,8 @@ IN: opengl.textures
SYMBOL: non-power-of-2-textures?
: check-extensions ( -- )
#! 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
! 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
gl-vendor "ATI Technologies Inc." = not os macosx? or [
"2.0" { "GL_ARB_texture_non_power_of_two" }
has-gl-version-or-extensions?
@ -409,8 +409,8 @@ CONSTANT: max-texture-size { 512 512 }
PRIVATE>
: make-texture ( image -- id )
#! We use glTexSubImage2D to work around the power of 2 texture size
#! limitation
! We use glTexSubImage2D to work around the power of 2 texture size
! limitation
gen-texture [
GL_TEXTURE_BIT [
GL_TEXTURE_2D swap glBindTexture

16
basis/peg/ebnf/ebnf-tests.factor
View File

@ -266,20 +266,20 @@ IN: peg.ebnf.tests
] must-fail
{ V{ V{ 49 } "+" V{ 49 } } } [
#! Test direct left recursion.
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
! Test direct left recursion.
! 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]
] unit-test
{ V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [
#! Test direct left recursion.
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
! Test direct left recursion.
! 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]
] unit-test
{ V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [
#! Test indirect left recursion.
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
! Test indirect left recursion.
! 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]
] unit-test
@ -511,8 +511,8 @@ foo=<foreign any-char> 'd'
] must-fail
{ t } [
#! 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.
! 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.
[ "fail" "foo" set "foo='a'" ebnf-parser parse transform drop t ] with-scope
] unit-test

86
basis/peg/ebnf/ebnf.factor
View File

@ -10,7 +10,7 @@ FROM: peg.search => replace ;
IN: peg.ebnf
: 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 ;
ERROR: no-rule rule parser ;
@ -85,17 +85,17 @@ C: <ebnf-semantic> ebnf-semantic
C: <ebnf> ebnf
: 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 ;
: syntax ( string -- parser )
#! Parses the string, ignoring white space, and
#! does not put the result in the AST.
! Parses the string, ignoring white space, and
! does not put the result in the AST.
token sp hide ;
: syntax-pack ( begin parser end -- parser )
#! Parse parser-parser surrounded by syntax elements
#! begin and end.
! Parse parser-parser surrounded by syntax elements
! begin and end.
[ syntax ] 2dip syntax pack ;
: insert-escapes ( string -- string )
@ -106,10 +106,10 @@ C: <ebnf> ebnf
] choice* replace ;
: identifier-parser ( -- parser )
#! Return a parser that parses an identifer delimited by
#! a quotation character. The quotation can be single
#! or double quotes. The AST produced is the identifier
#! between the quotes.
! Return a parser that parses an identifer delimited by
! a quotation character. The quotation can be single
! or double quotes. The AST produced is the identifier
! between the quotes.
[
[
[ CHAR: \ = ] satisfy
@ -120,9 +120,9 @@ C: <ebnf> ebnf
] choice* [ "" flatten-as unescape-string ] action ;
: non-terminal-parser ( -- parser )
#! A non-terminal is the name of another rule. It can
#! be any non-blank character except for characters used
#! in the EBNF syntax itself.
! A non-terminal is the name of another rule. It can
! be any non-blank character except for characters used
! in the EBNF syntax itself.
[
{
[ blank? ]
@ -131,12 +131,12 @@ C: <ebnf> ebnf
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
: terminal-parser ( -- parser )
#! A terminal is an identifier enclosed in quotations
#! and it represents the literal value of the identifier.
! A terminal is an identifier enclosed in quotations
! and it represents the literal value of the identifier.
identifier-parser [ <ebnf-terminal> ] action ;
: foreign-name-parser ( -- parser )
#! Parse a valid foreign parser name
! Parse a valid foreign parser name
[
{
[ blank? ]
@ -145,7 +145,7 @@ C: <ebnf> ebnf
] satisfy repeat1 [ >string ] action ;
: 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-name-parser sp ,
@ -154,11 +154,11 @@ C: <ebnf> ebnf
] seq* [ first2 <ebnf-foreign> ] action ;
: 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 ;
: range-parser-parser ( -- parser )
#! Match the syntax for declaring character ranges
! Match the syntax for declaring character ranges
[
[ "[" syntax , "[" token ensure-not , ] seq* hide ,
[ CHAR: ] = not ] satisfy repeat1 ,
@ -166,10 +166,10 @@ C: <ebnf> ebnf
] seq* [ first >string unescape-string <ebnf-range> ] action ;
: (element-parser) ( -- parser )
#! An element of a rule. It can be a terminal or a
#! non-terminal but must not be followed by a "=".
#! The latter indicates that it is the beginning of a
#! new rule.
! An element of a rule. It can be a terminal or a
! non-terminal but must not be followed by a "=".
! The latter indicates that it is the beginning of a
! new rule.
[
[
[
@ -206,9 +206,9 @@ DEFER: action-parser
DEFER: choice-parser
: grouped ( quot suffix -- parser )
#! Parse a group of choices, with a suffix indicating
#! the type of group (repeat0, repeat1, etc) and
#! an quot that is the action that produces the AST.
! Parse a group of choices, with a suffix indicating
! the type of group (repeat0, repeat1, etc) and
! an quot that is the action that produces the AST.
2dup
[
"(" [ choice-parser sp ] delay ")" syntax-pack
@ -220,7 +220,7 @@ DEFER: choice-parser
] choice* ;
: 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 ,
@ -248,26 +248,26 @@ DEFER: choice-parser
] seq* repeat0 [ "" concat-as ] action ;
: ensure-not-parser ( -- parser )
#! Parses the '!' syntax to ensure that
#! something that matches the following elements do
#! not exist in the parse stream.
! Parses the '!' syntax to ensure that
! something that matches the following elements do
! not exist in the parse stream.
[
"!" syntax ,
group-parser sp ,
] seq* [ first <ebnf-ensure-not> ] action ;
: ensure-parser ( -- parser )
#! Parses the '&' syntax to ensure that
#! something that matches the following elements does
#! exist in the parse stream.
! Parses the '&' syntax to ensure that
! something that matches the following elements does
! exist in the parse stream.
[
"&" syntax ,
group-parser sp ,
] seq* [ first <ebnf-ensure> ] action ;
: (sequence-parser) ( -- parser )
#! A sequence of terminals and non-terminals, including
#! groupings of those.
! A sequence of terminals and non-terminals, including
! groupings of those.
[
[
ensure-not-parser sp ,
@ -290,8 +290,8 @@ DEFER: choice-parser
"?[" factor-code-parser "]?" syntax-pack ;
: sequence-parser ( -- parser )
#! A sequence of terminals and non-terminals, including
#! groupings of those.
! A sequence of terminals and non-terminals, including
! groupings of those.
[
[ (sequence-parser) , action-parser , ] seq*
[ first2 <ebnf-action> ] action ,
@ -375,9 +375,9 @@ M: ebnf-rule (transform) ( ast -- parser )
] keep ;
M: ebnf-sequence (transform) ( ast -- parser )
#! If ignore-ws is set then each element of the sequence
#! ignores leading whitespace. This is not inherited by
#! subelements of the sequence.
! If ignore-ws is set then each element of the sequence
! ignores leading whitespace. This is not inherited by
! subelements of the sequence.
elements>> [
f ignore-ws [ (transform) ] with-variable
ignore-ws get [ sp ] when
@ -393,7 +393,7 @@ M: ebnf-range (transform) ( ast -- parser )
pattern>> range-pattern ;
: 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) ;
M: ebnf-ensure (transform) ( ast -- parser )
@ -420,8 +420,8 @@ M: ebnf-whitespace (transform) ( ast -- parser )
GENERIC: build-locals ( code ast -- code )
M: ebnf-sequence build-locals ( code ast -- code )
#! Note the need to filter out this ebnf items that
#! leave nothing in the AST
! Note the need to filter out this ebnf items that
! leave nothing in the AST
elements>> filter-hidden dup length 1 = [
first build-locals
] [

20
basis/peg/parsers/parsers.factor
View File

@ -81,8 +81,8 @@ PRIVATE>
] seq* [ first >string ] action ;
: (range-pattern) ( pattern -- string )
#! Given a range pattern, produce a string containing
#! all characters within that range.
! Given a range pattern, produce a string containing
! all characters within that range.
[
any-char ,
[ CHAR: - = ] satisfy hide ,
@ -93,14 +93,14 @@ PRIVATE>
replace ;
: range-pattern ( pattern -- parser )
#! 'pattern' is a set of characters describing the
#! parser to be produced. Any single character in
#! the pattern matches that character. If the pattern
#! begins with a ^ then the set is negated (the element
#! matches any character not in the set). Any pair of
#! characters separated with a dash (-) represents the
#! range of characters from the first to the second,
#! inclusive.
! 'pattern' is a set of characters describing the
! parser to be produced. Any single character in
! the pattern matches that character. If the pattern
! begins with a ^ then the set is negated (the element
! matches any character not in the set). Any pair of
! characters separated with a dash (-) represents the
! range of characters from the first to the second,
! inclusive.
dup first CHAR: ^ = [
rest (range-pattern) [ member? not ] curry satisfy
] [

6
basis/peg/peg-tests.factor
View File

@ -172,8 +172,8 @@ IN: peg.tests
] unit-test
: expr ( -- parser )
#! Test direct left recursion. Currently left recursion should cause a
#! failure of that parser.
! Test direct left recursion. Currently left recursion should cause a
! failure of that parser.
[ expr ] delay "+" token "1" token 3seq "1" token 2choice ;
{ V{ V{ "1" "+" "1" } "+" "1" } } [
@ -181,7 +181,7 @@ IN: peg.tests
] unit-test
{ t } [
#! Ensure a circular parser doesn't loop infinitely
! Ensure a circular parser doesn't loop infinitely
[ f , "a" token , ] seq*
dup peg>> parsers>>
dupd 0 swap set-nth compile word?

116
basis/peg/peg.factor
View File

@ -49,12 +49,12 @@ SYMBOL: error-stack
SYMBOL: ignore
: packrat ( id -- cache )
#! The packrat cache is a mapping of parser-id->cache.
#! For each parser it maps to a cache holding a mapping
#! of position->result. The packrat cache therefore keeps
#! track of all parses that have occurred at each position
#! of the input string and the results obtained from that
#! parser.
! The packrat cache is a mapping of parser-id->cache.
! For each parser it maps to a cache holding a mapping
! of position->result. The packrat cache therefore keeps
! track of all parses that have occurred at each position
! of the input string and the results obtained from that
! parser.
\ packrat get [ drop H{ } clone ] cache ;
SYMBOL: pos
@ -63,20 +63,20 @@ SYMBOL: fail
SYMBOL: lrstack
: heads ( -- cache )
#! A mapping from position->peg-head. It maps a
#! position in the input string being parsed to
#! the head of the left recursion which is currently
#! being grown. It is 'f' at any position where
#! left recursion growth is not underway.
! A mapping from position->peg-head. It maps a
! position in the input string being parsed to
! the head of the left recursion which is currently
! being grown. It is 'f' at any position where
! left recursion growth is not underway.
\ heads get ;
: failed? ( obj -- ? )
fail = ;
: peg-cache ( -- cache )
#! Holds a hashtable mapping a peg tuple to
#! the parser tuple for that peg. The parser tuple
#! holds a unique id and the compiled form of that peg.
! Holds a hashtable mapping a peg tuple to
! the parser tuple for that peg. The parser tuple
! holds a unique id and the compiled form of that peg.
\ peg-cache get-global [
H{ } clone dup \ peg-cache set-global
] unless* ;
@ -97,17 +97,17 @@ TUPLE: left-recursion seed rule-id head next ;
TUPLE: peg-head rule-id involved-set eval-set ;
: rule-id ( word -- id )
#! A rule is the parser compiled down to a word. It has
#! a "peg-id" property containing the id of the original parser.
! A rule is the parser compiled down to a word. It has
! a "peg-id" property containing the id of the original parser.
"peg-id" word-prop ;
: 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-from ( input -- n )
#! Return the index from the original string that the
#! input slice is based on.
! Return the index from the original string that the
! input slice is based on.
dup slice? [ from>> ] [ drop 0 ] if ;
: process-rule-result ( p result -- result )
@ -118,17 +118,17 @@ TUPLE: peg-head rule-id involved-set eval-set ;
] if* ;
: eval-rule ( rule -- ast )
#! Evaluate a rule, return an ast resulting from it.
#! Return fail if the rule failed. The rule has
#! stack effect ( -- parse-result )
! Evaluate a rule, return an ast resulting from it.
! Return fail if the rule failed. The rule has
! stack effect ( -- parse-result )
pos get swap execute( -- parse-result ) process-rule-result ; inline
: memo ( pos id -- memo-entry )
#! Return the result from the memo cache.
! Return the result from the memo cache.
packrat at ;
: set-memo ( memo-entry pos id -- )
#! Store an entry in the cache
! Store an entry in the cache
packrat set-at ;
: update-m ( ast m -- )
@ -239,7 +239,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
] if* ; inline
: with-packrat ( input quot -- result )
#! Run the quotation with a packrat cache active.
! Run the quotation with a packrat cache active.
[
swap input ,,
0 pos ,,
@ -265,18 +265,18 @@ GENERIC: (compile) ( peg -- quot )
gensym [ >>compiled ] keep ;
: define-parser-word ( parser word -- )
#! Return the body of the word that is the compiled version
#! of the parser.
! Return the body of the word that is the compiled version
! of the parser.
2dup swap peg>> (compile) ( -- result ) define-declared
swap id>> "peg-id" set-word-prop ;
: compile-parser ( parser -- word )
#! Look to see if the given parser has been compiled.
#! If not, compile it to a temporary word, cache it,
#! and return it. Otherwise return the existing one.
#! Circular parsers are supported by getting the word
#! name and storing it in the cache, before compiling,
#! so it is picked up when re-entered.
! Look to see if the given parser has been compiled.
! If not, compile it to a temporary word, cache it,
! and return it. Otherwise return the existing one.
! Circular parsers are supported by getting the word
! name and storing it in the cache, before compiling,
! so it is picked up when re-entered.
dup compiled>> [
nip
] [
@ -289,8 +289,8 @@ GENERIC: (compile) ( peg -- quot )
SYMBOL: delayed
: fixup-delayed ( -- )
#! Work through all delayed parsers and recompile their
#! words to have the correct bodies.
! Work through all delayed parsers and recompile their
! words to have the correct bodies.
delayed get [
call( -- parser ) compile-parser-quot ( -- result ) define-declared
] assoc-each ;
@ -314,13 +314,13 @@ SYMBOL: delayed
<PRIVATE
: next-id ( -- n )
#! Return the next unique id for a parser
! Return the next unique id for a parser
\ next-id counter ;
: wrap-peg ( peg -- parser )
#! Wrap a parser tuple around the peg object.
#! Look for an existing parser tuple for that
#! peg object.
! Wrap a parser tuple around the peg object.
! Look for an existing parser tuple for that
! peg object.
peg-cache [
f next-id parser boa
] cache ;
@ -328,7 +328,7 @@ SYMBOL: delayed
TUPLE: token-parser symbol ;
: parse-token ( input string -- result )
#! Parse the string, returning a parse result
! Parse the string, returning a parse result
[ ?head-slice ] keep swap [
<parse-result> f f f add-error
] [
@ -503,18 +503,18 @@ M: sp-parser (compile)
TUPLE: delay-parser quot ;
M: delay-parser (compile)
#! For efficiency we memoize the quotation.
#! This way it is run only once and the
#! parser constructed once at run time.
! For efficiency we memoize the quotation.
! This way it is run only once and the
! parser constructed once at run time.
quot>> gensym [ delayed get set-at ] keep 1quotation ;
TUPLE: box-parser quot ;
M: box-parser (compile)
#! Calls the quotation at compile time
#! to produce the parser to be compiled.
#! This differs from 'delay' which calls
#! it at run time.
! Calls the quotation at compile time
! to produce the parser to be compiled.
! This differs from 'delay' which calls
! it at run time.
quot>> call( -- parser ) compile-parser-quot ;
PRIVATE>
@ -589,17 +589,17 @@ PRIVATE>
delay-parser boa wrap-peg ;
: box ( quot -- parser )
#! because a box has its quotation run at compile time
#! it must always have a new parser wrapper created,
#! not a cached one. This is because the same box,
#! compiled twice can have a different compiled word
#! due to running at compile time.
#! Why the [ ] action at the end? Box parsers don't get
#! memoized during parsing due to all box parsers being
#! unique. This breaks left recursion detection during the
#! parse. The action adds an indirection with a parser type
#! that gets memoized and fixes this. Need to rethink how
#! to fix boxes so this isn't needed...
! because a box has its quotation run at compile time
! it must always have a new parser wrapper created,
! not a cached one. This is because the same box,
! compiled twice can have a different compiled word
! due to running at compile time.
! Why the [ ] action at the end? Box parsers don't get
! memoized during parsing due to all box parsers being
! unique. This breaks left recursion detection during the
! parse. The action adds an indirection with a parser type
! that gets memoized and fixes this. Need to rethink how
! to fix boxes so this isn't needed...
box-parser boa f next-id parser boa [ ] action ;
ERROR: parse-failed input word ;

6
basis/prettyprint/sections/sections.factor
View File

@ -262,9 +262,9 @@ TUPLE: flow < block ;
flow new-block ;
M: flow short-section? ( section -- ? )
#! If we can make room for this entire block by inserting
#! a newline, do it; otherwise, don't bother, print it as
#! a short section
! If we can make room for this entire block by inserting
! a newline, do it; otherwise, don't bother, print it as
! a short section
{
[ section-fits? ]
[ [ end>> 1 - ] [ start>> ] bi - text-fits? not ]

10
basis/serialize/serialize.factor
View File

@ -21,12 +21,12 @@ GENERIC: (serialize) ( obj -- )
SYMBOL: serialized
: add-object ( obj -- )
#! Add an object to the sequence of already serialized
#! objects.
! Add an object to the sequence of already serialized
! objects.
serialized get [ assoc-size swap ] keep set-at ;
: object-id ( obj -- id )
#! Return the id of an already serialized object
! Return the id of an already serialized object
serialized get at ;
! Positive numbers are serialized as follows:
@ -231,8 +231,8 @@ SYMBOL: deserialized
[ set-array-nth ] curry each-index ;
: deserialize-tuple ( -- array )
#! Ugly because we have to intern the tuple before reading
#! slots
! Ugly because we have to intern the tuple before reading
! slots
(deserialize) new
[ intern-object ]
[

2
basis/smtp/server/server.factor
View File

@ -71,7 +71,7 @@ SYMBOL: data-mode
} cond nip [ process ] when ;
:: 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> [

2
basis/smtp/smtp.factor
View File

@ -67,7 +67,7 @@ TUPLE: email
ERROR: bad-email-address email ;
: 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?
[ bad-email-address ] when ;

2
basis/sorting/slots/slots.factor
View File

@ -10,7 +10,7 @@ IN: sorting.slots
'[ _ execute( tuple -- value ) ] bi@ ;
: compare-slots ( obj1 obj2 sort-specs -- <=> )
#! sort-spec: { accessors comparator }
! sort-spec: { accessors comparator }
[
dup array? [
unclip-last-slice

4
basis/soundex/soundex.factor
View File

@ -9,8 +9,8 @@ TR: soundex-tr
"00000000111122222222334556" ;
: remove-duplicates ( seq -- seq' )
#! Remove _consecutive_ duplicates (unlike prune which removes
#! all duplicates).
! Remove _consecutive_ duplicates (unlike prune which removes
! all duplicates).
[ 2 <clumps> [ = ] assoc-reject values ] [ first ] bi prefix ;
: first>upper ( seq -- seq' ) 1 head >upper ;

2
basis/stack-checker/stack-checker.factor
View File

@ -14,5 +14,5 @@ M: callable infer ( quot -- effect )
(infer) ;
: infer. ( quot -- )
#! Safe to call from inference transforms.
! Safe to call from inference transforms.
infer effect>string print ;

4
basis/syndication/syndication-tests.factor
View File

@ -3,8 +3,8 @@ calendar urls xml.writer ;
IN: syndication.tests
: load-news-file ( filename -- feed )
#! Load an news syndication file and process it, returning
#! it as an feed tuple.
! Load an news syndication file and process it, returning
! it as an feed tuple.
binary file-contents parse-feed ;
{ T{

2
basis/syndication/syndication.factor
View File

@ -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 ;
: 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 ;
! Atom generation

4
basis/tools/continuations/continuations.factor
View File

@ -92,8 +92,8 @@ M: object add-breakpoint ;
] when ; inline
: change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the
#! continuation.
! Applies quot to innermost call frame of the
! continuation.
[ clone ] dip '[ _ (change-frame) ] change-call ; inline
PRIVATE>

2
basis/tools/deploy/backend/backend.factor
View File

@ -45,7 +45,7 @@ ERROR: can't-deploy-library-file library ;
utf8 [ copy-lines ] with-process-reader ;
: 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?
[ make-my-image ] unless ;

8
basis/tools/deploy/shaker/shaker.factor
View File

@ -599,11 +599,11 @@ SYMBOL: deploy-vocab
clear-megamorphic-caches ;
: 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-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 ;
: deploy-error-handler ( quot -- )
@ -617,8 +617,8 @@ SYMBOL: deploy-vocab
] recover ; inline
: (deploy) ( final-image vocab-manifest-out vocab config -- )
#! Does the actual work of a deployment in the slave
#! stage2 image
! Does the actual work of a deployment in the slave
! stage2 image
[
[
strip-debugger? [

6
basis/ui/backend/cocoa/cocoa.factor
View File

@ -80,9 +80,9 @@ M: pasteboard set-clipboard-contents
[ 0 0 ] dip dim>> first2 <CGRect> ;
: auto-position ( window loc -- )
#! Note: if this is the initial window, the length of the windows
#! vector should be 1, since (open-window) calls auto-position
#! after register-window.
! Note: if this is the initial window, the length of the windows
! vector should be 1, since (open-window) calls auto-position
! after register-window.
dup { 0 0 } = [
drop
ui-windows get-global length 1 <= [ -> center ] [

2
basis/ui/backend/cocoa/views/views.factor
View File

@ -16,7 +16,7 @@ IN: ui.backend.cocoa.views
! Issue #1453
: button ( event -- n )
#! Cocoa -> Factor UI button mapping
! Cocoa -> Factor UI button mapping
-> buttonNumber {
{ 0 [ 1 ] }
{ 1 [ 3 ] }

8
basis/ui/backend/windows/windows.factor
View File

@ -271,8 +271,8 @@ CONSTANT: window-control>ex-style
[ get-RECT-top-left ] [ get-RECT-width/height ] bi ;
: handle-wm-paint ( hWnd uMsg wParam lParam -- )
#! wParam and lParam are unused
#! only paint if width/height both > 0
! wParam and lParam are unused
! only paint if width/height both > 0
3drop window relayout-1 yield ;
: 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 ;
: 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 ;
: handle-wm-mouseleave ( hWnd uMsg wParam lParam -- )
#! message sent if mouse leaves main application
! message sent if mouse leaves main application
4drop forget-rollover ;
: system-background-color ( -- color )

4
basis/ui/gadgets/buttons/buttons.factor
View File

@ -152,8 +152,8 @@ repeat-button H{
} set-gestures
: <repeat-button> ( label quot: ( button -- ) -- button )
#! Button that calls the quotation every 100ms as long as
#! the mouse is held down.
! Button that calls the quotation every 100ms as long as
! the mouse is held down.
repeat-button new-button border-button-theme ;
<PRIVATE

6
basis/ui/gadgets/gadgets.factor
View File

@ -140,9 +140,9 @@ SYMBOL: ui-notify-flag
: layout-queue ( -- queue ) \ layout-queue get ;
: layout-later ( gadget -- )
#! When unit testing gadgets without the UI running, the
#! invalid queue is not initialized and we simply ignore
#! invalidation requests.
! When unit testing gadgets without the UI running, the
! invalid queue is not initialized and we simply ignore
! invalidation requests.
layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
: invalidate* ( gadget -- )

2
basis/ui/gadgets/panes/panes.factor
View File

@ -196,7 +196,7 @@ M: pane-control model-changed ( model pane-control -- )
! Character styles
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
name [ >>name ] when*
style {

6
basis/ui/gadgets/sliders/sliders.factor
View File

@ -49,9 +49,9 @@ CONSTANT: min-thumb-dim 30
[ elevator-length ] bi min ;
: slider-scale ( slider -- n )
#! A scaling factor such that if x is a slider co-ordinate,
#! x*n is the screen position of the thumb, and conversely
#! for x/n. The '1 max' calls avoid division by zero.
! A scaling factor such that if x is a slider co-ordinate,
! x*n is the screen position of the thumb, and conversely
! for x/n. The '1 max' calls avoid division by zero.
[ [ elevator-length ] [ thumb-dim ] bi - 1 max ]
[ slider-length* 1 max ]
bi / ;

4
basis/ui/gadgets/worlds/worlds.factor
View File

@ -197,8 +197,8 @@ M: world draw-world*
} cleave ;
: draw-world? ( world -- ? )
#! We don't draw deactivated worlds, or those with 0 size.
#! On Windows, the latter case results in GL errors.
! We don't draw deactivated worlds, or those with 0 size.
! On Windows, the latter case results in GL errors.
{ [ active?>> ] [ handle>> ] [ dim>> [ 0 > ] all? ] } 1&& ;
TUPLE: world-error error world ;

12
basis/ui/text/pango/pango.factor
View File

@ -67,13 +67,13 @@ SYMBOL: dpi
layout>> 0 pango_layout_get_line_readonly ;
: 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
f { int } [ pango_layout_line_index_to_x ] with-out-parameters
pango>float ;
: 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
float>pango
@ -118,8 +118,8 @@ SYMBOL: dpi
] make-bitmap-image ;
: escape-nulls ( str -- str' )
#! Replace nulls with something else since Pango uses null-terminated
#! strings
! Replace nulls with something else since Pango uses null-terminated
! strings
H{ { 0 CHAR: zero-width-no-break-space } } substitute ;
: unpack-selection ( layout string/selection -- layout )
@ -140,8 +140,8 @@ SYMBOL: dpi
swap <PangoLayout> &g_object_unref layout-extents drop dim>> second ;
MEMO: missing-font-metrics ( font -- metrics )
#! Pango doesn't provide x-height and cap-height but Core Text does, so we
#! simulate them on Pango.
! Pango doesn't provide x-height and cap-height but Core Text does, so we
! simulate them on Pango.
[
[ metrics new ] dip
[ "x" glyph-height >>x-height ]

2
basis/ui/tools/debugger/debugger.factor
View File

@ -57,7 +57,7 @@ M: debugger focusable-child*
dup restart-hook>> [ restart-list>> ] [ drop t ] if ;
: debugger-window ( error continuation -- )
#! No restarts for the debugger window
! No restarts for the debugger window
f f <debugger> "Error" open-status-window ;
GENERIC: error-in-debugger? ( error -- ? )

2
basis/ui/tools/error-list/error-list.factor
View File

@ -25,7 +25,7 @@ MEMO: error-icon ( type -- image-name )
[ swap <checkbox> add-gadget ] assoc-each ;
: <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-icon ] dip ] assoc-map <checkboxes> ]
[ <mapping> ] bi ;

6
basis/ui/tools/listener/listener.factor
View File

@ -34,7 +34,7 @@ INSTANCE: interactor input-stream
thread>> thread-continuation ;
: interactor-busy? ( interactor -- ? )
#! We're busy if there's no thread to resume.
! We're busy if there's no thread to resume.
{
[ waiting>> ]
[ thread>> dup [ thread-registered? ] when ]
@ -233,7 +233,7 @@ M: listener-gadget focusable-child*
input>> dup popup>> or ;
: wait-for-listener ( listener -- )
#! Wait for the listener to start.
! Wait for the listener to start.
input>> flag>> wait-for-flag ;
: listener-busy? ( listener -- ? )
@ -420,7 +420,7 @@ interactor "completion" f {
] "Listener" spawn drop ;
: restart-listener ( listener -- )
#! Returns when listener is ready to receive input.
! Returns when listener is ready to receive input.
{
[ com-end ]
[ clear-output ]

20
basis/ui/ui.factor
View File

@ -17,12 +17,12 @@ SYMBOL: ui-windows
: window ( handle -- world ) ui-windows get-global at ;
: register-window ( world handle -- )
#! Add the new window just below the topmost window. Why?
#! So that if the new window doesn't actually receive focus
#! (eg, we're using focus follows mouse and the mouse is not
#! in the new window when it appears) Factor doesn't get
#! confused and send workspace operations to the new window,
#! etc.
! Add the new window just below the topmost window. Why?
! So that if the new window doesn't actually receive focus
! (eg, we're using focus follows mouse and the mouse is not
! in the new window when it appears) Factor doesn't get
! confused and send workspace operations to the new window,
! etc.
swap 2array ui-windows get-global push
ui-windows get-global dup length 1 >
[ [ length 1 - dup 1 - ] keep exchange ] [ drop ] if ;
@ -156,10 +156,10 @@ PRIVATE>
<PRIVATE
: update-ui-loop ( -- )
#! Note the logic: if update-ui fails, we open an error window
#! and run one iteration of update-ui. If that also fails, well,
#! the whole UI subsystem is broken so we exit out of the
#! update-ui-loop.
! Note the logic: if update-ui fails, we open an error window
! and run one iteration of update-ui. If that also fails, well,
! the whole UI subsystem is broken so we exit out of the
! update-ui-loop.
[ { [ ui-running? ] [ ui-thread get-global self eq? ] } 0&& ]
[
ui-notify-flag get lower-flag

2
basis/validators/validators.factor
View File

@ -59,7 +59,7 @@ IN: validators
[ 2drop ] [ drop "invalid " prepend throw ] if ;
: v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html
! From http://www.regular-expressions.info/email.html
320 v-max-length
"e-mail"
R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i

2
basis/vocabs/hierarchy/hierarchy.factor
View File

@ -75,7 +75,7 @@ PRIVATE>
[ dup vocab-prefix? [ name>> <vocab-link> ] when ] map ;
: remove-redundant-prefixes ( seq -- seq' )
#! Hack.
! Hack.
[ vocab-prefix? ] partition
[
[ vocab-name ] map fast-set

4
basis/vocabs/refresh/monitor/monitor.factor
View File

@ -29,8 +29,8 @@ TR: convert-separators "/\\" ".." ;
chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
: monitor-loop ( monitor -- )
#! On OS X, monitors give us the full path, so we chop it
#! off if its there.
! On OS X, monitors give us the full path, so we chop it
! off if its there.
[
next-change path>> path>vocab
[ changed-vocab ] [ reset-cache ] bi

4
basis/windows/privileges/privileges.factor
View File

@ -18,11 +18,11 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
with-out-parameters ;
: open-process-token ( -- handle )
#! remember to CloseHandle
! remember to CloseHandle
GetCurrentProcess (open-process-token) ;
: with-process-token ( quot -- )
#! quot: ( token-handle -- token-handle )
! quot: ( token-handle -- token-handle )
[ open-process-token ] dip
[ keep ] curry
[ CloseHandle drop ] [ ] cleanup ; inline

2
basis/windows/time/time.factor
View File

@ -21,7 +21,7 @@ IN: windows.time
FILETIME>windows-time ;
: 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 ;
: windows-time>FILETIME ( n -- FILETIME )

2
basis/windows/winsock/winsock.factor
View File

@ -436,7 +436,7 @@ ERROR: winsock-exception n string ;
${ ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING } member? ;
: (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?
[ drop f ] [ [ ] [ n>win32-error-string ] bi \ winsock-exception boa ] if ;

2
basis/xml/elements/elements.factor
View File

@ -18,7 +18,7 @@ IN: xml.elements
[ quoteless-attr ] take-interpolated ;
: 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
parse-name swap ;

2
basis/xml/entities/entities.factor
View File

@ -20,7 +20,7 @@ CONSTANT: quoted-entities-out
}
: escape-string-by ( str table -- escaped )
#! Convert <, >, &, ' and " to HTML entities.
! Convert <, >, &, ' and " to HTML entities.
[ '[ dup _ at [ % ] [ , ] ?if ] each ] "" make ;
: escape-string ( str -- newstr )

8
basis/xml/tokenize/tokenize.factor
View File

@ -72,9 +72,9 @@ HINTS: next* { spot } ;
spot get (skip-until) ; inline
: take-until ( ... quot: ( ... char -- ... ? ) -- ... string )
#! Take the substring of a string starting at spot
#! from code until the quotation given is true and
#! advance spot to after the substring.
! Take the substring of a string starting at spot
! from code until the quotation given is true and
! advance spot to after the substring.
10 <sbuf> [
'[ _ keep over [ drop ] [ _ push ] if ] skip-until
] keep "" like ; inline
@ -83,7 +83,7 @@ HINTS: next* { spot } ;
'[ _ member? ] take-until ; inline
: pass-blank ( -- )
#! Advance code past any whitespace, including newlines
! Advance code past any whitespace, including newlines
[ blank? not ] skip-until ;
: next-matching ( pos ch str -- pos' )

8
core/byte-vectors/byte-vectors.factor
View File

@ -29,10 +29,10 @@ M: byte-vector equal?
M: byte-vector contract 2drop ; inline
M: byte-array like
#! If we have an byte-array, we're done.
#! If we have a byte-vector, and it's at full capacity,
#! we're done. Otherwise, call resize-byte-array, which is a
#! relatively fast primitive.
! If we have an byte-array, we're done.
! If we have a byte-vector, and it's at full capacity,
! we're done. Otherwise, call resize-byte-array, which is a
! relatively fast primitive.
drop dup byte-array? [
dup byte-vector? [
[ length ] [ underlying>> ] bi

6
core/checksums/checksums.factor
View File

@ -58,9 +58,9 @@ M: checksum checksum-lines
[ B{ CHAR: \n } join ] dip checksum-bytes ;
: checksum-file ( path checksum -- value )
#! normalize-path (file-reader) is equivalent to
#! binary <file-reader>. We use the lower-level form
#! so that we can move io.encodings.binary to basis/.
! normalize-path (file-reader) is equivalent to
! binary <file-reader>. We use the lower-level form
! so that we can move io.encodings.binary to basis/.
[ normalize-path (file-reader) ] dip checksum-stream ;
: hex-string ( seq -- str )

Some files were not shown because too many files have changed in this diff Show More