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

Merge branch 'master' of git://factorcode.org/git/factor into tangle

db4
Alex Chapman 2008-04-09 09:21:47 +10:00
parent 7ff62f2811 94863d980d
commit d916fd7a2e
42 changed files with 493 additions and 2471 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
build-support/factor.sh
View File

@ -89,11 +89,6 @@ set_md5sum() {
set_gcc() {
case $OS in
openbsd) ensure_program_installed egcc; CC=egcc;;
netbsd) if [[ $WORD -eq 64 ]] ; then
CC=/usr/pkg/gcc34/bin/gcc
else
CC=gcc
fi ;;
*) CC=gcc;;
esac
}

5
core/assocs/assocs.factor
View File

@ -155,6 +155,9 @@ M: assoc >alist [ 2array ] { } assoc>map ;
: value-at ( value assoc -- key/f )
swap [ = nip ] curry assoc-find 2drop ;
: zip ( keys values -- alist )
2array flip ; inline
: search-alist ( key alist -- pair i )
[ first = ] with find swap ; inline
@ -204,7 +207,7 @@ M: enum set-at seq>> set-nth ;
M: enum delete-at enum-seq delete-nth ;
M: enum >alist ( enum -- alist )
seq>> [ length ] keep 2array flip ;
seq>> [ length ] keep zip ;
M: enum assoc-size seq>> length ;

9
core/classes/tuple/tuple-tests.factor
View File

@ -529,3 +529,12 @@ TUPLE: another-forget-accessors-test ;
] unit-test
[ t ] [ \ another-forget-accessors-test class? ] unit-test
! Shadowing test
[ f ] [
t parser-notes? [
[
"IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval
] with-string-writer empty?
] with-variable
] unit-test

6
core/classes/tuple/tuple.factor
View File

@ -55,6 +55,9 @@ PRIVATE>
"slot-names" word-prop
[ dup array? [ second ] when ] map ;
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class prefix ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
@ -119,9 +122,6 @@ PRIVATE>
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class prefix ;
: compute-slot-permutation ( class old-slot-names -- permutation )
>r all-slot-names r> [ index ] curry map ;

4
core/combinators/combinators.factor
View File

@ -59,6 +59,10 @@ ERROR: no-case ;
M: sequence hashcode*
[ sequence-hashcode ] recursive-hashcode ;
M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
M: hashtable hashcode*
[
dup assoc-size 1 number=

8
core/compiler/compiler.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces arrays sequences io inference.backend
inference.state generator debugger math.parser prettyprint words
compiler.units continuations vocabs assocs alien.compiler dlists
optimizer definitions math compiler.errors threads graphs
generic inference ;
inference.state generator debugger words compiler.units
continuations vocabs assocs alien.compiler dlists optimizer
definitions math compiler.errors threads graphs generic
inference ;
IN: compiler
: ripple-up ( word -- )

4
core/cpu/ppc/architecture/architecture.factor
View File

@ -146,7 +146,7 @@ M: int-regs %save-param-reg drop 1 rot local@ STW ;
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
GENERIC: STF ( src dst reg-class -- )
GENERIC: STF ( src dst off reg-class -- )
M: single-float-regs STF drop STFS ;
@ -154,7 +154,7 @@ M: double-float-regs STF drop STFD ;
M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
GENERIC: LF ( src dst reg-class -- )
GENERIC: LF ( dst src off reg-class -- )
M: single-float-regs LF drop LFS ;

4
core/generator/registers/registers.factor
View File

@ -322,7 +322,7 @@ M: phantom-retainstack finalize-height
: (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved
[ phantom-locs* ] [ stack>> ] bi 2array flip
[ phantom-locs* ] [ stack>> ] bi zip
[ live-loc? ] assoc-subset
values ;
@ -421,7 +421,7 @@ M: loc lazy-store
: slow-shuffle-mapping ( locs tmp -- pairs )
>r dup length r>
[ swap - <ds-loc> ] curry map 2array flip ;
[ swap - <ds-loc> ] curry map zip ;
: slow-shuffle ( locs -- )
#! We don't have enough free registers to load all shuffle

2
core/inference/known-words/known-words.factor
View File

@ -373,7 +373,7 @@ set-primitive-effect
\ data-room { } { integer array } <effect> set-primitive-effect
\ data-room make-flushable
\ code-room { } { integer integer } <effect> set-primitive-effect
\ code-room { } { integer integer integer integer } <effect> set-primitive-effect
\ code-room make-flushable
\ os-env { string } { object } <effect> set-primitive-effect

2
core/mirrors/mirrors.factor
View File

@ -42,7 +42,7 @@ M: mirror delete-at ( key mirror -- )
M: mirror >alist ( mirror -- alist )
>mirror<
[ [ slot-spec-offset slot ] with map ] keep
[ slot-spec-name ] map swap 2array flip ;
[ slot-spec-name ] map swap zip ;
M: mirror assoc-size mirror-slots length ;

3
core/optimizer/optimizer-tests.factor
View File

@ -370,4 +370,7 @@ HINTS: recursive-inline-hang-2 array ;
HINTS: recursive-inline-hang-3 array ;
! Regression
USE: sequences.private
[ ] [ { (3append) } compile ] unit-test

10
core/parser/parser-docs.factor
View File

@ -153,6 +153,8 @@ ARTICLE: "parser-files" "Parsing source files"
{ $subsection parse-file }
{ $subsection bootstrap-file }
"The parser cross-references source files and definitions. This allows it to keep track of removed definitions, and prevent forward references and accidental redefinitions."
$nl
"While the above words are useful for one-off experiments, real programs should be written to use the vocabulary system instead; see " { $link "vocabs.loader" } "."
{ $see-also "source-files" } ;
ARTICLE: "parser-usage" "Reflective parser usage"
@ -161,6 +163,13 @@ ARTICLE: "parser-usage" "Reflective parser usage"
"The parser can also parse from a stream:"
{ $subsection parse-stream } ;
ARTICLE: "top-level-forms" "Top level forms"
"Any code outside of a definition is known as a " { $emphasis "top-level form" } "; top-level forms are run after the entire source file has been parsed, regardless of their position in the file."
$nl
"Top-level forms do not have access to the " { $link in } " and " { $link use } " variables that were set at parse time, nor do they run inside " { $link with-compilation-unit } "; so meta-programming might require extra work in a top-level form compared with a parsing word."
$nl
"Also, top-level forms run in a new dynamic scope, so using " { $link set } " to store values is almost always wrong, since the values will be lost after the top-level form completes. To save values computed by a top-level form, either use " { $link set-global } " or define a new word with the value." ;
ARTICLE: "parser" "The parser"
"This parser is a general facility for reading textual representations of objects and definitions. The parser is implemented in the " { $vocab-link "parser" } " and " { $vocab-link "syntax" } " vocabularies."
$nl
@ -168,6 +177,7 @@ $nl
{ $subsection "vocabulary-search" }
{ $subsection "parser-files" }
{ $subsection "parser-usage" }
{ $subsection "top-level-forms" }
"The parser can be extended."
{ $subsection "parsing-words" }
{ $subsection "parser-lexer" }

29
core/parser/parser.factor
View File

@ -1,12 +1,11 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs kernel math
namespaces 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 hashtables compiler.errors compiler.units
accessors ;
USING: arrays definitions generic assocs kernel math namespaces
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 ;
IN: parser
TUPLE: lexer text line line-text line-length column ;
@ -285,13 +284,27 @@ M: no-word-error summary
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
: shadowed-slots ( superclass slots -- shadowed )
>r all-slot-names r> seq-intersect ;
: check-slot-shadowing ( class superclass slots -- )
shadowed-slots [
[
"Definition of slot ``" %
%
"'' in class ``" %
word-name %
"'' shadows a superclass slot" %
] "" make note.
] with each ;
: parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS
scan {
{ ";" [ tuple f ] }
{ "<" [ scan-word ";" parse-tokens ] }
[ >r tuple ";" parse-tokens r> prefix ]
} case ;
} case 3dup check-slot-shadowing ;
ERROR: staging-violation word ;

20
core/sequences/sequences-tests.factor
View File

@ -1,6 +1,6 @@
USING: arrays kernel math namespaces sequences kernel.private
sequences.private strings sbufs tools.test vectors bit-arrays
generic ;
generic vocabs.loader ;
IN: sequences.tests
[ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test
@ -100,6 +100,16 @@ unit-test
[ [ ] ] [ [ 1 2 3 ] 3 tail ] unit-test
[ [ 3 ] ] [ [ 1 2 3 ] 2 tail ] unit-test
[ "blah" ] [ "blahxx" 2 head* ] unit-test
[ "xx" ] [ "blahxx" 2 tail* ] unit-test
[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice = ] unit-test
[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice [ hashcode ] bi@ = ] unit-test
[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* = ] unit-test
[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* [ hashcode ] bi@ = ] unit-test
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] sequence= ] unit-test
[ t ] [ [ 1 2 3 ] { 1 2 3 } sequence= ] unit-test
[ t ] [ { 1 2 3 } [ 1 2 3 ] sequence= ] unit-test
@ -195,6 +205,12 @@ unit-test
! Pathological case
[ "ihbye" ] [ "hi" <reversed> "bye" append ] unit-test
[ t ] [ "hi" <reversed> SBUF" hi" <reversed> = ] unit-test
[ t ] [ "hi" <reversed> SBUF" hi" <reversed> = ] unit-test
[ t ] [ "hi" <reversed> SBUF" hi" <reversed> [ hashcode ] bi@ = ] unit-test
[ -10 "hi" "bye" copy ] must-fail
[ 10 "hi" "bye" copy ] must-fail
@ -244,3 +260,5 @@ unit-test
[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
! Hardcore
[ ] [ "sequences" reload ] unit-test

30
core/sequences/sequences.factor
View File

@ -172,7 +172,9 @@ TUPLE: reversed seq ;
C: <reversed> reversed
M: reversed virtual-seq reversed-seq ;
M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ;
M: reversed length reversed-seq length ;
INSTANCE: reversed virtual-sequence
@ -198,7 +200,9 @@ ERROR: slice-error reason ;
slice construct-boa ; inline
M: slice virtual-seq slice-seq ;
M: slice virtual@ [ slice-from + ] keep slice-seq ;
M: slice length dup slice-to swap slice-from - ;
: head-slice ( seq n -- slice ) (head) <slice> ;
@ -466,6 +470,21 @@ M: sequence <=>
2dup [ length ] bi@ number=
[ mismatch not ] [ 2drop f ] if ; inline
: sequence-hashcode-step ( oldhash newpart -- newhash )
swap [
dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
fixnum+fast fixnum+fast
] keep fixnum-bitxor ; inline
: sequence-hashcode ( n seq -- x )
0 -rot [
hashcode* >fixnum sequence-hashcode-step
] with each ; inline
M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: move ( to from seq -- )
2over number=
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
@ -692,14 +711,3 @@ PRIVATE>
dup [ length ] map infimum
[ <column> dup like ] with map
] unless ;
: sequence-hashcode-step ( oldhash newpart -- newhash )
swap [
dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
fixnum+fast fixnum+fast
] keep fixnum-bitxor ; inline
: sequence-hashcode ( n seq -- x )
0 -rot [
hashcode* >fixnum sequence-hashcode-step
] with each ; inline

3
extra/assocs/lib/lib.factor
View File

@ -37,9 +37,6 @@ IN: assocs.lib
: insert ( value variable -- ) namespace insert-at ;
: 2seq>assoc ( keys values exemplar -- assoc )
>r 2array flip r> assoc-like ;
: generate-key ( assoc -- str )
>r 256 random-bits >hex r>
2dup key? [ nip generate-key ] [ drop ] if ;

2
extra/builder/builder.factor
View File

@ -106,7 +106,7 @@ IN: builder
+closed+ >>stdin
"../test-log" >>stdout
+stdout+ >>stderr
120 minutes >>timeout ;
240 minutes >>timeout ;
: do-builder-test ( -- )
builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;

52
extra/db/db.factor
View File

@ -11,14 +11,19 @@ TUPLE: db
update-statements
delete-statements ;
: <db> ( handle -- obj )
H{ } clone H{ } clone H{ } clone
db construct-boa ;
: construct-db ( class -- obj )
construct-empty
H{ } clone >>insert-statements
H{ } clone >>update-statements
H{ } clone >>delete-statements ;
GENERIC: make-db* ( seq class -- db )
GENERIC: db-open ( db -- )
: make-db ( seq class -- db )
construct-db make-db* ;
GENERIC: db-open ( db -- db )
HOOK: db-close db ( handle -- )
: make-db ( seq class -- db ) construct-empty make-db* ;
: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ;
@ -30,10 +35,13 @@ HOOK: db-close db ( handle -- )
handle>> db-close
] with-variable ;
! TUPLE: sql sql in-params out-params ;
TUPLE: statement handle sql in-params out-params bind-params bound? ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
TUPLE: nonthrowable-statement ;
TUPLE: simple-statement < statement ;
TUPLE: prepared-statement < statement ;
TUPLE: nonthrowable-statement < statement ;
TUPLE: throwable-statement < statement ;
: make-nonthrowable ( obj -- obj' )
dup sequence? [
[ make-nonthrowable ] map
@ -41,14 +49,13 @@ TUPLE: nonthrowable-statement ;
nonthrowable-statement construct-delegate
] if ;
MIXIN: throwable-statement
INSTANCE: statement throwable-statement
INSTANCE: simple-statement throwable-statement
INSTANCE: prepared-statement throwable-statement
TUPLE: result-set sql in-params out-params handle n max ;
: <statement> ( sql in out -- statement )
{ (>>sql) (>>in-params) (>>out-params) } statement construct ;
: construct-statement ( sql in out class -- statement )
construct-empty
swap >>out-params
swap >>in-params
swap >>sql ;
HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
@ -88,11 +95,14 @@ M: nonthrowable-statement execute-statement ( statement -- )
dup #rows >>max
0 >>n drop ;
: <result-set> ( query handle tuple -- result-set )
>r >r { sql>> in-params>> out-params>> } get-slots r>
{ (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set
construct r> construct-delegate ;
: construct-result-set ( query handle class -- result-set )
construct-empty
swap >>handle
>r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
swap >>out-params
swap >>in-params
swap >>sql ;
: sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ;
@ -110,7 +120,7 @@ M: nonthrowable-statement execute-statement ( statement -- )
accumulator >r query-each r> { } like ; inline
: with-db ( db seq quot -- )
>r make-db dup db-open db r>
>r make-db db-open db r>
[ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
: default-query ( query -- result-set )

3
extra/db/postgresql/ffi/ffi.factor
View File

@ -6,7 +6,8 @@ IN: db.postgresql.ffi
<< "postgresql" {
{ [ os winnt? ] [ "libpq.dll" ] }
{ [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] }
{ [ os macosx? ] [ "/opt/local/lib/postgresql83/libpq.dylib" ] }
! { [ os macosx? ] [ "libpq.dylib" ] }
{ [ os unix? ] [ "libpq.so" ] }
} cond "cdecl" add-library >>

59
extra/db/postgresql/postgresql.factor
View File

@ -5,40 +5,39 @@ kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators sequences.lib classes locals words tools.walker
namespaces.lib ;
namespaces.lib accessors ;
IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
TUPLE: postgresql-statement ;
INSTANCE: postgresql-statement throwable-statement
TUPLE: postgresql-result-set ;
TUPLE: postgresql-db < db
host port pgopts pgtty db user pass ;
TUPLE: postgresql-statement < throwable-statement ;
TUPLE: postgresql-result-set < result-set ;
: <postgresql-statement> ( statement in out -- postgresql-statement )
<statement>
postgresql-statement construct-delegate ;
postgresql-statement construct-statement ;
M: postgresql-db make-db* ( seq tuple -- db )
>r first4 r> [
{
set-postgresql-db-host
set-postgresql-db-user
set-postgresql-db-pass
set-postgresql-db-db
} set-slots
] keep ;
>r first4 r>
swap >>db
swap >>pass
swap >>user
swap >>host ;
M: postgresql-db db-open ( db -- )
dup {
postgresql-db-host
postgresql-db-port
postgresql-db-pgopts
postgresql-db-pgtty
postgresql-db-db
postgresql-db-user
postgresql-db-pass
} get-slots connect-postgres <db> swap set-delegate ;
M: postgresql-db db-open ( db -- db )
dup {
[ host>> ]
[ port>> ]
[ pgopts>> ]
[ pgtty>> ]
[ db>> ]
[ user>> ]
[ pass>> ]
} cleave connect-postgres >>handle ;
M: postgresql-db dispose ( db -- )
db-handle PQfinish ;
handle>> PQfinish ;
M: postgresql-statement bind-statement* ( statement -- )
drop ;
@ -50,10 +49,10 @@ M: postgresql-statement bind-tuple ( tuple statement -- )
] keep set-statement-bind-params ;
M: postgresql-result-set #rows ( result-set -- n )
result-set-handle PQntuples ;
handle>> PQntuples ;
M: postgresql-result-set #columns ( result-set -- n )
result-set-handle PQnfields ;
handle>> PQnfields ;
M: postgresql-result-set row-column ( result-set column -- obj )
>r dup result-set-handle swap result-set-n r> pq-get-string ;
@ -69,7 +68,7 @@ M: postgresql-statement query-results ( query -- result-set )
] [
dup do-postgresql-statement
] if*
postgresql-result-set <result-set>
postgresql-result-set construct-result-set
dup init-result-set ;
M: postgresql-result-set advance-row ( result-set -- )
@ -90,7 +89,7 @@ M: postgresql-result-set dispose ( result-set -- )
M: postgresql-statement prepare-statement ( statement -- )
[
>r db get db-handle "" r>
>r db get handle>> "" r>
dup statement-sql swap statement-in-params
length f PQprepare postgresql-error
] keep set-statement-handle ;

84
extra/db/sqlite/sqlite.factor
View File

@ -5,61 +5,48 @@ hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators
io namespaces.lib ;
USE: tools.walker
io namespaces.lib accessors ;
IN: db.sqlite
TUPLE: sqlite-db path ;
TUPLE: sqlite-db < db path ;
M: sqlite-db make-db* ( path db -- db )
[ set-sqlite-db-path ] keep ;
swap >>path ;
M: sqlite-db db-open ( db -- )
dup sqlite-db-path sqlite-open <db>
swap set-delegate ;
M: sqlite-db db-open ( db -- db )
[ path>> sqlite-open ] [ swap >>handle ] bi ;
M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ;
: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
TUPLE: sqlite-statement ;
INSTANCE: sqlite-statement throwable-statement
TUPLE: sqlite-statement < throwable-statement ;
TUPLE: sqlite-result-set has-more? ;
TUPLE: sqlite-result-set < result-set has-more? ;
M: sqlite-db <simple-statement> ( str in out -- obj )
<prepared-statement> ;
M: sqlite-db <prepared-statement> ( str in out -- obj )
{
set-statement-sql
set-statement-in-params
set-statement-out-params
} statement construct
sqlite-statement construct-delegate ;
sqlite-statement construct-statement ;
: sqlite-maybe-prepare ( statement -- statement )
dup statement-handle [
[
delegate
db get db-handle over statement-sql sqlite-prepare
swap set-statement-handle
] keep
dup handle>> [
db get handle>> over sql>> sqlite-prepare
>>handle
] unless ;
M: sqlite-statement dispose ( statement -- )
statement-handle
handle>>
[ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
M: sqlite-result-set dispose ( result-set -- )
f swap set-result-set-handle ;
f >>handle drop ;
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
: reset-statement ( statement -- )
sqlite-maybe-prepare
statement-handle sqlite-reset ;
sqlite-maybe-prepare handle>> sqlite-reset ;
M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare
@ -69,11 +56,11 @@ M: sqlite-statement bind-statement* ( statement -- )
M: sqlite-statement bind-tuple ( tuple statement -- )
[
statement-in-params
in-params>>
[
[ sql-spec-column-name ":" prepend ]
[ sql-spec-slot-name rot get-slot-named ]
[ sql-spec-type ] tri 3array
[ column-name>> ":" prepend ]
[ slot-name>> rot get-slot-named ]
[ type>> ] tri 3array
] with map
] keep
bind-statement ;
@ -86,25 +73,24 @@ M: sqlite-db insert-tuple* ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n )
result-set-handle sqlite-#columns ;
handle>> sqlite-#columns ;
M: sqlite-result-set row-column ( result-set n -- obj )
>r result-set-handle r> sqlite-column ;
[ handle>> ] [ sqlite-column ] bi* ;
M: sqlite-result-set row-column-typed ( result-set n -- obj )
dup pick result-set-out-params nth sql-spec-type
>r >r result-set-handle r> r> sqlite-column-typed ;
dup pick out-params>> nth type>>
>r >r handle>> r> r> sqlite-column-typed ;
M: sqlite-result-set advance-row ( result-set -- )
[ result-set-handle sqlite-next ] keep
set-sqlite-result-set-has-more? ;
dup handle>> sqlite-next >>has-more? drop ;
M: sqlite-result-set more-rows? ( result-set -- ? )
sqlite-result-set-has-more? ;
has-more?>> ;
M: sqlite-statement query-results ( query -- result-set )
sqlite-maybe-prepare
dup statement-handle sqlite-result-set <result-set>
dup handle>> sqlite-result-set construct-result-set
dup advance-row ;
M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
@ -119,9 +105,9 @@ M: sqlite-db create-sql-statement ( class -- statement )
[
"create table " 0% 0%
"(" 0% [ ", " 0% ] [
dup sql-spec-column-name 0%
dup column-name>> 0%
" " 0%
dup sql-spec-type t lookup-type 0%
dup type>> t lookup-type 0%
modifiers 0%
] interleave ");" 0%
] sqlite-make ;
@ -134,7 +120,7 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
"insert into " 0% 0%
"(" 0%
maybe-remove-id
dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
dup [ ", " 0% ] [ column-name>> 0% ] interleave
") values(" 0%
[ ", " 0% ] [ bind% ] interleave
");" 0%
@ -145,11 +131,11 @@ M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
: where-primary-key% ( specs -- )
" where " 0%
find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ;
find-primary-key dup column-name>> 0% " = " 0% bind% ;
: where-clause ( specs -- )
" where " 0%
[ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ;
[ " and " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave ;
M: sqlite-db <update-tuple-statement> ( class -- statement )
[
@ -157,7 +143,7 @@ M: sqlite-db <update-tuple-statement> ( class -- statement )
0%
" set " 0%
dup remove-id
[ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
[ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
where-primary-key%
] sqlite-make ;
@ -166,23 +152,23 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
"delete from " 0% 0%
" where " 0%
find-primary-key
dup sql-spec-column-name 0% " = " 0% bind%
dup column-name>> 0% " = " 0% bind%
] sqlite-make ;
! : select-interval ( interval name -- ) ;
! : select-sequence ( seq name -- ) ;
M: sqlite-db bind% ( spec -- )
dup 1, sql-spec-column-name ":" prepend 0% ;
dup 1, column-name>> ":" prepend 0% ;
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[
"select " 0%
over [ ", " 0% ]
[ dup sql-spec-column-name 0% 2, ] interleave
[ dup column-name>> 0% 2, ] interleave
" from " 0% 0%
[ sql-spec-slot-name swap get-slot-named ] with subset
[ slot-name>> swap get-slot-named ] with subset
dup empty? [ drop ] [ where-clause ] if ";" 0%
] sqlite-make ;

8
extra/db/tuples/tuples-tests.factor
View File

@ -260,10 +260,10 @@ C: <secret> secret
! [ test-random-id ] test-sqlite
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
! [ assigned-person-schema test-repeated-insert ] test-sqlite
! [ native-person-schema test-tuples ] test-postgresql
! [ assigned-person-schema test-tuples ] test-postgresql
! [ assigned-person-schema test-repeated-insert ] test-postgresql
[ assigned-person-schema test-repeated-insert ] test-sqlite
[ native-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-repeated-insert ] test-postgresql
! \ insert-tuple must-infer
! \ update-tuple must-infer

1
extra/hardware-info/backend/backend.factor
View File

@ -2,6 +2,7 @@ USING: system ;
IN: hardware-info.backend
HOOK: cpus os ( -- n )
HOOK: cpu-mhz os ( -- n )
HOOK: memory-load os ( -- n )
HOOK: physical-mem os ( -- n )
HOOK: available-mem os ( -- n )

4
extra/hardware-info/hardware-info.factor
View File

@ -3,11 +3,12 @@ combinators vocabs.loader hardware-info.backend system ;
IN: hardware-info
: write-unit ( x n str -- )
[ 2^ /i number>string write bl ] [ write ] bi* ;
[ 2^ /f number>string write bl ] [ write ] bi* ;
: kb ( x -- ) 10 "kB" write-unit ;
: megs ( x -- ) 20 "MB" write-unit ;
: gigs ( x -- ) 30 "GB" write-unit ;
: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
<< {
{ [ os windows? ] [ "hardware-info.windows" ] }
@ -18,4 +19,5 @@ IN: hardware-info
: hardware-report. ( -- )
"CPUs: " write cpus number>string write nl
"CPU Speed: " write cpu-mhz ghz nl
"Physical RAM: " write physical-mem megs nl ;

2
extra/hardware-info/macosx/macosx.factor
View File

@ -41,7 +41,7 @@ M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
: cpu-frequency ( -- n ) { 6 15 } sysctl-query-uint ;
M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;

22
extra/math/points/points.factor Normal file
View File

@ -0,0 +1,22 @@
USING: kernel arrays math.vectors ;
IN: math.points
<PRIVATE
: X ( x -- point ) 0 0 3array ;
: Y ( y -- point ) 0 swap 0 3array ;
: Z ( z -- point ) 0 0 rot 3array ;
PRIVATE>
: v+x ( seq x -- seq ) X v+ ;
: v-x ( seq x -- seq ) X v- ;
: v+y ( seq y -- seq ) Y v+ ;
: v-y ( seq y -- seq ) Y v- ;
: v+z ( seq z -- seq ) Z v+ ;
: v-z ( seq z -- seq ) Z v- ;

13
extra/newfx/newfx.factor
View File

@ -1,7 +1,8 @@
USING: kernel sequences assocs qualified ;
USING: kernel sequences assocs qualified circular ;
QUALIFIED: sequences
QUALIFIED: circular
IN: newfx
@ -53,8 +54,10 @@ IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: push ( seq obj -- seq ) over sequences:push ;
: push-on ( obj seq -- seq ) tuck sequences:push ;
: push ( seq obj -- seq ) over sequences:push ;
: push-on ( obj seq -- seq ) tuck sequences:push ;
: pushed ( seq obj -- ) swap sequences:push ;
: pushed-on ( obj seq -- ) sequences:push ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -91,6 +94,10 @@ IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: push-circular ( seq elt -- seq ) over circular:push-circular ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! A note about the 'mutate' qualifier. Other words also technically mutate
! their primary object. However, the 'mutate' qualifier is supposed to
! indicate that this is the main objective of the word, as a side effect.

4
extra/peg/peg.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces math assocs shuffle
vectors arrays combinators.lib math.parser
unicode.categories sequences.lib compiler.units parser
vectors arrays math.parser
unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting ;
IN: peg

97
extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor Normal file
View File

@ -0,0 +1,97 @@
USING: help.syntax help.markup ;
IN: processing.gallery.bubble-chamber
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
HELP: muon
{ $class-description
"The muon is a colorful particle with an entangled friend."
"It draws both itself and its horizontally symmetric partner."
"A high range of speed and almost no speed decay allow the"
"muon to reach the extents of the window, often forming rings"
"where theta has decayed but speed remains stable. The result"
"is color almost everywhere in the general direction of collision,"
"stabilized into fuzzy rings." } ;
HELP: quark
{ $class-description
"The quark draws as a translucent black. Their large numbers"
"create fields of blackness overwritten only by the glowing shadows of "
"Hadrons. "
"quarks are allowed to accelerate away with speed decay values above 1.0. "
"Each quark has an entangled friend. Both particles are drawn identically,"
"mirrored along the y-axis." } ;
HELP: hadron
{ $class-description
"Hadrons collide from totally random directions. "
"Those hadrons that do not exit the drawing area, "
"tend to stabilize into perfect circular orbits. "
"Each hadron draws with a slight glowing emboss. "
"The hadron itself is not drawn." } ;
HELP: axion
{ $class-description
"The axion particle draws a bold black path. Axions exist "
"in a slightly higher dimension and as such are drawn with "
"elevated embossed shadows. Axions are quick to stabilize "
"and fall into single pixel orbits axions automatically "
"recollide themselves after stabilizing." } ;
{ muon quark hadron axion } related-words
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "bubble-chamber" "Bubble Chamber"
{ $subsection "bubble-chamber-introduction" }
{ $subsection "bubble-chamber-particles" }
{ $subsection "bubble-chamber-author" }
{ $subsection "bubble-chamber-running" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "bubble-chamber-introduction" "Introduction"
"The Bubble Chamber is a generative painting system of imaginary "
"colliding particles. A single super-massive collision produces a "
"discrete universe of four particle types. Particles draw their "
"positions over time as pixel exposures. " ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "bubble-chamber-particles" "Particles"
"Four types of particles exist. The behavior and graphic appearance of "
"each particle type is unique."
{ $subsection muon }
{ $subsection quark }
{ $subsection hadron }
{ $subsection axion } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "bubble-chamber-author" "Author"
"Bubble Chamber was created by Jared Tarbell. "
"It was originally implemented in Processing. "
"It was ported to Factor by Eduardo Cavazos. "
"The original work is on display here: "
{ $url
"http://www.complexification.net/gallery/machines/bubblechamber/" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "bubble-chamber-running" "How to use"
"After you run the vocabulary, a window will appear. Click the "
"mouse in a random area to fire 11 particles of each type. "
"Another way to fire particles is to press the "
"spacebar. This fires all the particles." ;

106
extra/processing/gallery/bubble-chamber/bubble-chamber.factor
View File

@ -7,6 +7,7 @@ USING: kernel namespaces sequences combinators arrays threads
math.ranges
math.constants
math.functions
math.points
ui
ui.gadgets
@ -25,12 +26,6 @@ IN: processing.gallery.bubble-chamber
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
: 1random ( b -- num ) 0 swap 2random ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -82,17 +77,8 @@ VARS: particles muons quarks hadrons axions ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: x>> ( particle -- x ) pos>> first ;
: y>> ( particle -- x ) pos>> second ;
: >>x ( particle x -- particle ) over y>> 2array >>pos ;
: >>y ( particle y -- particle ) over x>> swap 2array >>pos ;
: x x>> ;
: y y>> ;
: v+y ( seq y -- seq ) >r first2 r> + 2array ;
: v-y ( seq y -- seq ) >r first2 r> - 2array ;
: x ( particle -- x ) pos>> first ;
: y ( particle -- x ) pos>> second ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -103,23 +89,34 @@ VARS: particles muons quarks hadrons axions ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: initialize-particle ( particle -- particle )
0 0 {2} >>pos
0 0 {2} >>vel
0 >>speed
0 >>speed-d
0 >>theta
0 >>theta-d
0 >>theta-dd
0 0 0 1 <rgba> >>myc
0 0 0 1 <rgba> >>mya ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
GENERIC: collide ( particle -- )
GENERIC: move ( particle -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: muon pos speed theta speed-d theta-d theta-dd myc mya ;
TUPLE: muon < particle ;
: <muon> ( -- muon )
muon construct-empty
0 0 2array >>pos
0 >>speed
0 >>speed-d
0 >>theta
0 >>theta-d
0 >>theta-dd
0 0 0 1 <rgba> >>myc
0 0 0 1 <rgba> >>mya ;
: <muon> ( -- muon ) muon construct-empty initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -177,18 +174,9 @@ METHOD: move { muon }
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: quark pos vel speed theta speed-d theta-d theta-dd myc ;
TUPLE: quark < particle ;
: <quark> ( -- quark )
quark construct-empty
0 0 2array >>pos
0 0 2array >>vel
0 >>speed
0 >>speed-d
0 >>theta
0 >>theta-d
0 >>theta-dd
0 0 0 1 <rgba> >>myc ;
: <quark> ( -- quark ) quark construct-empty initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -228,7 +216,8 @@ METHOD: move { quark }
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
1000 random 997 >
! 1000 random 997 >
3/1000 chance
[
dup speed>> neg >>speed
2 over speed-d>> - >>speed-d
@ -242,18 +231,9 @@ METHOD: move { quark }
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: hadron pos vel speed theta speed-d theta-d theta-dd myc ;
TUPLE: hadron < particle ;
: <hadron> ( -- hadron )
hadron construct-empty
0 0 2array >>pos
0 0 2array >>vel
0 >>speed
0 >>speed-d
0 >>theta
0 >>theta-d
0 >>theta-dd
0 0 0 1 <rgba> >>myc ;
: <hadron> ( -- hadron ) hadron construct-empty initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -296,12 +276,14 @@ METHOD: move { hadron }
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
1000 random 997 >
! 1000 random 997 >
3/1000 chance
[
1.0 >>speed-d
0.00001 >>theta-dd
100 random 70 >
! 100 random 70 >
30/100 chance
[
dim 2 / dup 2array >>pos
dup collide
@ -317,17 +299,9 @@ METHOD: move { hadron }
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: axion pos vel speed theta speed-d theta-d theta-dd ;
TUPLE: axion < particle ;
: <axion> ( -- axion )
axion construct-empty
0 0 2array >>pos
0 0 2array >>vel
0 >>speed
0 >>speed-d
0 >>theta
0 >>theta-d
0 >>theta-dd ;
: <axion> ( -- axion ) axion construct-empty initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -381,12 +355,14 @@ METHOD: move { axion }
[ ] [ speed-d>> 0.9999 * ] bi >>speed-d
1000 random 996 >
! 1000 random 996 >
4/1000 chance
[
dup speed>> neg >>speed
dup speed-d>> neg 2 + >>speed-d
100 random 30 >
! 100 random 30 >
70/100 chance
[
dim 2 / dup 2array >>pos
collide

19
extra/processing/gallery/trails/trails.factor
View File

@ -1,5 +1,6 @@
USING: kernel arrays sequences math qualified circular processing ui ;
USING: kernel arrays sequences math qualified
sequences.lib circular processing ui newfx ;
IN: processing.gallery.trails
@ -9,22 +10,6 @@ IN: processing.gallery.trails
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
QUALIFIED: circular
: push-circular ( seq elt -- seq ) over circular:push-circular ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: each-percent ( seq quot -- )
>r
dup length
dup [ / ] curry
[ 1+ ] swap compose
r> compose
2each ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: point-list ( n -- seq ) [ drop 0 0 2array ] map <circular> ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

14
extra/processing/processing.factor
View File

@ -1,6 +1,6 @@
USING: kernel namespaces threads combinators sequences arrays
math math.functions
math math.functions math.ranges random
opengl.gl opengl.glu vars multi-methods shuffle
ui
ui.gestures
@ -16,6 +16,18 @@ IN: processing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
: 1random ( b -- num ) 0 swap 2random ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: chance ( fraction -- ? ) 0 1 2random > ;
: percent-chance ( percent -- ? ) 100 / chance ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: fill-color
VAR: stroke-color

14
extra/sequences/lib/lib.factor
View File

@ -4,7 +4,7 @@
USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors
arrays math.parser math.private sorting strings ascii macros
assocs.lib quotations ;
assocs.lib quotations hashtables ;
IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline
@ -37,6 +37,16 @@ MACRO: firstn ( n -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: each-percent ( seq quot -- )
>r
dup length
dup [ / ] curry
[ 1+ ] swap compose
r> compose
2each ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: sigma ( seq quot -- n )
[ rot slip + ] curry 0 swap reduce ; inline
@ -221,7 +231,7 @@ PRIVATE>
[ swap nth ] with map ;
: replace ( str oldseq newseq -- str' )
H{ } 2seq>assoc substitute ;
zip >hashtable substitute ;
: remove-nth ( seq n -- seq' )
cut-slice 1 tail-slice append ;

4
extra/tools/memory/memory-tests.factor
View File

@ -1,4 +1,8 @@
USING: tools.test tools.memory ;
IN: tools.memory.tests
\ room. must-infer
[ ] [ room. ] unit-test
\ heap-stats. must-infer
[ ] [ heap-stats. ] unit-test

58
extra/tools/memory/memory.factor
View File

@ -1,22 +1,29 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences vectors arrays generic assocs io math
namespaces parser prettyprint strings io.styles vectors words
system sorting splitting math.parser classes memory ;
system sorting splitting math.parser classes memory combinators ;
IN: tools.memory
<PRIVATE
: write-size ( n -- )
number>string
dup length 4 > [ 3 cut* "," swap 3append ] when
" KB" append write-cell ;
: write-total/used/free ( free total str -- )
[
write-cell
dup number>string write-cell
over - number>string write-cell
number>string write-cell
dup write-size
over - write-size
write-size
] with-row ;
: write-total ( n str -- )
[
write-cell
number>string write-cell
write-size
[ ] with-cell
[ ] with-cell
] with-row ;
@ -25,26 +32,41 @@ IN: tools.memory
[ [ write-cell ] each ] with-row ;
: (data-room.) ( -- )
data-room 2 <groups> 0 [
"Generation " pick number>string append
>r first2 r> write-total/used/free 1+
] reduce drop
data-room 2 <groups> dup length [
[ first2 ] [ number>string "Generation " prepend ] bi*
write-total/used/free
] 2each
"Cards" write-total ;
: (code-room.) ( -- )
code-room "Code space" write-total/used/free ;
: write-labelled-size ( n string -- )
[ write-cell write-size ] with-row ;
: room. ( -- )
standard-table-style [
{ "" "Total" "Used" "Free" } write-headings
(data-room.)
(code-room.)
] tabular-output ;
: (code-room.) ( -- )
code-room {
[ "Size:" write-labelled-size ]
[ "Used:" write-labelled-size ]
[ "Total free space:" write-labelled-size ]
[ "Largest free block:" write-labelled-size ]
} spread ;
: heap-stat-step ( counts sizes obj -- )
[ dup size swap class rot at+ ] keep
1 swap class rot at+ ;
PRIVATE>
: room. ( -- )
"==== DATA HEAP" print
standard-table-style [
{ "" "Total" "Used" "Free" } write-headings
(data-room.)
] tabular-output
nl
"==== CODE HEAP" print
standard-table-style [
(code-room.)
] tabular-output ;
: heap-stats ( -- counts sizes )
H{ } clone H{ } clone
[ >r 2dup r> heap-stat-step ] each-object ;

8
extra/ui/tools/listener/listener-tests.factor
View File

@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private
threads ;
threads arrays generic ;
IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map empty? ] unit-test
@ -13,11 +13,11 @@ IN: ui.tools.listener.tests
"listener" get [
[ "dup" ] [
\ dup "listener" get word-completion-string
\ dup word-completion-string
] unit-test
[ "USE: slots.private slot" ]
[ \ slot "listener" get word-completion-string ] unit-test
[ "equal?" ]
[ \ array \ equal? method word-completion-string ] unit-test
<pane> <interactor> "i" set

33
vm/code_gc.c
View File

@ -198,20 +198,33 @@ void free_unmarked(F_HEAP *heap)
build_free_list(heap,heap->segment->size);
}
/* Compute total sum of sizes of free blocks */
CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status)
/* Compute total sum of sizes of free blocks, and size of largest free block */
void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free)
{
CELL size = 0;
*used = 0;
*total_free = 0;
*max_free = 0;
F_BLOCK *scan = first_block(heap);
while(scan)
{
if(scan->status == status)
size += scan->size;
switch(scan->status)
{
case B_ALLOCATED:
*used += scan->size;
break;
case B_FREE:
*total_free += scan->size;
if(scan->size > *max_free)
*max_free = scan->size;
break;
default:
critical_error("Invalid scan->status",(CELL)scan);
}
scan = next_block(heap,scan);
}
return size;
}
/* The size of the heap, not including the last block if it's free */
@ -283,8 +296,12 @@ void recursive_mark(F_BLOCK *block)
/* Push the free space and total size of the code heap */
DEFINE_PRIMITIVE(code_room)
{
dpush(tag_fixnum(heap_usage(&code_heap,B_FREE) / 1024));
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
dpush(tag_fixnum((code_heap.segment->size) / 1024));
dpush(tag_fixnum(used / 1024));
dpush(tag_fixnum(total_free / 1024));
dpush(tag_fixnum(max_free / 1024));
}
/* Dump all code blocks for debugging */

2
vm/code_gc.h
View File

@ -32,7 +32,7 @@ void build_free_list(F_HEAP *heap, CELL size);
CELL heap_allot(F_HEAP *heap, CELL size);
void unmark_marked(F_HEAP *heap);
void free_unmarked(F_HEAP *heap);
CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status);
void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free);
CELL heap_size(F_HEAP *heap);
INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)

9
vm/code_heap.c
View File

@ -229,7 +229,16 @@ CELL allot_code_block(CELL size)
/* Insufficient room even after code GC, give up */
if(start == 0)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
fprintf(stderr,"Code heap stats:\n");
fprintf(stderr,"Used: %ld\n",used);
fprintf(stderr,"Total free space: %ld\n",total_free);
fprintf(stderr,"Largest free block: %ld\n",max_free);
fatal_error("Out of memory in add-compiled-block",0);
}
}
return start;

4
vm/data_gc.h
View File

@ -315,8 +315,6 @@ INLINE void* allot_object(CELL type, CELL a)
{
CELL *object;
/* If the object is bigger than the nursery, allocate it in
tenured space */
if(nursery->size - ALLOT_BUFFER_ZONE > a)
{
/* If there is insufficient room, collect the nursery */
@ -325,6 +323,8 @@ INLINE void* allot_object(CELL type, CELL a)
object = allot_zone(nursery,a);
}
/* If the object is bigger than the nursery, allocate it in
tenured space */
else
{
F_ZONE *tenured = &data_heap->generations[TENURED];

687
vm/errors.s
View File

@ -1,687 +0,0 @@
.file "errors.c"
.section .rdata,"dr"
LC0:
.ascii "fatal_error: %s %lx\12\0"
.text
.globl _fatal_error
.def _fatal_error; .scl 2; .type 32; .endef
_fatal_error:
pushl %ebp
movl %esp, %ebp
subl $24, %esp
call ___getreent
movl %eax, %edx
movl 12(%ebp), %eax
movl %eax, 12(%esp)
movl 8(%ebp), %eax
movl %eax, 8(%esp)
movl $LC0, 4(%esp)
movl 12(%edx), %eax
movl %eax, (%esp)
call _fprintf
movl $1, (%esp)
call _exit
.section .rdata,"dr"
.align 4
LC1:
.ascii "You have triggered a bug in Factor. Please report.\12\0"
LC2:
.ascii "critical_error: %s %lx\12\0"
.text
.globl _critical_error
.def _critical_error; .scl 2; .type 32; .endef
_critical_error:
pushl %ebp
movl %esp, %ebp
subl $24, %esp
call ___getreent
movl $LC1, 4(%esp)
movl 12(%eax), %eax
movl %eax, (%esp)
call _fprintf
call ___getreent
movl %eax, %edx
movl 12(%ebp), %eax
movl %eax, 12(%esp)
movl 8(%ebp), %eax
movl %eax, 8(%esp)
movl $LC2, 4(%esp)
movl 12(%edx), %eax
movl %eax, (%esp)
call _fprintf
call _factorbug
leave
ret
.section .rdata,"dr"
LC3:
.ascii "early_error: \0"
LC4:
.ascii "\12\0"
.text
.globl _throw_error
.def _throw_error; .scl 2; .type 32; .endef
_throw_error:
pushl %ebp
movl %esp, %ebp
subl $8, %esp
cmpl $7, _userenv+20
je L4
movb $0, _gc_off
movl _gc_locals_region, %eax
movl (%eax), %eax
subl $4, %eax
movl %eax, _gc_locals
movl _extra_roots_region, %eax
movl (%eax), %eax
subl $4, %eax
movl %eax, _extra_roots
call _fix_stacks
movl 8(%ebp), %eax
movl %eax, (%esp)
call _dpush
cmpl $0, 12(%ebp)
je L5
movl _stack_chain, %eax
movl 4(%eax), %eax
movl %eax, 4(%esp)
movl 12(%ebp), %eax
movl %eax, (%esp)
call _fix_callstack_top
movl %eax, 12(%ebp)
jmp L6
L5:
movl _stack_chain, %eax
movl (%eax), %eax
movl %eax, 12(%ebp)
L6:
movl 12(%ebp), %edx
movl _userenv+20, %eax
call _throw_impl
jmp L3
L4:
call ___getreent
movl $LC1, 4(%esp)
movl 12(%eax), %eax
movl %eax, (%esp)
call _fprintf
call ___getreent
movl $LC3, 4(%esp)
movl 12(%eax), %eax
movl %eax, (%esp)
call _fprintf
movl 8(%ebp), %eax
movl %eax, (%esp)
call _print_obj
call ___getreent
movl $LC4, 4(%esp)
movl 12(%eax), %eax
movl %eax, (%esp)
call _fprintf
call _factorbug
L3:
leave
ret
.def _dpush; .scl 3; .type 32; .endef
_dpush:
pushl %ebp
movl %esp, %ebp
subl $8, %esp
addl $4, %esi
movl 8(%ebp), %eax
movl %eax, 4(%esp)
movl %esi, (%esp)
call _put
leave
ret
.def _put; .scl 3; .type 32; .endef
_put:
pushl %ebp
movl %esp, %ebp
movl 8(%ebp), %edx
movl 12(%ebp), %eax
movl %eax, (%edx)
popl %ebp
ret
.globl _general_error
.def _general_error; .scl 2; .type 32; .endef
_general_error:
pushl %ebp
movl %esp, %ebp
subl $24, %esp
movl 8(%ebp), %eax
movl %eax, (%esp)
call _tag_fixnum
movl %eax, %edx
movl 16(%ebp), %eax
movl %eax, 12(%esp)
movl 12(%ebp), %eax
movl %eax, 8(%esp)
movl %edx, 4(%esp)
movl _userenv+24, %eax
movl %eax, (%esp)
call _allot_array_4
movl %eax, %edx
movl 20(%ebp), %eax
movl %eax, 4(%esp)
movl %edx, (%esp)
call _throw_error
leave
ret
.def _tag_fixnum; .scl 3; .type 32; .endef
_tag_fixnum:
pushl %ebp
movl %esp, %ebp
movl 8(%ebp), %eax
sall $3, %eax
andl $-8, %eax
popl %ebp
ret
.globl _type_error
.def _type_error; .scl 2; .type 32; .endef
_type_error:
pushl %ebp
movl %esp, %ebp
subl $24, %esp
movl 8(%ebp), %eax
movl %eax, (%esp)
call _tag_fixnum
movl %eax, %edx
movl $0, 12(%esp)
movl 12(%ebp), %eax
movl %eax, 8(%esp)
movl %edx, 4(%esp)
movl $3, (%esp)
call _general_error
leave
ret
.globl _not_implemented_error
.def _not_implemented_error; .scl 2; .type 32; .endef
_not_implemented_error:
pushl %ebp
movl %esp, %ebp
subl $24, %esp
movl $0, 12(%esp)
movl $7, 8(%esp)
movl $7, 4(%esp)
movl $2, (%esp)
call _general_error
leave
ret
.globl _in_page
.def _in_page; .scl 2; .type 32; .endef
_in_page:
pushl %ebp
movl %esp, %ebp
subl $8, %esp
call _getpagesize
movl %eax, -4(%ebp)
movl 16(%ebp), %edx
leal 12(%ebp), %eax
addl %edx, (%eax)
movl 20(%ebp), %eax
movl %eax, %edx
imull -4(%ebp), %edx
leal 12(%ebp), %eax
addl %edx, (%eax)
movb $0, -5(%ebp)
movl 8(%ebp), %eax
cmpl 12(%ebp), %eax
jb L15
movl -4(%ebp), %eax
addl 12(%ebp), %eax
cmpl 8(%ebp), %eax
jb L15
movb $1, -5(%ebp)
L15:
movzbl -5(%ebp), %eax
leave
ret
.section .rdata,"dr"
.align 4
LC5:
.ascii "allot_object() missed GC check\0"
LC6:
.ascii "gc locals underflow\0"
LC7:
.ascii "gc locals overflow\0"
LC8:
.ascii "extra roots underflow\0"
LC9:
.ascii "extra roots overflow\0"
.text
.globl _memory_protection_error
.def _memory_protection_error; .scl 2; .type 32; .endef
_memory_protection_error:
pushl %ebp
movl %esp, %ebp
subl $24, %esp
movl $-1, 12(%esp)
movl $0, 8(%esp)
movl _stack_chain, %eax
movl 24(%eax), %eax
movl (%eax), %eax
movl %eax, 4(%esp)
movl 8(%ebp), %eax
movl %eax, (%esp)
call _in_page
testb %al, %al
je L17
movl 12(%ebp), %eax
movl %eax, 12(%esp)
movl $7, 8(%esp)
movl $7, 4(%esp)
movl $11, (%esp)
call _general_error
jmp L16
L17:
movl $0, 12(%esp)
movl _ds_size, %eax
movl %eax, 8(%esp)
movl _stack_chain, %eax
movl 24(%eax), %eax
movl (%eax), %eax
movl %eax, 4(%esp)
movl 8(%ebp), %eax
movl %eax, (%esp)
call _in_page
testb %al, %al
je L19
movl 12(%ebp), %eax
movl %eax, 12(%esp)
movl $7, 8(%esp)
movl $7, 4(%esp)
movl $12, (%esp)
call _general_error
jmp L16
L19:
movl $-1, 12(%esp)
movl $0, 8(%esp)
movl _stack_chain, %eax
movl 28(%eax), %eax
movl (%eax), %eax
movl %eax, 4(%esp)
movl 8(%ebp), %eax
movl %eax, (%esp)
call _in_page
testb %al, %al
je L21
movl 12(%ebp), %eax
movl %eax, 12(%esp)
movl $7, 8(%esp)
movl $7, 4(%esp)
movl $13, (%esp)
call _general_error
jmp L16
L21:
movl $0, 12(%esp)
movl _rs_size, %eax
movl %eax, 8(%esp)
movl _stack_chain, %eax
movl 28(%eax), %eax
movl (%eax), %eax
movl %eax, 4(%esp)
movl 8(%ebp), %eax
movl %eax, (%esp)
call _in_page
testb %al, %al
je L23
movl 12(%ebp), %eax
movl %eax, 12(%esp)
movl $7, 8(%esp)
movl $7, 4(%esp)
movl $14, (%esp)
call _general_error
jmp L16
L23:
movl $0, 12(%esp)
movl $0, 8(%esp)
movl _nursery, %eax
movl 12(%eax), %eax
movl %eax, 4(%esp)
movl 8(%ebp), %eax
movl %eax, (%esp)
call _in_page
testb %al, %al
je L25
movl $0, 4(%esp)
movl $LC5, (%esp)
call _critical_error
jmp L16
L25:
movl $-1, 12(%esp)
movl $0, 8(%esp)
movl _gc_locals_region, %eax
movl (%eax), %eax
movl %eax, 4(%esp)
movl 8(%ebp), %eax
movl %eax, (%esp)
call _in_page
testb %al, %al
je L27
movl $0, 4(%esp)
movl $LC6, (%esp)
call _critical_error
jmp L16
L27:
movl $0, 12(%esp)
movl $0, 8(%esp)
movl _gc_locals_region, %eax
movl 8(%eax), %eax
movl %eax, 4(%esp)
movl 8(%ebp), %eax
movl %eax, (%esp)
call _in_page
testb %al, %al
je L29
movl $0, 4(%esp)
movl $LC7, (%esp)
call _critical_error
jmp L16
L29:
movl $-1, 12(%esp)
movl $0, 8(%esp)
movl _extra_roots_region, %eax
movl (%eax), %eax
movl %eax, 4(%esp)
movl 8(%ebp), %eax
movl %eax, (%esp)
call _in_page
testb %al, %al
je L31
movl $0, 4(%esp)
movl $LC8, (%esp)
call _critical_error
jmp L16
L31:
movl $0, 12(%esp)
movl $0, 8(%esp)
movl _extra_roots_region, %eax
movl 8(%eax), %eax
movl %eax, 4(%esp)
movl 8(%ebp), %eax
movl %eax, (%esp)
call _in_page
testb %al, %al
je L33
movl $0, 4(%esp)
movl $LC9, (%esp)
call _critical_error
jmp L16
L33:
movl 8(%ebp), %eax
movl %eax, (%esp)
call _allot_cell
movl %eax, %edx
movl 12(%ebp), %eax
movl %eax, 12(%esp)
movl $7, 8(%esp)
movl %edx, 4(%esp)
movl $15, (%esp)
call _general_error
L16:
leave
ret
.def _allot_cell; .scl 3; .type 32; .endef
_allot_cell:
pushl %ebp
movl %esp, %ebp
subl $8, %esp
cmpl $268435455, 8(%ebp)
jbe L36
movl 8(%ebp), %eax
movl %eax, (%esp)
call _cell_to_bignum
movl %eax, (%esp)
call _tag_bignum
movl %eax, -4(%ebp)
jmp L35
L36:
movl 8(%ebp), %eax
movl %eax, (%esp)
call _tag_fixnum
movl %eax, -4(%ebp)
L35:
movl -4(%ebp), %eax
leave
ret
.def _tag_bignum; .scl 3; .type 32; .endef
_tag_bignum:
pushl %ebp
movl %esp, %ebp
movl 8(%ebp), %eax
andl $-8, %eax
orl $1, %eax
popl %ebp
ret
.globl _signal_error
.def _signal_error; .scl 2; .type 32; .endef
_signal_error:
pushl %ebp
movl %esp, %ebp
subl $24, %esp
movl 8(%ebp), %eax
movl %eax, (%esp)
call _tag_fixnum
movl %eax, %edx
movl 12(%ebp), %eax
movl %eax, 12(%esp)
movl $7, 8(%esp)
movl %edx, 4(%esp)
movl $5, (%esp)
call _general_error
leave
ret
.globl _divide_by_zero_error
.def _divide_by_zero_error; .scl 2; .type 32; .endef
_divide_by_zero_error:
pushl %ebp
movl %esp, %ebp
subl $24, %esp
movl 8(%ebp), %eax
movl %eax, 12(%esp)
movl $7, 8(%esp)
movl $7, 4(%esp)
movl $4, (%esp)
call _general_error
leave
ret
.globl _memory_signal_handler_impl
.def _memory_signal_handler_impl; .scl 2; .type 32; .endef
_memory_signal_handler_impl:
pushl %ebp
movl %esp, %ebp
subl $8, %esp
movl _signal_callstack_top, %eax
movl %eax, 4(%esp)
movl _signal_fault_addr, %eax
movl %eax, (%esp)
call _memory_protection_error
leave
ret
.globl _divide_by_zero_signal_handler_impl
.def _divide_by_zero_signal_handler_impl; .scl 2; .type 32; .endef
_divide_by_zero_signal_handler_impl:
pushl %ebp
movl %esp, %ebp
subl $8, %esp
movl _signal_callstack_top, %eax
movl %eax, (%esp)
call _divide_by_zero_error
leave
ret
.globl _misc_signal_handler_impl
.def _misc_signal_handler_impl; .scl 2; .type 32; .endef
_misc_signal_handler_impl:
pushl %ebp
movl %esp, %ebp
subl $8, %esp
movl _signal_callstack_top, %eax
movl %eax, 4(%esp)
movl _signal_number, %eax
movl %eax, (%esp)
call _signal_error
leave
ret
.globl _primitive_throw
.def _primitive_throw; .scl 2; .type 32; .endef
_primitive_throw:
pushl %ebp
movl %esp, %ebp
subl $8, %esp
movl %eax, -4(%ebp)
movl %edx, -8(%ebp)
movl -8(%ebp), %eax
call _save_callstack_top
call _primitive_throw_impl
leave
ret
.def _primitive_throw_impl; .scl 3; .type 32; .endef
_primitive_throw_impl:
pushl %ebp
movl %esp, %ebp
subl $8, %esp
call _dpop
call _dpop
movl %eax, %ecx
movl _stack_chain, %eax
movl (%eax), %edx
movl %ecx, %eax
call _throw_impl
leave
ret
.def _dpop; .scl 3; .type 32; .endef
_dpop:
pushl %ebp
movl %esp, %ebp
subl $8, %esp
movl %esi, (%esp)
call _get
movl %eax, -4(%ebp)
subl $4, %esi
movl -4(%ebp), %eax
leave
ret
.def _get; .scl 3; .type 32; .endef
_get:
pushl %ebp
movl %esp, %ebp
movl 8(%ebp), %eax
movl (%eax), %eax
popl %ebp
ret
.globl _primitive_call_clear
.def _primitive_call_clear; .scl 2; .type 32; .endef
_primitive_call_clear:
pushl %ebp
movl %esp, %ebp
subl $8, %esp
movl %eax, -4(%ebp)
movl %edx, -8(%ebp)
movl -8(%ebp), %eax
call _save_callstack_top
call _primitive_call_clear_impl
leave
ret
.def _primitive_call_clear_impl; .scl 3; .type 32; .endef
_primitive_call_clear_impl:
pushl %ebp
movl %esp, %ebp
subl $8, %esp
call _dpop
movl _stack_chain, %edx
movl 4(%edx), %edx
call _throw_impl
leave
ret
.globl _primitive_unimplemented2
.def _primitive_unimplemented2; .scl 2; .type 32; .endef
_primitive_unimplemented2:
pushl %ebp
movl %esp, %ebp
subl $8, %esp
movl %eax, -4(%ebp)
movl %edx, -8(%ebp)
call _not_implemented_error
leave
ret
.globl _primitive_unimplemented
.def _primitive_unimplemented; .scl 2; .type 32; .endef
_primitive_unimplemented:
pushl %ebp
movl %esp, %ebp
subl $8, %esp
movl %eax, -4(%ebp)
movl %edx, -8(%ebp)
movl -8(%ebp), %eax
call _save_callstack_top
call _primitive_unimplemented_impl
leave
ret
.def _primitive_unimplemented_impl; .scl 3; .type 32; .endef
_primitive_unimplemented_impl:
pushl %ebp
movl %esp, %ebp
subl $8, %esp
call _not_implemented_error
leave
ret
.comm _console_open, 16 # 1
.comm _userenv, 256 # 256
.comm _T, 16 # 4
.comm _stack_chain, 16 # 4
.comm _ds_size, 16 # 4
.comm _rs_size, 16 # 4
.comm _stage2, 16 # 1
.comm _profiling_p, 16 # 1
.comm _signal_number, 16 # 4
.comm _signal_fault_addr, 16 # 4
.comm _signal_callstack_top, 16 # 4
.comm _secure_gc, 16 # 1
.comm _data_heap, 16 # 4
.comm _cards_offset, 16 # 4
.comm _newspace, 16 # 4
.comm _nursery, 16 # 4
.comm _gc_time, 16 # 8
.comm _nursery_collections, 16 # 4
.comm _aging_collections, 16 # 4
.comm _cards_scanned, 16 # 4
.comm _performing_gc, 16 # 1
.comm _collecting_gen, 16 # 4
.comm _collecting_aging_again, 16 # 1
.comm _last_code_heap_scan, 16 # 4
.comm _growing_data_heap, 16 # 1
.comm _old_data_heap, 16 # 4
.comm _gc_jmp, 208 # 208
.comm _heap_scan_ptr, 16 # 4
.comm _gc_off, 16 # 1
.comm _gc_locals_region, 16 # 4
.comm _gc_locals, 16 # 4
.comm _extra_roots_region, 16 # 4
.comm _extra_roots, 16 # 4
.comm _bignum_zero, 16 # 4
.comm _bignum_pos_one, 16 # 4
.comm _bignum_neg_one, 16 # 4
.comm _code_heap, 16 # 8
.comm _data_relocation_base, 16 # 4
.comm _code_relocation_base, 16 # 4
.comm _posix_argc, 16 # 4
.comm _posix_argv, 16 # 4
.def _save_callstack_top; .scl 3; .type 32; .endef
.def _getpagesize; .scl 3; .type 32; .endef
.def _allot_array_4; .scl 3; .type 32; .endef
.def _print_obj; .scl 3; .type 32; .endef
.def _throw_impl; .scl 3; .type 32; .endef
.def _fix_callstack_top; .scl 3; .type 32; .endef
.def _fix_stacks; .scl 3; .type 32; .endef
.def _factorbug; .scl 3; .type 32; .endef
.def _exit; .scl 3; .type 32; .endef
.def ___getreent; .scl 3; .type 32; .endef
.def _fprintf; .scl 3; .type 32; .endef
.def _critical_error; .scl 3; .type 32; .endef
.def _type_error; .scl 3; .type 32; .endef
.section .drectve
.ascii " -export:nursery,data"
.ascii " -export:cards_offset,data"
.ascii " -export:stack_chain,data"
.ascii " -export:userenv,data"

1511
vm/run.s
View File

File diff suppressed because it is too large Load Diff