Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
42984adf12
109
README.txt
109
README.txt
|
|
@ -6,7 +6,6 @@ implementation. It is not an introduction to the language itself.
|
|||
|
||||
* Contents
|
||||
|
||||
- Platform support
|
||||
- Compiling the Factor VM
|
||||
- Libraries needed for compilation
|
||||
- Bootstrapping the Factor image
|
||||
|
|
@ -19,80 +18,50 @@ implementation. It is not an introduction to the language itself.
|
|||
- Source organization
|
||||
- Community
|
||||
|
||||
* Platform support
|
||||
|
||||
Factor supports the following platforms:
|
||||
|
||||
Linux/x86
|
||||
Linux/AMD64
|
||||
Linux/PowerPC
|
||||
Linux/ARM
|
||||
Mac OS X/x86
|
||||
Mac OS X/PowerPC
|
||||
FreeBSD/x86
|
||||
FreeBSD/AMD64
|
||||
OpenBSD/x86
|
||||
OpenBSD/AMD64
|
||||
Solaris/x86
|
||||
Solaris/AMD64
|
||||
MS Windows/x86 (XP and above)
|
||||
MS Windows CE/ARM
|
||||
|
||||
Please donate time or hardware if you wish to see Factor running on
|
||||
other platforms. In particular, we are interested in:
|
||||
|
||||
Windows/AMD64
|
||||
Mac OS X/AMD64
|
||||
Solaris/UltraSPARC
|
||||
Linux/MIPS
|
||||
|
||||
* Compiling the Factor VM
|
||||
|
||||
The Factor runtime is written in GNU C99, and is built with GNU make and
|
||||
gcc.
|
||||
|
||||
Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc
|
||||
3.3 or earlier. If you are using gcc 4.3, you might get an unusable
|
||||
Factor binary unless you add 'SITE_CFLAGS=-fno-forward-propagate' to the
|
||||
command-line arguments for make.
|
||||
Factor supports various platforms. For an up-to-date list, see
|
||||
<http://factorcode.org/getfactor.fhtml>.
|
||||
|
||||
Run 'make' (or 'gmake' on *BSD) with no parameters to see a list of
|
||||
targets and build options. Then run 'make' with the appropriate target
|
||||
for your platform.
|
||||
Factor requires gcc 3.4 or later.
|
||||
|
||||
On x86, Factor /will not/ build using gcc 3.3 or earlier.
|
||||
|
||||
If you are using gcc 4.3, you might get an unusable Factor binary unless
|
||||
you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line
|
||||
arguments for make.
|
||||
|
||||
Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
|
||||
|
||||
Compilation will yield an executable named 'factor' on Unix,
|
||||
'factor-nt.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
|
||||
'factor.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
|
||||
|
||||
* Libraries needed for compilation
|
||||
|
||||
For X11 support, you need recent development libraries for libc, Freetype,
|
||||
X11, OpenGL and GLUT. On a Debian-derived Linux distribution (like Ubuntu),
|
||||
you can use the line
|
||||
For X11 support, you need recent development libraries for libc,
|
||||
Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
|
||||
(like Ubuntu), you can use the line
|
||||
|
||||
sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
|
||||
sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
|
||||
|
||||
to grab everything (if you're on a non-debian-derived distro please tell us
|
||||
what the equivalent command is on there and it can be added :)
|
||||
to grab everything (if you're on a non-debian-derived distro please tell
|
||||
us what the equivalent command is on there and it can be added).
|
||||
|
||||
* Bootstrapping the Factor image
|
||||
|
||||
The boot images are no longer included with the Factor distribution
|
||||
due to size concerns. Instead, download a boot image from:
|
||||
|
||||
http://factorcode.org/images/
|
||||
|
||||
Once you have compiled the Factor runtime, you must bootstrap the Factor
|
||||
system using the image that corresponds to your CPU architecture.
|
||||
|
||||
Once you download the right image, bootstrap the system with the
|
||||
Boot images can be obtained from <http://factorcode.org/images/latest/>.
|
||||
|
||||
Once you download the right image, bootstrap Factor with the
|
||||
following command line:
|
||||
|
||||
./factor -i=boot.<cpu>.image
|
||||
|
||||
Or this command for Mac OS X systems:
|
||||
|
||||
./Factor.app/Contents/MacOS/factor -i=boot.<cpu>.image
|
||||
|
||||
Bootstrap can take a while, depending on your system. When the process
|
||||
completes, a 'factor.image' file will be generated. Note that this image
|
||||
is both CPU and OS-specific, so in general cannot be shared between
|
||||
|
|
@ -122,9 +91,8 @@ The latter keeps the terminal listener running.
|
|||
|
||||
* Running Factor on Mac OS X - Cocoa UI
|
||||
|
||||
On Mac OS X 10.4 and later, a Cocoa UI is available in addition to the
|
||||
terminal listener. If you are using Mac OS X 10.3, you can only run the
|
||||
X11 UI, as documented in the next section.
|
||||
On Mac OS X, a Cocoa UI is available in addition to the terminal
|
||||
listener.
|
||||
|
||||
The 'factor' executable runs the terminal listener:
|
||||
|
||||
|
|
@ -136,17 +104,16 @@ contains factor.image and the library sources.
|
|||
|
||||
* Running Factor on Mac OS X - X11 UI
|
||||
|
||||
The X11 UI is available on Mac OS X, however its use is not recommended
|
||||
since it does not integrate with the host OS. However, if you are
|
||||
running Mac OS X 10.3, it is your only choice.
|
||||
The X11 UI is also available on Mac OS X, however its use is not
|
||||
recommended since it does not integrate with the host OS.
|
||||
|
||||
When compiling Factor, pass the X11=1 parameter:
|
||||
|
||||
make macosx-ppc X11=1
|
||||
make X11=1
|
||||
|
||||
Then bootstrap with the following switches:
|
||||
|
||||
./factor -i=boot.ppc.image -ui-backend=x11
|
||||
./factor -i=boot.<cpu>.image -ui-backend=x11
|
||||
|
||||
Now if $DISPLAY is set, running ./factor will start the UI.
|
||||
|
||||
|
|
@ -155,40 +122,36 @@ Now if $DISPLAY is set, running ./factor will start the UI.
|
|||
If you did not download the binary package, you can bootstrap Factor in
|
||||
the command prompt:
|
||||
|
||||
factor-nt.exe -i=boot.x86.32.image
|
||||
factor.exe -i=boot.<cpu>.image
|
||||
|
||||
Once bootstrapped, double-clicking factor.exe starts the Factor UI.
|
||||
|
||||
To run the listener in the command prompt:
|
||||
|
||||
factor-nt.exe -run=listener
|
||||
factor.exe -run=listener
|
||||
|
||||
* The Factor FAQ
|
||||
|
||||
The Factor FAQ lives online at http://factorcode.org/faq.fhtml
|
||||
The Factor FAQ is available at <http://factorcode.org/faq.fhtml>.
|
||||
|
||||
* Command line usage
|
||||
|
||||
The Factor VM supports a number of command line switches. To read
|
||||
command line usage documentation, either enter the following in the UI
|
||||
listener:
|
||||
Factor supports a number of command line switches. To read command line
|
||||
usage documentation, enter the following in the UI listener:
|
||||
|
||||
"command-line" about
|
||||
|
||||
* Source organization
|
||||
|
||||
The following two directories are managed by the module system; consult
|
||||
the documentation for details:
|
||||
The Factor source tree is organized as follows:
|
||||
|
||||
build-support/ - scripts used for compiling Factor
|
||||
core/ - Factor core library and compiler
|
||||
extra/ - more libraries
|
||||
|
||||
The following directories contain additional files:
|
||||
|
||||
misc/ - editor modes, icons, etc
|
||||
vm/ - sources for the Factor runtime, written in C
|
||||
fonts/ - TrueType fonts used by UI
|
||||
misc/ - editor modes, icons, etc
|
||||
unmaintained/ - unmaintained contributions, please help!
|
||||
vm/ - sources for the Factor VM, written in C
|
||||
|
||||
* Community
|
||||
|
||||
|
|
|
|||
|
|
@ -78,7 +78,7 @@ $nl
|
|||
"<< \"freetype\" {"
|
||||
" { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
|
||||
" { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
|
||||
" { [ t ] [ drop ] }"
|
||||
" [ drop ]"
|
||||
"} cond >>"
|
||||
}
|
||||
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ TUPLE: library path abi dll ;
|
|||
: library ( name -- library ) libraries get at ;
|
||||
|
||||
: <library> ( path abi -- library )
|
||||
over dup [ dlopen ] when \ library construct-boa ;
|
||||
over dup [ dlopen ] when \ library boa ;
|
||||
|
||||
: load-library ( name -- dll )
|
||||
library dup [ library-dll ] when ;
|
||||
|
|
|
|||
|
|
@ -18,12 +18,12 @@ boxer prep unboxer
|
|||
getter setter
|
||||
reg-class size align stack-align? ;
|
||||
|
||||
: construct-c-type ( class -- type )
|
||||
construct-empty
|
||||
: new-c-type ( class -- type )
|
||||
new
|
||||
int-regs >>reg-class ;
|
||||
|
||||
: <c-type> ( -- type )
|
||||
\ c-type construct-c-type ;
|
||||
\ c-type new-c-type ;
|
||||
|
||||
SYMBOL: c-types
|
||||
|
||||
|
|
@ -189,7 +189,7 @@ DEFER: >c-ushort-array
|
|||
TUPLE: long-long-type < c-type ;
|
||||
|
||||
: <long-long-type> ( -- type )
|
||||
long-long-type construct-c-type ;
|
||||
long-long-type new-c-type ;
|
||||
|
||||
M: long-long-type unbox-parameter ( n type -- )
|
||||
c-type-unboxer %unbox-long-long ;
|
||||
|
|
|
|||
|
|
@ -220,7 +220,7 @@ M: no-such-library compiler-error-type
|
|||
drop +linkage+ ;
|
||||
|
||||
: no-such-library ( name -- )
|
||||
\ no-such-library construct-boa
|
||||
\ no-such-library boa
|
||||
compiling-word get compiler-error ;
|
||||
|
||||
TUPLE: no-such-symbol name ;
|
||||
|
|
@ -232,7 +232,7 @@ M: no-such-symbol compiler-error-type
|
|||
drop +linkage+ ;
|
||||
|
||||
: no-such-symbol ( name -- )
|
||||
\ no-such-symbol construct-boa
|
||||
\ no-such-symbol boa
|
||||
compiling-word get compiler-error ;
|
||||
|
||||
: check-dlsym ( symbols dll -- )
|
||||
|
|
@ -251,7 +251,7 @@ M: no-such-symbol compiler-error-type
|
|||
\ alien-invoke [
|
||||
! Four literals
|
||||
4 ensure-values
|
||||
#alien-invoke construct-empty
|
||||
#alien-invoke new
|
||||
! Compile-time parameters
|
||||
pop-parameters >>parameters
|
||||
pop-literal nip >>function
|
||||
|
|
@ -288,7 +288,7 @@ M: alien-indirect-error summary
|
|||
! Three literals and function pointer
|
||||
4 ensure-values
|
||||
4 reify-curries
|
||||
#alien-indirect construct-empty
|
||||
#alien-indirect new
|
||||
! Compile-time parameters
|
||||
pop-literal nip >>abi
|
||||
pop-parameters >>parameters
|
||||
|
|
@ -335,7 +335,7 @@ M: alien-callback-error summary
|
|||
|
||||
\ alien-callback [
|
||||
4 ensure-values
|
||||
#alien-callback construct-empty dup node,
|
||||
#alien-callback new dup node,
|
||||
pop-literal nip >>quot
|
||||
pop-literal nip >>abi
|
||||
pop-parameters >>parameters
|
||||
|
|
@ -375,13 +375,13 @@ TUPLE: callback-context ;
|
|||
return>> {
|
||||
{ [ dup "void" = ] [ drop [ ] ] }
|
||||
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
|
||||
{ [ t ] [ c-type c-type-prep ] }
|
||||
[ c-type c-type-prep ]
|
||||
} cond ;
|
||||
|
||||
: wrap-callback-quot ( node -- quot )
|
||||
[
|
||||
[ quot>> ] [ prepare-callback-return ] bi append ,
|
||||
[ callback-context construct-empty do-callback ] %
|
||||
[ callback-context new do-callback ] %
|
||||
] [ ] make ;
|
||||
|
||||
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
|
||||
|
|
@ -390,7 +390,7 @@ TUPLE: callback-context ;
|
|||
{
|
||||
{ [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
|
||||
{ [ dup return>> large-struct? ] [ drop 4 ] }
|
||||
{ [ t ] [ drop 0 ] }
|
||||
[ drop 0 ]
|
||||
} cond ;
|
||||
|
||||
: %callback-return ( node -- )
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ M: struct-type stack-size
|
|||
|
||||
: (define-struct) ( name vocab size align fields -- )
|
||||
>r [ align ] keep r>
|
||||
struct-type construct-boa
|
||||
struct-type boa
|
||||
-rot define-c-type ;
|
||||
|
||||
: make-field ( struct-name vocab type field-name -- spec )
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ M: alien pprint*
|
|||
{
|
||||
{ [ dup expired? ] [ drop "( alien expired )" text ] }
|
||||
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
|
||||
{ [ t ] [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] }
|
||||
[ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
|
||||
} cond ;
|
||||
|
||||
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
|
||||
|
|
|
|||
|
|
@ -12,9 +12,9 @@ M: array resize resize-array ;
|
|||
|
||||
: >array ( seq -- array ) { } clone-like ;
|
||||
|
||||
M: object new drop f <array> ;
|
||||
M: object new-sequence drop f <array> ;
|
||||
|
||||
M: f new drop dup zero? [ drop f ] [ f <array> ] if ;
|
||||
M: f new-sequence drop dup zero? [ drop f ] [ f <array> ] if ;
|
||||
|
||||
M: array like drop dup array? [ >array ] unless ;
|
||||
|
||||
|
|
|
|||
|
|
@ -69,14 +69,14 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs"
|
|||
ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
|
||||
"It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
|
||||
{ $subsection subassoc? }
|
||||
{ $subsection intersect }
|
||||
{ $subsection assoc-intersect }
|
||||
{ $subsection update }
|
||||
{ $subsection union }
|
||||
{ $subsection diff }
|
||||
{ $subsection assoc-union }
|
||||
{ $subsection assoc-diff }
|
||||
{ $subsection remove-all }
|
||||
{ $subsection substitute }
|
||||
{ $subsection substitute-here }
|
||||
{ $see-also key? } ;
|
||||
{ $see-also key? assoc-contains? assoc-all? "sets" } ;
|
||||
|
||||
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
|
||||
"Utility operations built up from the " { $link "assocs-protocol" } ":"
|
||||
|
|
@ -97,6 +97,7 @@ $nl
|
|||
{ $subsection assoc-map }
|
||||
{ $subsection assoc-push-if }
|
||||
{ $subsection assoc-subset }
|
||||
{ $subsection assoc-contains? }
|
||||
{ $subsection assoc-all? }
|
||||
"Three additional combinators:"
|
||||
{ $subsection cache }
|
||||
|
|
@ -206,9 +207,13 @@ HELP: assoc-subset
|
|||
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } }
|
||||
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
|
||||
|
||||
HELP: assoc-contains?
|
||||
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
|
||||
{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ;
|
||||
|
||||
HELP: assoc-all?
|
||||
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
|
||||
{ $description "Applies a predicate quotation to entry in the assoc. Outputs true if the assoc yields true for each entry (which includes the case where the assoc is empty)." } ;
|
||||
{ $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
|
||||
|
||||
HELP: subassoc?
|
||||
{ $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } }
|
||||
|
|
@ -260,7 +265,7 @@ HELP: values
|
|||
|
||||
{ keys values } related-words
|
||||
|
||||
HELP: intersect
|
||||
HELP: assoc-intersect
|
||||
{ $values { "assoc1" assoc } { "assoc2" assoc } { "intersection" "a new assoc" } }
|
||||
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " such that the key is also present in " { $snippet "assoc1" } "." }
|
||||
{ $notes "The values of the keys in " { $snippet "assoc1" } " are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } ;
|
||||
|
|
@ -270,11 +275,11 @@ HELP: update
|
|||
{ $description "Adds all entries from " { $snippet "assoc2" } " to " { $snippet "assoc1" } "." }
|
||||
{ $side-effects "assoc1" } ;
|
||||
|
||||
HELP: union
|
||||
HELP: assoc-union
|
||||
{ $values { "assoc1" assoc } { "assoc2" assoc } { "union" "a new assoc" } }
|
||||
{ $description "Outputs a assoc consisting of all entries from " { $snippet "assoc1" } " and " { $snippet "assoc2" } ", with entries from " { $snippet "assoc2" } " taking precedence in case the corresponding values are not equal." } ;
|
||||
|
||||
HELP: diff
|
||||
HELP: assoc-diff
|
||||
{ $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } }
|
||||
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " whose key is not contained in " { $snippet "assoc1" } "." }
|
||||
;
|
||||
|
|
|
|||
|
|
@ -58,24 +58,24 @@ H{ } clone "cache-test" set
|
|||
] [
|
||||
H{ { "factor" "rocks" } { "dup" "sq" } { 3 4 } }
|
||||
H{ { "factor" "rocks" } { 1 2 } { 2 3 } { 3 4 } }
|
||||
intersect
|
||||
assoc-intersect
|
||||
] unit-test
|
||||
|
||||
[
|
||||
H{ { 1 2 } { 2 3 } { 6 5 } }
|
||||
] [
|
||||
H{ { 2 4 } { 6 5 } } H{ { 1 2 } { 2 3 } }
|
||||
union
|
||||
assoc-union
|
||||
] unit-test
|
||||
|
||||
[ H{ { 1 2 } { 2 3 } } t ] [
|
||||
f H{ { 1 2 } { 2 3 } } [ union ] 2keep swap union dupd =
|
||||
f H{ { 1 2 } { 2 3 } } [ assoc-union ] 2keep swap assoc-union dupd =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
H{ { 1 f } }
|
||||
] [
|
||||
H{ { 1 f } } H{ { 1 f } } intersect
|
||||
H{ { 1 f } } H{ { 1 f } } assoc-intersect
|
||||
] unit-test
|
||||
|
||||
[ { 1 3 } ] [ H{ { 2 2 } } { 1 2 3 } remove-all ] unit-test
|
||||
|
|
|
|||
|
|
@ -109,17 +109,17 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
>r over r> hashcode* 2/ >r dupd hashcode* r> bitxor
|
||||
] { } assoc>map hashcode* ;
|
||||
|
||||
: intersect ( assoc1 assoc2 -- intersection )
|
||||
: assoc-intersect ( assoc1 assoc2 -- intersection )
|
||||
swap [ nip key? ] curry assoc-subset ;
|
||||
|
||||
: update ( assoc1 assoc2 -- )
|
||||
swap [ swapd set-at ] curry assoc-each ;
|
||||
|
||||
: union ( assoc1 assoc2 -- union )
|
||||
: assoc-union ( assoc1 assoc2 -- union )
|
||||
2dup [ assoc-size ] bi@ + pick new-assoc
|
||||
[ rot update ] keep [ swap update ] keep ;
|
||||
|
||||
: diff ( assoc1 assoc2 -- diff )
|
||||
: assoc-diff ( assoc1 assoc2 -- diff )
|
||||
swap [ nip key? not ] curry assoc-subset ;
|
||||
|
||||
: remove-all ( assoc seq -- subseq )
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ M: bit-array clone (clone) ;
|
|||
|
||||
M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
|
||||
|
||||
M: bit-array new drop <bit-array> ;
|
||||
M: bit-array new-sequence drop <bit-array> ;
|
||||
|
||||
M: bit-array equal?
|
||||
over bit-array? [ sequence= ] [ 2drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: bit-vectors
|
|||
<PRIVATE
|
||||
|
||||
: bit-array>vector ( bit-array length -- bit-vector )
|
||||
bit-vector construct-boa ; inline
|
||||
bit-vector boa ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -22,7 +22,7 @@ M: bit-vector like
|
|||
[ dup length bit-array>vector ] [ >bit-vector ] if
|
||||
] unless ;
|
||||
|
||||
M: bit-vector new
|
||||
M: bit-vector new-sequence
|
||||
drop [ <bit-array> ] keep >fixnum bit-array>vector ;
|
||||
|
||||
M: bit-vector equal?
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Growable bit arrays
|
||||
|
|
@ -0,0 +1 @@
|
|||
collections
|
||||
|
|
@ -53,7 +53,7 @@ nl
|
|||
"." write flush
|
||||
|
||||
{
|
||||
new nth push pop peek
|
||||
new-sequence nth push pop peek
|
||||
} compile
|
||||
|
||||
"." write flush
|
||||
|
|
|
|||
|
|
@ -36,4 +36,4 @@ tag-numbers get H{
|
|||
{ word 17 }
|
||||
{ byte-array 18 }
|
||||
{ tuple-layout 19 }
|
||||
} union type-numbers set
|
||||
} assoc-union type-numbers set
|
||||
|
|
|
|||
|
|
@ -390,7 +390,7 @@ define-builtin
|
|||
|
||||
! Create special tombstone values
|
||||
"tombstone" "hashtables.private" create
|
||||
"tuple" "kernel" lookup
|
||||
tuple
|
||||
{ } define-tuple-class
|
||||
|
||||
"((empty))" "hashtables.private" create
|
||||
|
|
@ -403,7 +403,7 @@ define-builtin
|
|||
|
||||
! Some tuple classes
|
||||
"hashtable" "hashtables" create
|
||||
"tuple" "kernel" lookup
|
||||
tuple
|
||||
{
|
||||
{
|
||||
{ "array-capacity" "sequences.private" }
|
||||
|
|
@ -424,7 +424,7 @@ define-builtin
|
|||
} define-tuple-class
|
||||
|
||||
"sbuf" "sbufs" create
|
||||
"tuple" "kernel" lookup
|
||||
tuple
|
||||
{
|
||||
{
|
||||
{ "string" "strings" }
|
||||
|
|
@ -440,7 +440,7 @@ define-builtin
|
|||
} define-tuple-class
|
||||
|
||||
"vector" "vectors" create
|
||||
"tuple" "kernel" lookup
|
||||
tuple
|
||||
{
|
||||
{
|
||||
{ "array" "arrays" }
|
||||
|
|
@ -456,7 +456,7 @@ define-builtin
|
|||
} define-tuple-class
|
||||
|
||||
"byte-vector" "byte-vectors" create
|
||||
"tuple" "kernel" lookup
|
||||
tuple
|
||||
{
|
||||
{
|
||||
{ "byte-array" "byte-arrays" }
|
||||
|
|
@ -472,7 +472,7 @@ define-builtin
|
|||
} define-tuple-class
|
||||
|
||||
"bit-vector" "bit-vectors" create
|
||||
"tuple" "kernel" lookup
|
||||
tuple
|
||||
{
|
||||
{
|
||||
{ "bit-array" "bit-arrays" }
|
||||
|
|
@ -488,7 +488,7 @@ define-builtin
|
|||
} define-tuple-class
|
||||
|
||||
"float-vector" "float-vectors" create
|
||||
"tuple" "kernel" lookup
|
||||
tuple
|
||||
{
|
||||
{
|
||||
{ "float-array" "float-arrays" }
|
||||
|
|
@ -504,7 +504,7 @@ define-builtin
|
|||
} define-tuple-class
|
||||
|
||||
"curry" "kernel" create
|
||||
"tuple" "kernel" lookup
|
||||
tuple
|
||||
{
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
|
|
@ -525,7 +525,7 @@ define-builtin
|
|||
[ tuple-layout [ <tuple-boa> ] curry ] tri define
|
||||
|
||||
"compose" "kernel" create
|
||||
"tuple" "kernel" lookup
|
||||
tuple
|
||||
{
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ kernel.private math memory continuations kernel io.files
|
|||
io.backend system parser vocabs sequences prettyprint
|
||||
vocabs.loader combinators splitting source-files strings
|
||||
definitions assocs compiler.errors compiler.units
|
||||
math.parser generic ;
|
||||
math.parser generic sets ;
|
||||
IN: bootstrap.stage2
|
||||
|
||||
SYMBOL: bootstrap-time
|
||||
|
|
@ -24,7 +24,7 @@ SYMBOL: bootstrap-time
|
|||
: load-components ( -- )
|
||||
"exclude" "include"
|
||||
[ get-global " " split [ empty? not ] subset ] bi@
|
||||
seq-diff
|
||||
diff
|
||||
[ "bootstrap." prepend require ] each ;
|
||||
|
||||
! : compile-remaining ( -- )
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ IN: boxes
|
|||
|
||||
TUPLE: box value full? ;
|
||||
|
||||
: <box> ( -- box ) box construct-empty ;
|
||||
: <box> ( -- box ) box new ;
|
||||
|
||||
: >box ( value box -- )
|
||||
dup box-full? [ "Box already has a value" throw ] when
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ;
|
|||
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
|
||||
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
|
||||
M: byte-array like drop dup byte-array? [ >byte-array ] unless ;
|
||||
M: byte-array new drop <byte-array> ;
|
||||
M: byte-array new-sequence drop <byte-array> ;
|
||||
|
||||
M: byte-array equal?
|
||||
over byte-array? [ sequence= ] [ 2drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: byte-vectors
|
|||
<PRIVATE
|
||||
|
||||
: byte-array>vector ( byte-array length -- byte-vector )
|
||||
byte-vector construct-boa ; inline
|
||||
byte-vector boa ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -22,7 +22,7 @@ M: byte-vector like
|
|||
[ dup length byte-array>vector ] [ >byte-vector ] if
|
||||
] unless ;
|
||||
|
||||
M: byte-vector new
|
||||
M: byte-vector new-sequence
|
||||
drop [ <byte-array> ] keep >fixnum byte-array>vector ;
|
||||
|
||||
M: byte-vector equal?
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Growable byte arrays
|
||||
|
|
@ -0,0 +1 @@
|
|||
collections
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel classes classes.builtin combinators accessors
|
||||
sequences arrays vectors assocs namespaces words sorting layouts
|
||||
math hashtables kernel.private ;
|
||||
math hashtables kernel.private sets ;
|
||||
IN: classes.algebra
|
||||
|
||||
: 2cache ( key1 key2 assoc quot -- value )
|
||||
|
|
@ -84,7 +84,7 @@ C: <anonymous-complement> anonymous-complement
|
|||
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
|
||||
{ [ dup members ] [ right-union-class< ] }
|
||||
{ [ over superclass ] [ superclass< ] }
|
||||
{ [ t ] [ 2drop f ] }
|
||||
[ 2drop f ]
|
||||
} cond ;
|
||||
|
||||
: anonymous-union-intersect? ( first second -- ? )
|
||||
|
|
@ -104,14 +104,14 @@ C: <anonymous-complement> anonymous-complement
|
|||
{ [ over tuple eq? ] [ 2drop t ] }
|
||||
{ [ over builtin-class? ] [ 2drop f ] }
|
||||
{ [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] }
|
||||
{ [ t ] [ swap classes-intersect? ] }
|
||||
[ swap classes-intersect? ]
|
||||
} cond ;
|
||||
|
||||
: builtin-class-intersect? ( first second -- ? )
|
||||
{
|
||||
{ [ 2dup eq? ] [ 2drop t ] }
|
||||
{ [ over builtin-class? ] [ 2drop f ] }
|
||||
{ [ t ] [ swap classes-intersect? ] }
|
||||
[ swap classes-intersect? ]
|
||||
} cond ;
|
||||
|
||||
: (classes-intersect?) ( first second -- ? )
|
||||
|
|
@ -154,7 +154,7 @@ C: <anonymous-complement> anonymous-complement
|
|||
{ [ over members ] [ left-union-and ] }
|
||||
{ [ over anonymous-union? ] [ left-anonymous-union-and ] }
|
||||
{ [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] }
|
||||
{ [ t ] [ 2array <anonymous-intersection> ] }
|
||||
[ 2array <anonymous-intersection> ]
|
||||
} cond ;
|
||||
|
||||
: left-anonymous-union-or ( first second -- class )
|
||||
|
|
@ -169,7 +169,7 @@ C: <anonymous-complement> anonymous-complement
|
|||
{ [ 2dup swap class< ] [ drop ] }
|
||||
{ [ dup anonymous-union? ] [ right-anonymous-union-or ] }
|
||||
{ [ over anonymous-union? ] [ left-anonymous-union-or ] }
|
||||
{ [ t ] [ 2array <anonymous-union> ] }
|
||||
[ 2array <anonymous-union> ]
|
||||
} cond ;
|
||||
|
||||
: (class-not) ( class -- complement )
|
||||
|
|
@ -177,7 +177,7 @@ C: <anonymous-complement> anonymous-complement
|
|||
{ [ dup anonymous-complement? ] [ class>> ] }
|
||||
{ [ dup object eq? ] [ drop null ] }
|
||||
{ [ dup null eq? ] [ drop object ] }
|
||||
{ [ t ] [ <anonymous-complement> ] }
|
||||
[ <anonymous-complement> ]
|
||||
} cond ;
|
||||
|
||||
: largest-class ( seq -- n elt )
|
||||
|
|
@ -205,7 +205,7 @@ C: <anonymous-complement> anonymous-complement
|
|||
{ [ dup builtin-class? ] [ dup set ] }
|
||||
{ [ dup members ] [ members [ (flatten-class) ] each ] }
|
||||
{ [ dup superclass ] [ superclass (flatten-class) ] }
|
||||
{ [ t ] [ drop ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
: flatten-class ( class -- assoc )
|
||||
|
|
|
|||
|
|
@ -89,7 +89,7 @@ M: word reset-class drop ;
|
|||
dup reset-class
|
||||
dup deferred? [ dup define-symbol ] when
|
||||
dup word-props
|
||||
r> union over set-word-props
|
||||
r> assoc-union over set-word-props
|
||||
dup predicate-word
|
||||
[ 1quotation "predicate" set-word-prop ]
|
||||
[ swap "predicating" set-word-prop ]
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ TUPLE: check-mixin-class mixin ;
|
|||
|
||||
: check-mixin-class ( mixin -- mixin )
|
||||
dup mixin-class? [
|
||||
\ check-mixin-class construct-boa throw
|
||||
\ check-mixin-class boa throw
|
||||
] unless ;
|
||||
|
||||
: if-mixin-member? ( class mixin true false -- )
|
||||
|
|
@ -49,7 +49,7 @@ M: mixin-instance equal?
|
|||
{ [ over mixin-instance? not ] [ f ] }
|
||||
{ [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] }
|
||||
{ [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] }
|
||||
{ [ t ] [ t ] }
|
||||
[ t ]
|
||||
} cond 2nip ;
|
||||
|
||||
M: mixin-instance hashcode*
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ generic.standard sequences definitions compiler.units ;
|
|||
IN: classes.tuple
|
||||
|
||||
ARTICLE: "parametrized-constructors" "Parameterized constructors"
|
||||
"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link construct-empty } " or " { $link construct-boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
|
||||
"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link new } " or " { $link boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
|
||||
$nl
|
||||
"Parametrized constructors are useful in many situations, in particular with subclassing. For example, consider the following code:"
|
||||
{ $code
|
||||
|
|
@ -14,14 +14,14 @@ $nl
|
|||
""
|
||||
"TUPLE: car < vehicle engine ;"
|
||||
": <car> ( max-speed engine -- car )"
|
||||
" car construct-empty"
|
||||
" car new"
|
||||
" V{ } clone >>occupants"
|
||||
" swap >>engine"
|
||||
" swap >>max-speed ;"
|
||||
""
|
||||
"TUPLE: aeroplane < vehicle max-altitude ;"
|
||||
": <aeroplane> ( max-speed max-altitude -- aeroplane )"
|
||||
" aeroplane construct-empty"
|
||||
" aeroplane new"
|
||||
" V{ } clone >>occupants"
|
||||
" swap >>max-altitude"
|
||||
" swap >>max-speed ;"
|
||||
|
|
@ -32,28 +32,28 @@ $nl
|
|||
""
|
||||
": add-occupant ( person vehicle -- ) occupants>> push ;"
|
||||
""
|
||||
": construct-vehicle ( class -- vehicle )"
|
||||
" construct-empty"
|
||||
": new-vehicle ( class -- vehicle )"
|
||||
" new"
|
||||
" V{ } clone >>occupants ;"
|
||||
""
|
||||
"TUPLE: car < vehicle engine ;"
|
||||
": <car> ( max-speed engine -- car )"
|
||||
" car construct-vehicle"
|
||||
" car new-vehicle"
|
||||
" swap >>engine"
|
||||
" swap >>max-speed ;"
|
||||
""
|
||||
"TUPLE: aeroplane < vehicle max-altitude ;"
|
||||
": <aeroplane> ( max-speed max-altitude -- aeroplane )"
|
||||
" aeroplane construct-vehicle"
|
||||
" aeroplane new-vehicle"
|
||||
" swap >>max-altitude"
|
||||
" swap >>max-speed ;"
|
||||
}
|
||||
"The naming convention for parametrized constructors is " { $snippet "construct-" { $emphasis "class" } } "." ;
|
||||
"The naming convention for parametrized constructors is " { $snippet "new-" { $emphasis "class" } } "." ;
|
||||
|
||||
ARTICLE: "tuple-constructors" "Tuple constructors"
|
||||
"Tuples are created by calling one of two constructor primitives:"
|
||||
{ $subsection construct-empty }
|
||||
{ $subsection construct-boa }
|
||||
{ $subsection new }
|
||||
{ $subsection boa }
|
||||
"A shortcut for defining BOA constructors:"
|
||||
{ $subsection POSTPONE: C: }
|
||||
"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
|
||||
|
|
@ -64,13 +64,16 @@ $nl
|
|||
{ $code
|
||||
"TUPLE: color red green blue alpha ;"
|
||||
""
|
||||
"! The following two are equivalent"
|
||||
"C: <rgba> rgba"
|
||||
": <rgba> color construct-boa ; ! identical to above"
|
||||
": <rgba> color boa ;"
|
||||
""
|
||||
"! We can define constructors which call other constructors"
|
||||
": <rgb> f <rgba> ;"
|
||||
""
|
||||
": <color> construct-empty ;"
|
||||
": <color> f f f f <rgba> ; ! identical to above"
|
||||
"! The following two are equivalent"
|
||||
": <color> color new ;"
|
||||
": <color> f f f f <rgba> ;"
|
||||
}
|
||||
{ $subsection "parametrized-constructors" } ;
|
||||
|
||||
|
|
@ -129,7 +132,7 @@ $nl
|
|||
$nl
|
||||
"The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes."
|
||||
{ $heading "Anti-pattern #3: subclassing to override a method definition" }
|
||||
"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link construct-empty } ", " { $link construct-boa } ", or a custom parametrized constructor."
|
||||
"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor."
|
||||
{ $see-also "parametrized-constructors" } ;
|
||||
|
||||
ARTICLE: "tuple-subclassing" "Tuple subclassing"
|
||||
|
|
@ -164,11 +167,11 @@ ARTICLE: "tuple-examples" "Tuple examples"
|
|||
}
|
||||
"We can define a constructor which makes an empty employee:"
|
||||
{ $code ": <employee> ( -- employee )"
|
||||
" employee construct-empty ;" }
|
||||
" employee new ;" }
|
||||
"Or we may wish the default constructor to always give employees a starting salary:"
|
||||
{ $code
|
||||
": <employee> ( -- employee )"
|
||||
" employee construct-empty"
|
||||
" employee new"
|
||||
" 40000 >>salary ;"
|
||||
}
|
||||
"We can define more refined constructors:"
|
||||
|
|
@ -178,7 +181,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
|
|||
"An alternative strategy is to define the most general BOA constructor first:"
|
||||
{ $code
|
||||
": <employee> ( name position -- person )"
|
||||
" 40000 employee construct-boa ;"
|
||||
" 40000 employee boa ;"
|
||||
}
|
||||
"Now we can define more specific constructors:"
|
||||
{ $code
|
||||
|
|
@ -191,7 +194,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
|
|||
"SYMBOL: checks"
|
||||
""
|
||||
": <check> ( to amount -- check )"
|
||||
" checks counter check construct-boa ;"
|
||||
" checks counter check boa ;"
|
||||
""
|
||||
": biweekly-paycheck ( employee -- check )"
|
||||
" dup name>> swap salary>> 26 / <check> ;"
|
||||
|
|
@ -326,20 +329,20 @@ HELP: tuple>array ( tuple -- array )
|
|||
|
||||
HELP: <tuple> ( layout -- tuple )
|
||||
{ $values { "layout" tuple-layout } { "tuple" tuple } }
|
||||
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-empty } "." } ;
|
||||
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ;
|
||||
|
||||
HELP: <tuple-boa> ( ... layout -- tuple )
|
||||
{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
|
||||
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link construct-boa } "." } ;
|
||||
{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ;
|
||||
|
||||
HELP: construct-empty
|
||||
HELP: new
|
||||
{ $values { "class" tuple-class } { "tuple" tuple } }
|
||||
{ $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: kernel prettyprint ;"
|
||||
"TUPLE: employee number name department ;"
|
||||
"employee construct-empty ."
|
||||
"employee new ."
|
||||
"T{ employee f f f f }"
|
||||
}
|
||||
} ;
|
||||
|
|
@ -361,12 +364,12 @@ HELP: construct
|
|||
" color construct ;"
|
||||
}
|
||||
"The last definition is actually equivalent to the following:"
|
||||
{ $code ": <rgba> ( r g b a -- color ) rgba construct-boa ;" }
|
||||
{ $code ": <rgba> ( r g b a -- color ) rgba boa ;" }
|
||||
"Which can be abbreviated further:"
|
||||
{ $code "C: <rgba> color" }
|
||||
} ;
|
||||
|
||||
HELP: construct-boa
|
||||
HELP: boa
|
||||
{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
|
||||
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
|
||||
{ $notes "The " { $snippet "-boa" } " suffix is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;
|
||||
{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ calendar prettyprint io.streams.string splitting inspector ;
|
|||
IN: classes.tuple.tests
|
||||
|
||||
TUPLE: rect x y w h ;
|
||||
: <rect> rect construct-boa ;
|
||||
: <rect> rect boa ;
|
||||
|
||||
: move ( x rect -- rect )
|
||||
[ + ] change-x ;
|
||||
|
|
@ -198,8 +198,8 @@ SYMBOL: not-a-tuple-class
|
|||
] unit-test
|
||||
|
||||
! Missing check
|
||||
[ not-a-tuple-class construct-boa ] must-fail
|
||||
[ not-a-tuple-class construct-empty ] must-fail
|
||||
[ not-a-tuple-class boa ] must-fail
|
||||
[ not-a-tuple-class new ] must-fail
|
||||
|
||||
TUPLE: erg's-reshape-problem a b c d ;
|
||||
|
||||
|
|
@ -207,8 +207,8 @@ C: <erg's-reshape-problem> erg's-reshape-problem
|
|||
|
||||
! We want to make sure constructors are recompiled when
|
||||
! tuples are reshaped
|
||||
: cons-test-1 \ erg's-reshape-problem construct-empty ;
|
||||
: cons-test-2 \ erg's-reshape-problem construct-boa ;
|
||||
: cons-test-1 \ erg's-reshape-problem new ;
|
||||
: cons-test-2 \ erg's-reshape-problem boa ;
|
||||
|
||||
"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
|
||||
|
||||
|
|
@ -538,3 +538,6 @@ TUPLE: another-forget-accessors-test ;
|
|||
] with-string-writer empty?
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
! Missing error check
|
||||
[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
|
||||
|
|
|
|||
|
|
@ -58,6 +58,8 @@ PRIVATE>
|
|||
: all-slot-names ( class -- slots )
|
||||
superclasses [ slot-names ] map concat \ class prefix ;
|
||||
|
||||
ERROR: bad-superclass class ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: tuple= ( tuple1 tuple2 -- ? )
|
||||
|
|
@ -185,21 +187,28 @@ M: tuple-class update-class
|
|||
: tuple-class-unchanged? ( class superclass slots -- ? )
|
||||
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
|
||||
|
||||
: valid-superclass? ( class -- ? )
|
||||
[ tuple-class? ] [ tuple eq? ] bi or ;
|
||||
|
||||
: check-superclass ( superclass -- )
|
||||
dup valid-superclass? [ bad-superclass ] unless drop ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC# define-tuple-class 2 ( class superclass slots -- )
|
||||
|
||||
M: word define-tuple-class
|
||||
over check-superclass
|
||||
define-new-tuple-class ;
|
||||
|
||||
M: tuple-class define-tuple-class
|
||||
3dup tuple-class-unchanged?
|
||||
[ 3dup redefine-tuple-class ] unless
|
||||
[ over check-superclass 3dup redefine-tuple-class ] unless
|
||||
3drop ;
|
||||
|
||||
: define-error-class ( class superclass slots -- )
|
||||
[ define-tuple-class ] [ 2drop ] 3bi
|
||||
dup [ construct-boa throw ] curry define ;
|
||||
dup [ boa throw ] curry define ;
|
||||
|
||||
M: tuple-class reset-class
|
||||
[
|
||||
|
|
|
|||
|
|
@ -64,9 +64,9 @@ HELP: alist>quot
|
|||
{ $notes "This word is used to implement compile-time behavior for " { $link cond } ", and it is also used by the generic word system. Note that unlike " { $link cond } ", the constructed quotation performs the tests starting from the end and not the beginning." } ;
|
||||
|
||||
HELP: cond
|
||||
{ $values { "assoc" "a sequence of quotation pairs" } }
|
||||
{ $values { "assoc" "a sequence of quotation pairs and an optional quotation" } }
|
||||
{ $description
|
||||
"Calls the second quotation in the first pair whose first quotation yields a true value."
|
||||
"Calls the second quotation in the first pair whose first quotation yields a true value. A single quotation will always yield a true value."
|
||||
$nl
|
||||
"The following two phrases are equivalent:"
|
||||
{ $code "{ { [ X ] [ Y ] } { [ Z ] [ T ] } } cond" }
|
||||
|
|
@ -78,7 +78,7 @@ HELP: cond
|
|||
"{"
|
||||
" { [ dup 0 > ] [ \"positive\" ] }"
|
||||
" { [ dup 0 < ] [ \"negative\" ] }"
|
||||
" { [ dup zero? ] [ \"zero\" ] }"
|
||||
" [ \"zero\" ]"
|
||||
"} cond"
|
||||
}
|
||||
} ;
|
||||
|
|
@ -88,9 +88,9 @@ HELP: no-cond
|
|||
{ $error-description "Thrown by " { $link cond } " if none of the test quotations yield a true value. Some uses of " { $link cond } " include a default case where the test quotation is " { $snippet "[ t ]" } "; such a " { $link cond } " form will never throw this error." } ;
|
||||
|
||||
HELP: case
|
||||
{ $values { "obj" object } { "assoc" "a sequence of object/quotation pairs, with an optional quotation at the end" } }
|
||||
{ $values { "obj" object } { "assoc" "a sequence of object/word,quotation pairs, with an optional quotation at the end" } }
|
||||
{ $description
|
||||
"Compares " { $snippet "obj" } " against the first element of every pair. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation."
|
||||
"Compares " { $snippet "obj" } " against the first element of every pair, first evaluating the first element if it is a word. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation."
|
||||
$nl
|
||||
"If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied."
|
||||
$nl
|
||||
|
|
|
|||
|
|
@ -1,7 +1,54 @@
|
|||
IN: combinators.tests
|
||||
USING: alien strings kernel math tools.test io prettyprint
|
||||
namespaces combinators words ;
|
||||
namespaces combinators words classes sequences ;
|
||||
IN: combinators.tests
|
||||
|
||||
! Compiled
|
||||
: cond-test-1 ( obj -- str )
|
||||
{
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
} cond ;
|
||||
|
||||
\ cond-test-1 must-infer
|
||||
|
||||
[ "even" ] [ 2 cond-test-1 ] unit-test
|
||||
[ "odd" ] [ 3 cond-test-1 ] unit-test
|
||||
|
||||
: cond-test-2 ( obj -- str )
|
||||
{
|
||||
{ [ dup t = ] [ drop "true" ] }
|
||||
{ [ dup f = ] [ drop "false" ] }
|
||||
[ drop "something else" ]
|
||||
} cond ;
|
||||
|
||||
\ cond-test-2 must-infer
|
||||
|
||||
[ "true" ] [ t cond-test-2 ] unit-test
|
||||
[ "false" ] [ f cond-test-2 ] unit-test
|
||||
[ "something else" ] [ "ohio" cond-test-2 ] unit-test
|
||||
|
||||
: cond-test-3 ( obj -- str )
|
||||
{
|
||||
[ drop "something else" ]
|
||||
{ [ dup t = ] [ drop "true" ] }
|
||||
{ [ dup f = ] [ drop "false" ] }
|
||||
} cond ;
|
||||
|
||||
\ cond-test-3 must-infer
|
||||
|
||||
[ "something else" ] [ t cond-test-3 ] unit-test
|
||||
[ "something else" ] [ f cond-test-3 ] unit-test
|
||||
[ "something else" ] [ "ohio" cond-test-3 ] unit-test
|
||||
|
||||
: cond-test-4 ( -- )
|
||||
{
|
||||
} cond ;
|
||||
|
||||
\ cond-test-4 must-infer
|
||||
|
||||
[ cond-test-4 ] [ class \ no-cond = ] must-fail-with
|
||||
|
||||
! Interpreted
|
||||
[ "even" ] [
|
||||
2 {
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
|
|
@ -21,11 +68,66 @@ namespaces combinators words ;
|
|||
{ [ dup string? ] [ drop "string" ] }
|
||||
{ [ dup float? ] [ drop "float" ] }
|
||||
{ [ dup alien? ] [ drop "alien" ] }
|
||||
{ [ t ] [ drop "neither" ] }
|
||||
[ drop "neither" ]
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
: case-test-1
|
||||
[ "neither" ] [
|
||||
3 {
|
||||
{ [ dup string? ] [ drop "string" ] }
|
||||
{ [ dup float? ] [ drop "float" ] }
|
||||
{ [ dup alien? ] [ drop "alien" ] }
|
||||
[ drop "neither" ]
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ "neither" ] [
|
||||
3 {
|
||||
{ [ dup string? ] [ drop "string" ] }
|
||||
{ [ dup float? ] [ drop "float" ] }
|
||||
{ [ dup alien? ] [ drop "alien" ] }
|
||||
[ drop "neither" ]
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ "early" ] [
|
||||
2 {
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
[ drop "early" ]
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ "really early" ] [
|
||||
2 {
|
||||
[ drop "really early" ]
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ { } cond ] [ class \ no-cond = ] must-fail-with
|
||||
|
||||
[ "early" ] [
|
||||
2 {
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
[ drop "early" ]
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ "really early" ] [
|
||||
2 {
|
||||
[ drop "really early" ]
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ { } cond ] [ class \ no-cond = ] must-fail-with
|
||||
|
||||
! Compiled
|
||||
: case-test-1 ( obj -- obj' )
|
||||
{
|
||||
{ 1 [ "one" ] }
|
||||
{ 2 [ "two" ] }
|
||||
|
|
@ -33,6 +135,8 @@ namespaces combinators words ;
|
|||
{ 4 [ "four" ] }
|
||||
} case ;
|
||||
|
||||
\ case-test-1 must-infer
|
||||
|
||||
[ "two" ] [ 2 case-test-1 ] unit-test
|
||||
|
||||
! Interpreted
|
||||
|
|
@ -40,7 +144,7 @@ namespaces combinators words ;
|
|||
|
||||
[ "x" case-test-1 ] must-fail
|
||||
|
||||
: case-test-2
|
||||
: case-test-2 ( obj -- obj' )
|
||||
{
|
||||
{ 1 [ "one" ] }
|
||||
{ 2 [ "two" ] }
|
||||
|
|
@ -49,12 +153,14 @@ namespaces combinators words ;
|
|||
[ sq ]
|
||||
} case ;
|
||||
|
||||
\ case-test-2 must-infer
|
||||
|
||||
[ 25 ] [ 5 case-test-2 ] unit-test
|
||||
|
||||
! Interpreted
|
||||
[ 25 ] [ 5 \ case-test-2 word-def call ] unit-test
|
||||
|
||||
: case-test-3
|
||||
: case-test-3 ( obj -- obj' )
|
||||
{
|
||||
{ 1 [ "one" ] }
|
||||
{ 2 [ "two" ] }
|
||||
|
|
@ -65,8 +171,122 @@ namespaces combinators words ;
|
|||
[ sq ]
|
||||
} case ;
|
||||
|
||||
\ case-test-3 must-infer
|
||||
|
||||
[ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test
|
||||
|
||||
: case-const-1 1 ;
|
||||
: case-const-2 2 ; inline
|
||||
|
||||
! Compiled
|
||||
: case-test-4 ( obj -- str )
|
||||
{
|
||||
{ case-const-1 [ "uno" ] }
|
||||
{ case-const-2 [ "dos" ] }
|
||||
{ 3 [ "tres" ] }
|
||||
{ 4 [ "cuatro" ] }
|
||||
{ 5 [ "cinco" ] }
|
||||
[ drop "demasiado" ]
|
||||
} case ;
|
||||
|
||||
\ case-test-4 must-infer
|
||||
|
||||
[ "uno" ] [ 1 case-test-4 ] unit-test
|
||||
[ "dos" ] [ 2 case-test-4 ] unit-test
|
||||
[ "tres" ] [ 3 case-test-4 ] unit-test
|
||||
[ "demasiado" ] [ 100 case-test-4 ] unit-test
|
||||
|
||||
: case-test-5 ( obj -- )
|
||||
{
|
||||
{ case-const-1 [ "uno" print ] }
|
||||
{ case-const-2 [ "dos" print ] }
|
||||
{ 3 [ "tres" print ] }
|
||||
{ 4 [ "cuatro" print ] }
|
||||
{ 5 [ "cinco" print ] }
|
||||
[ drop "demasiado" print ]
|
||||
} case ;
|
||||
|
||||
\ case-test-5 must-infer
|
||||
|
||||
[ ] [ 1 case-test-5 ] unit-test
|
||||
|
||||
! Interpreted
|
||||
[ "uno" ] [
|
||||
1 {
|
||||
{ case-const-1 [ "uno" ] }
|
||||
{ case-const-2 [ "dos" ] }
|
||||
{ 3 [ "tres" ] }
|
||||
{ 4 [ "cuatro" ] }
|
||||
{ 5 [ "cinco" ] }
|
||||
[ drop "demasiado" ]
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
[ "dos" ] [
|
||||
2 {
|
||||
{ case-const-1 [ "uno" ] }
|
||||
{ case-const-2 [ "dos" ] }
|
||||
{ 3 [ "tres" ] }
|
||||
{ 4 [ "cuatro" ] }
|
||||
{ 5 [ "cinco" ] }
|
||||
[ drop "demasiado" ]
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
[ "tres" ] [
|
||||
3 {
|
||||
{ case-const-1 [ "uno" ] }
|
||||
{ case-const-2 [ "dos" ] }
|
||||
{ 3 [ "tres" ] }
|
||||
{ 4 [ "cuatro" ] }
|
||||
{ 5 [ "cinco" ] }
|
||||
[ drop "demasiado" ]
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
[ "demasiado" ] [
|
||||
100 {
|
||||
{ case-const-1 [ "uno" ] }
|
||||
{ case-const-2 [ "dos" ] }
|
||||
{ 3 [ "tres" ] }
|
||||
{ 4 [ "cuatro" ] }
|
||||
{ 5 [ "cinco" ] }
|
||||
[ drop "demasiado" ]
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
: do-not-call "do not call" throw ;
|
||||
|
||||
: test-case-6
|
||||
{
|
||||
{ \ do-not-call [ "do-not-call" ] }
|
||||
{ 3 [ "three" ] }
|
||||
} case ;
|
||||
|
||||
[ "three" ] [ 3 test-case-6 ] unit-test
|
||||
[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
|
||||
|
||||
[ "three" ] [
|
||||
3 {
|
||||
{ \ do-not-call [ "do-not-call" ] }
|
||||
{ 3 [ "three" ] }
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
[ "do-not-call" ] [
|
||||
[ do-not-call ] first {
|
||||
{ \ do-not-call [ "do-not-call" ] }
|
||||
{ 3 [ "three" ] }
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
[ "do-not-call" ] [
|
||||
\ do-not-call {
|
||||
{ \ do-not-call [ "do-not-call" ] }
|
||||
{ 3 [ "three" ] }
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
! Interpreted
|
||||
[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
IN: combinators
|
||||
USING: arrays sequences sequences.private math.private
|
||||
kernel kernel.private math assocs quotations vectors
|
||||
hashtables sorting ;
|
||||
hashtables sorting words sets ;
|
||||
|
||||
: cleave ( x seq -- )
|
||||
[ call ] with each ;
|
||||
|
|
@ -34,13 +34,24 @@ hashtables sorting ;
|
|||
ERROR: no-cond ;
|
||||
|
||||
: cond ( assoc -- )
|
||||
[ first call ] find nip dup [ second call ] [ no-cond ] if ;
|
||||
[ dup callable? [ drop t ] [ first call ] if ] find nip
|
||||
[ dup callable? [ call ] [ second call ] if ]
|
||||
[ no-cond ] if* ;
|
||||
|
||||
ERROR: no-case ;
|
||||
: case-find ( obj assoc -- obj' )
|
||||
[
|
||||
dup array? [
|
||||
dupd first dup word? [
|
||||
execute
|
||||
] [
|
||||
dup wrapper? [ wrapped ] when
|
||||
] if =
|
||||
] [ quotation? ] if
|
||||
] find nip ;
|
||||
|
||||
: case ( obj assoc -- )
|
||||
[ dup array? [ dupd first = ] [ quotation? ] if ] find nip
|
||||
{
|
||||
case-find {
|
||||
{ [ dup array? ] [ nip second call ] }
|
||||
{ [ dup quotation? ] [ call ] }
|
||||
{ [ dup not ] [ no-case ] }
|
||||
|
|
@ -73,11 +84,14 @@ M: hashtable hashcode*
|
|||
[ rot \ if 3array append [ ] like ] assoc-each ;
|
||||
|
||||
: cond>quot ( assoc -- quot )
|
||||
[ dup callable? [ [ t ] swap 2array ] when ] map
|
||||
reverse [ no-cond ] swap alist>quot ;
|
||||
|
||||
: linear-case-quot ( default assoc -- quot )
|
||||
[ >r [ dupd = ] curry r> \ drop prefix ] assoc-map
|
||||
alist>quot ;
|
||||
[
|
||||
[ 1quotation \ dup prefix \ = suffix ]
|
||||
[ \ drop prefix ] bi*
|
||||
] assoc-map alist>quot ;
|
||||
|
||||
: (distribute-buckets) ( buckets pair keys -- )
|
||||
dup t eq? [
|
||||
|
|
@ -135,7 +149,9 @@ M: hashtable hashcode*
|
|||
dup empty? [
|
||||
drop
|
||||
] [
|
||||
dup length 4 <= [
|
||||
dup length 4 <=
|
||||
over keys [ word? ] contains? or
|
||||
[
|
||||
linear-case-quot
|
||||
] [
|
||||
dup keys contiguous-range? [
|
||||
|
|
|
|||
|
|
@ -7,9 +7,10 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
|
|||
{ { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
|
||||
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
|
||||
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
|
||||
{ { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must be >= 2" }
|
||||
{ { $snippet "-young=" { $emphasis "n" } } { "Size of " { $snippet { $emphasis "n" } "-1" } " youngest generations, megabytes" } }
|
||||
{ { $snippet "-aging=" { $emphasis "n" } } "Size of tenured and semi-spaces, megabytes" }
|
||||
{ { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must equal 1, 2 or 3" }
|
||||
{ { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
|
||||
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
|
||||
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
|
||||
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
|
||||
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ IN: compiler
|
|||
: finish-compile ( word effect dependencies -- )
|
||||
>r dupd save-effect r>
|
||||
over compiled-unxref
|
||||
over crossref? [ compiled-xref ] [ 2drop ] if ;
|
||||
over compiled-crossref? [ compiled-xref ] [ 2drop ] if ;
|
||||
|
||||
: compile-succeeded ( word -- effect dependencies )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -187,7 +187,7 @@ DEFER: countdown-b
|
|||
{ [ dup string? ] [ drop "string" ] }
|
||||
{ [ dup float? ] [ drop "float" ] }
|
||||
{ [ dup alien? ] [ drop "alien" ] }
|
||||
{ [ t ] [ drop "neither" ] }
|
||||
[ drop "neither" ]
|
||||
} cond
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
|
@ -196,7 +196,7 @@ DEFER: countdown-b
|
|||
[
|
||||
3 {
|
||||
{ [ dup fixnum? ] [ ] }
|
||||
{ [ t ] [ drop t ] }
|
||||
[ drop t ]
|
||||
} cond
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -4,16 +4,16 @@ USING: kernel tools.test compiler.units ;
|
|||
TUPLE: color red green blue ;
|
||||
|
||||
[ T{ color f 1 2 3 } ]
|
||||
[ 1 2 3 [ color construct-boa ] compile-call ] unit-test
|
||||
[ 1 2 3 [ color boa ] compile-call ] unit-test
|
||||
|
||||
[ 1 3 ] [
|
||||
1 2 3 color construct-boa
|
||||
1 2 3 color boa
|
||||
[ { color-red color-blue } get-slots ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ T{ color f 10 2 20 } ] [
|
||||
10 20
|
||||
1 2 3 color construct-boa [
|
||||
1 2 3 color boa [
|
||||
[
|
||||
{ set-color-red set-color-blue } set-slots
|
||||
] compile-call
|
||||
|
|
@ -21,4 +21,4 @@ TUPLE: color red green blue ;
|
|||
] unit-test
|
||||
|
||||
[ T{ color f f f f } ]
|
||||
[ [ color construct-empty ] compile-call ] unit-test
|
||||
[ [ color new ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ SYMBOL: new-definitions
|
|||
TUPLE: redefine-error def ;
|
||||
|
||||
: redefine-error ( definition -- )
|
||||
\ redefine-error construct-boa
|
||||
\ redefine-error boa
|
||||
{ { "Continue" t } } throw-restarts drop ;
|
||||
|
||||
: add-once ( key assoc -- )
|
||||
|
|
@ -66,7 +66,7 @@ GENERIC: definitions-changed ( assoc obj -- )
|
|||
|
||||
: compile ( words -- )
|
||||
recompile-hook get call
|
||||
dup [ drop crossref? ] assoc-contains?
|
||||
dup [ drop compiled-crossref? ] assoc-contains?
|
||||
modify-code-heap ;
|
||||
|
||||
SYMBOL: outdated-tuples
|
||||
|
|
@ -82,7 +82,7 @@ SYMBOL: update-tuples-hook
|
|||
: finish-compilation-unit ( -- )
|
||||
call-recompile-hook
|
||||
call-update-tuples-hook
|
||||
dup [ drop crossref? ] assoc-contains? modify-code-heap
|
||||
dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
|
||||
updated-definitions notify-definition-observers ;
|
||||
|
||||
: with-compilation-unit ( quot -- )
|
||||
|
|
|
|||
|
|
@ -90,7 +90,11 @@ ABOUT: "continuations"
|
|||
|
||||
HELP: dispose
|
||||
{ $values { "object" "a disposable object" } }
|
||||
{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." }
|
||||
{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on."
|
||||
$nl
|
||||
"No further operations can be performed on a disposable object after this call."
|
||||
$nl
|
||||
"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." }
|
||||
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ;
|
||||
|
||||
HELP: with-disposal
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic kernel kernel.private math memory
|
||||
namespaces sequences layouts system hashtables classes alien
|
||||
byte-arrays bit-arrays float-arrays combinators words ;
|
||||
byte-arrays bit-arrays float-arrays combinators words sets ;
|
||||
IN: cpu.architecture
|
||||
|
||||
! A pseudo-register class for parameters spilled on the stack
|
||||
|
|
|
|||
|
|
@ -246,9 +246,8 @@ M: x86.32 %cleanup ( alien-node -- )
|
|||
} {
|
||||
[ dup return>> large-struct? ]
|
||||
[ drop EAX PUSH ]
|
||||
} {
|
||||
[ t ] [ drop ]
|
||||
}
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
|
||||
|
|
|
|||
|
|
@ -104,7 +104,7 @@ M: indirect extended? indirect-base extended? ;
|
|||
canonicalize-ESP ;
|
||||
|
||||
: <indirect> ( base index scale displacement -- indirect )
|
||||
indirect construct-boa dup canonicalize ;
|
||||
indirect boa dup canonicalize ;
|
||||
|
||||
: reg-code "register" word-prop 7 bitand ;
|
||||
|
||||
|
|
@ -189,7 +189,7 @@ UNION: operand register indirect ;
|
|||
{
|
||||
{ [ dup register-128? ] [ drop operand-64? ] }
|
||||
{ [ dup not ] [ drop operand-64? ] }
|
||||
{ [ t ] [ nip operand-64? ] }
|
||||
[ nip operand-64? ]
|
||||
} cond and ;
|
||||
|
||||
: rex.r
|
||||
|
|
|
|||
|
|
@ -160,7 +160,7 @@ PREDICATE: kernel-error < array
|
|||
{
|
||||
{ [ dup empty? ] [ drop f ] }
|
||||
{ [ dup first "kernel-error" = not ] [ drop f ] }
|
||||
{ [ t ] [ second 0 15 between? ] }
|
||||
[ second 0 15 between? ]
|
||||
} cond ;
|
||||
|
||||
: kernel-errors
|
||||
|
|
@ -215,7 +215,10 @@ M: check-method summary
|
|||
drop "Invalid parameters for create-method" ;
|
||||
|
||||
M: no-tuple-class summary
|
||||
drop "Invalid class for define-constructor" ;
|
||||
drop "BOA constructors can only be defined for tuple classes" ;
|
||||
|
||||
M: bad-superclass summary
|
||||
drop "Tuple classes can only inherit from other tuple classes" ;
|
||||
|
||||
M: no-cond summary
|
||||
drop "Fall-through in cond" ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: dlists dlists.private kernel tools.test random assocs
|
||||
hashtables sequences namespaces sorting debugger io prettyprint
|
||||
sets sequences namespaces sorting debugger io prettyprint
|
||||
math ;
|
||||
IN: dlists.tests
|
||||
|
||||
|
|
@ -79,7 +79,7 @@ IN: dlists.tests
|
|||
[ dlist-push-all ] keep
|
||||
[ dlist-delete-all ] keep
|
||||
dlist>array
|
||||
] 2keep seq-diff assert-same-elements
|
||||
] 2keep diff assert-same-elements
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: dlists
|
|||
TUPLE: dlist front back length ;
|
||||
|
||||
: <dlist> ( -- obj )
|
||||
dlist construct-empty
|
||||
dlist new
|
||||
0 >>length ;
|
||||
|
||||
: dlist-empty? ( dlist -- ? ) front>> not ;
|
||||
|
|
@ -126,7 +126,7 @@ PRIVATE>
|
|||
{
|
||||
{ [ over front>> over eq? ] [ drop pop-front* ] }
|
||||
{ [ over back>> over eq? ] [ drop pop-back* ] }
|
||||
{ [ t ] [ unlink-node dec-length ] }
|
||||
[ unlink-node dec-length ]
|
||||
} cond ;
|
||||
|
||||
: delete-node-if* ( dlist quot -- obj/f ? )
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ TUPLE: effect in out terminated? ;
|
|||
|
||||
: <effect> ( in out -- effect )
|
||||
dup { "*" } sequence= [ drop { } t ] [ f ] if
|
||||
effect construct-boa ;
|
||||
effect boa ;
|
||||
|
||||
: effect-height ( effect -- n )
|
||||
dup effect-out length swap effect-in length - ;
|
||||
|
|
@ -20,7 +20,7 @@ TUPLE: effect in out terminated? ;
|
|||
{ [ dup effect-terminated? ] [ f ] }
|
||||
{ [ 2dup [ effect-in length ] bi@ > ] [ f ] }
|
||||
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
|
||||
{ [ t ] [ t ] }
|
||||
[ t ]
|
||||
} cond 2nip ;
|
||||
|
||||
GENERIC: (stack-picture) ( obj -- str )
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ M: float-array set-nth-unsafe
|
|||
M: float-array like
|
||||
drop dup float-array? [ >float-array ] unless ;
|
||||
|
||||
M: float-array new drop 0.0 <float-array> ;
|
||||
M: float-array new-sequence drop 0.0 <float-array> ;
|
||||
|
||||
M: float-array equal?
|
||||
over float-array? [ sequence= ] [ 2drop f ] if ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: float-vectors
|
|||
<PRIVATE
|
||||
|
||||
: float-array>vector ( float-array length -- float-vector )
|
||||
float-vector construct-boa ; inline
|
||||
float-vector boa ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -22,7 +22,7 @@ M: float-vector like
|
|||
[ dup length float-array>vector ] [ >float-vector ] if
|
||||
] unless ;
|
||||
|
||||
M: float-vector new
|
||||
M: float-vector new-sequence
|
||||
drop [ 0.0 <float-array> ] keep >fixnum float-array>vector ;
|
||||
|
||||
M: float-vector equal?
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Growable float arrays
|
||||
|
|
@ -0,0 +1 @@
|
|||
collections
|
||||
|
|
@ -10,7 +10,7 @@ IN: generator.fixup
|
|||
|
||||
TUPLE: frame-required n ;
|
||||
|
||||
: frame-required ( n -- ) \ frame-required construct-boa , ;
|
||||
: frame-required ( n -- ) \ frame-required boa , ;
|
||||
|
||||
: stack-frame-size ( code -- n )
|
||||
no-stack-frame [
|
||||
|
|
@ -25,7 +25,7 @@ GENERIC: fixup* ( frame-size obj -- frame-size )
|
|||
|
||||
TUPLE: label offset ;
|
||||
|
||||
: <label> ( -- label ) label construct-empty ;
|
||||
: <label> ( -- label ) label new ;
|
||||
|
||||
M: label fixup*
|
||||
compiled-offset swap set-label-offset ;
|
||||
|
|
@ -40,8 +40,8 @@ M: label fixup*
|
|||
|
||||
M: word fixup*
|
||||
{
|
||||
{ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
|
||||
{ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
|
||||
{ \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
|
||||
{ \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
|
||||
} case ;
|
||||
|
||||
SYMBOL: relocation-table
|
||||
|
|
@ -74,7 +74,7 @@ SYMBOL: label-table
|
|||
|
||||
TUPLE: label-fixup label class ;
|
||||
|
||||
: label-fixup ( label class -- ) \ label-fixup construct-boa , ;
|
||||
: label-fixup ( label class -- ) \ label-fixup boa , ;
|
||||
|
||||
M: label-fixup fixup*
|
||||
dup label-fixup-class rc-absolute?
|
||||
|
|
@ -84,7 +84,7 @@ M: label-fixup fixup*
|
|||
|
||||
TUPLE: rel-fixup arg class type ;
|
||||
|
||||
: rel-fixup ( arg class type -- ) \ rel-fixup construct-boa , ;
|
||||
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
|
||||
|
||||
: (rel-fixup) ( arg class type offset -- pair )
|
||||
pick rc-absolute-cell = cell 4 ? -
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ SYMBOL: compiled
|
|||
{ [ dup compiled get key? ] [ drop ] }
|
||||
{ [ dup inlined-block? ] [ drop ] }
|
||||
{ [ dup primitive? ] [ drop ] }
|
||||
{ [ t ] [ dup compile-queue get set-at ] }
|
||||
[ dup compile-queue get set-at ]
|
||||
} cond ;
|
||||
|
||||
: maybe-compile ( word -- )
|
||||
|
|
@ -202,7 +202,7 @@ M: #dispatch generate-node
|
|||
: define-if>boolean-intrinsics ( word intrinsics -- )
|
||||
[
|
||||
>r [ if>boolean-intrinsic ] curry r>
|
||||
{ { f "if-scratch" } } +scratch+ associate union
|
||||
{ { f "if-scratch" } } +scratch+ associate assoc-union
|
||||
] assoc-map "intrinsics" set-word-prop ;
|
||||
|
||||
: define-if-intrinsics ( word intrinsics -- )
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: arrays assocs classes classes.private classes.algebra
|
|||
combinators cpu.architecture generator.fixup hashtables kernel
|
||||
layouts math namespaces quotations sequences system vectors
|
||||
words effects alien byte-arrays bit-arrays float-arrays
|
||||
accessors ;
|
||||
accessors sets ;
|
||||
IN: generator.registers
|
||||
|
||||
SYMBOL: +input+
|
||||
|
|
@ -76,7 +76,7 @@ INSTANCE: temp-reg value
|
|||
! A data stack location.
|
||||
TUPLE: ds-loc n class ;
|
||||
|
||||
: <ds-loc> f ds-loc construct-boa ;
|
||||
: <ds-loc> f ds-loc boa ;
|
||||
|
||||
M: ds-loc minimal-ds-loc* ds-loc-n min ;
|
||||
M: ds-loc operand-class* ds-loc-class ;
|
||||
|
|
@ -87,7 +87,7 @@ M: ds-loc live-loc?
|
|||
! A retain stack location.
|
||||
TUPLE: rs-loc n class ;
|
||||
|
||||
: <rs-loc> f rs-loc construct-boa ;
|
||||
: <rs-loc> f rs-loc boa ;
|
||||
M: rs-loc operand-class* rs-loc-class ;
|
||||
M: rs-loc set-operand-class set-rs-loc-class ;
|
||||
M: rs-loc live-loc?
|
||||
|
|
@ -128,7 +128,7 @@ INSTANCE: cached value
|
|||
TUPLE: tagged vreg class ;
|
||||
|
||||
: <tagged> ( vreg -- tagged )
|
||||
f tagged construct-boa ;
|
||||
f tagged boa ;
|
||||
|
||||
M: tagged v>operand tagged-vreg v>operand ;
|
||||
M: tagged set-operand-class set-tagged-class ;
|
||||
|
|
@ -195,7 +195,7 @@ INSTANCE: constant value
|
|||
{ [ dup byte-array class< ] [ drop %unbox-byte-array ] }
|
||||
{ [ dup bit-array class< ] [ drop %unbox-byte-array ] }
|
||||
{ [ dup float-array class< ] [ drop %unbox-byte-array ] }
|
||||
{ [ t ] [ drop %unbox-any-c-ptr ] }
|
||||
[ drop %unbox-any-c-ptr ]
|
||||
} cond ; inline
|
||||
|
||||
: %move-via-temp ( dst src -- )
|
||||
|
|
@ -237,8 +237,8 @@ M: phantom-stack clone
|
|||
|
||||
GENERIC: finalize-height ( stack -- )
|
||||
|
||||
: construct-phantom-stack ( class -- stack )
|
||||
>r 0 V{ } clone r> construct-boa ; inline
|
||||
: new-phantom-stack ( class -- stack )
|
||||
>r 0 V{ } clone r> boa ; inline
|
||||
|
||||
: (loc)
|
||||
#! Utility for methods on <loc>
|
||||
|
|
@ -257,7 +257,7 @@ GENERIC: <loc> ( n stack -- loc )
|
|||
TUPLE: phantom-datastack < phantom-stack ;
|
||||
|
||||
: <phantom-datastack> ( -- stack )
|
||||
phantom-datastack construct-phantom-stack ;
|
||||
phantom-datastack new-phantom-stack ;
|
||||
|
||||
M: phantom-datastack <loc> (loc) <ds-loc> ;
|
||||
|
||||
|
|
@ -267,7 +267,7 @@ M: phantom-datastack finalize-height
|
|||
TUPLE: phantom-retainstack < phantom-stack ;
|
||||
|
||||
: <phantom-retainstack> ( -- stack )
|
||||
phantom-retainstack construct-phantom-stack ;
|
||||
phantom-retainstack new-phantom-stack ;
|
||||
|
||||
M: phantom-retainstack <loc> (loc) <rs-loc> ;
|
||||
|
||||
|
|
@ -357,14 +357,14 @@ SYMBOL: fresh-objects
|
|||
{ [ dup unboxed-c-ptr eq? ] [
|
||||
over { unboxed-byte-array unboxed-alien } member?
|
||||
] }
|
||||
{ [ t ] [ f ] }
|
||||
[ f ]
|
||||
} cond 2nip ;
|
||||
|
||||
: allocation ( value spec -- reg-class )
|
||||
{
|
||||
{ [ dup quotation? ] [ 2drop f ] }
|
||||
{ [ 2dup compatible? ] [ 2drop f ] }
|
||||
{ [ t ] [ nip reg-spec>class ] }
|
||||
[ nip reg-spec>class ]
|
||||
} cond ;
|
||||
|
||||
: alloc-vreg-for ( value spec -- vreg )
|
||||
|
|
@ -381,7 +381,7 @@ M: value (lazy-load)
|
|||
: (compute-free-vregs) ( used class -- vector )
|
||||
#! Find all vregs in 'class' which are not in 'used'.
|
||||
[ vregs length reverse ] keep
|
||||
[ <vreg> ] curry map seq-diff
|
||||
[ <vreg> ] curry map diff
|
||||
>vector ;
|
||||
|
||||
: compute-free-vregs ( -- )
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ TUPLE: check-method class generic ;
|
|||
|
||||
: check-method ( class generic -- class generic )
|
||||
over class? over generic? and [
|
||||
\ check-method construct-boa throw
|
||||
\ check-method boa throw
|
||||
] unless ; inline
|
||||
|
||||
: with-methods ( generic quot -- )
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ PREDICATE: math-class < class
|
|||
{
|
||||
{ [ dup null class< ] [ drop { -1 -1 } ] }
|
||||
{ [ dup math-class? ] [ class-types last/first ] }
|
||||
{ [ t ] [ drop { 100 100 } ] }
|
||||
[ drop { 100 100 } ]
|
||||
} cond ;
|
||||
|
||||
: math-class-max ( class class -- class )
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
|
|||
{ [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
|
||||
{ [ dup length 1 = ] [ first second { } ] }
|
||||
{ [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
|
||||
{ [ t ] [ [ first second ] [ 1 tail-slice ] bi ] }
|
||||
[ [ first second ] [ 1 tail-slice ] bi ]
|
||||
} cond ;
|
||||
|
||||
: sort-methods ( assoc -- assoc' )
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@ TUPLE: tuple-dispatch-engine echelons ;
|
|||
dupd <echelon-dispatch-engine>
|
||||
] if
|
||||
] assoc-map [ nip ] assoc-subset
|
||||
\ tuple-dispatch-engine construct-boa ;
|
||||
\ tuple-dispatch-engine boa ;
|
||||
|
||||
: convert-tuple-methods ( assoc -- assoc' )
|
||||
tuple bootstrap-word
|
||||
|
|
@ -63,14 +63,14 @@ M: trivial-tuple-dispatch-engine engine>quot
|
|||
] "" make ;
|
||||
|
||||
PREDICATE: tuple-dispatch-engine-word < word
|
||||
"tuple-dispatch-engine" word-prop ;
|
||||
"tuple-dispatch-generic" word-prop generic? ;
|
||||
|
||||
M: tuple-dispatch-engine-word stack-effect
|
||||
"tuple-dispatch-generic" word-prop
|
||||
[ extra-values ] [ stack-effect clone ] bi
|
||||
[ length + ] change-in ;
|
||||
[ extra-values ] [ stack-effect ] bi
|
||||
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
|
||||
|
||||
M: tuple-dispatch-engine-word crossref?
|
||||
M: tuple-dispatch-engine-word compiled-crossref?
|
||||
drop t ;
|
||||
|
||||
: remember-engine ( word -- )
|
||||
|
|
@ -78,12 +78,10 @@ M: tuple-dispatch-engine-word crossref?
|
|||
|
||||
: <tuple-dispatch-engine-word> ( engine -- word )
|
||||
tuple-dispatch-engine-word-name f <word>
|
||||
{
|
||||
[ t "tuple-dispatch-engine" set-word-prop ]
|
||||
[ generic get "tuple-dispatch-generic" set-word-prop ]
|
||||
[ remember-engine ]
|
||||
[ ]
|
||||
} cleave ;
|
||||
[ generic get "tuple-dispatch-generic" set-word-prop ]
|
||||
[ remember-engine ]
|
||||
[ ]
|
||||
tri ;
|
||||
|
||||
: define-tuple-dispatch-engine-word ( engine quot -- word )
|
||||
>r <tuple-dispatch-engine-word> dup r> define ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@ IN: generic.standard.tests
|
|||
USING: tools.test math math.functions math.constants
|
||||
generic.standard strings sequences arrays kernel accessors
|
||||
words float-arrays byte-arrays bit-arrays parser namespaces
|
||||
quotations inference vectors growable ;
|
||||
quotations inference vectors growable hashtables sbufs
|
||||
prettyprint ;
|
||||
|
||||
GENERIC: lo-tag-test
|
||||
|
||||
|
|
@ -182,22 +183,22 @@ M: ceo salary
|
|||
|
||||
[ salary ] must-infer
|
||||
|
||||
[ 24000 ] [ employee construct-boa salary ] unit-test
|
||||
[ 24000 ] [ employee boa salary ] unit-test
|
||||
|
||||
[ 24000 ] [ tape-monkey construct-boa salary ] unit-test
|
||||
[ 24000 ] [ tape-monkey boa salary ] unit-test
|
||||
|
||||
[ 36000 ] [ junior-manager construct-boa salary ] unit-test
|
||||
[ 36000 ] [ junior-manager boa salary ] unit-test
|
||||
|
||||
[ 41000 ] [ middle-manager construct-boa salary ] unit-test
|
||||
[ 41000 ] [ middle-manager boa salary ] unit-test
|
||||
|
||||
[ 51000 ] [ senior-manager construct-boa salary ] unit-test
|
||||
[ 51000 ] [ senior-manager boa salary ] unit-test
|
||||
|
||||
[ 102000 ] [ executive construct-boa salary ] unit-test
|
||||
[ 102000 ] [ executive boa salary ] unit-test
|
||||
|
||||
[ ceo construct-boa salary ]
|
||||
[ ceo boa salary ]
|
||||
[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
|
||||
|
||||
[ intern construct-boa salary ]
|
||||
[ intern boa salary ]
|
||||
[ T{ no-next-method f intern salary } = ] must-fail-with
|
||||
|
||||
! Weird shit
|
||||
|
|
@ -268,3 +269,13 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
|
|||
[ "vector growable sequence" ] [
|
||||
V{ } my-var [ call-next-hooker ] with-variable
|
||||
] unit-test
|
||||
|
||||
GENERIC: no-stack-effect-decl
|
||||
|
||||
M: hashtable no-stack-effect-decl ;
|
||||
M: vector no-stack-effect-decl ;
|
||||
M: sbuf no-stack-effect-decl ;
|
||||
|
||||
[ ] [ \ no-stack-effect-decl see ] unit-test
|
||||
|
||||
[ ] [ \ no-stack-effect-decl word-def . ] unit-test
|
||||
|
|
|
|||
|
|
@ -110,6 +110,9 @@ ERROR: no-next-method class generic ;
|
|||
\ if ,
|
||||
] [ ] make ;
|
||||
|
||||
: single-effective-method ( obj word -- method )
|
||||
[ order [ instance? ] with find-last nip ] keep method ;
|
||||
|
||||
TUPLE: standard-combination # ;
|
||||
|
||||
C: <standard-combination> standard-combination
|
||||
|
|
@ -142,8 +145,7 @@ M: standard-combination next-method-quot*
|
|||
] with-standard ;
|
||||
|
||||
M: standard-generic effective-method
|
||||
[ dispatch# (picker) call ] keep
|
||||
[ order [ instance? ] with find-last nip ] keep method ;
|
||||
[ dispatch# (picker) call ] keep single-effective-method ;
|
||||
|
||||
TUPLE: hook-combination var ;
|
||||
|
||||
|
|
@ -161,6 +163,10 @@ M: hook-combination dispatch# drop 0 ;
|
|||
|
||||
M: hook-generic extra-values drop 1 ;
|
||||
|
||||
M: hook-generic effective-method
|
||||
[ "combination" word-prop var>> get ] keep
|
||||
single-effective-method ;
|
||||
|
||||
M: hook-combination make-default-method
|
||||
[ error-method ] with-hook ;
|
||||
|
||||
|
|
|
|||
|
|
@ -21,12 +21,12 @@ HELP: graph
|
|||
|
||||
HELP: add-vertex
|
||||
{ $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } }
|
||||
{ $description "Adds a vertex to a directed graph, using the " { $snippet "edges" } " quotation to generate a sequence of edges leaving the vertex." }
|
||||
{ $description "Adds a vertex to a directed graph, with " { $snippet "edges" } " as the outward edges from the vertex." }
|
||||
{ $side-effects "graph" } ;
|
||||
|
||||
HELP: remove-vertex
|
||||
{ $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } }
|
||||
{ $description "Removes a vertex from a graph, using the quotation to generate a sequence of edges leaving the vertex." }
|
||||
{ $description "Removes a vertex from a graph, using the given edges sequence." }
|
||||
{ $notes "The " { $snippet "edges" } " sequence must equal the value passed to " { $link add-vertex } ", otherwise some vertices of the graph may continue to refer to the removed vertex." }
|
||||
{ $side-effects "graph" } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -49,11 +49,7 @@ $nl
|
|||
ARTICLE: "hashtables.utilities" "Hashtable utilities"
|
||||
"Utility words to create a new hashtable from a single key/value pair:"
|
||||
{ $subsection associate }
|
||||
{ $subsection ?set-at }
|
||||
"The final two words pertain to sequences but use a hashtable internally. Removing duplicate elements from a sequence in linear time, using a hashtable:"
|
||||
{ $subsection prune }
|
||||
"Test if a sequence contains duplicates in linear time:"
|
||||
{ $subsection all-unique? } ;
|
||||
{ $subsection ?set-at } ;
|
||||
|
||||
ABOUT: "hashtables"
|
||||
|
||||
|
|
@ -138,22 +134,6 @@ HELP: >hashtable
|
|||
{ $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } }
|
||||
{ $description "Constructs a hashtable from any assoc." } ;
|
||||
|
||||
HELP: prune
|
||||
{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
|
||||
{ $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." }
|
||||
{ $examples
|
||||
{ $example "USING: hashtables prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
|
||||
} ;
|
||||
|
||||
HELP: all-unique?
|
||||
{ $values { "seq" sequence } { "?" "a boolean" } }
|
||||
{ $description "Tests whether a sequence contains any repeated elements." }
|
||||
{ $example
|
||||
"USING: hashtables prettyprint ;"
|
||||
"{ 0 1 1 2 3 5 } all-unique? ."
|
||||
"f"
|
||||
} ;
|
||||
|
||||
HELP: rehash
|
||||
{ $values { "hash" hashtable } }
|
||||
{ $description "Rebuild the hashtable. This word should be called if the hashcodes of the hashtable's keys have changed, or if the hashing algorithms themselves have changed, neither of which should occur during normal operation." } ;
|
||||
|
|
|
|||
|
|
@ -164,6 +164,3 @@ H{ } "x" set
|
|||
[ { "one" "two" 3 } ] [
|
||||
{ 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute
|
||||
] unit-test
|
||||
|
||||
[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
|
||||
[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
|
||||
|
|
|
|||
|
|
@ -116,7 +116,7 @@ IN: hashtables
|
|||
PRIVATE>
|
||||
|
||||
: <hashtable> ( n -- hash )
|
||||
hashtable construct-empty [ reset-hash ] keep ;
|
||||
hashtable new [ reset-hash ] keep ;
|
||||
|
||||
M: hashtable at* ( key hash -- value ? )
|
||||
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
|
||||
|
|
@ -174,18 +174,4 @@ M: hashtable assoc-like
|
|||
: ?set-at ( value key assoc/f -- assoc )
|
||||
[ [ set-at ] keep ] [ associate ] if* ;
|
||||
|
||||
: (prune) ( hash vec elt -- )
|
||||
rot 2dup key?
|
||||
[ 3drop ] [ dupd dupd set-at swap push ] if ; inline
|
||||
|
||||
: prune ( seq -- newseq )
|
||||
[ length <hashtable> ]
|
||||
[ length <vector> ]
|
||||
[ ] tri
|
||||
[ >r 2dup r> (prune) ] each nip ;
|
||||
|
||||
: all-unique? ( seq -- ? )
|
||||
[ length ]
|
||||
[ prune length ] bi = ;
|
||||
|
||||
INSTANCE: hashtable assoc
|
||||
|
|
|
|||
|
|
@ -20,11 +20,11 @@ GENERIC: heap-size ( heap -- n )
|
|||
TUPLE: heap data ;
|
||||
|
||||
: <heap> ( class -- heap )
|
||||
>r V{ } clone r> construct-boa ; inline
|
||||
>r V{ } clone r> boa ; inline
|
||||
|
||||
TUPLE: entry value key heap index ;
|
||||
|
||||
: <entry> ( value key heap -- entry ) f entry construct-boa ;
|
||||
: <entry> ( value key heap -- entry ) f entry boa ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
collections
|
||||
|
|
@ -39,9 +39,9 @@ M: inference-error compiler-error-type type>> ;
|
|||
M: inference-error error-help error>> error-help ;
|
||||
|
||||
: (inference-error) ( ... class type -- * )
|
||||
>r construct-boa r>
|
||||
>r boa r>
|
||||
recursive-state get
|
||||
\ inference-error construct-boa throw ; inline
|
||||
\ inference-error boa throw ; inline
|
||||
|
||||
: inference-error ( ... class -- * )
|
||||
+error+ (inference-error) ; inline
|
||||
|
|
@ -251,7 +251,7 @@ TUPLE: cannot-unify-specials ;
|
|||
{ [ dup [ curried? ] all? ] [ unify-curries ] }
|
||||
{ [ dup [ composed? ] all? ] [ unify-composed ] }
|
||||
{ [ dup [ special? ] contains? ] [ cannot-unify-specials ] }
|
||||
{ [ t ] [ drop <computed> ] }
|
||||
[ drop <computed> ]
|
||||
} cond ;
|
||||
|
||||
: unify-stacks ( seq -- stack )
|
||||
|
|
@ -395,7 +395,7 @@ TUPLE: effect-error word effect ;
|
|||
{ [ dup "infer" word-prop ] [ custom-infer ] }
|
||||
{ [ dup "no-effect" word-prop ] [ no-effect ] }
|
||||
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
|
||||
{ [ t ] [ dup infer-word make-call-node ] }
|
||||
[ dup infer-word make-call-node ]
|
||||
} cond ;
|
||||
|
||||
TUPLE: recursive-declare-error word ;
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ IN: inference.dataflow
|
|||
TUPLE: value < identity-tuple literal uid recursion ;
|
||||
|
||||
: <value> ( obj -- value )
|
||||
<computed> recursive-state get value construct-boa ;
|
||||
<computed> recursive-state get value boa ;
|
||||
|
||||
M: value hashcode* nip value-uid ;
|
||||
|
||||
|
|
@ -68,16 +68,16 @@ M: object flatten-curry , ;
|
|||
[ in-d>> ] [ out-d>> ] bi <effect> ;
|
||||
|
||||
: param-node ( param class -- node )
|
||||
construct-empty swap >>param ; inline
|
||||
new swap >>param ; inline
|
||||
|
||||
: in-node ( seq class -- node )
|
||||
construct-empty swap >>in-d ; inline
|
||||
new swap >>in-d ; inline
|
||||
|
||||
: all-in-node ( class -- node )
|
||||
flatten-meta-d swap in-node ; inline
|
||||
|
||||
: out-node ( seq class -- node )
|
||||
construct-empty swap >>out-d ; inline
|
||||
new swap >>out-d ; inline
|
||||
|
||||
: all-out-node ( class -- node )
|
||||
flatten-meta-d swap out-node ; inline
|
||||
|
|
@ -111,19 +111,19 @@ TUPLE: #call-label < node ;
|
|||
|
||||
TUPLE: #push < node ;
|
||||
|
||||
: #push ( -- node ) \ #push construct-empty ;
|
||||
: #push ( -- node ) \ #push new ;
|
||||
|
||||
TUPLE: #shuffle < node ;
|
||||
|
||||
: #shuffle ( -- node ) \ #shuffle construct-empty ;
|
||||
: #shuffle ( -- node ) \ #shuffle new ;
|
||||
|
||||
TUPLE: #>r < node ;
|
||||
|
||||
: #>r ( -- node ) \ #>r construct-empty ;
|
||||
: #>r ( -- node ) \ #>r new ;
|
||||
|
||||
TUPLE: #r> < node ;
|
||||
|
||||
: #r> ( -- node ) \ #r> construct-empty ;
|
||||
: #r> ( -- node ) \ #r> new ;
|
||||
|
||||
TUPLE: #values < node ;
|
||||
|
||||
|
|
@ -150,7 +150,7 @@ TUPLE: #merge < node ;
|
|||
|
||||
TUPLE: #terminate < node ;
|
||||
|
||||
: #terminate ( -- node ) \ #terminate construct-empty ;
|
||||
: #terminate ( -- node ) \ #terminate new ;
|
||||
|
||||
TUPLE: #declare < node ;
|
||||
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ classes ;
|
|||
|
||||
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
|
||||
|
||||
\ construct-empty must-infer
|
||||
\ new must-infer
|
||||
|
||||
TUPLE: a-tuple x y z ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: arrays kernel words sequences generic math namespaces
|
||||
quotations assocs combinators math.bitfields inference.backend
|
||||
inference.dataflow inference.state classes.tuple.private effects
|
||||
inspector hashtables classes generic ;
|
||||
inspector hashtables classes generic sets ;
|
||||
IN: inference.transforms
|
||||
|
||||
: pop-literals ( n -- rstate seq )
|
||||
|
|
@ -82,12 +82,12 @@ M: duplicated-slots-error summary
|
|||
[ <reversed> [get-slots] ] [ duplicated-slots-error ] if
|
||||
] 1 define-transform
|
||||
|
||||
\ construct-boa [
|
||||
\ boa [
|
||||
dup +inlined+ depends-on
|
||||
tuple-layout [ <tuple-boa> ] curry
|
||||
] 1 define-transform
|
||||
|
||||
\ construct-empty [
|
||||
\ new [
|
||||
1 ensure-values
|
||||
peek-d value? [
|
||||
pop-literal
|
||||
|
|
@ -95,7 +95,7 @@ M: duplicated-slots-error summary
|
|||
tuple-layout [ <tuple> ] curry
|
||||
swap infer-quot
|
||||
] [
|
||||
\ construct-empty 1 1 <effect> make-call-node
|
||||
\ new 1 1 <effect> make-call-node
|
||||
] if
|
||||
] "infer" set-word-prop
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic hashtables io kernel assocs math
|
||||
namespaces prettyprint sequences strings io.styles vectors words
|
||||
quotations mirrors splitting math.parser classes vocabs refs ;
|
||||
quotations mirrors splitting math.parser classes vocabs refs
|
||||
sets ;
|
||||
IN: inspector
|
||||
|
||||
GENERIC: summary ( object -- string )
|
||||
|
|
|
|||
|
|
@ -30,8 +30,8 @@ ERROR: encode-error ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
M: tuple-class <decoder> construct-empty <decoder> ;
|
||||
M: tuple <decoder> f decoder construct-boa ;
|
||||
M: tuple-class <decoder> new <decoder> ;
|
||||
M: tuple <decoder> f decoder boa ;
|
||||
|
||||
: >decoder< ( decoder -- stream encoding )
|
||||
[ stream>> ] [ code>> ] bi ;
|
||||
|
|
@ -104,8 +104,8 @@ M: decoder stream-readln ( stream -- str )
|
|||
M: decoder dispose decoder-stream dispose ;
|
||||
|
||||
! Encoding
|
||||
M: tuple-class <encoder> construct-empty <encoder> ;
|
||||
M: tuple <encoder> encoder construct-boa ;
|
||||
M: tuple-class <encoder> new <encoder> ;
|
||||
M: tuple <encoder> encoder boa ;
|
||||
|
||||
: >encoder< ( encoder -- stream encoding )
|
||||
[ stream>> ] [ code>> ] bi ;
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ TUPLE: utf8 ;
|
|||
{ [ dup -5 shift BIN: 110 number= ] [ double ] }
|
||||
{ [ dup -4 shift BIN: 1110 number= ] [ triple ] }
|
||||
{ [ dup -3 shift BIN: 11110 number= ] [ quad ] }
|
||||
{ [ t ] [ drop replacement-char ] }
|
||||
[ drop replacement-char ]
|
||||
} cond ;
|
||||
|
||||
: decode-utf8 ( stream -- char/f )
|
||||
|
|
@ -59,12 +59,12 @@ M: utf8 decode-char
|
|||
2dup -6 shift encoded
|
||||
encoded
|
||||
] }
|
||||
{ [ t ] [
|
||||
[
|
||||
2dup -18 shift BIN: 11110000 bitor swap stream-write1
|
||||
2dup -12 shift encoded
|
||||
2dup -6 shift encoded
|
||||
encoded
|
||||
] }
|
||||
]
|
||||
} cond ;
|
||||
|
||||
M: utf8 encode-char
|
||||
|
|
|
|||
|
|
@ -39,11 +39,19 @@ ARTICLE: "symbolic-links" "Symbolic links"
|
|||
"Not all operating systems support symbolic links."
|
||||
{ $see-also link-info } ;
|
||||
|
||||
ARTICLE: "directories" "Directories"
|
||||
"Current directory:"
|
||||
ARTICLE: "current-directory" "Current working directory"
|
||||
"File system I/O operations use the value of a variable to resolve relative pathnames:"
|
||||
{ $subsection current-directory }
|
||||
"This variable can be changed with a pair of words:"
|
||||
{ $subsection set-current-directory }
|
||||
{ $subsection with-directory }
|
||||
"This variable is independent of the operating system notion of ``current working directory''. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
|
||||
{ $subsection (normalize-path) }
|
||||
"The second is to change the working directory of the current process:"
|
||||
{ $subsection cd }
|
||||
{ $subsection cwd } ;
|
||||
|
||||
ARTICLE: "directories" "Directories"
|
||||
"Home directory:"
|
||||
{ $subsection home }
|
||||
"Directory listing:"
|
||||
|
|
@ -51,7 +59,8 @@ ARTICLE: "directories" "Directories"
|
|||
{ $subsection directory* }
|
||||
"Creating directories:"
|
||||
{ $subsection make-directory }
|
||||
{ $subsection make-directories } ;
|
||||
{ $subsection make-directories }
|
||||
{ $subsection "current-directory" } ;
|
||||
|
||||
ARTICLE: "file-types" "File Types"
|
||||
"Platform-independent types:"
|
||||
|
|
@ -112,8 +121,7 @@ ARTICLE: "io.files" "Basic file operations"
|
|||
{ $subsection "file-streams" }
|
||||
{ $subsection "fs-meta" }
|
||||
{ $subsection "directories" }
|
||||
{ $subsection "delete-move-copy" }
|
||||
{ $see-also "os" } ;
|
||||
{ $subsection "delete-move-copy" } ;
|
||||
|
||||
ABOUT: "io.files"
|
||||
|
||||
|
|
@ -243,11 +251,21 @@ HELP: cd
|
|||
{ cd cwd current-directory set-current-directory with-directory } related-words
|
||||
|
||||
HELP: current-directory
|
||||
{ $description "A variable holding the current directory. Words that use the filesystem do so in relation to this variable. On startup, an init hook sets this word to the directory from which Factor was run." } ;
|
||||
{ $description "A variable holding the current directory as an absolute path. Words that use the filesystem do so in relation to this variable."
|
||||
$nl
|
||||
"This variable should never be set directly; instead, use " { $link set-current-directory } " or " { $link with-directory } ". This preserves the invariant that the value of this variable is an absolute path." } ;
|
||||
|
||||
HELP: set-current-directory
|
||||
{ $values { "path" "a pathname string" } }
|
||||
{ $description "Changes the " { $link current-directory } " variable."
|
||||
$nl
|
||||
"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
|
||||
|
||||
HELP: with-directory
|
||||
{ $values { "path" "a pathname string" } { "quot" quotation } }
|
||||
{ $description "Changes the " { $link current-directory } " variable for the duration of a quotation's execution. Words that use the file-system should call " { $link normalize-path } " in order to obtain a path relative to the current directory." } ;
|
||||
{ $description "Calls the quotation in a new dynamic scope with the " { $link current-directory } " variable rebound."
|
||||
$nl
|
||||
"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
|
||||
|
||||
HELP: append-path
|
||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
|
||||
|
|
@ -301,7 +319,7 @@ HELP: directory*
|
|||
|
||||
HELP: resource-path
|
||||
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
|
||||
{ $description "Resolve a path relative to the Factor source code location. This first checks if the " { $link resource-path } " variable is set to a path, and if not, uses the parent directory of the current image." } ;
|
||||
{ $description "Resolve a path relative to the Factor source code location." } ;
|
||||
|
||||
HELP: pathname
|
||||
{ $class-description "Class of pathname presentations. Path name presentations can be created by calling " { $link <pathname> } ". Instances can be passed to " { $link write-object } " to output a clickable pathname." } ;
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@ ERROR: no-parent-directory path ;
|
|||
1 tail left-trim-separators append-path-empty
|
||||
] }
|
||||
{ [ dup head..? ] [ drop no-parent-directory ] }
|
||||
{ [ t ] [ nip ] }
|
||||
[ nip ]
|
||||
} cond ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
@ -105,7 +105,7 @@ PRIVATE>
|
|||
{ [ dup "\\\\?\\" head? ] [ t ] }
|
||||
{ [ dup length 2 < ] [ f ] }
|
||||
{ [ dup second CHAR: : = ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
[ f ]
|
||||
} cond ;
|
||||
|
||||
: absolute-path? ( path -- ? )
|
||||
|
|
@ -114,7 +114,7 @@ PRIVATE>
|
|||
{ [ dup "resource:" head? ] [ t ] }
|
||||
{ [ os windows? ] [ windows-absolute-path? ] }
|
||||
{ [ dup first path-separator? ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
[ f ]
|
||||
} cond nip ;
|
||||
|
||||
: append-path ( str1 str2 -- str )
|
||||
|
|
@ -130,10 +130,10 @@ PRIVATE>
|
|||
{ [ over absolute-path? over first path-separator? and ] [
|
||||
>r 2 head r> append
|
||||
] }
|
||||
{ [ t ] [
|
||||
[
|
||||
>r right-trim-separators "/" r>
|
||||
left-trim-separators 3append
|
||||
] }
|
||||
]
|
||||
} cond ;
|
||||
|
||||
: prepend-path ( str1 str2 -- str )
|
||||
|
|
@ -220,10 +220,10 @@ HOOK: make-directory io-backend ( path -- )
|
|||
{ [ dup root-directory? ] [ ] }
|
||||
{ [ dup empty? ] [ ] }
|
||||
{ [ dup exists? ] [ ] }
|
||||
{ [ t ] [
|
||||
[
|
||||
dup parent-directory make-directories
|
||||
dup make-directory
|
||||
] }
|
||||
]
|
||||
} cond drop ;
|
||||
|
||||
! Directory listings
|
||||
|
|
@ -322,9 +322,10 @@ C: <pathname> pathname
|
|||
M: pathname <=> [ pathname-string ] compare ;
|
||||
|
||||
! Home directory
|
||||
: home ( -- dir )
|
||||
{
|
||||
{ [ os winnt? ] [ "USERPROFILE" os-env ] }
|
||||
{ [ os wince? ] [ "" resource-path ] }
|
||||
{ [ os unix? ] [ "HOME" os-env ] }
|
||||
} cond ;
|
||||
HOOK: home os ( -- dir )
|
||||
|
||||
M: winnt home "USERPROFILE" os-env ;
|
||||
|
||||
M: wince home "" resource-path ;
|
||||
|
||||
M: unix home "HOME" os-env ;
|
||||
|
|
|
|||
|
|
@ -4,8 +4,7 @@ IN: io.streams.duplex
|
|||
ARTICLE: "io.streams.duplex" "Duplex streams"
|
||||
"Duplex streams combine an input stream and an output stream into a bidirectional stream."
|
||||
{ $subsection duplex-stream }
|
||||
{ $subsection <duplex-stream> }
|
||||
{ $subsection check-closed } ;
|
||||
{ $subsection <duplex-stream> } ;
|
||||
|
||||
ABOUT: "io.streams.duplex"
|
||||
|
||||
|
|
@ -16,7 +15,5 @@ HELP: <duplex-stream>
|
|||
{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
|
||||
{ $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ;
|
||||
|
||||
HELP: check-closed
|
||||
{ $values { "stream" "a duplex stream" } }
|
||||
{ $description "Throws a " { $link check-closed } " error if the stream has already been closed." }
|
||||
HELP: stream-closed-twice
|
||||
{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: io.streams.duplex.tests
|
|||
! Test duplex stream close behavior
|
||||
TUPLE: closing-stream closed? ;
|
||||
|
||||
: <closing-stream> closing-stream construct-empty ;
|
||||
: <closing-stream> closing-stream new ;
|
||||
|
||||
M: closing-stream dispose
|
||||
dup closing-stream-closed? [
|
||||
|
|
@ -15,7 +15,7 @@ M: closing-stream dispose
|
|||
|
||||
TUPLE: unclosable-stream ;
|
||||
|
||||
: <unclosable-stream> unclosable-stream construct-empty ;
|
||||
: <unclosable-stream> unclosable-stream new ;
|
||||
|
||||
M: unclosable-stream dispose
|
||||
"Can't close me!" throw ;
|
||||
|
|
|
|||
|
|
@ -1,75 +1,77 @@
|
|||
! Copyright (C) 2005 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel continuations io accessors ;
|
||||
IN: io.streams.duplex
|
||||
USING: kernel continuations io ;
|
||||
|
||||
! We ensure that the stream can only be closed once, to preserve
|
||||
! integrity of duplex I/O ports.
|
||||
|
||||
TUPLE: duplex-stream in out closed? ;
|
||||
TUPLE: duplex-stream in out closed ;
|
||||
|
||||
: <duplex-stream> ( in out -- stream )
|
||||
f duplex-stream construct-boa ;
|
||||
f duplex-stream boa ;
|
||||
|
||||
ERROR: stream-closed-twice ;
|
||||
|
||||
: check-closed ( stream -- )
|
||||
duplex-stream-closed? [ stream-closed-twice ] when ;
|
||||
<PRIVATE
|
||||
|
||||
: duplex-stream-in+ ( duplex -- stream )
|
||||
dup check-closed duplex-stream-in ;
|
||||
: check-closed ( stream -- stream )
|
||||
dup closed>> [ stream-closed-twice ] when ; inline
|
||||
|
||||
: duplex-stream-out+ ( duplex -- stream )
|
||||
dup check-closed duplex-stream-out ;
|
||||
: in ( duplex -- stream ) check-closed in>> ;
|
||||
|
||||
: out ( duplex -- stream ) check-closed out>> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: duplex-stream stream-flush
|
||||
duplex-stream-out+ stream-flush ;
|
||||
out stream-flush ;
|
||||
|
||||
M: duplex-stream stream-readln
|
||||
duplex-stream-in+ stream-readln ;
|
||||
in stream-readln ;
|
||||
|
||||
M: duplex-stream stream-read1
|
||||
duplex-stream-in+ stream-read1 ;
|
||||
in stream-read1 ;
|
||||
|
||||
M: duplex-stream stream-read-until
|
||||
duplex-stream-in+ stream-read-until ;
|
||||
in stream-read-until ;
|
||||
|
||||
M: duplex-stream stream-read-partial
|
||||
duplex-stream-in+ stream-read-partial ;
|
||||
in stream-read-partial ;
|
||||
|
||||
M: duplex-stream stream-read
|
||||
duplex-stream-in+ stream-read ;
|
||||
in stream-read ;
|
||||
|
||||
M: duplex-stream stream-write1
|
||||
duplex-stream-out+ stream-write1 ;
|
||||
out stream-write1 ;
|
||||
|
||||
M: duplex-stream stream-write
|
||||
duplex-stream-out+ stream-write ;
|
||||
out stream-write ;
|
||||
|
||||
M: duplex-stream stream-nl
|
||||
duplex-stream-out+ stream-nl ;
|
||||
out stream-nl ;
|
||||
|
||||
M: duplex-stream stream-format
|
||||
duplex-stream-out+ stream-format ;
|
||||
out stream-format ;
|
||||
|
||||
M: duplex-stream make-span-stream
|
||||
duplex-stream-out+ make-span-stream ;
|
||||
out make-span-stream ;
|
||||
|
||||
M: duplex-stream make-block-stream
|
||||
duplex-stream-out+ make-block-stream ;
|
||||
out make-block-stream ;
|
||||
|
||||
M: duplex-stream make-cell-stream
|
||||
duplex-stream-out+ make-cell-stream ;
|
||||
out make-cell-stream ;
|
||||
|
||||
M: duplex-stream stream-write-table
|
||||
duplex-stream-out+ stream-write-table ;
|
||||
out stream-write-table ;
|
||||
|
||||
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.
|
||||
dup duplex-stream-closed? [
|
||||
t over set-duplex-stream-closed?
|
||||
[ dup duplex-stream-out dispose ]
|
||||
[ dup duplex-stream-in dispose ] [ ] cleanup
|
||||
dup closed>> [
|
||||
t >>closed
|
||||
[ dup out>> dispose ]
|
||||
[ dup in>> dispose ] [ ] cleanup
|
||||
] unless drop ;
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@ C: <ignore-close-stream> ignore-close-stream
|
|||
TUPLE: style-stream < filter-writer style ;
|
||||
|
||||
: do-nested-style ( style style-stream -- style stream )
|
||||
[ style>> swap union ] [ stream>> ] bi ; inline
|
||||
[ style>> swap assoc-union ] [ stream>> ] bi ; inline
|
||||
|
||||
C: <style-stream> style-stream
|
||||
|
||||
|
|
|
|||
|
|
@ -142,10 +142,10 @@ M: object clone ;
|
|||
M: callstack clone (clone) ;
|
||||
|
||||
! Tuple construction
|
||||
: construct-empty ( class -- tuple )
|
||||
: new ( class -- tuple )
|
||||
tuple-layout <tuple> ;
|
||||
|
||||
: construct-boa ( ... class -- tuple )
|
||||
: boa ( ... class -- tuple )
|
||||
tuple-layout <tuple-boa> ;
|
||||
|
||||
! Quotation building
|
||||
|
|
@ -203,7 +203,7 @@ GENERIC# get-slots 1 ( tuple slots -- ... )
|
|||
GENERIC# set-slots 1 ( ... tuple slots -- )
|
||||
|
||||
: construct ( ... slots class -- tuple )
|
||||
construct-empty [ swap set-slots ] keep ; inline
|
||||
new [ swap set-slots ] keep ; inline
|
||||
|
||||
: construct-delegate ( delegate class -- tuple )
|
||||
>r { set-delegate } r> construct ; inline
|
||||
|
|
|
|||
|
|
@ -103,7 +103,7 @@ C: <interval> interval
|
|||
2drop over second over second and
|
||||
[ <interval> ] [ 2drop f ] if
|
||||
] }
|
||||
{ [ t ] [ 2drop <interval> ] }
|
||||
[ 2drop <interval> ]
|
||||
} cond ;
|
||||
|
||||
: interval-intersect ( i1 i2 -- i3 )
|
||||
|
|
@ -202,7 +202,7 @@ SYMBOL: incomparable
|
|||
{ [ 2dup interval-intersect not ] [ (interval<) ] }
|
||||
{ [ 2dup left-endpoint-< ] [ f ] }
|
||||
{ [ 2dup right-endpoint-< ] [ f ] }
|
||||
{ [ t ] [ incomparable ] }
|
||||
[ incomparable ]
|
||||
} cond 2nip ;
|
||||
|
||||
: left-endpoint-<= ( i1 i2 -- ? )
|
||||
|
|
@ -215,7 +215,7 @@ SYMBOL: incomparable
|
|||
{
|
||||
{ [ 2dup interval-intersect not ] [ (interval<) ] }
|
||||
{ [ 2dup right-endpoint-<= ] [ t ] }
|
||||
{ [ t ] [ incomparable ] }
|
||||
[ incomparable ]
|
||||
} cond 2nip ;
|
||||
|
||||
: interval> ( i1 i2 -- ? )
|
||||
|
|
|
|||
|
|
@ -62,6 +62,8 @@ M: object zero? drop f ;
|
|||
: neg ( x -- -x ) 0 swap - ; foldable
|
||||
: recip ( x -- y ) 1 swap / ; foldable
|
||||
|
||||
: ?1+ [ 1+ ] [ 0 ] if* ; inline
|
||||
|
||||
: /f ( x y -- z ) >r >float r> >float float/f ; inline
|
||||
|
||||
: max ( x y -- z ) [ > ] most ; foldable
|
||||
|
|
|
|||
|
|
@ -62,7 +62,7 @@ SYMBOL: negative?
|
|||
{
|
||||
{ [ dup empty? ] [ drop f ] }
|
||||
{ [ f over memq? ] [ drop f ] }
|
||||
{ [ t ] [ radix get [ < ] curry all? ] }
|
||||
[ radix get [ < ] curry all? ]
|
||||
} cond ;
|
||||
|
||||
: string>integer ( str -- n/f )
|
||||
|
|
@ -77,7 +77,7 @@ PRIVATE>
|
|||
{
|
||||
{ [ CHAR: / over member? ] [ string>ratio ] }
|
||||
{ [ CHAR: . over member? ] [ string>float ] }
|
||||
{ [ t ] [ string>integer ] }
|
||||
[ string>integer ]
|
||||
} cond
|
||||
r> [ dup [ neg ] when ] when
|
||||
] with-radix ;
|
||||
|
|
@ -134,10 +134,8 @@ M: ratio >base
|
|||
} {
|
||||
[ CHAR: . over member? ]
|
||||
[ ]
|
||||
} {
|
||||
[ t ]
|
||||
[ ".0" append ]
|
||||
}
|
||||
[ ".0" append ]
|
||||
} cond ;
|
||||
|
||||
M: float >base
|
||||
|
|
@ -145,7 +143,7 @@ M: float >base
|
|||
{ [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
|
||||
{ [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
|
||||
{ [ dup fp-nan? ] [ drop "0.0/0.0" ] }
|
||||
{ [ t ] [ float>string fix-float ] }
|
||||
[ float>string fix-float ]
|
||||
} cond ;
|
||||
|
||||
: number>string ( n -- str ) 10 >base ;
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ IN: mirrors
|
|||
TUPLE: mirror object slots ;
|
||||
|
||||
: <mirror> ( object -- mirror )
|
||||
dup object-slots mirror construct-boa ;
|
||||
dup object-slots mirror boa ;
|
||||
|
||||
: >mirror< ( mirror -- obj slots )
|
||||
dup mirror-object swap mirror-slots ;
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ SYMBOL: optimizer-changed
|
|||
GENERIC: optimize-node* ( node -- node/t changed? )
|
||||
|
||||
: ?union ( assoc/f assoc -- hash )
|
||||
over [ union ] [ nip ] if ;
|
||||
over [ assoc-union ] [ nip ] if ;
|
||||
|
||||
: add-node-literals ( assoc node -- )
|
||||
over assoc-empty? [
|
||||
|
|
@ -82,7 +82,7 @@ M: node optimize-node* drop t f ;
|
|||
2dup at* [ swap follow nip ] [ 2drop ] if ;
|
||||
|
||||
: union* ( assoc1 assoc2 -- assoc )
|
||||
union [ keys ] keep
|
||||
assoc-union [ keys ] keep
|
||||
[ dupd follow ] curry
|
||||
H{ } map>assoc ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,23 +9,23 @@ optimizer ;
|
|||
{ [ over #label? not ] [ 2drop f ] }
|
||||
{ [ over #label-word over eq? not ] [ 2drop f ] }
|
||||
{ [ over #label-loop? not ] [ 2drop f ] }
|
||||
{ [ t ] [ 2drop t ] }
|
||||
[ 2drop t ]
|
||||
} cond
|
||||
] curry node-exists? ;
|
||||
|
||||
: label-is-not-loop? ( node word -- ? )
|
||||
[
|
||||
{
|
||||
{ [ over #label? not ] [ 2drop f ] }
|
||||
{ [ over #label-word over eq? not ] [ 2drop f ] }
|
||||
{ [ over #label-loop? ] [ 2drop f ] }
|
||||
{ [ t ] [ 2drop t ] }
|
||||
} cond
|
||||
{ [ over #label? not ] [ f ] }
|
||||
{ [ over #label-word over eq? not ] [ f ] }
|
||||
{ [ over #label-loop? ] [ f ] }
|
||||
[ t ]
|
||||
} cond 2nip
|
||||
] curry node-exists? ;
|
||||
|
||||
: loop-test-1 ( a -- )
|
||||
dup [ 1+ loop-test-1 ] [ drop ] if ; inline
|
||||
|
||||
|
||||
[ t ] [
|
||||
[ loop-test-1 ] dataflow dup detect-loops
|
||||
\ loop-test-1 label-is-loop?
|
||||
|
|
|
|||
|
|
@ -156,7 +156,7 @@ SYMBOL: potential-loops
|
|||
{ [ dup null class< ] [ drop f f ] }
|
||||
{ [ dup \ f class-not class< ] [ drop t t ] }
|
||||
{ [ dup \ f class< ] [ drop f t ] }
|
||||
{ [ t ] [ drop f f ] }
|
||||
[ drop f f ]
|
||||
} cond
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ DEFER: (flat-length)
|
|||
! not inline
|
||||
{ [ dup inline? not ] [ drop 1 ] }
|
||||
! inline
|
||||
{ [ t ] [ dup dup set word-def (flat-length) ] }
|
||||
[ dup dup set word-def (flat-length) ]
|
||||
} cond ;
|
||||
|
||||
: (flat-length) ( seq -- n )
|
||||
|
|
@ -45,7 +45,7 @@ DEFER: (flat-length)
|
|||
{ [ dup quotation? ] [ (flat-length) 1+ ] }
|
||||
{ [ dup array? ] [ (flat-length) ] }
|
||||
{ [ dup word? ] [ word-flat-length ] }
|
||||
{ [ t ] [ drop 1 ] }
|
||||
[ drop 1 ]
|
||||
} cond
|
||||
] map sum ;
|
||||
|
||||
|
|
@ -94,7 +94,7 @@ DEFER: (flat-length)
|
|||
dup node-param {
|
||||
{ [ dup standard-generic? ] [ inline-standard-method ] }
|
||||
{ [ dup math-generic? ] [ inline-math-method ] }
|
||||
{ [ t ] [ 2drop t ] }
|
||||
[ 2drop t ]
|
||||
} cond ;
|
||||
|
||||
! Resolve type checks at compile time where possible
|
||||
|
|
@ -217,5 +217,5 @@ M: #call optimize-node*
|
|||
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
|
||||
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
|
||||
{ [ dup method-body-inline? ] [ optimistic-inline ] }
|
||||
{ [ t ] [ inline-method ] }
|
||||
[ inline-method ]
|
||||
} cond dup not ;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ sequences.private combinators ;
|
|||
] "output-classes" set-word-prop
|
||||
] each
|
||||
|
||||
\ construct-empty [
|
||||
\ new [
|
||||
dup node-in-d peek node-literal
|
||||
dup class? [ drop tuple ] unless 1array f
|
||||
] "output-classes" set-word-prop
|
||||
|
|
|
|||
|
|
@ -283,7 +283,7 @@ TUPLE: silly-tuple a b ;
|
|||
|
||||
[ t ] [ \ node-successor-f-bug compiled? ] unit-test
|
||||
|
||||
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
|
||||
[ ] [ [ new ] dataflow optimize drop ] unit-test
|
||||
|
||||
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ SYMBOL: @
|
|||
{ [ dup @ eq? ] [ drop match-@ ] }
|
||||
{ [ dup class? ] [ match-class ] }
|
||||
{ [ over value? not ] [ 2drop f ] }
|
||||
{ [ t ] [ swap value-literal = ] }
|
||||
[ swap value-literal = ]
|
||||
} cond ;
|
||||
|
||||
: node-match? ( node values pattern -- ? )
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ IN: optimizer.specializers
|
|||
[ dup "specializer" word-prop ]
|
||||
[ "specializer" word-prop specialize-quot ]
|
||||
}
|
||||
{ [ t ] [ drop ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
: specialized-length ( specializer -- n )
|
||||
|
|
|
|||
|
|
@ -358,6 +358,18 @@ HELP: scan-word
|
|||
{ $errors "Throws an error if the token does not name a word, and does not parse as a number." }
|
||||
$parsing-note ;
|
||||
|
||||
HELP: invalid-slot-name
|
||||
{ $values { "name" string } }
|
||||
{ $description "Throws an " { $link invalid-slot-name } " error." }
|
||||
{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." }
|
||||
{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:"
|
||||
{ $code
|
||||
"TUPLE: my-mistaken-tuple slot-a slot-b"
|
||||
""
|
||||
": some-word ( a b c -- ) ... ;"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: unexpected
|
||||
{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } }
|
||||
{ $description "Throws an " { $link unexpected } " error." }
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ prettyprint sequences strings vectors words quotations inspector
|
|||
io.styles io combinators sorting splitting math.parser effects
|
||||
continuations debugger io.files io.streams.string vocabs
|
||||
io.encodings.utf8 source-files classes classes.tuple hashtables
|
||||
compiler.errors compiler.units accessors ;
|
||||
compiler.errors compiler.units accessors sets ;
|
||||
IN: parser
|
||||
|
||||
TUPLE: lexer text line line-text line-length column ;
|
||||
|
|
@ -17,9 +17,14 @@ TUPLE: lexer text line line-text line-length column ;
|
|||
0 >>column
|
||||
drop ;
|
||||
|
||||
: new-lexer ( text class -- lexer )
|
||||
new
|
||||
0 >>line
|
||||
swap >>text
|
||||
dup next-line ; inline
|
||||
|
||||
: <lexer> ( text -- lexer )
|
||||
0 { set-lexer-text set-lexer-line } lexer construct
|
||||
dup next-line ;
|
||||
lexer new-lexer ;
|
||||
|
||||
: location ( -- loc )
|
||||
file get lexer get lexer-line 2dup and
|
||||
|
|
@ -159,7 +164,7 @@ name>char-hook global [
|
|||
TUPLE: parse-error file line column line-text error ;
|
||||
|
||||
: <parse-error> ( msg -- error )
|
||||
\ parse-error construct-empty
|
||||
\ parse-error new
|
||||
file get >>file
|
||||
lexer get line>> >>line
|
||||
lexer get column>> >>column
|
||||
|
|
@ -184,6 +189,9 @@ M: parse-error summary
|
|||
M: parse-error compute-restarts
|
||||
error>> compute-restarts ;
|
||||
|
||||
M: parse-error error-help
|
||||
error>> error-help ;
|
||||
|
||||
SYMBOL: use
|
||||
SYMBOL: in
|
||||
|
||||
|
|
@ -253,7 +261,7 @@ M: no-word-error summary
|
|||
drop "Word not found in current vocabulary search path" ;
|
||||
|
||||
: no-word ( name -- newword )
|
||||
dup no-word-error construct-boa
|
||||
dup no-word-error boa
|
||||
swap words-named [ forward-reference? not ] subset
|
||||
word-restarts throw-restarts
|
||||
dup word-vocabulary (use+) ;
|
||||
|
|
@ -285,7 +293,7 @@ M: no-word-error summary
|
|||
scan-word bootstrap-word scan-word create-method-in ;
|
||||
|
||||
: shadowed-slots ( superclass slots -- shadowed )
|
||||
>r all-slot-names r> seq-intersect ;
|
||||
>r all-slot-names r> intersect ;
|
||||
|
||||
: check-slot-shadowing ( class superclass slots -- )
|
||||
shadowed-slots [
|
||||
|
|
@ -298,12 +306,35 @@ M: no-word-error summary
|
|||
] "" make note.
|
||||
] with each ;
|
||||
|
||||
ERROR: invalid-slot-name name ;
|
||||
|
||||
M: invalid-slot-name summary
|
||||
drop
|
||||
"Invalid slot name" ;
|
||||
|
||||
: (parse-tuple-slots) ( -- )
|
||||
#! This isn't meant to enforce any kind of policy, just
|
||||
#! to check for mistakes of this form:
|
||||
#!
|
||||
#! TUPLE: blahblah foo bing
|
||||
#!
|
||||
#! : ...
|
||||
scan {
|
||||
{ [ dup not ] [ unexpected-eof ] }
|
||||
{ [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] }
|
||||
{ [ dup ";" = ] [ drop ] }
|
||||
[ , (parse-tuple-slots) ]
|
||||
} cond ;
|
||||
|
||||
: parse-tuple-slots ( -- seq )
|
||||
[ (parse-tuple-slots) ] { } make ;
|
||||
|
||||
: parse-tuple-definition ( -- class superclass slots )
|
||||
CREATE-CLASS
|
||||
scan {
|
||||
{ ";" [ tuple f ] }
|
||||
{ "<" [ scan-word ";" parse-tokens ] }
|
||||
[ >r tuple ";" parse-tokens r> prefix ]
|
||||
{ "<" [ scan-word parse-tuple-slots ] }
|
||||
[ >r tuple parse-tuple-slots r> prefix ]
|
||||
} case 3dup check-slot-shadowing ;
|
||||
|
||||
ERROR: staging-violation word ;
|
||||
|
|
@ -324,7 +355,7 @@ M: staging-violation summary
|
|||
{ [ dup not ] [ drop unexpected-eof t ] }
|
||||
{ [ dup delimiter? ] [ unexpected t ] }
|
||||
{ [ dup parsing? ] [ nip execute-parsing t ] }
|
||||
{ [ t ] [ pick push drop t ] }
|
||||
[ pick push drop t ]
|
||||
} cond ;
|
||||
|
||||
: (parse-until) ( accum end -- accum )
|
||||
|
|
@ -475,14 +506,14 @@ SYMBOL: interactive-vocabs
|
|||
] if ;
|
||||
|
||||
: filter-moved ( assoc1 assoc2 -- seq )
|
||||
diff [
|
||||
assoc-diff [
|
||||
drop where dup [ first ] when
|
||||
file get source-file-path =
|
||||
] assoc-subset keys ;
|
||||
|
||||
: removed-definitions ( -- assoc1 assoc2 )
|
||||
new-definitions old-definitions
|
||||
[ get first2 union ] bi@ ;
|
||||
[ get first2 assoc-union ] bi@ ;
|
||||
|
||||
: removed-classes ( -- assoc1 assoc2 )
|
||||
new-definitions old-definitions
|
||||
|
|
|
|||
|
|
@ -60,8 +60,8 @@ $nl
|
|||
{ $subsection short-section }
|
||||
{ $subsection long-section }
|
||||
"Utilities to use when implementing sections:"
|
||||
{ $subsection construct-section }
|
||||
{ $subsection construct-block }
|
||||
{ $subsection new-section }
|
||||
{ $subsection new-block }
|
||||
{ $subsection add-section } ;
|
||||
|
||||
ARTICLE: "prettyprint-sections" "Prettyprinter sections"
|
||||
|
|
|
|||
|
|
@ -7,7 +7,8 @@ vectors words prettyprint.backend prettyprint.sections
|
|||
prettyprint.config sorting splitting math.parser vocabs
|
||||
definitions effects classes.builtin classes.tuple io.files
|
||||
classes continuations hashtables classes.mixin classes.union
|
||||
classes.predicate classes.singleton combinators quotations ;
|
||||
classes.predicate classes.singleton combinators quotations
|
||||
sets ;
|
||||
|
||||
: make-pprint ( obj quot -- block in use )
|
||||
[
|
||||
|
|
@ -107,7 +108,7 @@ SYMBOL: ->
|
|||
{ [ dup word? not ] [ , ] }
|
||||
{ [ dup "break?" word-prop ] [ drop ] }
|
||||
{ [ dup "step-into?" word-prop ] [ remove-step-into ] }
|
||||
{ [ t ] [ , ] }
|
||||
[ , ]
|
||||
} cond
|
||||
] each
|
||||
] [ ] make ;
|
||||
|
|
|
|||
|
|
@ -78,7 +78,7 @@ HELP: section
|
|||
{ { $snippet "overhang" } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" }
|
||||
} } ;
|
||||
|
||||
HELP: construct-section
|
||||
HELP: new-section
|
||||
{ $values { "length" integer } { "class" "a subclass of " { $link section } } { "section" section } }
|
||||
{ $description "Creates a new section with the given length starting from " { $link position } ", advancing " { $link position } "." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ SYMBOL: pprinter-use
|
|||
|
||||
TUPLE: pprinter last-newline line-count end-printing indent ;
|
||||
|
||||
: <pprinter> ( -- pprinter ) 0 1 f 0 pprinter construct-boa ;
|
||||
: <pprinter> ( -- pprinter ) 0 1 f 0 pprinter boa ;
|
||||
|
||||
: record-vocab ( word -- )
|
||||
word-vocabulary [ dup pprinter-use get set-at ] when* ;
|
||||
|
|
@ -71,8 +71,8 @@ start end
|
|||
start-group? end-group?
|
||||
style overhang ;
|
||||
|
||||
: construct-section ( length class -- section )
|
||||
construct-empty
|
||||
: new-section ( length class -- section )
|
||||
new
|
||||
position get >>start
|
||||
swap position [ + ] change
|
||||
position get >>end
|
||||
|
|
@ -127,7 +127,7 @@ M: object short-section? section-fits? ;
|
|||
TUPLE: line-break < section type ;
|
||||
|
||||
: <line-break> ( type -- section )
|
||||
0 \ line-break construct-section
|
||||
0 \ line-break new-section
|
||||
swap >>type ;
|
||||
|
||||
M: line-break short-section drop ;
|
||||
|
|
@ -137,13 +137,13 @@ M: line-break long-section drop ;
|
|||
! Block sections
|
||||
TUPLE: block < section sections ;
|
||||
|
||||
: construct-block ( style class -- block )
|
||||
0 swap construct-section
|
||||
: new-block ( style class -- block )
|
||||
0 swap new-section
|
||||
V{ } clone >>sections
|
||||
swap >>style ; inline
|
||||
|
||||
: <block> ( style -- block )
|
||||
block construct-block ;
|
||||
block new-block ;
|
||||
|
||||
: pprinter-block ( -- block ) pprinter-stack get peek ;
|
||||
|
||||
|
|
@ -200,7 +200,7 @@ M: block short-section ( block -- )
|
|||
TUPLE: text < section string ;
|
||||
|
||||
: <text> ( string style -- text )
|
||||
over length 1+ \ text construct-section
|
||||
over length 1+ \ text new-section
|
||||
swap >>style
|
||||
swap >>string ;
|
||||
|
||||
|
|
@ -216,7 +216,7 @@ M: text long-section short-section ;
|
|||
TUPLE: inset < block narrow? ;
|
||||
|
||||
: <inset> ( narrow? -- block )
|
||||
H{ } inset construct-block
|
||||
H{ } inset new-block
|
||||
2 >>overhang
|
||||
swap >>narrow? ;
|
||||
|
||||
|
|
@ -237,7 +237,7 @@ M: inset newline-after? drop t ;
|
|||
TUPLE: flow < block ;
|
||||
|
||||
: <flow> ( -- block )
|
||||
H{ } flow construct-block ;
|
||||
H{ } flow new-block ;
|
||||
|
||||
M: flow short-section? ( section -- ? )
|
||||
#! If we can make room for this entire block by inserting
|
||||
|
|
@ -253,7 +253,7 @@ M: flow short-section? ( section -- ? )
|
|||
TUPLE: colon < block ;
|
||||
|
||||
: <colon> ( -- block )
|
||||
H{ } colon construct-block ;
|
||||
H{ } colon new-block ;
|
||||
|
||||
M: colon long-section short-section ;
|
||||
|
||||
|
|
|
|||
|
|
@ -19,6 +19,6 @@ IN: sbufs.tests
|
|||
|
||||
[ SBUF" x" ] [ 1 <sbuf> CHAR: x >bignum over push ] unit-test
|
||||
|
||||
[ fixnum ] [ 1 >bignum SBUF" " new length class ] unit-test
|
||||
[ fixnum ] [ 1 >bignum SBUF" " new-sequence length class ] unit-test
|
||||
|
||||
[ fixnum ] [ 1 >bignum [ ] SBUF" " map-as length class ] unit-test
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: sbufs
|
|||
<PRIVATE
|
||||
|
||||
: string>sbuf ( string length -- sbuf )
|
||||
sbuf construct-boa ; inline
|
||||
sbuf boa ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -16,7 +16,7 @@ PRIVATE>
|
|||
M: sbuf set-nth-unsafe
|
||||
underlying >r >r >fixnum r> >fixnum r> set-string-nth ;
|
||||
|
||||
M: sbuf new drop [ 0 <string> ] keep >fixnum string>sbuf ;
|
||||
M: sbuf new-sequence drop [ 0 <string> ] keep >fixnum string>sbuf ;
|
||||
|
||||
: >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ ARTICLE: "sequence-protocol" "Sequence protocol"
|
|||
"An optional generic word for creating sequences of the same class as a given sequence:"
|
||||
{ $subsection like }
|
||||
"Optional generic words for optimization purposes:"
|
||||
{ $subsection new }
|
||||
{ $subsection new-sequence }
|
||||
{ $subsection new-resizable }
|
||||
{ $see-also "sequences-unsafe" } ;
|
||||
|
||||
|
|
@ -64,8 +64,7 @@ ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
|
|||
{ $subsection prefix }
|
||||
{ $subsection suffix }
|
||||
"Removing elements:"
|
||||
{ $subsection remove }
|
||||
{ $subsection seq-diff } ;
|
||||
{ $subsection remove } ;
|
||||
|
||||
ARTICLE: "sequences-reshape" "Reshaping sequences"
|
||||
"A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:"
|
||||
|
|
@ -233,6 +232,8 @@ $nl
|
|||
{ $subsection "sequences-split" }
|
||||
{ $subsection "sequences-destructive" }
|
||||
{ $subsection "sequences-stacks" }
|
||||
{ $subsection "sequences-sorting" }
|
||||
{ $subsection "sets" }
|
||||
"For inner loops:"
|
||||
{ $subsection "sequences-unsafe" } ;
|
||||
|
||||
|
|
@ -280,7 +281,7 @@ HELP: immutable
|
|||
{ $description "Throws an " { $link immutable } " error." }
|
||||
{ $error-description "Thrown if an attempt is made to modify an immutable sequence." } ;
|
||||
|
||||
HELP: new
|
||||
HELP: new-sequence
|
||||
{ $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a mutable sequence" } }
|
||||
{ $contract "Outputs a mutable sequence of length " { $snippet "n" } " which can hold the elements of " { $snippet "seq" } "." } ;
|
||||
|
||||
|
|
@ -527,12 +528,7 @@ HELP: contains?
|
|||
|
||||
HELP: all?
|
||||
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "?" "a boolean" } }
|
||||
{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." }
|
||||
{ $notes
|
||||
"The implementation makes use of a well-known logical identity:"
|
||||
$nl
|
||||
{ $snippet "P[x] for all x <==> not ((not P[x]) for some x)" }
|
||||
} ;
|
||||
{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." } ;
|
||||
|
||||
HELP: push-if
|
||||
{ $values { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } }
|
||||
|
|
@ -659,10 +655,6 @@ HELP: prefix
|
|||
{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 prefix ." "{ 0 1 2 3 }" }
|
||||
} ;
|
||||
|
||||
HELP: seq-diff
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
|
||||
{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq2" } " but not " { $snippet "seq1" } ", comparing elements for equality." } ;
|
||||
|
||||
HELP: sum-lengths
|
||||
{ $values { "seq" "a sequence of sequences" } { "n" integer } }
|
||||
{ $description "Outputs the sum of the lengths of all sequences in " { $snippet "seq" } "." } ;
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue