furnace.chloe-tags\r
html.forms\r
html.components\r
-html.components\r
html.templates.chloe\r
html.templates.chloe.syntax\r
html.templates.chloe.compiler ;\r
: 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 ;
-USING: accessors alien.c-types byte-arrays continuations
-kernel windows.advapi32 init namespaces random destructors
-locals windows.errors ;
+USING: accessors alien.c-types byte-arrays
+combinators.short-circuit continuations destructors init kernel
+locals namespaces random windows.advapi32 windows.errors
+windows.kernel32 ;
IN: random.windows
TUPLE: windows-rng provider type ;
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 )
- [let | handle [ "HCRYPTPROV" <c-object> ] |
- handle
- factor-crypto-container
- provider
- type
- flags
- CryptAcquireContextW win32-error=0/f
- handle *void* ] ;
+:: (acquire-crypto-context) ( provider type flags -- handle ret )
+ "HCRYPTPROV" <c-object> :> handle
+ handle
+ factor-crypto-container
+ provider
+ type
+ flags
+ CryptAcquireContextW handle swap ;
: acquire-crypto-context ( provider type -- handle )
- [ 0 (acquire-crypto-context) ]
- [ drop CRYPT_NEWKEYSET (acquire-crypto-context) ] recover ;
+ 0 (acquire-crypto-context)
+ 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 )
[
MS_DEF_PROV
PROV_RSA_FULL <windows-rng> system-random-generator set-global
- MS_STRONG_PROV
- PROV_RSA_FULL <windows-rng> secure-random-generator set-global
+ [ MS_STRONG_PROV PROV_RSA_FULL <windows-rng> ]
+ [ 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
-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
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
! 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
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
! 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
[ 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&&
-! 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
: short-running-process ( command -- )
#! Give network operations and shell commands at most
#! 15 minutes to complete, to catch hangs.
- >process
- 15 minutes >>timeout
- +closed+ >>stdin
- try-output-process ;
+ >process 15 minutes >>timeout try-output-process ;
HOOK: really-delete-tree os ( path -- )
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 )
] { } make prepend
[ 5 ] 2dip '[
<process>
- _ [ +closed+ ] unless* >>stdin
+ _ >>stdin
_ >>command
short-running-process
] retry
] 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 ;
! 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: +dirty+ "dirty"
-
-TUPLE: builder host-name os cpu clean-git-id last-git-id last-report current-git-id status ;
+CONSTANT: +clean+ "status-clean"
+CONSTANT: +dirty+ "status-dirty"
+CONSTANT: +error+ "status-error"
+
+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
: 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 -- )
{ "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
"test-log" "Tests failed" failed-report ;
: timings-table ( -- xml )
- {
- $ boot-time-file
- $ load-time-file
- $ test-time-file
- $ help-lint-time-file
- $ benchmark-time-file
- $ html-help-time-file
+ ${
+ boot-time-file
+ load-time-file
+ test-time-file
+ help-lint-time-file
+ benchmark-time-file
+ html-help-time-file
} [
dup eval-file milli-seconds>time
[XML <tr><td><-></td><td><-></td></tr> XML]
] with-report ;
: build-clean? ( -- ? )
- {
- [ load-all-vocabs-file eval-file empty? ]
- [ test-all-vocabs-file eval-file empty? ]
- [ help-lint-vocabs-file eval-file empty? ]
- [ compiler-errors-file eval-file empty? ]
- [ benchmark-error-vocabs-file eval-file empty? ]
- } 0&& ;
+ ${
+ load-all-vocabs-file
+ test-all-vocabs-file
+ help-lint-vocabs-file
+ compiler-errors-file
+ benchmark-error-vocabs-file
+ } [ eval-file empty? ] all? ;
: success ( -- status )
successful-report build-clean? status-clean status-dirty ? ;
\ No newline at end of file
USING: slides help.markup math arrays hashtables namespaces
-sequences kernel sequences parser memoize ;
+sequences kernel parser memoize ;
IN: minneapolis-talk
CONSTANT: minneapolis-slides
--- /dev/null
+<?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>
! 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
-mason.report math.order sequences sorting splitting xml.syntax
-xml.writer io.pathnames io.encodings.utf8 io.files ;
+http.server.responses http.server.dispatchers kernel mason.platform
+mason.notify.server mason.report math.order sequences sorting
+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 )
[XML <-> for <-> XML] ;
: current-status ( builder -- xml )
- dup status>> {
- { "status-dirty" [ drop "Dirty" ] }
- { "status-clean" [ drop "Clean" ] }
- { "status-error" [ drop "Error" ] }
- { "starting" [ "Starting" building ] }
- { "make-vm" [ "Compiling VM" building ] }
- { "boot" [ "Bootstrapping" building ] }
- { "test" [ "Testing" building ] }
- [ 2drop "Unknown" ]
- } case ;
+ [
+ dup status>> {
+ { +dirty+ [ drop "Dirty" ] }
+ { +clean+ [ drop "Clean" ] }
+ { +error+ [ drop "Error" ] }
+ { +starting+ [ "Starting build" building ] }
+ { +make-vm+ [ "Compiling VM" building ] }
+ { +boot+ [ "Bootstrapping" building ] }
+ { +test+ [ "Testing" building ] }
+ [ 2drop "Unknown" ]
+ } case
+ ] [ current-timestamp>> present " (as of " ")" surround ] bi 2array ;
-: binaries-link ( builder -- link )
- [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend
+: 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 )
+ binaries-url url-link ;
+
+: 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
- dup [XML <a href=<->><-></a> XML] ;
+ clean-image-url url-link ;
+
+: 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 )
{
[ cpu>> ]
[ host-name>> "." split1 drop ]
[ current-status ]
- [ last-git-id>> dup [ git-link ] when ]
- [ clean-git-id>> dup [ git-link ] when ]
+ [ [ last-git-id>> ] [ last-timestamp>> ] bi build-status ]
+ [ [ clean-git-id>> ] [ clean-timestamp>> ] bi build-status ]
[ binaries-link ]
[ clean-image-link ]
+ [ report-link ]
+ [ latest-binary-link ]
} cleave
[XML
<h2><-> / <-></h2>
<tr><td>Binaries:</td><td><-></td></tr>
<tr><td>Clean images:</td><td><-></td></tr>
</table>
+
+ <-> | <->
XML] ;
: machine-report ( -- xml )
[ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort
[ machine-table ] map ;
-: build-farm-report ( -- xml )
+: build-farm-summary ( -- xml )
recent-events
machine-report
[XML
</html>
XML] ;
-: <build-farm-report-action> ( -- action )
+: <summary-action> ( -- action )
<action>
- [
- mason-db [ build-farm-report xml>string ] with-db
- "text/html" <content>
- ] >>display ;
\ No newline at end of file
+ [ build-farm-summary xml>string "text/html" <content> ] >>display ;
+
+TUPLE: builder-link href title ;
+
+C: <builder-link> builder-link
+
+: requirements ( builder -- xml )
+ [
+ os>> {
+ { "winnt" "Windows XP (also tested on Vista)" }
+ { "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> ;
+
/* Allocates memory */
cell frame_scan(stack_frame *frame)
{
- if(frame_type(frame) == QUOTATION_TYPE)
+ switch(frame_type(frame))
{
- cell quot = frame_executing(frame);
- if(quot == F)
- return F;
- else
+ case QUOTATION_TYPE:
{
- char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame);
- char *quot_xt = (char *)(frame_code(frame) + 1);
-
- return tag_fixnum(quot_code_offset_to_scan(
- quot,(cell)(return_addr - quot_xt)));
+ cell quot = frame_executing(frame);
+ if(quot == F)
+ return F;
+ else
+ {
+ char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame);
+ char *quot_xt = (char *)(frame_code(frame) + 1);
+
+ return tag_fixnum(quot_code_offset_to_scan(
+ 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;
- gc_root<array> frames;
- stack_frame_accumulator(cell count) : index(0), frames(allot_array(count,F)) {}
+ growable_array frames;
+
void operator()(stack_frame *frame)
{
- set_array_nth(frames.untagged(),index++,frame_executing(frame));
- set_array_nth(frames.untagged(),index++,frame_scan(frame));
+ gc_root<object> executing(frame_executing(frame));
+ gc_root<object> scan(frame_scan(frame));
+
+ frames.add(executing.value());
+ frames.add(scan.value());
}
};
{
gc_root<callstack> callstack(dpop());
- stack_frame_counter counter;
- iterate_callstack_object(callstack.untagged(),counter);
-
- stack_frame_accumulator accum(counter.count);
+ stack_frame_accumulator accum;
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)
}
}
-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);
+ }
}
}
/* 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)); }
};
projects / factor.git / commitdiff