[ 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
: 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 ;
! 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?
] 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 -- )
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
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
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
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 )
] 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>> + ]
[ >time< [ [ 3600 * ] [ 60 * ] bi* ] dip + + ] bi@ - + ;
M: timestamp time-
- #! Exact calendar-time difference
+ ! Exact calendar-time difference
(time-) seconds ;
: time* ( obj1 obj2 -- obj3 )
: 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
} 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 ]
] 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 -- )
[ 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 ;
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) ;
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 )
]
:: 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
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
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 -- )
-> 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? ;
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 -- )
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 -- )
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 -- )
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
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 )
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 -- ? )
SYMBOL: compiled
: compile? ( word -- ? )
- #! Don't attempt to compile certain words.
+ ! Don't attempt to compile certain words.
{
[ "forgotten" word-prop ]
[ inlined-block? ]
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? [
] 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 )
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 ] }
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
] 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 ]
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
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
[ 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
] 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 ] }
} 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 ]
: >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 ;
[ 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
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 )
[ 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 ;
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' )
] bi ;
M: #enter-recursive escape-analysis* ( #enter-recursive -- )
- #! Handled by #recursive
+ ! Handled by #recursive
drop ;
M: #call-recursive escape-analysis* ( #call-label -- )
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
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
] [
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
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 ]
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 ]
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? ]
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? ]
} 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*
[ 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 '[
_ _
[ 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>
"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 ] }
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
[ 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 ;
[ [ 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 )
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
] [
[ 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 ;
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
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 ( -- )
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 )
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
[ 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
} 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
] [
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 )
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 ;
] ($code) ;
: $unchecked-example ( element -- )
- #! help-lint ignores these.
+ ! help-lint ignores these.
$example ;
: $markup-example ( element -- )
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
} 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 ;
] 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 )
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 ,
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 ,
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" ,,
] 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>> [
: &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
PRIVATE>
: set-file-times ( path timestamps -- )
- #! set access, write
+ ! set access, write
[ normalize-path ] dip
timestamps>byte-array [ utimes ] unix-system-call drop ;
] 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>>
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
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 ;
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
] 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 ] }
>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 )
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
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 ;
[ 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 , ]
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 ;
(define-logging) ;
SYNTAX: LOG:
- #! Syntax: name level
+ ! Syntax: name level
scan-new-word dup scan-word
'[ 1array stack>message _ _ log-message ]
( message -- ) define-declared ;
] 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 -- )
[ 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
] dip [ 2drop [-inf,inf] ] if ; inline
: interval-shift ( i1 i2 -- i3 )
- #! Inaccurate; could be tighter
+ ! Inaccurate; could be tighter
[
[
[ interval-closure ] bi@
[ [ [ / ] 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 )
from>> first 0 >= ;
: interval-bitand ( i1 i2 -- i3 )
- #! Inaccurate.
+ ! Inaccurate.
[
{
{
] do-empty-interval ;
: interval-bitor ( i1 i2 -- i3 )
- #! Inaccurate.
+ ! Inaccurate.
[
2dup [ interval-nonnegative? ] both?
[
] do-empty-interval ;
: interval-bitxor ( i1 i2 -- i3 )
- #! Inaccurate.
+ ! Inaccurate.
interval-bitor ;
: interval-log2 ( i1 -- i2 )
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 )
<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!
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 )
--
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
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 )
[
fix-coordinates glViewport ;
: init-matrices ( -- )
- #! Leaves with matrix mode GL_MODELVIEW
+ ! Leaves with matrix mode GL_MODELVIEW
GL_PROJECTION glMatrixMode
glLoadIdentity
GL_MODELVIEW glMatrixMode
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?
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
] 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
] 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
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 ;
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 )
] 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
] 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? ]
] 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? ]
] 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 ,
] 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 ,
] 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.
[
[
[
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
] 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 ,
] 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 ,
"?[" 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 ,
] 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
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 )
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
] [
] 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 ,
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
] [
] 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" } } [
] 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?
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
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* ;
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 )
] 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 -- )
] 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 ,,
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
] [
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 ;
<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 ;
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
] [
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>
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 ;
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 ]
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:
[ 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 ]
[
} 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> [
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 ;
'[ _ execute( tuple -- value ) ] bi@ ;
: compare-slots ( obj1 obj2 sort-specs -- <=> )
- #! sort-spec: { accessors comparator }
+ ! sort-spec: { accessors comparator }
[
dup array? [
unclip-last-slice
"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 ;
(infer) ;
: infer. ( quot -- )
- #! Safe to call from inference transforms.
+ ! Safe to call from inference transforms.
infer effect>string print ;
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{
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
] 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>
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 ;
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 -- )
] 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? [
[ 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 ] [
! Issue #1453
: button ( event -- n )
- #! Cocoa -> Factor UI button mapping
+ ! Cocoa -> Factor UI button mapping
-> buttonNumber {
{ 0 [ 1 ] }
{ 1 [ 3 ] }
[ 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 -- )
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 )
} 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
: 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 -- )
! 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 {
[ 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 / ;
} 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 ;
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
] 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 )
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 ]
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 -- ? )
[ 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 ;
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 ]
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 -- ? )
] "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 ]
: 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 ;
<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
[ 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
[ dup vocab-prefix? [ name>> <vocab-link> ] when ] map ;
: remove-redundant-prefixes ( seq -- seq' )
- #! Hack.
+ ! Hack.
[ vocab-prefix? ] partition
[
[ vocab-name ] map fast-set
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
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
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 )
${ 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 ;
[ 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 ;
}
: 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 )
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
'[ _ 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' )
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
[ 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 )
swap superclass-of? ;
: class-members ( class -- seq )
- #! Output f for non-classes to work with algebra code
+ ! Output f for non-classes to work with algebra code
dup class? [ "members" word-prop ] [ drop f ] if ;
: class-participants ( class -- seq )
- #! Output f for non-classes to work with algebra code
+ ! Output f for non-classes to work with algebra code
dup class? [ "participants" word-prop ] [ drop f ] if ;
GENERIC: implementors ( class/classes -- seq )
swap redefine-mixin-class ; inline
: (add-mixin-instance) ( class mixin -- )
- #! Call update-methods before adding the member:
- #! - Call sites of generics specializing on 'mixin'
- #! where the inferred type is 'class' are updated,
- #! - Call sites where the inferred type is a subtype
- #! of 'mixin' disjoint from 'class' are not updated
+ ! Call update-methods before adding the member:
+ ! - Call sites of generics specializing on 'mixin'
+ ! where the inferred type is 'class' are updated,
+ ! - Call sites where the inferred type is a subtype
+ ! of 'mixin' disjoint from 'class' are not updated
dup class-usages {
[ nip update-methods ]
[ drop [ suffix ] change-mixin-class ]
} 3cleave ;
: (remove-mixin-instance) ( class mixin -- )
- #! Call update-methods after removing the member:
- #! - Call sites of generics specializing on 'mixin'
- #! where the inferred type is 'class' are updated,
- #! - Call sites where the inferred type is a subtype
- #! of 'mixin' disjoint from 'class' are not updated
+ ! Call update-methods after removing the member:
+ ! - Call sites of generics specializing on 'mixin'
+ ! where the inferred type is 'class' are updated,
+ ! - Call sites where the inferred type is a subtype
+ ! of 'mixin' disjoint from 'class' are not updated
dup class-usages {
[ drop [ swap remove ] change-mixin-class ]
[ drop "instances" word-prop delete-at ]
<PRIVATE
: tuple-predicate-quot/1 ( class -- quot )
- #! Fast path for tuples with no superclass
+ ! Fast path for tuples with no superclass
[ ] curry [ layout-of 7 slot ] [ eq? ] surround 1quotation
[ dup tuple? ] [ [ drop f ] if ] surround ;
! ! ! Build an engine ! ! !
: find-default ( methods -- default )
- #! Side-effects methods.
+ ! Side-effects methods.
[ object bootstrap-word ] dip delete-at* [
drop generic-word get "default-method" word-prop
] unless ;
[ ?set-at ] change-at ;
: echelon-sort ( assoc -- assoc' )
- #! Convert an assoc mapping classes to methods into an
- #! assoc mapping echelons to assocs. The first echelon
- #! is always there
+ ! Convert an assoc mapping classes to methods into an
+ ! assoc mapping echelons to assocs. The first echelon
+ ! is always there
H{ { 0 f } } clone [ [ push-echelon ] curry assoc-each ] keep ;
: copy-superclass-methods ( engine superclass assoc -- )
[ swapd copy-superclass-methods ] 2curry each ;
: convert-tuple-inheritance ( assoc -- assoc' )
- #! A method on a superclass A might have a higher precedence
- #! than a method on a subclass B, if the methods are
- #! defined on incomparable classes that happen to contain
- #! A and B, respectively. Copy A's methods into B's set so
- #! that they can be sorted and selected properly.
+ ! A method on a superclass A might have a higher precedence
+ ! than a method on a subclass B, if the methods are
+ ! defined on incomparable classes that happen to contain
+ ! A and B, respectively. Copy A's methods into B's set so
+ ! that they can be sorted and selected properly.
dup dup [ copy-superclasses-methods ] curry assoc-each ;
: <tuple-dispatch-engine> ( methods -- engine )
GENERIC: salary ( person -- n )
M: intern salary
- #! Intentional mistake.
+ ! Intentional mistake.
call-next-method ;
M: employee salary drop 24000 ;
M: executive salary call-next-method 2 * ;
M: ceo salary
- #! Intentional error.
+ ! Intentional error.
drop 5 call-next-method 3 * ;
[ salary ] must-infer
[ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ;
M: standard-combination inline-cache-quots
- #! Direct calls to the generic word (not tail calls or indirect calls)
- #! will jump to the inline cache entry point instead of the megamorphic
- #! dispatch entry point.
+ ! Direct calls to the generic word (not tail calls or indirect calls)
+ ! will jump to the inline cache entry point instead of the megamorphic
+ ! dispatch entry point.
[ \ inline-cache-miss inline-cache-quot ]
[ \ inline-cache-miss-tail inline-cache-quot ]
2bi ;
swapd [ with-output-stream* ] curry with-input-stream* ; inline
: with-streams ( input output quot -- )
- #! We have to dispose of the output stream first, so that
- #! if both streams point to the same FD, we get to flush the
- #! buffer before closing the FD.
+ ! We have to dispose of the output stream first, so that
+ ! if both streams point to the same FD, we get to flush the
+ ! buffer before closing the FD.
swapd [ with-output-stream ] curry with-input-stream ; inline
: with-input-output+error-streams* ( input output+error quot -- )
"ab" fopen <c-writer> ;
: show ( msg -- )
- #! A word which directly calls primitives. It is used to
- #! print stuff from contexts where the I/O system would
- #! otherwise not work (tools.deploy.shaker, the I/O
- #! multiplexer thread).
+ ! A word which directly calls primitives. It is used to
+ ! print stuff from contexts where the I/O system would
+ ! otherwise not work (tools.deploy.shaker, the I/O
+ ! multiplexer thread).
"\n" append >byte-array dup length
stdout-handle fwrite
stdout-handle fflush ;
DEFER: if
: ? ( ? true false -- true/false )
- #! 'if' and '?' can be defined in terms of each other
- #! because the JIT special-cases an 'if' preceeded by
- #! two literal quotations.
+ ! 'if' and '?' can be defined in terms of each other
+ ! because the JIT special-cases an 'if' preceeded by
+ ! two literal quotations.
rot [ drop ] [ nip ] if ; inline
: if ( ..a ? true: ( ..a -- ..b ) false: ( ..a -- ..b ) -- ..b ) ? call ;
: if-iterate? ( i n true false -- ) [ 2over < ] 2dip if ; inline
: iterate-step ( i n quot -- i n quot )
- #! Apply quot to i, keep i and quot, hide n.
+ ! Apply quot to i, keep i and quot, hide n.
[ nip call ] 3keep ; inline
: iterate-rot ( ? i n quot -- i n quot ? )
SYMBOL: +gt+
: invert-comparison ( <=> -- >=< )
- #! Can't use case, index or nth here
+ ! Can't use case, index or nth here
dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ;
GENERIC: <=> ( obj1 obj2 -- <=> )
filter-moved [ class? ] filter [ forget-class ] each ;
: fix-class-words ( -- )
- #! If a class word had a compound definition which was
- #! removed, it must go back to being a symbol.
+ ! If a class word had a compound definition which was
+ ! removed, it must go back to being a symbol.
new-definitions get first2
filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
M: sbuf new-resizable drop <sbuf> ; inline
M: string like
- #! If we have a string, we're done.
- #! If we have an sbuf, and it's at full capacity, we're done.
- #! Otherwise, call resize-string, which is a relatively
- #! fast primitive.
+ ! If we have a string, we're done.
+ ! If we have an sbuf, and it's at full capacity, we're done.
+ ! Otherwise, call resize-string, which is a relatively
+ ! fast primitive.
drop dup string? [
dup sbuf? [
[ length ] [ underlying>> ] bi
[ nth2-unsafe ] [ [ 2 + ] dip nth-unsafe ] 2bi ; inline
: (binary-reduce) ( seq start quot: ( elt1 elt2 -- newelt ) from length -- value )
- #! We can't use case here since combinators depends on
- #! sequences
+ ! We can't use case here since combinators depends on
+ ! sequences
dup 4 < [
integer>fixnum {
[ 2drop nip ]
swap >>error rethrow ;
: with-source-file ( name quot -- )
- #! Should be called from inside with-compilation-unit.
+ ! Should be called from inside with-compilation-unit.
[
[
path>source-file
ARTICLE: "syntax-comments" "Comments"
{ $subsections
POSTPONE: !
- POSTPONE: #!
+ POSTPONE: !
} ;
ARTICLE: "syntax-immediate" "Parse time evaluation"
{ $values { "comment" "characters" } }
{ $description "Discards all input until the end of the line." } ;
-{ POSTPONE: ! POSTPONE: #! } related-words
+{ POSTPONE: ! POSTPONE: ! } related-words
-HELP: #!
+HELP: !
{ $syntax "#!comment..." }
{ $values { "comment" "characters" } }
{ $description "Discards all input until the end of the line." }
over vector? [ sequence= ] [ 2drop f ] if ;
M: array like
- #! If we have an array, we're done.
- #! If we have a vector, and it's at full capacity, we're done.
- #! Otherwise, call resize-array, which is a relatively
- #! fast primitive.
+ ! If we have an array, we're done.
+ ! If we have a vector, and it's at full capacity, we're done.
+ ! Otherwise, call resize-array, which is a relatively
+ ! fast primitive.
drop dup array? [
dup vector? [
[ length ] [ underlying>> ] bi
: undefined ( -- * ) get-callstack caller undefined-word boa throw ;
: undefined-def ( -- quot )
- #! 'f' inhibits tail call optimization in non-optimizing
- #! compiler, ensuring that we can pull out the caller word
- #! above.
+ ! 'f' inhibits tail call optimization in non-optimizing
+ ! compiler, ensuring that we can pull out the caller word
+ ! above.
[ undefined f ] ;
PREDICATE: deferred < word def>> undefined-def = ;
stream-buffer-size ; inline
: read-bytes-into ( dest size stream -- len )
- #! Read the given number of bytes from a stream
- #! and store them in the destination byte array.
+ ! Read the given number of bytes from a stream
+ ! and store them in the destination byte array.
stream-read >byte-array dup length [ memcpy ] keep ;
: stream-into-buffer ( buffer size vorbis-stream -- len )
{ + - * } amb-execute ;
: some-rots ( a b c -- a b c )
- #! Try to rot 0, 1 or 2 times.
+ ! Try to rot 0, 1 or 2 times.
{ nop rot -rot } amb-execute ;
MEMO: 24-from-1 ( a -- ? )
IN: benchmark.fannkuch
: count ( quot: ( -- ? ) -- n )
- #! Call quot until it returns false, return number of times
- #! it was true
+ ! Call quot until it returns false, return number of times
+ ! it was true
[ 0 ] dip '[ _ dip swap [ [ 1 + ] when ] keep ] loop ; inline
: count-flips ( perm -- flip# )
dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline
: if-ray-sphere ( hit ray sphere quot -- hit )
- #! quot: hit ray sphere l -- hit
+ ! quot: hit ray sphere l -- hit
[
[ ] [ swap ray-sphere nip ] [ 2drop lambda>> ] 3tri
[ drop ] [ < ] 2bi
[
>>exitcc
resumecc>> call( -- )
- #! At this point, the coroutine quotation must have terminated
- #! normally (without calling coyield, coreset, or coterminate).
- #! This shouldn't happen.
+ ! At this point, the coroutine quotation must have terminated
+ ! normally (without calling coyield, coreset, or coterminate).
+ ! This shouldn't happen.
f over
] callcc1 2nip ;
3drop ;
M: cpu read-port
- #! Read a byte from the hardware port. 'port' should
- #! be an 8-bit value.
+ ! Read a byte from the hardware port. 'port' should
+ ! be an 8-bit value.
2drop 0 ;
M: cpu write-port
- #! Write a byte to the hardware port, where 'port' is
- #! an 8-bit value.
+ ! Write a byte to the hardware port, where 'port' is
+ ! an 8-bit value.
3drop ;
CONSTANT: carry-flag 0x01
CONSTANT: sign-flag 0x80
: >word< ( word -- byte byte )
- #! Explode a word into its two 8 bit values.
+ ! Explode a word into its two 8 bit values.
dup 0xFF bitand swap -8 shift 0xFF bitand swap ;
: af>> ( cpu -- word )
- #! Return the 16-bit pseudo register AF.
+ ! Return the 16-bit pseudo register AF.
[ a>> 8 shift ] keep f>> bitor ;
: af<< ( value cpu -- )
- #! Set the value of the 16-bit pseudo register AF
+ ! Set the value of the 16-bit pseudo register AF
[ >word< ] dip swap >>f swap >>a drop ;
: bc>> ( cpu -- word )
- #! Return the 16-bit pseudo register BC.
+ ! Return the 16-bit pseudo register BC.
[ b>> 8 shift ] keep c>> bitor ;
: bc<< ( value cpu -- )
- #! Set the value of the 16-bit pseudo register BC
+ ! Set the value of the 16-bit pseudo register BC
[ >word< ] dip swap >>c swap >>b drop ;
: de>> ( cpu -- word )
- #! Return the 16-bit pseudo register DE.
+ ! Return the 16-bit pseudo register DE.
[ d>> 8 shift ] keep e>> bitor ;
: de<< ( value cpu -- )
- #! Set the value of the 16-bit pseudo register DE
+ ! Set the value of the 16-bit pseudo register DE
[ >word< ] dip swap >>e swap >>d drop ;
: hl>> ( cpu -- word )
- #! Return the 16-bit pseudo register HL.
+ ! Return the 16-bit pseudo register HL.
[ h>> 8 shift ] keep l>> bitor ;
: hl<< ( value cpu -- )
- #! Set the value of the 16-bit pseudo register HL
+ ! Set the value of the 16-bit pseudo register HL
[ >word< ] dip swap >>l swap >>h drop ;
: flag-set? ( flag cpu -- bool )
f>> bitand 0 = ;
: flag-nz? ( cpu -- bool )
- #! Test flag status
+ ! Test flag status
f>> zero-flag bitand 0 = ;
: flag-z? ( cpu -- bool )
- #! Test flag status
+ ! Test flag status
f>> zero-flag bitand 0 = not ;
: flag-nc? ( cpu -- bool )
- #! Test flag status
+ ! Test flag status
f>> carry-flag bitand 0 = ;
: flag-c? ( cpu -- bool )
- #! Test flag status
+ ! Test flag status
f>> carry-flag bitand 0 = not ;
: flag-po? ( cpu -- bool )
- #! Test flag status
+ ! Test flag status
f>> parity-flag bitand 0 = ;
: flag-pe? ( cpu -- bool )
- #! Test flag status
+ ! Test flag status
f>> parity-flag bitand 0 = not ;
: flag-p? ( cpu -- bool )
- #! Test flag status
+ ! Test flag status
f>> sign-flag bitand 0 = ;
: flag-m? ( cpu -- bool )
- #! Test flag status
+ ! Test flag status
f>> sign-flag bitand 0 = not ;
: read-byte ( addr cpu -- byte )
- #! Read one byte from memory at the specified address.
- #! The address is 16-bit, but if a value greater than
- #! 0xFFFF is provided then return a default value.
+ ! Read one byte from memory at the specified address.
+ ! The address is 16-bit, but if a value greater than
+ ! 0xFFFF is provided then return a default value.
over 0xFFFF <= [
ram>> nth
] [
] if ;
: read-word ( addr cpu -- word )
- #! Read a 16-bit word from memory at the specified address.
- #! The address is 16-bit, but if a value greater than
- #! 0xFFFF is provided then return a default value.
+ ! Read a 16-bit word from memory at the specified address.
+ ! The address is 16-bit, but if a value greater than
+ ! 0xFFFF is provided then return a default value.
[ read-byte ] 2keep [ 1 + ] dip read-byte 8 shift bitor ;
: next-byte ( cpu -- byte )
- #! Return the value of the byte at PC, and increment PC.
+ ! Return the value of the byte at PC, and increment PC.
{
[ pc>> ]
[ read-byte ]
} cleave ;
: next-word ( cpu -- word )
- #! Return the value of the word at PC, and increment PC.
+ ! Return the value of the word at PC, and increment PC.
[ pc>> ] keep
[ read-word ] keep
[ pc>> 2 + ] keep
: write-byte ( value addr cpu -- )
- #! Write a byte to the specified memory address.
+ ! Write a byte to the specified memory address.
over dup 0x2000 < swap 0xFFFF > or [
3drop
] [
: write-word ( value addr cpu -- )
- #! Write a 16-bit word to the specified memory address.
+ ! Write a 16-bit word to the specified memory address.
[ >word< ] 2dip [ write-byte ] 2keep [ 1 + ] dip write-byte ;
: cpu-a-bitand ( quot cpu -- )
- #! A &= quot call
+ ! A &= quot call
[ a>> swap call bitand ] keep a<< ; inline
: cpu-a-bitor ( quot cpu -- )
- #! A |= quot call
+ ! A |= quot call
[ a>> swap call bitor ] keep a<< ; inline
: cpu-a-bitxor ( quot cpu -- )
- #! A ^= quot call
+ ! A ^= quot call
[ a>> swap call bitxor ] keep a<< ; inline
: cpu-a-bitxor= ( value cpu -- )
- #! cpu-a ^= value
+ ! cpu-a ^= value
[ a>> bitxor ] keep a<< ;
: cpu-f-bitand ( quot cpu -- )
- #! F &= quot call
+ ! F &= quot call
[ f>> swap call bitand ] keep f<< ; inline
: cpu-f-bitor ( quot cpu -- )
- #! F |= quot call
+ ! F |= quot call
[ f>> swap call bitor ] keep f<< ; inline
: cpu-f-bitxor ( quot cpu -- )
- #! F |= quot call
+ ! F |= quot call
[ f>> swap call bitxor ] keep f<< ; inline
: cpu-f-bitor= ( value cpu -- )
- #! cpu-f |= value
+ ! cpu-f |= value
[ f>> bitor ] keep f<< ;
: cpu-f-bitand= ( value cpu -- )
- #! cpu-f &= value
+ ! cpu-f &= value
[ f>> bitand ] keep f<< ;
: cpu-f-bitxor= ( value cpu -- )
- #! cpu-f ^= value
+ ! cpu-f ^= value
[ f>> bitxor ] keep f<< ;
: set-flag ( cpu flag -- )
bitnot 0xFF bitand swap cpu-f-bitand= ;
: update-zero-flag ( result cpu -- )
- #! If the result of an instruction has the value 0, this
- #! flag is set, otherwise it is reset.
+ ! If the result of an instruction has the value 0, this
+ ! flag is set, otherwise it is reset.
swap 0xFF bitand 0 =
[ zero-flag set-flag ]
[ zero-flag clear-flag ] if ;
: update-sign-flag ( result cpu -- )
- #! If the most significant bit of the result
- #! has the value 1 then the flag is set, otherwise
- #! it is reset.
+ ! If the most significant bit of the result
+ ! has the value 1 then the flag is set, otherwise
+ ! it is reset.
swap 0x80 bitand 0 =
[ sign-flag clear-flag ]
[ sign-flag set-flag ] if ;
: update-parity-flag ( result cpu -- )
- #! If the modulo 2 sum of the bits of the result
- #! is 0, (ie. if the result has even parity) this flag
- #! is set, otherwise it is reset.
+ ! If the modulo 2 sum of the bits of the result
+ ! is 0, (ie. if the result has even parity) this flag
+ ! is set, otherwise it is reset.
swap 0xFF bitand 2 mod 0 =
[ parity-flag set-flag ]
[ parity-flag clear-flag ] if ;
: update-carry-flag ( result cpu -- )
- #! If the instruction resulted in a carry (from addition)
- #! or a borrow (from subtraction or a comparison) out of the
- #! higher order bit, this flag is set, otherwise it is reset.
+ ! If the instruction resulted in a carry (from addition)
+ ! or a borrow (from subtraction or a comparison) out of the
+ ! higher order bit, this flag is set, otherwise it is reset.
swap dup 0x100 >= swap 0 < or
[ carry-flag set-flag ]
[ carry-flag clear-flag ] if ;
: update-half-carry-flag ( original change-by result cpu -- )
- #! If the instruction caused a carry out of bit 3 and into bit 4 of the
- #! resulting value, the half carry flag is set, otherwise it is reset.
- #! The 'original' is the original value of the register being changed.
- #! 'change-by' is the amount it is being added or decremented by.
- #! 'result' is the result of that change.
+ ! If the instruction caused a carry out of bit 3 and into bit 4 of the
+ ! resulting value, the half carry flag is set, otherwise it is reset.
+ ! The 'original' is the original value of the register being changed.
+ ! 'change-by' is the amount it is being added or decremented by.
+ ! 'result' is the result of that change.
[ bitxor bitxor 0x10 bitand 0 = not ] dip swap
[ half-carry-flag set-flag ]
[ half-carry-flag clear-flag ] if ;
[ update-zero-flag ] 2tri ;
: add-byte ( lhs rhs cpu -- result )
- #! Add rhs to lhs
+ ! Add rhs to lhs
[ 2dup + ] dip
[ update-flags ] 2keep
[ update-half-carry-flag ] 2keep
drop 0xFF bitand ;
: add-carry ( change-by result cpu -- change-by result )
- #! Add the effect of the carry flag to the result
+ ! Add the effect of the carry flag to the result
flag-c? [ 1 + [ 1 + ] dip ] when ;
: add-byte-with-carry ( lhs rhs cpu -- result )
- #! Add rhs to lhs plus carry.
+ ! Add rhs to lhs plus carry.
[ 2dup + ] dip
[ add-carry ] keep
[ update-flags ] 2keep
drop 0xFF bitand ;
: sub-carry ( change-by result cpu -- change-by result )
- #! Subtract the effect of the carry flag from the result
+ ! Subtract the effect of the carry flag from the result
flag-c? [ 1 - [ 1 - ] dip ] when ;
: sub-byte ( lhs rhs cpu -- result )
- #! Subtract rhs from lhs
+ ! Subtract rhs from lhs
[ 2dup - ] dip
[ update-flags ] 2keep
[ update-half-carry-flag ] 2keep
drop 0xFF bitand ;
: sub-byte-with-carry ( lhs rhs cpu -- result )
- #! Subtract rhs from lhs and take carry into account
+ ! Subtract rhs from lhs and take carry into account
[ 2dup - ] dip
[ sub-carry ] keep
[ update-flags ] 2keep
drop 0xFF bitand ;
: inc-byte ( byte cpu -- result )
- #! Increment byte by one. Note that carry flag is not affected
- #! by this operation.
+ ! Increment byte by one. Note that carry flag is not affected
+ ! by this operation.
[ 1 2dup + ] dip
[ update-flags-no-carry ] 2keep
[ update-half-carry-flag ] 2keep
drop 0xFF bitand ;
: dec-byte ( byte cpu -- result )
- #! Decrement byte by one. Note that carry flag is not affected
- #! by this operation.
+ ! Decrement byte by one. Note that carry flag is not affected
+ ! by this operation.
[ 1 2dup - ] dip
[ update-flags-no-carry ] 2keep
[ update-half-carry-flag ] 2keep
drop 0xFF bitand ;
: inc-word ( w cpu -- w )
- #! Increment word by one. Note that no flags are modified.
+ ! Increment word by one. Note that no flags are modified.
drop 1 + 0xFFFF bitand ;
: dec-word ( w cpu -- w )
- #! Decrement word by one. Note that no flags are modified.
+ ! Decrement word by one. Note that no flags are modified.
drop 1 - 0xFFFF bitand ;
: add-word ( lhs rhs cpu -- result )
- #! Add rhs to lhs. Note that only the carry flag is modified
- #! and only if there is a carry out of the double precision add.
+ ! Add rhs to lhs. Note that only the carry flag is modified
+ ! and only if there is a carry out of the double precision add.
[ + ] dip over 0xFFFF > [ carry-flag set-flag ] [ drop ] if 0xFFFF bitand ;
: bit3or ( lhs rhs -- 0|1 )
- #! bitor bit 3 of the two numbers on the stack
+ ! bitor bit 3 of the two numbers on the stack
[ 0b00001000 bitand -3 shift ] bi@ bitor ;
: and-byte ( lhs rhs cpu -- result )
- #! Logically and rhs to lhs. The carry flag is cleared and
- #! the half carry is set to the ORing of bits 3 of the operands.
+ ! Logically and rhs to lhs. The carry flag is cleared and
+ ! the half carry is set to the ORing of bits 3 of the operands.
[ drop bit3or ] 3keep ! bit3or lhs rhs cpu
[ bitand ] dip [ update-flags ] 2keep
[ carry-flag clear-flag ] keep
0xFF bitand ;
: xor-byte ( lhs rhs cpu -- result )
- #! Logically xor rhs to lhs. The carry and half-carry flags are cleared.
+ ! Logically xor rhs to lhs. The carry and half-carry flags are cleared.
[ bitxor ] dip [ update-flags ] 2keep
half-carry-flag carry-flag bitor clear-flag
0xFF bitand ;
: or-byte ( lhs rhs cpu -- result )
- #! Logically or rhs to lhs. The carry and half-carry flags are cleared.
+ ! Logically or rhs to lhs. The carry and half-carry flags are cleared.
[ bitor ] dip [ update-flags ] 2keep
half-carry-flag carry-flag bitor clear-flag
0xFF bitand ;
: decrement-sp ( n cpu -- )
- #! Decrement the stackpointer by n.
+ ! Decrement the stackpointer by n.
[ sp>> swap - ] keep sp<< ;
: save-pc ( cpu -- )
- #! Save the value of the PC on the stack.
+ ! Save the value of the PC on the stack.
[ pc>> ] [ sp>> ] [ write-word ] tri ;
: push-pc ( cpu -- )
- #! Push the value of the PC on the stack.
+ ! Push the value of the PC on the stack.
[ 2 swap decrement-sp ] [ save-pc ] bi ;
: pop-pc ( cpu -- pc )
- #! Pop the value of the PC off the stack.
+ ! Pop the value of the PC off the stack.
[ sp>> ] [ read-word ] [ -2 swap decrement-sp ] tri ;
: push-sp ( value cpu -- )
[ sp>> ] [ read-word ] [ -2 swap decrement-sp ] tri ;
: call-sub ( addr cpu -- )
- #! Call the address as a subroutine.
+ ! Call the address as a subroutine.
dup push-pc
[ 0xFFFF bitand ] dip pc<< ;
[ pop-pc ] keep pc<< ;
: interrupt ( number cpu -- )
- #! Perform a hardware interrupt
+ ! Perform a hardware interrupt
! "***Interrupt: " write over >hex print
dup f>> interrupt-flag bitand 0 = not [
dup push-pc
] if ;
: inc-cycles ( n cpu -- )
- #! Increment the number of cpu cycles
+ ! Increment the number of cpu cycles
[ cycles>> + ] keep cycles<< ;
: instruction-cycles ( -- vector )
- #! Return a 256 element vector containing the cycles for
- #! each opcode in the 8080 instruction set.
+ ! Return a 256 element vector containing the cycles for
+ ! each opcode in the 8080 instruction set.
\ instruction-cycles get-global [
256 f <array> \ instruction-cycles set-global
] unless
drop ;
: instructions ( -- vector )
- #! Return a 256 element vector containing the emulation words for
- #! each opcode in the 8080 instruction set.
+ ! Return a 256 element vector containing the emulation words for
+ ! each opcode in the 8080 instruction set.
\ instructions get-global [
256 [ not-implemented ] <array> \ instructions set-global
] unless
instructions set-nth ;
M: cpu reset
- #! Reset the CPU to its poweron state
+ ! Reset the CPU to its poweron state
0 >>b
0 >>c
0 >>d
2drop
] if* ;
- #! Reads the ROM from stdin and stores it in ROM from
- #! offset n.
+ ! Reads the ROM from stdin and stores it in ROM from
+ ! offset n.
: load-rom ( filename cpu -- )
- #! Load the contents of the file into ROM.
- #! (address 0x0000-0x1FFF).
+ ! Load the contents of the file into ROM.
+ ! (address 0x0000-0x1FFF).
ram>> swap binary [
0 swap (load-rom)
] with-file-reader ;
] unless* ;
: load-rom* ( seq cpu -- )
- #! 'seq' is an array of arrays. Each array contains
- #! an address and filename of a ROM file. The ROM
- #! file will be loaded at the specified address. This
- #! file path shoul dbe relative to the '/roms' resource path.
+ ! 'seq' is an array of arrays. Each array contains
+ ! an address and filename of a ROM file. The ROM
+ ! file will be loaded at the specified address. This
+ ! file path shoul dbe relative to the '/roms' resource path.
rom-dir [
ram>> [
swap first2 rom-dir prepend-path binary [
] if ;
: read-instruction ( cpu -- word )
- #! Read the next instruction from the cpu's program
- #! counter, and increment the program counter.
+ ! Read the next instruction from the cpu's program
+ ! counter, and increment the program counter.
[ pc>> ] keep ! pc cpu
[ over 1 + swap pc<< ] keep
read-byte ;
ERROR: undefined-8080-opcode n ;
: get-cycles ( n -- opcode )
- #! Returns the cycles for the given instruction value.
- #! If the opcode is not defined throw an error.
+ ! Returns the cycles for the given instruction value.
+ ! If the opcode is not defined throw an error.
dup instruction-cycles nth [
nip
] [
] if* ;
: process-interrupts ( cpu -- )
- #! Process any hardware interrupts
+ ! Process any hardware interrupts
[ cycles>> ] keep
over 16667 < [
2drop
] if ;
: peek-instruction ( cpu -- word )
- #! Return the next instruction from the cpu's program
- #! counter, but don't increment the counter.
+ ! Return the next instruction from the cpu's program
+ ! counter, but don't increment the counter.
[ pc>> ] keep read-byte instructions nth first ;
: cpu. ( cpu -- )
} cleave ;
: register-lookup ( string -- vector )
- #! Given a string containing a register name, return a vector
- #! where the 1st item is the getter and the 2nd is the setter
- #! for that register.
+ ! Given a string containing a register name, return a vector
+ ! where the 1st item is the getter and the 2nd is the setter
+ ! for that register.
H{
{ "A" { a>> a<< } }
{ "B" { b>> b<< } }
: flag-lookup ( string -- vector )
- #! Given a string containing a flag name, return a vector
- #! where the 1st item is a word that tests that flag.
+ ! Given a string containing a flag name, return a vector
+ ! where the 1st item is a word that tests that flag.
H{
{ "NZ" { flag-nz? } }
{ "NC" { flag-nc? } }
] with deep-map ;
: (emulate-RST) ( n cpu -- )
- #! RST nn
+ ! RST nn
[ sp>> 2 - dup ] keep ! sp sp cpu
[ sp<< ] keep ! sp cpu
[ pc>> ] keep ! sp pc cpu
[ 8 * ] dip pc<< ;
: (emulate-CALL) ( cpu -- )
- #! 205 - CALL nn
+ ! 205 - CALL nn
[ next-word 0xFFFF bitand ] keep ! addr cpu
[ sp>> 2 - dup ] keep ! addr sp sp cpu
[ sp<< ] keep ! addr sp cpu
pc<< ;
: (emulate-RLCA) ( cpu -- )
- #! The content of the accumulator is rotated left
- #! one position. The low order bit and the carry flag
- #! are both set to the value shifd out of the high
- #! order bit position. Only the carry flag is affected.
+ ! The content of the accumulator is rotated left
+ ! one position. The low order bit and the carry flag
+ ! are both set to the value shifd out of the high
+ ! order bit position. Only the carry flag is affected.
[ a>> -7 shift ] keep
over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
[ a>> 1 shift 0xFF bitand ] keep
[ bitor ] dip a<< ;
: (emulate-RRCA) ( cpu -- )
- #! The content of the accumulator is rotated right
- #! one position. The high order bit and the carry flag
- #! are both set to the value shifd out of the low
- #! order bit position. Only the carry flag is affected.
+ ! The content of the accumulator is rotated right
+ ! one position. The high order bit and the carry flag
+ ! are both set to the value shifd out of the low
+ ! order bit position. Only the carry flag is affected.
[ a>> 1 bitand 7 shift ] keep
over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
[ a>> 254 bitand -1 shift ] keep
[ bitor ] dip a<< ;
: (emulate-RLA) ( cpu -- )
- #! The content of the accumulator is rotated left
- #! one position through the carry flag. The low
- #! order bit is set equal to the carry flag and
- #! the carry flag is set to the value shifd out
- #! of the high order bit. Only the carry flag is
- #! affected.
+ ! The content of the accumulator is rotated left
+ ! one position through the carry flag. The low
+ ! order bit is set equal to the carry flag and
+ ! the carry flag is set to the value shifd out
+ ! of the high order bit. Only the carry flag is
+ ! affected.
[ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep
[ a>> 127 bitand 7 shift ] keep
dup a>> 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
[ bitor ] dip a<< ;
: (emulate-RRA) ( cpu -- )
- #! The content of the accumulator is rotated right
- #! one position through the carry flag. The high order
- #! bit is set to the carry flag and the carry flag is
- #! set to the value shifd out of the low order bit.
- #! Only the carry flag is affected.
+ ! The content of the accumulator is rotated right
+ ! one position through the carry flag. The high order
+ ! bit is set to the carry flag and the carry flag is
+ ! set to the value shifd out of the low order bit.
+ ! Only the carry flag is affected.
[ carry-flag swap flag-set? [ 0b10000000 ] [ 0 ] if ] keep
[ a>> 254 bitand -1 shift ] keep
dup a>> 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
[ bitor ] dip a<< ;
: (emulate-CPL) ( cpu -- )
- #! The contents of the accumulator are complemented
- #! (zero bits become one, one bits becomes zero).
- #! No flags are affected.
+ ! The contents of the accumulator are complemented
+ ! (zero bits become one, one bits becomes zero).
+ ! No flags are affected.
0xFF swap cpu-a-bitxor= ;
: (emulate-DAA) ( cpu -- )
- #! The eight bit number in the accumulator is
- #! adjusted to form two four-bit binary-coded-decimal
- #! digits.
+ ! The eight bit number in the accumulator is
+ ! adjusted to form two four-bit binary-coded-decimal
+ ! digits.
[
dup half-carry-flag swap flag-set? swap
a>> 0b1111 bitand 9 > or [ 6 ] [ 0 ] if
swap 0xFF bitand swap a<< ;
: patterns ( -- hashtable )
- #! table of code quotation patterns for each type of instruction.
+ ! table of code quotation patterns for each type of instruction.
H{
{ "NOP" [ drop ] }
{ "RET-NN" [ ret-from-sub ] }
} ;
: 8-bit-registers ( -- parser )
- #! A parser for 8-bit registers. On a successfull parse the
- #! parse tree contains a vector. The first item in the vector
- #! is the getter word for that register with stack effect
- #! ( cpu -- value ). The second item is the setter word with
- #! stack effect ( value cpu -- ).
+ ! A parser for 8-bit registers. On a successfull parse the
+ ! parse tree contains a vector. The first item in the vector
+ ! is the getter word for that register with stack effect
+ ! ( cpu -- value ). The second item is the setter word with
+ ! stack effect ( value cpu -- ).
<EBNF
main=("A" | "B" | "C" | "D" | "E" | "H" | "L") => [[ register-lookup ]]
EBNF> ;
: all-flags ( -- parser )
- #! A parser for 16-bit flags.
+ ! A parser for 16-bit flags.
<EBNF
main=("NZ" | "NC" | "PO" | "PE" | "Z" | "C" | "P" | "M") => [[ flag-lookup ]]
EBNF> ;
: 16-bit-registers ( -- parser )
- #! A parser for 16-bit registers. On a successfull parse the
- #! parse tree contains a vector. The first item in the vector
- #! is the getter word for that register with stack effect
- #! ( cpu -- value ). The second item is the setter word with
- #! stack effect ( value cpu -- ).
+ ! A parser for 16-bit registers. On a successfull parse the
+ ! parse tree contains a vector. The first item in the vector
+ ! is the getter word for that register with stack effect
+ ! ( cpu -- value ). The second item is the setter word with
+ ! stack effect ( value cpu -- ).
<EBNF
main=("AF" | "BC" | "DE" | "HL" | "SP") => [[ register-lookup ]]
EBNF> ;
: all-registers ( -- parser )
- #! Return a parser that can parse the format
- #! for 8 bit or 16 bit registers.
+ ! Return a parser that can parse the format
+ ! for 8 bit or 16 bit registers.
[ 16-bit-registers , 8-bit-registers , ] choice* ;
: indirect ( parser -- parser )
- #! Given a parser, return a parser which parses the original
- #! wrapped in brackets, representing an indirect reference.
- #! eg. BC -> (BC). The value of the original parser is left in
- #! the parse tree.
+ ! Given a parser, return a parser which parses the original
+ ! wrapped in brackets, representing an indirect reference.
+ ! eg. BC -> (BC). The value of the original parser is left in
+ ! the parse tree.
"(" ")" surrounded-by ;
: generate-instruction ( vector string -- quot )
- #! Generate the quotation for an instruction, given the instruction in
- #! the 'string' and a vector containing the arguments for that instruction.
+ ! Generate the quotation for an instruction, given the instruction in
+ ! the 'string' and a vector containing the arguments for that instruction.
patterns at replace-patterns ;
: simple-instruction ( token -- parser )
- #! Return a parser for then instruction identified by the token.
- #! The parser return parses the token only and expects no additional
- #! arguments to the instruction.
+ ! Return a parser for then instruction identified by the token.
+ ! The parser return parses the token only and expects no additional
+ ! arguments to the instruction.
token [ '[ { } _ generate-instruction ] ] action ;
: complex-instruction ( type token -- parser )
- #! Return a parser for an instruction identified by the token.
- #! The instruction is expected to take additional arguments by
- #! being combined with other parsers. Then 'type' is used for a lookup
- #! in a pattern hashtable to return the instruction quotation pattern.
+ ! Return a parser for an instruction identified by the token.
+ ! The instruction is expected to take additional arguments by
+ ! being combined with other parsers. Then 'type' is used for a lookup
+ ! in a pattern hashtable to return the instruction quotation pattern.
token swap [ nip '[ _ generate-instruction ] ] curry action ;
: no-params ( ast -- ast )
] seq* [ two-params ] action ;
: LD-RR,NN-instruction ( -- parser )
- #! LD BC,nn
+ ! LD BC,nn
[
"LD-RR,NN" "LD" complex-instruction ,
16-bit-registers sp ,
] seq* [ one-param ] action ;
: LD-R,N-instruction ( -- parser )
- #! LD B,n
+ ! LD B,n
[
"LD-R,N" "LD" complex-instruction ,
8-bit-registers sp ,
] seq* [ one-param ] action ;
: LD-(RR),R-instruction ( -- parser )
- #! LD (BC),A
+ ! LD (BC),A
[
"LD-(RR),R" "LD" complex-instruction ,
16-bit-registers indirect sp ,
] choice* [ call( -- quot ) ] action ;
: instruction-quotations ( string -- emulate-quot )
- #! Given an instruction string, return the emulation quotation for
- #! it. This will later be expanded to produce the disassembly and
- #! assembly quotations.
+ ! Given an instruction string, return the emulation quotation for
+ ! it. This will later be expanded to produce the disassembly and
+ ! assembly quotations.
8080-generator-parser parse ;
SYMBOL: last-instruction
SYMBOL: last-opcode
: parse-instructions ( list -- )
- #! Process the list of strings, which should make
- #! up an 8080 instruction, and output a quotation
- #! that would implement that instruction.
+ ! Process the list of strings, which should make
+ ! up an 8080 instruction, and output a quotation
+ ! that would implement that instruction.
dup " " join instruction-quotations
[
"_" join [ "emulate-" % % ] "" make create-word-in
SYNTAX: INSTRUCTION: ";" parse-tokens parse-instructions ;
SYNTAX: cycles:
- #! Set the number of cycles for the last instruction that was defined.
+ ! Set the number of cycles for the last instruction that was defined.
scan-token string>number last-opcode get-global instruction-cycles set-nth ;
SYNTAX: opcode:
- #! Set the opcode number for the last instruction that was defined.
+ ! Set the opcode number for the last instruction that was defined.
last-instruction get-global 1quotation scan-token hex>
dup last-opcode set-global set-instruction ;
IN: cpu.8080.test
: step ( cpu -- )
- #! Run a single 8080 instruction
+ ! Run a single 8080 instruction
[ read-instruction ] keep ! n cpu
over get-cycles over inc-cycles
[ swap instructions nth call( cpu -- ) ] keep
[ 8 <bits> ] dip each ; inline
: >ppm ( cpu filename -- cpu )
- #! Dump the current screen image to a ppm image file with the given name.
+ ! Dump the current screen image to a ppm image file with the given name.
ascii [
"P3" print
"256 224" print
cond-code set ;
: CC> ( -- n )
- #! Default value is 0b1110 AL (= always)
+ ! Default value is 0b1110 AL (= always)
cond-code [ f ] change 0b1110 or ;
: EQ ( -- ) 0b0000 >CC ;
2893506291 435870753 684796225 1465647214 3491035560 3387827593
3779005640 3059944614 }
} [
- HEX{ 2b 7e 15 16 28 ae d2 a6 ab f7 15 88 09 cf 4f 3c } #! AES-128 key expansion test vector from FIPS-197 (appendix)
+ HEX{ 2b 7e 15 16 28 ae d2 a6 ab f7 15 88 09 cf 4f 3c } ! AES-128 key expansion test vector from FIPS-197 (appendix)
10 (expand-enc-key)
] unit-test
#! FIPS-197 AES
#! input block, state, output block -- 4 32-bit words
CONSTANT: FIPS-197 {
- { 128 10 } #! aes-128 -- Key(4) Block(4) Rounds(10)
- { 192 12 } #! aes-192 -- Key(6) Block(4) Rounds(12)
- { 256 14 } #! aes-256 -- Key(8) Block(4) Rounds(14)
+ { 128 10 } ! aes-128 -- Key(4) Block(4) Rounds(10)
+ { 192 12 } ! aes-192 -- Key(6) Block(4) Rounds(12)
+ { 256 14 } ! aes-256 -- Key(8) Block(4) Rounds(14)
}
<PRIVATE
[ dup 4th-from-end ] dip bitxor suffix! ; inline
: (sched-interval) ( K Nr -- seq )
- [ length ] dip 1 + 4 * [a,b) ; #! over the interval Nk...Nb(Nr + 1)
+ [ length ] dip 1 + 4 * [a,b) ; ! over the interval Nk...Nb(Nr + 1)
: (init-round) ( out -- out temp quot )
[ ]
#! rotate each row n times, transpose again, and then
#! smash them back into 4-byte words.
:: (shift-rows) ( c0 c1 c2 c3 -- c0' c1' c2' c3' )
- c3 gb0 c2 gb1 c1 gb2 c0 gb3 >ui32 #! c0'
- c0 gb0 c3 gb1 c2 gb2 c1 gb3 >ui32 #! c1'
- c1 gb0 c0 gb1 c3 gb2 c2 gb3 >ui32 #! c2'
- c2 gb0 c1 gb1 c0 gb2 c3 gb3 >ui32 ; #! c3'
+ c3 gb0 c2 gb1 c1 gb2 c0 gb3 >ui32 ! c0'
+ c0 gb0 c3 gb1 c2 gb2 c1 gb3 >ui32 ! c1'
+ c1 gb0 c0 gb1 c3 gb2 c2 gb3 >ui32 ! c2'
+ c2 gb0 c1 gb1 c0 gb2 c3 gb3 >ui32 ; ! c3'
:: (unshift-rows) ( c0 c1 c2 c3 -- c0' c1' c2' c3' )
- c1 gb0 c2 gb1 c3 gb2 c0 gb3 >ui32 #! c0'
- c2 gb0 c3 gb1 c0 gb2 c1 gb3 >ui32 #! c1'
- c3 gb0 c0 gb1 c1 gb2 c2 gb3 >ui32 #! c2'
- c0 gb0 c1 gb1 c2 gb2 c3 gb3 >ui32 ; #! c3'
+ c1 gb0 c2 gb1 c3 gb2 c0 gb3 >ui32 ! c0'
+ c2 gb0 c3 gb1 c0 gb2 c1 gb3 >ui32 ! c1'
+ c3 gb0 c0 gb1 c1 gb2 c2 gb3 >ui32 ! c2'
+ c0 gb0 c1 gb1 c2 gb2 c3 gb3 >ui32 ; ! c3'
: (add-round-key) ( key state -- state' )
4 [ bitxor ] unrolled-2map ;
IN: crypto.barrett
: barrett-mu ( n size -- mu )
- #! Calculates Barrett's reduction parameter mu
- #! size = word size in bits (8, 16, 32, 64, ...)
+ ! Calculates Barrett's reduction parameter mu
+ ! size = word size in bits (8, 16, 32, 64, ...)
[ [ log2 1 + ] [ / 2 * ] bi* ]
[ 2^ rot ^ swap /i ] 2bi ;
2/ 2 swap unique-primes first2 ;
: modulus-phi ( numbits -- n phi )
- #! Loop until phi is not divisible by the public key.
+ ! Loop until phi is not divisible by the public key.
dup rsa-primes [ * ] 2keep
[ 1 - ] bi@ *
dup public-key coprime? [
"browser-dom" set-in
: elements ( string -- result )
- #! Call JQuery's $ function
+ ! Call JQuery's $ function
window { "result" } "" "$" { "string" } alien-invoke ;
: html ( string -- element )
- #! Set the innerHTML of element using jQuery
+ ! Set the innerHTML of element using jQuery
{ } "" "html" { "string" } alien-invoke ;
: bind-event ( name element quot -- )
] callcc0 ;
: alert ( string -- )
- #! Display the string in an alert box
+ ! Display the string in an alert box
window { } "" "alert" { "string" } alien-invoke ;
CONSTANT: elements-vocab "html.elements"
: html-word ( name def effect -- )
- #! Define 'word creating' word to allow
- #! dynamically creating words.
+ ! Define 'word creating' word to allow
+ ! dynamically creating words.
[ elements-vocab create-word ] 2dip define-declared ;
: <foo> ( str -- <str> ) "<" ">" surround ;
: def-for-html-word-<foo> ( name -- )
- #! Return the name and code for the <foo> patterned
- #! word.
+ ! Return the name and code for the <foo> patterned
+ ! word.
dup <foo> swap '[ _ <foo> write-html ]
( -- ) html-word ;
: <foo ( str -- <str ) "<" prepend ;
: def-for-html-word-<foo ( name -- )
- #! Return the name and code for the <foo patterned
- #! word.
+ ! Return the name and code for the <foo patterned
+ ! word.
<foo dup '[ _ write-html ]
( -- ) html-word ;
: foo> ( str -- foo> ) ">" append ;
: def-for-html-word-foo> ( name -- )
- #! Return the name and code for the foo> patterned
- #! word.
+ ! Return the name and code for the foo> patterned
+ ! word.
foo> [ ">" write-html ] ( -- ) html-word ;
: </foo> ( str -- </str> ) "</" ">" surround ;
: def-for-html-word-</foo> ( name -- )
- #! Return the name and code for the </foo> patterned
- #! word.
+ ! Return the name and code for the </foo> patterned
+ ! word.
</foo> dup '[ _ write-html ] ( -- ) html-word ;
: <foo/> ( str -- <str/> ) "<" "/>" surround ;
: def-for-html-word-<foo/> ( name -- )
- #! Return the name and code for the <foo/> patterned
- #! word.
+ ! Return the name and code for the <foo/> patterned
+ ! word.
dup <foo/> swap '[ _ <foo/> write-html ]
( -- ) html-word ;
: foo/> ( str -- str/> ) "/>" append ;
: def-for-html-word-foo/> ( name -- )
- #! Return the name and code for the foo/> patterned
- #! word.
+ ! Return the name and code for the foo/> patterned
+ ! word.
foo/> [ "/>" write-html ] ( -- ) html-word ;
: define-closed-html-word ( name -- )
- #! Given an HTML tag name, define the words for
- #! that closable HTML tag.
+ ! Given an HTML tag name, define the words for
+ ! that closable HTML tag.
dup def-for-html-word-<foo>
dup def-for-html-word-<foo
dup def-for-html-word-foo>
def-for-html-word-</foo> ;
: define-open-html-word ( name -- )
- #! Given an HTML tag name, define the words for
- #! that open HTML tag.
+ ! Given an HTML tag name, define the words for
+ ! that open HTML tag.
dup def-for-html-word-<foo/>
dup def-for-html-word-<foo
def-for-html-word-foo/> ;
] map >hashtable ; inline
:: read-tga ( -- image )
- #! Read header
+ ! Read header
read-id-length :> id-length
read-color-map-type :> map-type
read-image-type :> image-type
image-width image-height pixel-depth read-image-data :> image-data
[
- #! Read optional footer
+ ! Read optional footer
26 seek-end seek-input
read-extension-area-offset :> extension-offset
read-developer-directory-offset :> directory-offset
read-signature
- #! Read optional extension section
+ ! Read optional extension section
extension-offset 0 =
[
extension-offset seek-absolute seek-input
scan-line-offset seek-absolute seek-input
image-height read-scan-line-table :> scan-offsets
- #! Read optional developer section
+ ! Read optional developer section
directory-offset 0 =
[ f ]
[
] unless
] ignore-errors
- #! Only 24-bit uncompressed BGR and 32-bit uncompressed BGRA are supported.
- #! Other formats would need to be converted to work within the image class.
+ ! Only 24-bit uncompressed BGR and 32-bit uncompressed BGRA are supported.
+ ! Other formats would need to be converted to work within the image class.
map-type 0 = [ bad-tga-unsupported ] unless
image-type 2 = [ bad-tga-unsupported ] unless
pixel-depth { 24 32 } member? [ bad-tga-unsupported ] unless
pixel-order { 0 2 } member? [ bad-tga-unsupported ] unless
- #! Create image instance
+ ! Create image instance
image new
alpha-bits 0 = [ BGR ] [ BGRA ] if >>component-order
{ image-width image-height } >>dim
component-order>> { BGRA BGRA } member? [ bad-tga-unsupported ] unless
] keep
- B{ 0 } write #! id-length
- B{ 0 } write #! map-type
- B{ 2 } write #! image-type
- B{ 0 0 0 0 0 } write #! color map first, length, entry size
- B{ 0 0 0 0 } write #! x-origin, y-origin
+ B{ 0 } write ! id-length
+ B{ 0 } write ! map-type
+ B{ 2 } write ! image-type
+ B{ 0 0 0 0 0 } write ! color map first, length, entry size
+ B{ 0 0 0 0 } write ! x-origin, y-origin
{
[ dim>> first 2 >le write ]
[ dim>> second 2 >le write ]
swap [ segment-vertex ] keep dupd segment-vertex-normal ;
: equally-spaced-radians ( n -- seq )
- #! return a sequence of n numbers between 0 and 2pi
+ ! return a sequence of n numbers between 0 and 2pi
[ iota ] keep [ / pi 2 * * ] curry map ;
: draw-segment-vertex ( segment theta -- )
/ pi 4 * * ; ! 2 / / pi 2 * * ;
: x>radians ( x gadget -- theta )
- #! translate motion of x pixels to an angle
+ ! translate motion of x pixels to an angle
dim>> first pix>radians neg ;
: y>radians ( y gadget -- theta )
- #! translate motion of y pixels to an angle
+ ! translate motion of y pixels to an angle
dim>> second pix>radians ;
: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
over forward>> rotate-oint ;
: random-float+- ( n -- m )
- #! find a random float between -n/2 and n/2
+ ! find a random float between -n/2 and n/2
dup 10000 * >integer random 10000 / swap 2 / - ;
: random-turn ( oint theta -- )
distance-vector norm ;
: scalar-projection ( v1 v2 -- n )
- #! the scalar projection of v1 onto v2
+ ! the scalar projection of v1 onto v2
[ v. ] [ norm ] bi / ;
: proj-perp ( u v -- w )
-rot up>> scalar-projection abs + ;
:: reflect ( v n -- v' )
- #! bounce v on a surface with normal n
+ ! bounce v on a surface with normal n
v v n v. n n v. / 2 * n n*v v- ;
: half-way ( p1 p2 -- p3 )
n-segments simple-segments ;
: sub-tunnel ( from to segments -- segments )
- #! return segments between from and to, after clamping from and to to
- #! valid values
+ ! return segments between from and to, after clamping from and to to
+ ! valid values
[ '[ _ clamp-length ] bi@ ] keep <slice> ;
: get-segment ( segments n -- segment )
number>> 1 - get-segment ;
: heading-segment ( segments current-segment heading -- segment )
- #! the next segment on the given heading
+ ! the next segment on the given heading
over forward>> v. 0 <=> {
{ +gt+ [ next-segment ] }
{ +lt+ [ previous-segment ] }
CONSTANT: distant 1000
: max-real ( a b -- c )
- #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
+ ! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
dup real? [
over real? [ max ] [ nip ] if
] [
[ wall-normal ] [ forward>> swap reflect ] [ forward<< ] tri ;
: bounce-left ( segment oint -- )
- #! must be done after forward
+ ! must be done after forward
[ forward>> vneg ] dip [ left>> swap reflect ]
[ forward>> proj-perp normalize ] [ left<< ] tri ;
: bounce-up ( segment oint -- )
- #! must be done after forward and left!
+ ! must be done after forward and left!
nip [ forward>> ] [ left>> cross ] [ up<< ] tri ;
: bounce-off-wall ( oint segment -- )
] if ;
: interior ( x y -- i_y[x] )
- #! y is a generator
+ ! y is a generator
swap >alt [ dupd (interior) ] linear-op nip ;
! Computing a basis
! Graded by degree
: (graded-ker/im-d) ( n seq -- null/rank )
- #! d: C(n) ---> C(n+1)
+ ! d: C(n) ---> C(n+1)
[ ?nth ] [ [ 1 + ] dip ?nth ] 2bi
dim-im/ker-d ;
! Bi-graded for two-step complexes
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )
- #! d: C(u,z) ---> C(u+2,z-1)
+ ! d: C(u,z) ---> C(u+2,z-1)
[ ?nth ?nth ] 3keep [ [ 2 + ] dip 1 - ] dip ?nth ?nth
dim-im/ker-d ;
] each-index ;
: bigraded-triple ( u-deg z-deg bigraded-basis -- triple )
- #! d: C(u,z) ---> C(u+2,z-1)
+ ! d: C(u,z) ---> C(u+2,z-1)
[ [ 2 - ] [ 1 + ] [ ] tri* ?nth ?nth ]
[ ?nth ?nth ]
[ [ 2 + ] [ 1 - ] [ ] tri* ?nth ?nth ]
SYMBOL: current-git-id
: short-running-process ( command -- )
- #! Give network operations and shell commands at most
- #! 30 minutes to complete, to catch hangs.
+ ! Give network operations and shell commands at most
+ ! 30 minutes to complete, to catch hangs.
>process
30 minutes >>timeout
+new-group+ >>group
'[ drop @ f ] attempt-all drop ; inline
: upload-process ( process -- )
- #! Give network operations and shell commands at most
- #! 30 minutes to complete, to catch hangs.
+ ! Give network operations and shell commands at most
+ ! 30 minutes to complete, to catch hangs.
>process
upload-timeout get >>timeout
+new-group+ >>group
} ;
: git-clone ( -- )
- #! Must be run from builds-dir
+ ! Must be run from builds-dir
"Cloning initial repository" print-timestamp
git-clone-cmd try-output-process ;
{ "git" "status" } ;
: git-status-failed ( error -- )
- #! Exit code 1 means there's nothing to commit.
+ ! Exit code 1 means there's nothing to commit.
dup { [ process-failed? ] [ code>> 1 = ] } 1&&
[ drop ] [ rethrow ] if ;
PRIVATE>
: git-clone-or-pull ( -- id )
- #! Must be run from builds-dir.
+ ! Must be run from builds-dir.
"factor" exists? [
check-repository [
"factor" [
counter-url get-global http-get nip string>number ;
: update-sources ( -- )
- #! Must be run from builds-dir
+ ! Must be run from builds-dir
git-clone-or-pull latest-boot-image latest-counter <sources>
latest-sources set-global ;
latest-sources get-global last-built-sources get-global = not ;
: finish-build ( -- )
- #! If the build completed (successfully or not) without
- #! mason crashing or being killed, don't build this git ID
- #! and boot image hash again.
+ ! If the build completed (successfully or not) without
+ ! mason crashing or being killed, don't build this git ID
+ ! and boot image hash again.
latest-sources get-global last-built-sources set-global ;
[ + recip ] with { } map-integers 1.0 0 pick set-nth ;
: (gamma-lanczos6) ( x -- log[gamma[x+1]] )
- #! log(gamma(x+1)
+ ! log(gamma(x+1)
[ 0.5 + dup gamma-g6 + [ log * ] keep - ]
[ 6 gamma-z gamma-p6 v. log ] bi + ;
: gamma-lanczos6 ( x -- gamma[x] )
- #! gamma(x) = gamma(x+1) / x
+ ! gamma(x) = gamma(x+1) / x
[ (gamma-lanczos6) e^ ] keep / ;
: gammaln-lanczos6 ( x -- gammaln[x] )
- #! log(gamma(x)) = log(gamma(x+1)) - log(x)
+ ! log(gamma(x)) = log(gamma(x+1)) - log(x)
[ (gamma-lanczos6) ] keep log - ;
: gamma-neg ( gamma[abs[x]] x -- gamma[x] )
PRIVATE>
: gamma ( x -- y )
- #! gamma(x) = integral 0..inf [ t^(x-1) exp(-t) ] dt
- #! gamma(n+1) = n! for n > 0
+ ! gamma(x) = integral 0..inf [ t^(x-1) exp(-t) ] dt
+ ! gamma(n+1) = n! for n > 0
dup { [ 0.0 <= ] [ 1.0 mod zero? ] } 1&& [
drop 1/0.
] [
] if ;
: gammaln ( x -- gamma[x] )
- #! gammaln(x) is an alternative when gamma(x)'s range
- #! varies too widely
+ ! gammaln(x) is an alternative when gamma(x)'s range
+ ! varies too widely
dup 0 < [
drop 1/0.
] [
! copyright notice is preserved.
: exp-int ( x -- y )
- #! For real values of x only. Accurate to 7 decimals.
+ ! For real values of x only. Accurate to 7 decimals.
dup 1.0 < [
dup 0.00107857 * 0.00976004 -
over *
C: satisfy satisfy-parser
M: satisfy-parser parse ( input parser -- list )
- #! A parser that succeeds if the predicate,
- #! when passed the first character in the input, returns
- #! true.
+ ! A parser that succeeds if the predicate,
+ ! when passed the first character in the input, returns
+ ! true.
over empty? [
2drop nil
] [
C: epsilon epsilon-parser
M: epsilon-parser parse ( input parser -- list )
- #! A parser that parses the empty string. It
- #! does not consume any input and always returns
- #! an empty list as the parse tree with the
- #! unmodified input.
+ ! A parser that parses the empty string. It
+ ! does not consume any input and always returns
+ ! an empty list as the parse tree with the
+ ! unmodified input.
drop "" swap <parse-results> ;
TUPLE: succeed-parser result ;
C: succeed succeed-parser
M: succeed-parser parse ( input parser -- list )
- #! A parser that always returns 'result' as a
- #! successful parse with no input consumed.
+ ! A parser that always returns 'result' as a
+ ! successful parse with no input consumed.
result>> swap <parse-results> ;
TUPLE: fail-parser ;
C: fail fail-parser
M: fail-parser parse ( input parser -- list )
- #! A parser that always fails and returns
- #! an empty list of successes.
+ ! A parser that always fails and returns
+ ! an empty list of successes.
2drop nil ;
TUPLE: ensure-parser test ;
] with lazy-map lconcat ;
M: and-parser parse ( input parser -- list )
- #! Parse 'input' by sequentially combining the
- #! two parsers. First parser1 is applied to the
- #! input then parser2 is applied to the rest of
- #! the input strings from the first parser.
+ ! Parse 'input' by sequentially combining the
+ ! two parsers. First parser1 is applied to the
+ ! input then parser2 is applied to the rest of
+ ! the input strings from the first parser.
parsers>> unclip swapd parse
[ [ and-parser-parse ] reduce ] 2curry <promise> ;
2array <or-parser> ;
M: or-parser parse ( input parser1 -- list )
- #! Return the combined list resulting from the parses
- #! of parser1 and parser2 being applied to the same
- #! input. This implements the choice parsing operator.
+ ! Return the combined list resulting from the parses
+ ! of parser1 and parser2 being applied to the same
+ ! input. This implements the choice parsing operator.
parsers>> sequence>list
[ parse ] with lazy-map lconcat ;
: trim-head-slice ( string -- string )
- #! Return a new string without any leading whitespace
- #! from the original string.
+ ! Return a new string without any leading whitespace
+ ! from the original string.
dup empty? [
dup first blank? [ rest-slice trim-head-slice ] when
] unless ;
C: sp sp-parser
M: sp-parser parse ( input parser -- list )
- #! Skip all leading whitespace from the input then call
- #! the parser on the remaining input.
+ ! Skip all leading whitespace from the input then call
+ ! the parser on the remaining input.
[ trim-head-slice ] dip p1>> parse ;
TUPLE: just-parser p1 ;
C: just just-parser
M: just-parser parse ( input parser -- result )
- #! Calls the given parser on the input removes
- #! from the results anything where the remaining
- #! input to be parsed is not empty. So ensures a
- #! fully parsed input string.
+ ! Calls the given parser on the input removes
+ ! from the results anything where the remaining
+ ! input to be parsed is not empty. So ensures a
+ ! fully parsed input string.
p1>> parse [ unparsed>> empty? ] lfilter ;
TUPLE: apply-parser p1 quot ;
C: <@ apply-parser
M: apply-parser parse ( input parser -- result )
- #! Calls the parser on the input. For each successful
- #! parse the quot is call with the parse result on the stack.
- #! The result of that quotation then becomes the new parse result.
- #! This allows modification of parse tree results (like
- #! converting strings to integers, etc).
+ ! Calls the parser on the input. For each successful
+ ! parse the quot is call with the parse result on the stack.
+ ! The result of that quotation then becomes the new parse result.
+ ! This allows modification of parse tree results (like
+ ! converting strings to integers, etc).
[ p1>> ] [ quot>> ] bi
-rot parse [
[ parsed>> swap call ] keep
C: some some-parser
M: some-parser parse ( input parser -- result )
- #! Calls the parser on the input, guarantees
- #! the parse is complete (the remaining input is empty),
- #! picks the first solution and only returns the parse
- #! tree since the remaining input is empty.
+ ! Calls the parser on the input, guarantees
+ ! the parse is complete (the remaining input is empty),
+ ! picks the first solution and only returns the parse
+ ! tree since the remaining input is empty.
p1>> just parse-1 ;
: <& ( parser1 parser2 -- parser )
- #! Same as <&> except discard the results of the second parser.
+ ! Same as <&> except discard the results of the second parser.
<&> [ first ] <@ ;
: &> ( parser1 parser2 -- parser )
- #! Same as <&> except discard the results of the first parser.
+ ! Same as <&> except discard the results of the first parser.
<&> [ second ] <@ ;
: <:&> ( parser1 parser2 -- result )
- #! Same as <&> except flatten the result.
+ ! Same as <&> except flatten the result.
<&> [ first2 suffix ] <@ ;
: <&:> ( parser1 parser2 -- result )
- #! Same as <&> except flatten the result.
+ ! Same as <&> except flatten the result.
<&> [ first2 swap prefix ] <@ ;
: <:&:> ( parser1 parser2 -- result )
- #! Same as <&> except flatten the result.
+ ! Same as <&> except flatten the result.
<&> [ first2 append ] <@ ;
LAZY: <*> ( parser -- parser )
dup <*> <&:> { } succeed <|> ;
: <+> ( parser -- parser )
- #! Return a parser that accepts one or more occurences of the original
- #! parser.
+ ! Return a parser that accepts one or more occurences of the original
+ ! parser.
dup <*> <&:> ;
LAZY: <?> ( parser -- parser )
- #! Return a parser that optionally uses the parser
- #! if that parser would be successful.
+ ! Return a parser that optionally uses the parser
+ ! if that parser would be successful.
[ 1array ] <@ f succeed <|> ;
TUPLE: only-first-parser p1 ;
only-first-parser boa ;
M: only-first-parser parse ( input parser -- list )
- #! Transform a parser into a parser that only yields
- #! the first possibility.
+ ! Transform a parser into a parser that only yields
+ ! the first possibility.
p1>> parse 1 swap ltake ;
LAZY: <!*> ( parser -- parser )
- #! Like <*> but only return one possible result
- #! containing all matching parses. Does not return
- #! partial matches. Useful for efficiency since that's
- #! usually the effect you want and cuts down on backtracking
- #! required.
+ ! Like <*> but only return one possible result
+ ! containing all matching parses. Does not return
+ ! partial matches. Useful for efficiency since that's
+ ! usually the effect you want and cuts down on backtracking
+ ! required.
<*> only-first ;
LAZY: <!+> ( parser -- parser )
- #! Like <+> but only return one possible result
- #! containing all matching parses. Does not return
- #! partial matches. Useful for efficiency since that's
- #! usually the effect you want and cuts down on backtracking
- #! required.
+ ! Like <+> but only return one possible result
+ ! containing all matching parses. Does not return
+ ! partial matches. Useful for efficiency since that's
+ ! usually the effect you want and cuts down on backtracking
+ ! required.
<+> only-first ;
LAZY: <!?> ( parser -- parser )
- #! Like <?> but only return one possible result
- #! containing all matching parses. Does not return
- #! partial matches. Useful for efficiency since that's
- #! usually the effect you want and cuts down on backtracking
- #! required.
+ ! Like <?> but only return one possible result
+ ! containing all matching parses. Does not return
+ ! partial matches. Useful for efficiency since that's
+ ! usually the effect you want and cuts down on backtracking
+ ! required.
<?> only-first ;
LAZY: <(?)> ( parser -- parser )
- #! Like <?> but take shortest match first.
+ ! Like <?> but take shortest match first.
f succeed swap [ 1array ] <@ <|> ;
LAZY: <(*)> ( parser -- parser )
- #! Like <*> but take shortest match first.
- #! Implementation by Matthew Willis.
+ ! Like <*> but take shortest match first.
+ ! Implementation by Matthew Willis.
{ } succeed swap dup <(*)> <&:> <|> ;
LAZY: <(+)> ( parser -- parser )
- #! Like <+> but take shortest match first.
- #! Implementation by Matthew Willis.
+ ! Like <+> but take shortest match first.
+ ! Implementation by Matthew Willis.
dup <(*)> <&:> ;
: pack ( close body open -- parser )
- #! Parse a construct enclosed by two symbols,
- #! given a parser for the opening symbol, the
- #! closing symbol, and the body.
+ ! Parse a construct enclosed by two symbols,
+ ! given a parser for the opening symbol, the
+ ! closing symbol, and the body.
<& &> ;
: nonempty-list-of ( items separator -- parser )
[ over &> <*> <&:> ] keep <?> [ nip ] 2keep pack ;
: list-of ( items separator -- parser )
- #! Given a parser for the separator and for the
- #! items themselves, return a parser that parses
- #! lists of those items. The parse tree is an
- #! array of the parsed items.
+ ! Given a parser for the separator and for the
+ ! items themselves, return a parser that parses
+ ! lists of those items. The parse tree is an
+ ! array of the parsed items.
nonempty-list-of { } succeed <|> ;
LAZY: surrounded-by ( parser start end -- parser' )
[ 0xFF bitand ] map-product ;
: perfect-hash-find ( q -- value )
- #! magic to convert a hand's unique identifying bits to the
- #! proper index for fast lookup in a table of hand values
+ ! magic to convert a hand's unique identifying bits to the
+ ! proper index for fast lookup in a table of hand values
0xE91AAA35 +
dup -16 shift bitxor
dup 8 shift w+
} cond nip [ process ] when ;
:: mock-pop3-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> utf8 <server> [
7 10^ sqrt >integer 1000 [ - ] [ + ] 2bi primes-between ; inline
: n-and-phi ( seq -- seq' )
- #! ( seq = { p1, p2 } -- seq' = { n, φ(n) } )
+ ! ( seq = { p1, p2 } -- seq' = { n, φ(n) } )
[ product ] [ [ 1 - ] map product ] bi 2array ;
: fit-requirements? ( seq -- ? )
ascii file-lines [ "," split [ string>number ] map ] map ;
: simplify ( seq -- seq )
- #! exponent * log(base)
+ ! exponent * log(base)
flip first2 swap [ log ] map v* ;
: solve ( seq -- index )
: noise-factor ( x y -- z ) / 100 * >integer ;
: quot-noise-factor ( quot -- n )
- #! For very short words, noise doesn't count so much
- #! (so dup foo swap bar isn't penalized as badly).
+ ! For very short words, noise doesn't count so much
+ ! (so dup foo swap bar isn't penalized as badly).
noise first2 {
{ [ over 4 <= ] [ [ drop 0 ] dip ] }
{ [ over 15 >= ] [ [ 2 * ] dip ] }
<PRIVATE
: ?+ ( x/f y/f -- sum )
- #! addition that treats f as 0
+ ! addition that treats f as 0
[
swap [ + ] when*
] [
game-height game-width 3 * * uchar <c-array> ;
: bitmap-index ( point -- index )
- #! Point is a {x y}.
+ ! Point is a {x y}.
first2 game-width 3 * * swap 3 * + ;
:: set-bitmap-pixel ( bitmap point color -- )
color third index 2 + bitmap set-nth ;
: get-bitmap-pixel ( point array -- color )
- #! Point is a {x y}. color is a {r g b}
+ ! Point is a {x y}. color is a {r g b}
[ bitmap-index ] dip
[ nth ]
[ [ 1 + ] dip nth ]
swap sounds>> nth source-stop ;
: read-port1 ( cpu -- byte )
- #! Port 1 maps the keys for space invaders
- #! Bit 0 = coin slot
- #! Bit 1 = two players button
- #! Bit 2 = one player button
- #! Bit 4 = player one fire
- #! Bit 5 = player one left
- #! Bit 6 = player one right
+ ! Port 1 maps the keys for space invaders
+ ! Bit 0 = coin slot
+ ! Bit 1 = two players button
+ ! Bit 2 = one player button
+ ! Bit 4 = player one fire
+ ! Bit 5 = player one left
+ ! Bit 6 = player one right
[ dup 0xFE bitand ] change-port1 drop ;
: read-port2 ( cpu -- byte )
- #! Port 2 maps player 2 controls and dip switches
- #! Bit 0,1 = number of ships
- #! Bit 2 = mode (1=easy, 0=hard)
- #! Bit 4 = player two fire
- #! Bit 5 = player two left
- #! Bit 6 = player two right
- #! Bit 7 = show or hide coin info
+ ! Port 2 maps player 2 controls and dip switches
+ ! Bit 0,1 = number of ships
+ ! Bit 2 = mode (1=easy, 0=hard)
+ ! Bit 4 = player two fire
+ ! Bit 5 = player two left
+ ! Bit 6 = player two right
+ ! Bit 7 = show or hide coin info
[ port2i>> 0x8F bitand ]
[ port1>> 0x70 bitand bitor ] bi ;
: read-port3 ( cpu -- byte )
- #! Used to compute a special formula
+ ! Used to compute a special formula
[ port4hi>> 8 shift ] keep
[ port4lo>> bitor ] keep
port2o>> shift -8 shift 0xFF bitand ;
M: space-invaders read-port
- #! Read a byte from the hardware port. 'port' should
- #! be an 8-bit value.
+ ! Read a byte from the hardware port. 'port' should
+ ! be an 8-bit value.
swap {
{ 1 [ read-port1 ] }
{ 2 [ read-port2 ] }
} case ;
: write-port2 ( value cpu -- )
- #! Setting this value affects the value read from port 3
+ ! Setting this value affects the value read from port 3
port2o<< ;
:: bit-newly-set? ( old-value new-value bit -- bool )
[ port5o>> swap ] dip bit-newly-set? ;
: write-port3 ( value cpu -- )
- #! Connected to the sound hardware
- #! Bit 0 = spaceship sound (looped)
- #! Bit 1 = Shot
- #! Bit 2 = Your ship hit
- #! Bit 3 = Invader hit
- #! Bit 4 = Extended play sound
+ ! Connected to the sound hardware
+ ! Bit 0 = spaceship sound (looped)
+ ! Bit 1 = Shot
+ ! Bit 2 = Your ship hit
+ ! Bit 3 = Invader hit
+ ! Bit 4 = Extended play sound
over 0 bit? [
dup looping?>> [
dup SOUND-UFO play-invaders-sound
port3o<< ;
: write-port4 ( value cpu -- )
- #! Affects the value returned by reading port 3
+ ! Affects the value returned by reading port 3
[ port4hi>> ] [ port4lo<< ] [ port4hi<< ] tri ;
: write-port5 ( value cpu -- )
- #! Plays sounds
- #! Bit 0 = invaders sound 1
- #! Bit 1 = invaders sound 2
- #! Bit 2 = invaders sound 3
- #! Bit 3 = invaders sound 4
- #! Bit 4 = spaceship hit
- #! Bit 5 = amplifier enabled/disabled
+ ! Plays sounds
+ ! Bit 0 = invaders sound 1
+ ! Bit 1 = invaders sound 2
+ ! Bit 2 = invaders sound 3
+ ! Bit 3 = invaders sound 4
+ ! Bit 4 = spaceship hit
+ ! Bit 5 = amplifier enabled/disabled
2dup 0 port5-newly-set? [ dup SOUND-WALK1 play-invaders-sound ] when
2dup 1 port5-newly-set? [ dup SOUND-WALK2 play-invaders-sound ] when
2dup 2 port5-newly-set? [ dup SOUND-WALK3 play-invaders-sound ] when
port5o<< ;
M: space-invaders write-port
- #! Write a byte to the hardware port, where 'port' is
- #! an 8-bit value.
+ ! Write a byte to the hardware port, where 'port' is
+ ! an 8-bit value.
swap {
{ 2 [ write-port2 ] }
{ 3 [ write-port3 ] }
CONSTANT: red { 255 0 0 }
: addr>xy ( addr -- point )
- #! Convert video RAM address to base X Y value. point is a {x y}.
+ ! Convert video RAM address to base X Y value. point is a {x y}.
0x2400 - ! n
dup 0x1f bitand 8 * 255 swap - ! n y
swap -5 shift swap 2array ;
: plot-bitmap-pixel ( bitmap point color -- )
- #! point is a {x y}. color is a {r g b}.
+ ! point is a {x y}. color is a {r g b}.
set-bitmap-pixel ;
: get-point-color ( point -- color )
- #! Return the color to use for the given x/y position.
+ ! Return the color to use for the given x/y position.
first2
{
{ [ dup 184 238 between? pick 0 223 between? and ] [ 2drop green ] }
} cond ;
: plot-bitmap-bits ( bitmap point byte bit -- )
- #! point is a {x y}.
+ ! point is a {x y}.
[ first2 ] 2dip
dup swapd -1 * shift 1 bitand 0 =
[ - 2array ] dip
] if ;
: sync-frame ( micros -- micros )
- #! Sleep until the time for the next frame arrives.
+ ! Sleep until the time for the next frame arrives.
16,667 + system:nano-count - dup 0 >
[ 1,000 * threads:sleep ] [ drop threads:yield ] if
system:nano-count ;
: invaders-process ( micros gadget -- )
- #! Run a space invaders gadget inside a
- #! concurrent process. Messages can be sent to
- #! signal key presses, etc.
+ ! Run a space invaders gadget inside a
+ ! concurrent process. Messages can be sent to
+ ! signal key presses, etc.
dup quit?>> [
2drop
] [
[ [ row-not-full? ] filter ] change-rows ;
: check-rows ( board -- n )
- #! remove full rows, then add blank ones at the top, returning the number
- #! of rows removed (and added)
+ ! remove full rows, then add blank ones at the top, returning the number
+ ! of rows removed (and added)
remove-full-rows dup height>> over rows>> length - swap top-up-rows ;
[ drop board>> ] [ [ current-piece clone ] dip move-piece ] 2bi piece-valid? ;
: tetris-move ( tetris move -- ? )
- #! moves the piece if possible, returns whether the piece was moved
+ ! moves the piece if possible, returns whether the piece was moved
2dup can-move? [
[ current-piece ] dip move-piece drop t
] [
[ width>> ] [ height>> ] bi swapd [ / ] dup 2bi* 1 glScalef ;
: draw-tetris ( width height tetris -- )
- #! width and height are in pixels
+ ! width and height are in pixels
[
{
[ board>> scale-board ]
piece new swap >>tetromino ;
: (piece-blocks) ( piece -- blocks )
- #! rotates the piece
+ ! rotates the piece
[ rotation>> ] [ tetromino>> states>> ] bi nth ;
: piece-blocks ( piece -- blocks )
- #! rotates and positions the piece
+ ! rotates and positions the piece
[ (piece-blocks) ] [ location>> ] bi [ v+ ] curry map ;
: piece-width ( piece -- width )
[ [ <random-piece> ] curry ] keep [ <piece-llist> ] curry lazy-cons ;
: modulo ( n m -- n )
- #! -2 7 mod => -2, -2 7 modulo => 5
+ ! -2 7 mod => -2, -2 7 modulo => 5
[ mod ] [ + ] [ mod ] tri ;
: (rotate-piece) ( rotation inc n-states -- rotation' )
] if* ;
: replace-with-a-child ( node -- node shorter? )
- #! assumes that node is not a leaf, otherwise will recurse forever
+ ! assumes that node is not a leaf, otherwise will recurse forever
dup node-link [
dupd [ avl-replace-with-extremity ] with-other-side
[ over set-node-link ] dip [ balance-delete ] [ f ] if
] if* ;
: avl-delete-node ( node -- node shorter? )
- #! delete this node, returning its replacement, and whether this subtree is
- #! shorter as a result
+ ! delete this node, returning its replacement, and whether this subtree is
+ ! shorter as a result
dup leaf? [
drop f t
] [
] if* ;
: prune-extremity ( node -- new-extremity )
- #! remove and return the leftmost or rightmost child of this node.
- #! assumes at least one child
+ ! remove and return the leftmost or rightmost child of this node.
+ ! assumes at least one child
dup node-link (prune-extremity) ;
: replace-with-child ( node -- node )
] if ;
: delete-node-with-two-children ( node -- node )
- #! randomised to minimise tree unbalancing
+ ! randomised to minimise tree unbalancing
random-side [ replace-with-extremity ] with-side ;
: delete-node ( node -- node )
- #! delete this node, returning its replacement
+ ! delete this node, returning its replacement
dup [ right>> ] [ left>> ] bi [
swap [
drop delete-node-with-two-children
20 0 <array> >vector tape set
: sym ( -- sym )
- #! Symbol at head position.
+ ! Symbol at head position.
position get tape get nth ;
: set-sym ( sym -- )
- #! Set symbol at head position.
+ ! Set symbol at head position.
position get tape get set-nth ;
: next-state ( -- state )
- #! Look up the next state/symbol/direction triplet.
+ ! Look up the next state/symbol/direction triplet.
state get sym 2array states get at ;
: turing-step ( -- )
- #! Do one step of the turing machine.
+ ! Do one step of the turing machine.
next-state
dup sym>> set-sym
dup dir>> position [ + ] change
next>> state set ;
: c ( -- )
- #! Print current turing machine state.
+ ! Print current turing machine state.
state get .
tape get .
2 position get 2 * + CHAR: \s <string> write "^" print ;
: n ( -- )
- #! Do one step and print new state.
+ ! Do one step and print new state.
turing-step c ;
dup index>> swap control-value ?nth ;
: scroll>selected ( list -- )
- #! We change the rectangle's width to zero to avoid
- #! scrolling right.
+ ! We change the rectangle's width to zero to avoid
+ ! scrolling right.
[ selected-rect rect-bounds { 0 1 } v* <rect> ] keep
scroll>rect ;
SYMBOL: render-output
: twiddle ( bytes -- bytes )
- #! On Windows, white is { 253 253 253 } ?
+ ! On Windows, white is { 253 253 253 } ?
[ 10 /i ] map ;
: bitmap= ( bitmap1 bitmap2 -- ? )
over [ find-from drop ] dip length or ; 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 )
: load-zone-ptr ( reg -- ) "nursery" f rot %alien-global ;
: %allot ( header size -- )
- #! Store a pointer to 'size' bytes allocated from the
- #! nursery in R11
+ ! Store a pointer to 'size' bytes allocated from the
+ ! nursery in R11
8 align ! align the size
R12 load-zone-ptr ! nusery -> r12
R11 R12 cell <+> LDR ! nursery.here -> r11
>r dup fresh-object v>operand R11 r> tag-number ORR ;
: %allot-bignum ( #digits -- )
- #! 1 cell header, 1 cell length, 1 cell sign, + digits
- #! length is the # of digits + sign
+ ! 1 cell header, 1 cell length, 1 cell sign, + digits
+ ! length is the # of digits + sign
bignum over 3 + cells %allot
R12 swap 1+ v>operand MOV ! compute the length
R12 R11 cell <+> STR ! store the length
;
: %allot-bignum-signed-1 ( dst src -- )
- #! on entry, reg is a 30-bit quantity sign-extended to
- #! 32-bits.
- #! exits with tagged ptr to bignum in reg.
+ ! on entry, reg is a 30-bit quantity sign-extended to
+ ! 32-bits.
+ ! exits with tagged ptr to bignum in reg.
[
"end" define-label
! is it zero?
[ compile-dlsym ] keep dup 0 <+> LDR ;
M: arm-backend %profiler-prologue ( -- )
- #! We can clobber R0 here since it is undefined at the start
- #! of a word.
+ ! We can clobber R0 here since it is undefined at the start
+ ! of a word.
R12 load-indirect
R0 R12 profile-count-offset <+> LDR
R0 R0 1 v>operand ADD
M: arm-backend %jump-label ( label -- ) B ;
: %prepare-primitive ( -- )
- #! Save stack pointer to stack_chain->callstack_top, load XT
+ ! Save stack pointer to stack_chain->callstack_top, load XT
R1 SP 4 SUB ;
M: arm-backend %call-primitive ( word -- )
"flag" operand f v>operand CMP NE B ;
: (%dispatch) ( word-table# -- )
- #! Load jump table target address into reg.
+ ! Load jump table target address into reg.
"scratch" operand PC "n" operand 1 <LSR> ADD
"scratch" operand dup 0 <+> LDR
rc-indirect-arm rel-dispatch
] when* ;
M: arm-backend %unbox-small-struct ( size -- )
- #! Alien must be in R0.
+ ! Alien must be in R0.
drop
"alien_offset" f %alien-invoke
! Load first cell
R0 R0 0 <+> LDR ;
M: arm-backend %unbox-large-struct ( n size -- )
- #! Alien must be in R0.
+ ! Alien must be in R0.
! Compute destination address
R1 SP roll ADD
R2 swap MOV
] when* r> f %alien-invoke ;
M: arm-backend %box-small-struct ( size -- )
- #! Box a 4-byte struct returned in R0.
+ ! Box a 4-byte struct returned in R0.
R2 swap MOV
"box_small_struct" f %alien-invoke ;
4 <= ;
M: arm-backend %prepare-alien-invoke
- #! 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.
"stack_chain" f R12 %alien-global
SP R12 0 <+> STR
ds-reg R12 8 <+> STR
drop v>operand 0 MOV ;
M: arm-backend %unbox-any-c-ptr ( dst src -- )
- #! We need three registers here. R11 and R12 are reserved
- #! temporary registers. The third one is R14, which we have
- #! to save/restore.
+ ! We need three registers here. R11 and R12 are reserved
+ ! temporary registers. The third one is R14, which we have
+ ! to save/restore.
"end" define-label
"start" define-label
! Save R14.
} define-intrinsic
: userenv ( reg -- )
- #! Load the userenv pointer in a register.
+ ! Load the userenv pointer in a register.
"userenv" f rot compile-dlsym ;
\ getenv [
<callback> callback-responder get callbacks>> set-at-unique ;
: forward-to-url ( url -- * )
- #! When executed inside a 'show' call, this will force a
- #! HTTP 302 to occur to instruct the browser to forward to
- #! the request URL.
+ ! When executed inside a 'show' call, this will force a
+ ! HTTP 302 to occur to instruct the browser to forward to
+ ! the request URL.
<temporary-redirect> exit-with ;
: cont-id "factorcontid" ;
: forward-to-id ( id -- * )
- #! When executed inside a 'show' call, this will force a
- #! HTTP 302 to occur to instruct the browser to forward to
- #! the request URL.
+ ! When executed inside a 'show' call, this will force a
+ ! HTTP 302 to occur to instruct the browser to forward to
+ ! the request URL.
<url>
swap cont-id set-query-param forward-to-url ;
SYMBOL: post-refresh-get?
: redirect-to-here ( -- )
- #! Force a redirect to the client browser so that the browser
- #! goes to the current point in the code. This forces an URL
- #! change on the browser so that refreshing that URL will
- #! immediately run from this code point. This prevents the
- #! "this request will issue a POST" warning from the browser
- #! and prevents re-running the previous POST logic. This is
- #! known as the 'post-refresh-get' pattern.
+ ! Force a redirect to the client browser so that the browser
+ ! goes to the current point in the code. This forces an URL
+ ! change on the browser so that refreshing that URL will
+ ! immediately run from this code point. This prevents the
+ ! "this request will issue a POST" warning from the browser
+ ! and prevents re-running the previous POST logic. This is
+ ! known as the 'post-refresh-get' pattern.
post-refresh-get? get [
[
[ ] t register-callback forward-to-id
SYMBOL: current-show
: store-current-show ( -- )
- #! Store the current continuation in the variable 'current-show'
- #! so it can be returned to later by 'quot-id'. Note that it
- #! recalls itself when the continuation is called to ensure that
- #! it resets its value back to the most recent show call.
+ ! Store the current continuation in the variable 'current-show'
+ ! so it can be returned to later by 'quot-id'. Note that it
+ ! recalls itself when the continuation is called to ensure that
+ ! it resets its value back to the most recent show call.
[ current-show set f ] callcc1
[ restore-request store-current-show ] when* ;
! mysql-connection-resulthandle mysql_num_fields ;
! : mysql-char*-nth ( index object -- str )
- ! #! Utility based on 'char*-nth' to perform an additional sanity check on the value
- ! #! extracted from the array of strings.
+ ! ! Utility based on 'char*-nth' to perform an additional sanity check on the value
+ ! ! extracted from the array of strings.
! void*-nth [ alien>char-string ] [ "" ] if* ;
! : mysql-row>seq ( object n -- seq )
} case ;
: succeeded? ( n -- bool )
- #! Did the call succeed (SQL-SUCCESS or SQL-SUCCESS-WITH-INFO)
+ ! Did the call succeed (SQL-SUCCESS or SQL-SUCCESS-WITH-INFO)
{
{ SQL-SUCCESS [ t ] }
{ SQL-SUCCESS-WITH-INFO [ t ] }
[ buffers>> second uint <ref> alSourceQueueBuffers check-error ] keep ;
: fill-processed-audio-buffer ( player n -- player )
- #! n is the number of audio buffers processed
+ ! n is the number of audio buffers processed
over >r >r dup source>> r> pick buffer-indexes>>
[ alSourceUnqueueBuffers check-error ] keep
uint deref dup r> swap >r al-channel-format rot
dup playing?>> [ append-audio ] [ start-audio ] if ;
: read-bytes-into ( dest size stream -- len )
- #! Read the given number of bytes from a stream
- #! and store them in the destination byte array.
+ ! Read the given number of bytes from a stream
+ ! and store them in the destination byte array.
stream-read >byte-array dup length [ memcpy ] keep ;
: check-not-negative ( int -- )
[ oy>> swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ;
: buffer-data ( player -- player eof? )
- #! Take some compressed bitstream data and sync it for
- #! page extraction.
+ ! Take some compressed bitstream data and sync it for
+ ! page extraction.
sync-buffer stream-into-buffer confirm-buffer ;
: queue-page ( player -- player )
- #! Push a page into the stream for packetization
+ ! Push a page into the stream for packetization
[ [ vo>> ] [ og>> ] bi ogg_stream_pagein drop ]
[ [ to>> ] [ og>> ] bi ogg_stream_pagein drop ]
[ ] tri ;
: retrieve-page ( player -- player bool )
- #! Sync the streams and get a page. Return true if a page was
- #! successfully retrieved.
+ ! Sync the streams and get a page. Return true if a page was
+ ! successfully retrieved.
dup [ oy>> ] [ og>> ] bi ogg_sync_pageout 0 > ;
: standard-initial-header? ( player -- player bool )
dup og>> ogg_page_bos zero? not ;
: ogg-stream-init ( player -- state player )
- #! Init the encode/decode logical stream state
+ ! Init the encode/decode logical stream state
[ temp-state>> ] keep
[ og>> ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ;
: ogg-stream-pagein ( state player -- state player )
- #! Add the incoming page to the stream state
+ ! Add the incoming page to the stream state
[ og>> ogg_stream_pagein drop ] 2keep ;
: ogg-stream-packetout ( state player -- state player )
ogg-stream-init ogg-stream-pagein ogg-stream-packetout ;
: theora-header? ( player -- player bool )
- #! Is the current page a theora header?
+ ! Is the current page a theora header?
dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header 0 >= ;
: is-theora-packet? ( player -- player bool )
dup theora>> zero? [ theora-header? ] [ f ] if ;
: copy-to-theora-state ( state player -- player )
- #! Copy the state to the theora state structure in the player
+ ! Copy the state to the theora state structure in the player
[ to>> swap dup length memcpy ] keep ;
: handle-initial-theora-header ( state player -- player )
copy-to-theora-state 1 >>theora ;
: vorbis-header? ( player -- player bool )
- #! Is the current page a vorbis header?
+ ! Is the current page a vorbis header?
dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin 0 >= ;
: is-vorbis-packet? ( player -- player bool )
dup vorbis>> zero? [ vorbis-header? ] [ f ] if ;
: copy-to-vorbis-state ( state player -- player )
- #! Copy the state to the vorbis state structure in the player
+ ! Copy the state to the vorbis state structure in the player
[ vo>> swap dup length memcpy ] keep ;
: handle-initial-vorbis-header ( state player -- player )
swap ogg_stream_clear drop ;
: process-initial-header ( player -- player bool )
- #! Is this a standard initial header? If not, stop parsing
+ ! Is this a standard initial header? If not, stop parsing
standard-initial-header? [
decode-packet {
{ [ is-vorbis-packet? ] [ handle-initial-vorbis-header ] }
] if ;
: parse-initial-headers ( player -- player )
- #! Parse Vorbis headers, ignoring any other type stored
- #! in the Ogg container.
+ ! Parse Vorbis headers, ignoring any other type stored
+ ! in the Ogg container.
retrieve-page [
process-initial-header [
parse-initial-headers
] [
- #! Don't leak the page, get it into the appropriate stream
+ ! Don't leak the page, get it into the appropriate stream
queue-page
] if
] [
] if ;
: have-required-vorbis-headers? ( player -- player bool )
- #! Return true if we need to decode vorbis due to there being
- #! vorbis headers read from the stream but we don't have them all
- #! yet.
+ ! Return true if we need to decode vorbis due to there being
+ ! vorbis headers read from the stream but we don't have them all
+ ! yet.
dup vorbis>> 1 2 between? not ;
: have-required-theora-headers? ( player -- player bool )
- #! Return true if we need to decode theora due to there being
- #! theora headers read from the stream but we don't have them all
- #! yet.
+ ! Return true if we need to decode theora due to there being
+ ! theora headers read from the stream but we don't have them all
+ ! yet.
dup theora>> 1 2 between? not ;
: get-remaining-vorbis-header-packet ( player -- player bool )
] when
dup vd>> granulepos>> dup 0 >= [
! numtoread player granulepos
- #! This is wrong: fix
+ ! This is wrong: fix
pick - >>audio-granulepos
] [
! numtoread player granulepos
[ vd>> swap vorbis_synthesis_read drop ] keep ;
: no-pending-audio ( player -- player bool )
- #! No pending audio. Is there a pending packet to decode.
+ ! No pending audio. Is there a pending packet to decode.
dup [ vo>> ] [ op>> ] bi ogg_stream_packetout 0 > [
dup [ vb>> ] [ op>> ] bi vorbis_synthesis 0 = [
dup [ vd>> ] [ vb>> ] bi vorbis_synthesis_blockin drop
] when
t
] [
- #! Need more data. Break out to suck in another page.
+ ! Need more data. Break out to suck in another page.
f
] if ;
: decode-audio ( player -- player )
audio-buffer-not-ready? [
- #! If there's pending decoded audio, grab it
+ ! If there's pending decoded audio, grab it
pending-decoded-audio? [
decode-pending-audio decode-audio
] [
delete-openal-source ;
: wait-for-sound ( player -- player )
- #! Waits for the openal to finish playing remaining sounds
+ ! Waits for the openal to finish playing remaining sounds
dup source>> AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep
*int AL_PLAYING = [
100 sleep
SYNTAX: APPLYING: ";" parse-tokens [ sandbox-use+ ] each ;
REVEALING:
- ! #!
+ ! !
HEX: OCT: BIN: f t CHAR: "
[ { T{
] } ;
! http://www.iana.org/assignments/ethernet-numbers
: bpf-align ( n -- n' )
- #! Align to next higher word size
+ ! Align to next higher word size
"long" heap-size align ;
M: unix-io packet. ( string -- )
<digraph> swap triggers set-at ;
: add-trigger ( key quot trigger -- )
- #! trigger should be a symbol. Note that symbols with the same name but
- #! different vocab are not equal
+ ! trigger should be a symbol. Note that symbols with the same name but
+ ! different vocab are not equal
trigger-graph add-vertex ;
: before ( key1 key2 trigger -- )
IN: webapps.numbers
: web-print ( str -- )
- #! Display the string in a web page.
+ ! Display the string in a web page.
[
swap dup
<html>
projects / factor.git / commitdiff