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

build-support/factor.sh

@@ -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
 }

extra/builder/builder.factor

@@ -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 ;

extra/db/db.factor

@@ -11,14 +11,19 @@ TUPLE: db
     update-statements
     delete-statements ;
 
-: <db> ( handle -- obj )
+: construct-db ( class -- obj )
-    H{ } clone H{ } clone H{ } clone
+    construct-empty
-    db construct-boa ;
+        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: simple-statement < statement ;
-TUPLE: prepared-statement ;
+TUPLE: prepared-statement < statement ;
-TUPLE: nonthrowable-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,10 +95,13 @@ M: nonthrowable-statement execute-statement ( statement -- )
     dup #rows >>max
     0 >>n drop ;
 
-: <result-set> ( query handle tuple -- result-set )
+: construct-result-set ( query handle class -- result-set )
-    >r >r { sql>> in-params>> out-params>> } get-slots r>
+    construct-empty
-    { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set
+        swap >>handle
-    construct r> construct-delegate ;
+        >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 )

extra/db/postgresql/ffi/ffi.factor

@@ -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 >>
 

extra/db/postgresql/postgresql.factor

@@ -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-db < db
-TUPLE: postgresql-statement ;
+    host port pgopts pgtty db user pass ;
-INSTANCE: postgresql-statement throwable-statement
+
-TUPLE: postgresql-result-set ;
+TUPLE: postgresql-statement < throwable-statement ;
+
+TUPLE: postgresql-result-set < result-set ;
+
 : <postgresql-statement> ( statement in out -- postgresql-statement )
-    <statement>
+    postgresql-statement construct-statement ;
-    postgresql-statement construct-delegate ;
 
 M: postgresql-db make-db* ( seq tuple -- db )
-    >r first4 r> [
+    >r first4 r>
-        {
+        swap >>db
-            set-postgresql-db-host
+        swap >>pass
-            set-postgresql-db-user
+        swap >>user
-            set-postgresql-db-pass
+        swap >>host ;
-            set-postgresql-db-db
-        } set-slots
-    ] keep ;
 
-M: postgresql-db db-open ( db -- )
+M: postgresql-db db-open ( db -- db )
     dup {
-        postgresql-db-host
+        [ host>> ]
-        postgresql-db-port
+        [ port>> ]
-        postgresql-db-pgopts
+        [ pgopts>> ]
-        postgresql-db-pgtty
+        [ pgtty>> ]
-        postgresql-db-db
+        [ db>> ]
-        postgresql-db-user
+        [ user>> ]
-        postgresql-db-pass
+        [ pass>> ]
-    } get-slots connect-postgres <db> swap set-delegate ;
+    } 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 ;

extra/db/sqlite/sqlite.factor

@@ -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 ;
+io namespaces.lib accessors ;
-USE: tools.walker
 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 -- )
+M: sqlite-db db-open ( db -- db )
-    dup sqlite-db-path sqlite-open <db>
+    [ path>> sqlite-open ] [ swap >>handle ] bi ;
-    swap set-delegate ;
 
 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 ;
+TUPLE: sqlite-statement < throwable-statement ;
-INSTANCE: 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 )
-    {
+    sqlite-statement construct-statement ;
-        set-statement-sql
-        set-statement-in-params
-        set-statement-out-params
-    } statement construct
-    sqlite-statement construct-delegate ;
 
 : sqlite-maybe-prepare ( statement -- statement )
-    dup statement-handle [
+    dup handle>> [
-        [
+        db get handle>> over sql>> sqlite-prepare
-            delegate
+        >>handle
-            db get db-handle over statement-sql sqlite-prepare
-            swap set-statement-handle
-        ] keep
     ] 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
+    sqlite-maybe-prepare handle>> sqlite-reset ;
-    statement-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 ]
+            [ column-name>> ":" prepend ]
-            [ sql-spec-slot-name rot get-slot-named ]
+            [ slot-name>> rot get-slot-named ]
-            [ sql-spec-type ] tri 3array
+            [ 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
+    dup pick out-params>> nth type>>
-    >r >r result-set-handle r> r> sqlite-column-typed ;
+    >r >r handle>> r> r> sqlite-column-typed ;
 
 M: sqlite-result-set advance-row ( result-set -- )
-    [ result-set-handle sqlite-next ] keep
+    dup handle>> sqlite-next >>has-more? drop ;
-    set-sqlite-result-set-has-more? ;
 
 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 ;
 

extra/db/tuples/tuples-tests.factor

@@ -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
+ [ assigned-person-schema test-repeated-insert ] test-sqlite
-! [ native-person-schema test-tuples ] test-postgresql
+ [ native-person-schema test-tuples ] test-postgresql
-! [ assigned-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-postgresql
 
 ! \ insert-tuple must-infer
 ! \ update-tuple must-infer

extra/hardware-info/backend/backend.factor

@@ -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 )

extra/hardware-info/hardware-info.factor

@@ -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 ;

extra/hardware-info/macosx/macosx.factor

@@ -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 ;

vm/data_gc.h

@@ -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];

vm/errors.s

@@ -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"