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

basis/furnace/actions/actions.factor

@@ -12,7 +12,6 @@ furnace.conversations
 furnace.chloe-tags
 html.forms
 html.components
-html.components
 html.templates.chloe
 html.templates.chloe.syntax
 html.templates.chloe.compiler ;

basis/io/launcher/launcher.factor

@@ -264,7 +264,7 @@ M: output-process-error error.
 : try-output-process ( command -- )
     >process
     +stdout+ >>stderr
-    +closed+ >>stdin
+    [ +closed+ or ] change-stdin
     utf8 <process-reader*>
     [ stream-contents ] [ dup wait-for-process ] bi*
     0 = [ 2drop ] [ output-process-error ] if ;

basis/random/windows/windows.factor

@@ -1,6 +1,7 @@
-USING: accessors alien.c-types byte-arrays continuations
+USING: accessors alien.c-types byte-arrays
-kernel windows.advapi32 init namespaces random destructors
+combinators.short-circuit continuations destructors init kernel
-locals windows.errors ;
+locals namespaces random windows.advapi32 windows.errors
+windows.kernel32 ;
 IN: random.windows
 
 TUPLE: windows-rng provider type ;
@@ -12,25 +13,40 @@ C: <windows-crypto-context> windows-crypto-context
 M: windows-crypto-context dispose ( tuple -- )
     handle>> 0 CryptReleaseContext win32-error=0/f ;
 
-: factor-crypto-container ( -- string ) "FactorCryptoContainer" ; inline
+CONSTANT: factor-crypto-container "FactorCryptoContainer"
 
-:: (acquire-crypto-context) ( provider type flags -- handle )
+:: (acquire-crypto-context) ( provider type flags -- handle ret )
-    [let | handle [ "HCRYPTPROV" <c-object> ] |
+    "HCRYPTPROV" <c-object> :> handle
     handle
     factor-crypto-container
     provider
     type
     flags
-        CryptAcquireContextW win32-error=0/f
+    CryptAcquireContextW handle swap ;
-        handle *void* ] ;
 
 : acquire-crypto-context ( provider type -- handle )
-    [ 0 (acquire-crypto-context) ]
+    0 (acquire-crypto-context)
-    [ drop CRYPT_NEWKEYSET (acquire-crypto-context) ] recover ;
+    0 = [
+        GetLastError NTE_BAD_KEYSET =
+        [ drop f ] [ win32-error-string throw ] if
+    ] [
+        *void*
+    ] if ;
 
+: create-crypto-context ( provider type -- handle )
+    CRYPT_NEWKEYSET (acquire-crypto-context) win32-error=0/f *void* ;
+
+ERROR: acquire-crypto-context-failed provider type ;
+
+: attempt-crypto-context ( provider type -- handle )
+    {
+        [ acquire-crypto-context ] 
+        [ create-crypto-context ] 
+        [ acquire-crypto-context-failed ]
+    } 2|| ;
 
 : windows-crypto-context ( provider type -- context )
-    acquire-crypto-context <windows-crypto-context> ;
+    attempt-crypto-context <windows-crypto-context> ;
 
 M: windows-rng random-bytes* ( n tuple -- bytes )
     [
@@ -44,9 +60,8 @@ M: windows-rng random-bytes* ( n tuple -- bytes )
     MS_DEF_PROV
     PROV_RSA_FULL <windows-rng> system-random-generator set-global
 
-    MS_STRONG_PROV
+    [ MS_STRONG_PROV PROV_RSA_FULL <windows-rng> ]
-    PROV_RSA_FULL <windows-rng> secure-random-generator set-global
+    [ drop MS_ENH_RSA_AES_PROV PROV_RSA_AES <windows-rng> ] recover
+    secure-random-generator set-global
 
-    ! MS_ENH_RSA_AES_PROV
-    ! PROV_RSA_AES <windows-rng> secure-random-generator set-global
 ] "random.windows" add-init-hook

basis/windows/advapi32/advapi32.factor

@@ -1,4 +1,5 @@
-USING: alien.syntax kernel math windows.types math.bitwise ;
+USING: alien.syntax kernel math windows.types windows.kernel32
+math.bitwise ;
 IN: windows.advapi32
 
 LIBRARY: advapi32
@@ -291,6 +292,40 @@ CONSTANT: SE_GROUP_ENABLED 4
 CONSTANT: SE_GROUP_OWNER 8
 CONSTANT: SE_GROUP_LOGON_ID -1073741824
 
+CONSTANT: NTE_BAD_UID HEX: 80090001
+CONSTANT: NTE_BAD_HASH HEX: 80090002
+CONSTANT: NTE_BAD_KEY HEX: 80090003
+CONSTANT: NTE_BAD_LEN HEX: 80090004
+CONSTANT: NTE_BAD_DATA HEX: 80090005
+CONSTANT: NTE_BAD_SIGNATURE HEX: 80090006
+CONSTANT: NTE_BAD_VER HEX: 80090007
+CONSTANT: NTE_BAD_ALGID HEX: 80090008
+CONSTANT: NTE_BAD_FLAGS HEX: 80090009
+CONSTANT: NTE_BAD_TYPE HEX: 8009000A
+CONSTANT: NTE_BAD_KEY_STATE HEX: 8009000B
+CONSTANT: NTE_BAD_HASH_STATE HEX: 8009000C
+CONSTANT: NTE_NO_KEY HEX: 8009000D
+CONSTANT: NTE_NO_MEMORY HEX: 8009000E
+CONSTANT: NTE_EXISTS HEX: 8009000F
+CONSTANT: NTE_PERM HEX: 80090010
+CONSTANT: NTE_NOT_FOUND HEX: 80090011
+CONSTANT: NTE_DOUBLE_ENCRYPT HEX: 80090012
+CONSTANT: NTE_BAD_PROVIDER HEX: 80090013
+CONSTANT: NTE_BAD_PROV_TYPE HEX: 80090014
+CONSTANT: NTE_BAD_PUBLIC_KEY HEX: 80090015
+CONSTANT: NTE_BAD_KEYSET HEX: 80090016
+CONSTANT: NTE_PROV_TYPE_NOT_DEF HEX: 80090017
+CONSTANT: NTE_PROV_TYPE_ENTRY_BAD HEX: 80090018
+CONSTANT: NTE_KEYSET_NOT_DEF HEX: 80090019
+CONSTANT: NTE_KEYSET_ENTRY_BAD HEX: 8009001A
+CONSTANT: NTE_PROV_TYPE_NO_MATCH HEX: 8009001B
+CONSTANT: NTE_SIGNATURE_FILE_BAD HEX: 8009001C
+CONSTANT: NTE_PROVIDER_DLL_FAIL HEX: 8009001D
+CONSTANT: NTE_PROV_DLL_NOT_FOUND HEX: 8009001E
+CONSTANT: NTE_BAD_KEYSET_PARAM HEX: 8009001F
+CONSTANT: NTE_FAIL HEX: 80090020
+CONSTANT: NTE_SYS_ERR HEX: 80090021
+
 ! SID is a variable length structure
 TYPEDEF: void* PSID
 

extra/galois-talk/galois-talk.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: slides help.markup math arrays hashtables namespaces
-sequences kernel sequences parser memoize io.encodings.binary
+sequences kernel parser memoize io.encodings.binary
 locals kernel.private help.vocabs assocs quotations
 urls peg.ebnf tools.annotations tools.crossref
 help.topics math.functions compiler.tree.optimizer

extra/html/parser/parser-tests.factor

@@ -73,3 +73,26 @@ V{
     T{ tag f "head" H{ } f t }
 }
 ] [ "<head<title>Spagna</title></head" parse-html ] unit-test
+
+[
+V{
+    T{ tag
+        { name dtd }
+        { text
+            "DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Draft//EN\""
+        }
+    }
+}
+]
+[
+    "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Draft//EN\">"
+    parse-html
+] unit-test
+
+[
+V{
+    T{ tag { name comment } { text "comment" } }
+}
+] [
+    "<!--comment-->" parse-html
+] unit-test

extra/html/parser/parser.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays hashtables sequence-parser
-html.parser.utils kernel namespaces sequences
+html.parser.utils kernel namespaces sequences math
 unicode.case unicode.categories combinators.short-circuit
 quoting fry ;
 IN: html.parser
@@ -63,10 +63,12 @@ SYMBOL: tagstack
     [ blank? ] trim ;
 
 : read-comment ( sequence-parser -- )
-    "-->" take-until-sequence comment new-tag push-tag ;
+    [ "-->" take-until-sequence comment new-tag push-tag ]
+    [ '[ _ advance drop ] 3 swap times ] bi ;
 
 : read-dtd ( sequence-parser -- )
-    ">" take-until-sequence dtd new-tag push-tag ;
+    [ ">" take-until-sequence dtd new-tag push-tag ]
+    [ advance drop ] bi ;
 
 : read-bang ( sequence-parser -- )
     advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&

extra/mason/common/common.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces sequences splitting system accessors
 math.functions make io io.files io.pathnames io.directories
@@ -13,10 +13,7 @@ SYMBOL: current-git-id
 : short-running-process ( command -- )
     #! Give network operations and shell commands at most
     #! 15 minutes to complete, to catch hangs.
-    >process
+    >process 15 minutes >>timeout try-output-process ;
-        15 minutes >>timeout
-        +closed+ >>stdin
-    try-output-process ;
 
 HOOK: really-delete-tree os ( path -- )
 
@@ -45,10 +42,6 @@ M: unix really-delete-tree delete-tree ;
     dup utf8 file-lines parse-fresh
     [ "Empty file: " swap append throw ] [ nip first ] if-empty ;
 
-: cat ( file -- ) utf8 file-contents print ;
-
-: cat-n ( file n -- ) [ utf8 file-lines ] dip short tail* [ print ] each ;
-
 : to-file ( object file -- ) utf8 [ . ] with-file-writer ;
 
 : datestamp ( timestamp -- string )

extra/mason/notify/notify.factor

@@ -16,7 +16,7 @@ IN: mason.notify
         ] { } make prepend
         [ 5 ] 2dip '[
             <process>
-                _ [ +closed+ ] unless* >>stdin
+                _ >>stdin
                 _ >>command
             short-running-process
         ] retry
@@ -49,4 +49,6 @@ IN: mason.notify
     ] bi ;
 
 : notify-release ( archive-name -- )
-    "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ;
+    [ "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ]
+    [ f swap "release" swap 2array status-notify ]
+    bi ;

extra/mason/notify/server/server.factor

@@ -1,26 +1,44 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators combinators.smart command-line db
-db.sqlite db.tuples db.types io kernel namespaces sequences ;
+db.sqlite db.tuples db.types io io.encodings.utf8 io.files
+present kernel namespaces sequences calendar ;
 IN: mason.notify.server
 
 CONSTANT: +starting+ "starting"
 CONSTANT: +make-vm+ "make-vm"
 CONSTANT: +boot+ "boot"
 CONSTANT: +test+ "test"
-CONSTANT: +clean+ "clean"
+CONSTANT: +clean+ "status-clean"
-CONSTANT: +dirty+ "dirty"
+CONSTANT: +dirty+ "status-dirty"
+CONSTANT: +error+ "status-error"
 
-TUPLE: builder host-name os cpu clean-git-id last-git-id last-report current-git-id status ;
+TUPLE: builder
+host-name os cpu
+clean-git-id clean-timestamp
+last-release release-git-id
+last-git-id last-timestamp last-report
+current-git-id current-timestamp
+status ;
 
 builder "BUILDERS" {
     { "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
     { "os" "OS" TEXT +user-assigned-id+ }
     { "cpu" "CPU" TEXT +user-assigned-id+ }
+    
     { "clean-git-id" "CLEAN_GIT_ID" TEXT }
+    { "clean-timestamp" "CLEAN_TIMESTAMP" TIMESTAMP }
+
+    { "last-release" "LAST_RELEASE" TEXT }
+    { "release-git-id" "RELEASE_GIT_ID" TEXT }
+    
     { "last-git-id" "LAST_GIT_ID" TEXT }
+    { "last-timestamp" "LAST_TIMESTAMP" TIMESTAMP }
     { "last-report" "LAST_REPORT" TEXT }
+
     { "current-git-id" "CURRENT_GIT_ID" TEXT }
+    ! Can't name it CURRENT_TIMESTAMP because of bug in db library
+    { "current-timestamp" "CURR_TIMESTAMP" TIMESTAMP }
     { "status" "STATUS" TEXT }
 } define-persistent
 
@@ -49,14 +67,23 @@ SYMBOLS: host-name target-os target-cpu message message-arg ;
 
 : make-vm ( builder -- ) +make-vm+ >>status drop ;
 
-: boot ( report -- ) +boot+ >>status drop ;
+: boot ( builder -- ) +boot+ >>status drop ;
 
-: test ( report -- ) +test+ >>status drop ;
+: test ( builder -- ) +test+ >>status drop ;
 
 : report ( builder status content -- )
     [ >>status ] [ >>last-report ] bi*
-    dup status>> +clean+ = [ dup current-git-id>> >>clean-git-id ] when
+    dup status>> +clean+ = [
+        dup current-git-id>> >>clean-git-id
+        dup current-timestamp>> >>clean-timestamp
+    ] when
     dup current-git-id>> >>last-git-id
+    dup current-timestamp>> >>last-timestamp
+    drop ;
+
+: release ( builder name -- )
+    >>last-release
+    dup clean-git-id>> >>release-git-id
     drop ;
 
 : update-builder ( builder -- )
@@ -66,17 +93,25 @@ SYMBOLS: host-name target-os target-cpu message message-arg ;
         { "boot" [ boot ] }
         { "test" [ test ] }
         { "report" [ message-arg get contents report ] }
+        { "release" [ message-arg get release ] }
     } case ;
 
 : mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
 
-: handle-update ( command-line -- )
+: handle-update ( command-line timestamp -- )
     mason-db [
-        parse-args find-builder
+        [ parse-args find-builder ] dip >>current-timestamp
         [ update-builder ] [ update-tuple ] bi
     ] with-db ;
 
+CONSTANT: log-file "resource:mason.log"
+
+: log-update ( command-line timestamp -- )
+    log-file utf8 [
+        present write ": " write " " join print
+    ] with-file-appender ;
+
 : main ( -- )
-    command-line get handle-update ;
+    command-line get now [ log-update ] [ handle-update ] 2bi ;
 
 MAIN: main

extra/mason/report/report.factor

@@ -59,13 +59,13 @@ IN: mason.report
     "test-log" "Tests failed" failed-report ;
 
 : timings-table ( -- xml )
-    {
+    ${
-        $ boot-time-file
+        boot-time-file
-        $ load-time-file
+        load-time-file
-        $ test-time-file
+        test-time-file
-        $ help-lint-time-file
+        help-lint-time-file
-        $ benchmark-time-file
+        benchmark-time-file
-        $ html-help-time-file
+        html-help-time-file
     } [
         dup eval-file milli-seconds>time
         [XML <tr><td><-></td><td><-></td></tr> XML]
@@ -121,13 +121,13 @@ IN: mason.report
     ] with-report ;
 
 : build-clean? ( -- ? )
-    {
+    ${
-        [ load-all-vocabs-file eval-file empty? ]
+        load-all-vocabs-file
-        [ test-all-vocabs-file eval-file empty? ]
+        test-all-vocabs-file
-        [ help-lint-vocabs-file eval-file empty? ]
+        help-lint-vocabs-file
-        [ compiler-errors-file eval-file empty? ]
+        compiler-errors-file
-        [ benchmark-error-vocabs-file eval-file empty? ]
+        benchmark-error-vocabs-file
-    } 0&& ;
+    } [ eval-file empty? ] all? ;
 
 : success ( -- status )
     successful-report build-clean? status-clean status-dirty ? ;

extra/minneapolis-talk/minneapolis-talk.factor

@@ -1,5 +1,5 @@
 USING: slides help.markup math arrays hashtables namespaces
-sequences kernel sequences parser memoize ;
+sequences kernel parser memoize ;
 IN: minneapolis-talk
 
 CONSTANT: minneapolis-slides

extra/webapps/mason/download.xml

@@ -0,0 +1,23 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<html>
+  <head>
+    <title>Factor binary package for <t:label t:name="platform" /></title>
+  </head>
+  <body>
+    <h1>Factor binary package for <t:label t:name="platform" /></h1>
+
+    <p>Requirements:</p>
+    <t:xml t:name="requirements" />
+
+    <h2>Download <t:xml t:name="package" /></h2>
+
+    <p>This package was built from GIT ID <t:xml t:name="git-id" />.</p>
+
+    <p>Once you download Factor, you can <a href="http://concatenative.org/wiki/view/Factor/Getting started">get started</a> with the language.</p>
+  </body>
+</html>
+
+</t:chloe>

extra/webapps/mason/mason.factor

@@ -1,11 +1,28 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators db db.tuples furnace.actions
-http.server.responses kernel mason.platform mason.notify.server
+http.server.responses http.server.dispatchers kernel mason.platform
-mason.report math.order sequences sorting splitting xml.syntax
+mason.notify.server mason.report math.order sequences sorting
-xml.writer io.pathnames io.encodings.utf8 io.files ;
+splitting xml.syntax xml.writer io.pathnames io.encodings.utf8
+io.files present validators html.forms furnace.db assocs urls ;
 IN: webapps.mason
 
+TUPLE: mason-app < dispatcher ;
+
+: validate-os/cpu ( -- )
+    {
+        { "os" [ v-one-line ] }
+        { "cpu" [ v-one-line ] }
+    } validate-params ;
+
+: current-builder ( -- builder )
+    builder new "os" value >>os "cpu" value >>cpu select-tuple ;
+
+: <build-report-action> ( -- action )
+    <action>
+    [ validate-os/cpu ] >>init
+    [ current-builder last-report>> "text/html" <content> ] >>display ;
+
 : log-file ( -- path ) home "mason.log" append-path ;
 
 : recent-events ( -- xml )
@@ -20,24 +37,48 @@ IN: webapps.mason
     [XML <-> for <-> XML] ;
 
 : current-status ( builder -- xml )
+    [
         dup status>> {
-        { "status-dirty" [ drop "Dirty" ] }
+            { +dirty+ [ drop "Dirty" ] }
-        { "status-clean" [ drop "Clean" ] }
+            { +clean+ [ drop "Clean" ] }
-        { "status-error" [ drop "Error" ] }
+            { +error+ [ drop "Error" ] }
-        { "starting" [ "Starting" building ] }
+            { +starting+ [ "Starting build" building ] }
-        { "make-vm" [ "Compiling VM" building ] }
+            { +make-vm+ [ "Compiling VM" building ] }
-        { "boot" [ "Bootstrapping" building ] }
+            { +boot+ [ "Bootstrapping" building ] }
-        { "test" [ "Testing" building ] }
+            { +test+ [ "Testing" building ] }
             [ 2drop "Unknown" ]
-    } case ;
+        } case
+    ] [ current-timestamp>> present " (as of " ")" surround ] bi 2array ;
+
+: build-status ( git-id timestamp -- xml )
+    over [ [ git-link ] [ present ] bi* " (built on " ")" surround 2array ] [ 2drop f ] if ;
+
+: binaries-url ( builder -- url )
+    [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend ;
+
+: url-link ( url -- xml )
+    dup [XML <a href=<->><-></a> XML] ;
+
+: latest-binary-link ( builder -- xml )
+    [ URL" download" ] dip
+    [ os>> "os" set-query-param ]
+    [ cpu>> "cpu" set-query-param ] bi
+    [XML <a href=<->>Latest download</a> XML] ;
 
 : binaries-link ( builder -- link )
-    [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend
+    binaries-url url-link ;
-    dup [XML <a href=<->><-></a> XML] ;
+
+: clean-image-url ( builder -- url )
+    [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend ;
 
 : clean-image-link ( builder -- link )
-    [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend
+    clean-image-url url-link ;
-    dup [XML <a href=<->><-></a> XML] ;
+
+: report-link ( builder -- xml )
+    [ URL" report" ] dip
+    [ os>> "os" set-query-param ]
+    [ cpu>> "cpu" set-query-param ] bi
+    [XML <a href=<->>Latest build report</a> XML] ;
 
 : machine-table ( builder -- xml )
     {
@@ -45,10 +86,12 @@ IN: webapps.mason
         [ cpu>> ]
         [ host-name>> "." split1 drop ]
         [ current-status ]
-        [ last-git-id>> dup [ git-link ] when ]
+        [ [ last-git-id>> ] [ last-timestamp>> ] bi build-status ]
-        [ clean-git-id>> dup [ git-link ] when ]
+        [ [ clean-git-id>> ] [ clean-timestamp>> ] bi build-status ]
         [ binaries-link ]
         [ clean-image-link ]
+        [ report-link ]
+        [ latest-binary-link ]
     } cleave
     [XML
     <h2><-> / <-></h2>
@@ -60,6 +103,8 @@ IN: webapps.mason
     <tr><td>Binaries:</td><td><-></td></tr>
     <tr><td>Clean images:</td><td><-></td></tr>
     </table>
+
+    <-> | <->
     XML] ;
 
 : machine-report ( -- xml )
@@ -67,7 +112,7 @@ IN: webapps.mason
     [ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort
     [ machine-table ] map ;
 
-: build-farm-report ( -- xml )
+: build-farm-summary ( -- xml )
     recent-events
     machine-report
     [XML
@@ -77,9 +122,52 @@ IN: webapps.mason
     </html>
     XML] ;
 
-: <build-farm-report-action> ( -- action )
+: <summary-action> ( -- action )
     <action>
+    [ build-farm-summary xml>string "text/html" <content> ] >>display ;
+
+TUPLE: builder-link href title ;
+
+C: <builder-link> builder-link
+
+: requirements ( builder -- xml )
     [
-            mason-db [ build-farm-report xml>string ] with-db
+        os>> {
-            "text/html" <content>
+            { "winnt" "Windows XP (also tested on Vista)" }
-        ] >>display ;
+            { "macosx" "Mac OS X 10.5 Leopard" }
+            { "linux" "Linux 2.6.16 with GLIBC 2.4" }
+            { "freebsd" "FreeBSD 7.0" }
+            { "netbsd" "NetBSD 4.0" }
+            { "openbsd" "OpenBSD 4.2" }
+        } at
+    ] [
+        dup cpu>> "x86-32" = [
+            os>> {
+                { [ dup { "winnt" "linux" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] }
+                { [ dup { "freebsd" "netbsd" "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
+                { [ t ] [ drop f ] }
+            } cond
+        ] [ drop f ] if
+    ] bi
+    2array sift [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ;
+
+: <download-binary-action> ( -- action )
+    <page-action>
+    [
+        validate-os/cpu
+        "os" value "cpu" value (platform) "platform" set-value
+        current-builder
+        [ latest-binary-link "package" set-value ]
+        [ release-git-id>> git-link "git-id" set-value ]
+        [ requirements "requirements" set-value ]
+        tri
+    ] >>init
+    { mason-app "download" } >>template ;
+
+: <mason-app> ( -- dispatcher )
+    mason-app new-dispatcher
+    <summary-action> "" add-responder
+    <build-report-action> "report" add-responder
+    <download-binary-action> "download" add-responder
+    mason-db <db-persistence> ;
+

vm/callstack.cpp

@@ -107,7 +107,9 @@ stack_frame *frame_successor(stack_frame *frame)
 /* Allocates memory */
 cell frame_scan(stack_frame *frame)
 {
-	if(frame_type(frame) == QUOTATION_TYPE)
+	switch(frame_type(frame))
+	{
+	case QUOTATION_TYPE:
 		{
 			cell quot = frame_executing(frame);
 			if(quot == F)
@@ -121,27 +123,27 @@ cell frame_scan(stack_frame *frame)
 					quot,(cell)(return_addr - quot_xt)));
 			}
 		}
-	else
+	case WORD_TYPE:
 		return F;
+	default:
+		critical_error("Bad frame type",frame_type(frame));
+		return F;
+	}
 }
 
 namespace
 {
 
-struct stack_frame_counter {
-	cell count;
-	stack_frame_counter() : count(0) {}
-	void operator()(stack_frame *frame) { count += 2; }
-};
-
 struct stack_frame_accumulator {
-	cell index;
+	growable_array frames;
-	gc_root<array> frames;
+
-	stack_frame_accumulator(cell count) : index(0), frames(allot_array(count,F)) {}
 	void operator()(stack_frame *frame)
 	{
-		set_array_nth(frames.untagged(),index++,frame_executing(frame));
+		gc_root<object> executing(frame_executing(frame));
-		set_array_nth(frames.untagged(),index++,frame_scan(frame));
+		gc_root<object> scan(frame_scan(frame));
+
+		frames.add(executing.value());
+		frames.add(scan.value());
 	}
 };
 
@@ -151,13 +153,11 @@ PRIMITIVE(callstack_to_array)
 {
 	gc_root<callstack> callstack(dpop());
 
-	stack_frame_counter counter;
+	stack_frame_accumulator accum;
-	iterate_callstack_object(callstack.untagged(),counter);
-
-	stack_frame_accumulator accum(counter.count);
 	iterate_callstack_object(callstack.untagged(),accum);
+	accum.frames.trim();
 
-	dpush(accum.frames.value());
+	dpush(accum.frames.elements.value());
 }
 
 stack_frame *innermost_stack_frame(callstack *stack)

vm/callstack.hpp

@@ -33,9 +33,19 @@ template<typename T> void iterate_callstack(cell top, cell bottom, T &iterator)
 	}
 }
 
-template<typename T> void iterate_callstack_object(callstack *stack, T &iterator)
+/* This is a little tricky. The iterator may allocate memory, so we
+keep the callstack in a GC root and use relative offsets */
+template<typename T> void iterate_callstack_object(callstack *stack_, T &iterator)
 {
-	iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator);
+	gc_root<callstack> stack(stack_);
+	fixnum frame_offset = untag_fixnum(stack->length) - sizeof(stack_frame);
+
+	while(frame_offset >= 0)
+	{
+		stack_frame *frame = stack->frame_at(frame_offset);
+		frame_offset -= frame->size;
+		iterator(frame);
+	}
 }
 
 }

vm/layouts.hpp

@@ -309,6 +309,11 @@ struct callstack : public object {
 	/* tagged */
 	cell length;
 	
+	stack_frame *frame_at(cell offset)
+	{
+		return (stack_frame *)((char *)(this + 1) + offset);
+	}
+
 	stack_frame *top() { return (stack_frame *)(this + 1); }
 	stack_frame *bottom() { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); }
 };