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

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

db4
Joe Groff 2009-05-21 18:50:36 -05:00
parent c5d440700d a2d83c1650
commit 79474be994
17 changed files with 347 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
basis/furnace/actions/actions.factor
View File

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

2
basis/io/launcher/launcher.factor
View File

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

55
basis/random/windows/windows.factor
View File

@ -1,6 +1,7 @@
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 ;
@ -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 )
[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 )
[
@ -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
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

37
basis/windows/advapi32/advapi32.factor Normal file → Executable file
View File

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

2
extra/galois-talk/galois-talk.factor
View File

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

23
extra/html/parser/parser-tests.factor
View File

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

8
extra/html/parser/parser.factor
View File

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

11
extra/mason/common/common.factor
View File

@ -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
15 minutes >>timeout
+closed+ >>stdin
try-output-process ;
>process 15 minutes >>timeout 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 )

6
extra/mason/notify/notify.factor
View File

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

55
extra/mason/notify/server/server.factor
View File

@ -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: +dirty+ "dirty"
CONSTANT: +clean+ "status-clean"
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

28
extra/mason/report/report.factor
View File

@ -59,13 +59,13 @@ IN: mason.report
"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]
@ -121,13 +121,13 @@ IN: mason.report
] 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 ? ;

2
extra/minneapolis-talk/minneapolis-talk.factor
View File

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

23
extra/webapps/mason/download.xml Normal file
View File

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

138
extra/webapps/mason/mason.factor
View File

@ -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
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 )
@ -20,24 +37,48 @@ IN: webapps.mason
[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 ;
: 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
dup [XML <a href=<->><-></a> XML] ;
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 )
{
@ -45,10 +86,12 @@ IN: webapps.mason
[ 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>
@ -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>
[
mason-db [ build-farm-report xml>string ] with-db
"text/html" <content>
] >>display ;
[ 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> ;

54
vm/callstack.cpp
View File

@ -107,41 +107,43 @@ 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))
{
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);
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)));
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());
}
};
@ -151,13 +153,11 @@ PRIMITIVE(callstack_to_array)
{
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)

14
vm/callstack.hpp
View File

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

5
vm/layouts.hpp
View File

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