Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
433f16e18b
|
|
@ -1,6 +1,6 @@
|
|||
USING: kernel db.postgresql alien continuations io classes
|
||||
prettyprint sequences namespaces tools.test db
|
||||
db.tuples db.types unicode.case accessors ;
|
||||
db.tuples db.types unicode.case accessors system ;
|
||||
IN: db.postgresql.tests
|
||||
|
||||
: test-db ( -- postgresql-db )
|
||||
|
|
@ -10,9 +10,10 @@ IN: db.postgresql.tests
|
|||
"thepasswordistrust" >>password
|
||||
"factor-test" >>database ;
|
||||
|
||||
[ ] [ test-db [ ] with-db ] unit-test
|
||||
os windows? cpu x86.64? and [
|
||||
[ ] [ test-db [ ] with-db ] unit-test
|
||||
|
||||
[ ] [
|
||||
[ ] [
|
||||
test-db [
|
||||
[ "drop table person;" sql-command ] ignore-errors
|
||||
"create table person (name varchar(30), country varchar(30));"
|
||||
|
|
@ -21,43 +22,43 @@ IN: db.postgresql.tests
|
|||
"insert into person values('John', 'America');" sql-command
|
||||
"insert into person values('Jane', 'New Zealand');" sql-command
|
||||
] with-db
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
||||
[
|
||||
[
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
}
|
||||
] [
|
||||
] [
|
||||
test-db [
|
||||
"select * from person" sql-query
|
||||
] with-db
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
||||
[
|
||||
[
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
}
|
||||
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
[
|
||||
] [
|
||||
test-db [
|
||||
"insert into person(name, country) values('Jimmy', 'Canada')"
|
||||
sql-command
|
||||
] with-db
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
||||
[
|
||||
[
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
{ "Jimmy" "Canada" }
|
||||
}
|
||||
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
|
||||
[
|
||||
[
|
||||
test-db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
|
|
@ -65,16 +66,16 @@ IN: db.postgresql.tests
|
|||
"oops" throw
|
||||
] with-transaction
|
||||
] with-db
|
||||
] must-fail
|
||||
] must-fail
|
||||
|
||||
[ 3 ] [
|
||||
[ 3 ] [
|
||||
test-db [
|
||||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
[
|
||||
] [
|
||||
test-db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
|
|
@ -83,13 +84,14 @@ IN: db.postgresql.tests
|
|||
sql-command
|
||||
] with-transaction
|
||||
] with-db
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
||||
[ 5 ] [
|
||||
[ 5 ] [
|
||||
test-db [
|
||||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
] unit-test
|
||||
] unless
|
||||
|
||||
|
||||
: with-dummy-db ( quot -- )
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: io.files kernel tools.test db db.tuples classes
|
||||
db.types continuations namespaces math math.ranges
|
||||
prettyprint calendar sequences db.sqlite math.intervals
|
||||
db.postgresql accessors random math.bitwise
|
||||
db.postgresql accessors random math.bitwise system
|
||||
math.ranges strings urls fry db.tuples.private ;
|
||||
IN: db.tuples.tests
|
||||
|
||||
|
|
@ -26,7 +26,9 @@ IN: db.tuples.tests
|
|||
|
||||
: test-postgresql ( quot -- )
|
||||
'[
|
||||
os windows? cpu x86.64? and [
|
||||
[ ] [ postgresql-db _ with-db ] unit-test
|
||||
] unless
|
||||
] call ; inline
|
||||
|
||||
! These words leak resources, but are useful for interactivel testing
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors hashtables kernel math state-tables vectors ;
|
||||
USING: accessors hashtables kernel math vectors ;
|
||||
IN: regexp.backend
|
||||
|
||||
TUPLE: regexp
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs grouping kernel regexp.backend
|
||||
locals math namespaces regexp.parser sequences state-tables fry
|
||||
quotations math.order math.ranges vectors unicode.categories
|
||||
regexp.utils regexp.transition-tables words sets ;
|
||||
locals math namespaces regexp.parser sequences fry quotations
|
||||
math.order math.ranges vectors unicode.categories regexp.utils
|
||||
regexp.transition-tables words sets ;
|
||||
IN: regexp.nfa
|
||||
|
||||
SYMBOL: negation-mode
|
||||
|
|
@ -22,6 +22,9 @@ SINGLETON: front-anchor INSTANCE: front-anchor traversal-flag
|
|||
SINGLETON: back-anchor INSTANCE: back-anchor traversal-flag
|
||||
SINGLETON: word-boundary INSTANCE: word-boundary traversal-flag
|
||||
|
||||
: add-global-flag ( flag -- )
|
||||
current-regexp get nfa-table>> flags>> conjoin ;
|
||||
|
||||
: next-state ( regexp -- state )
|
||||
[ state>> ] [ [ 1+ ] change-state drop ] bi ;
|
||||
|
||||
|
|
@ -138,21 +141,25 @@ M: non-capture-group nfa-node ( node -- )
|
|||
M: reluctant-kleene-star nfa-node ( node -- )
|
||||
term>> <kleene-star> nfa-node ;
|
||||
|
||||
|
||||
: add-epsilon-flag ( flag -- )
|
||||
eps literal-transition add-simple-entry add-traversal-flag ;
|
||||
|
||||
M: beginning-of-line nfa-node ( node -- )
|
||||
drop beginning-of-line add-epsilon-flag ;
|
||||
drop
|
||||
eps literal-transition add-simple-entry
|
||||
beginning-of-line add-global-flag ;
|
||||
|
||||
M: end-of-line nfa-node ( node -- )
|
||||
drop end-of-line add-epsilon-flag ;
|
||||
drop
|
||||
eps literal-transition add-simple-entry
|
||||
end-of-line add-global-flag ;
|
||||
|
||||
M: beginning-of-input nfa-node ( node -- )
|
||||
drop beginning-of-input add-epsilon-flag ;
|
||||
drop
|
||||
eps literal-transition add-simple-entry
|
||||
beginning-of-input add-global-flag ;
|
||||
|
||||
M: end-of-input nfa-node ( node -- )
|
||||
drop end-of-input add-epsilon-flag ;
|
||||
drop
|
||||
eps literal-transition add-simple-entry
|
||||
end-of-input add-global-flag ;
|
||||
|
||||
M: negation nfa-node ( node -- )
|
||||
negation-mode inc
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ SINGLETONS: letter-class LETTER-class Letter-class digit-class
|
|||
alpha-class non-newline-blank-class
|
||||
ascii-class punctuation-class java-printable-class blank-class
|
||||
control-character-class hex-digit-class java-blank-class c-identifier-class
|
||||
terminator-class unmatchable-class word-boundary-class ;
|
||||
unmatchable-class terminator-class word-boundary-class ;
|
||||
|
||||
SINGLETONS: beginning-of-group end-of-group
|
||||
beginning-of-character-class end-of-character-class
|
||||
|
|
@ -87,8 +87,8 @@ left-parenthesis pipe caret dash ;
|
|||
: <kleene-star> ( obj -- kleene-star ) kleene-star boa ;
|
||||
: <constant> ( obj -- constant )
|
||||
dup Letter? get-case-insensitive and [
|
||||
[ ch>lower constant boa ]
|
||||
[ ch>upper constant boa ] bi 2array <alternation>
|
||||
[ ch>lower ] [ ch>upper ] bi
|
||||
[ constant boa ] bi@ 2array <alternation>
|
||||
] [
|
||||
constant boa
|
||||
] if ;
|
||||
|
|
@ -384,20 +384,22 @@ DEFER: handle-left-bracket
|
|||
} case
|
||||
[ (parse-character-class) ] when ;
|
||||
|
||||
: push-constant ( ch -- ) <constant> push-stack ;
|
||||
|
||||
: parse-character-class-second ( -- )
|
||||
read1 {
|
||||
{ CHAR: [ [ CHAR: [ <constant> push-stack ] }
|
||||
{ CHAR: ] [ CHAR: ] <constant> push-stack ] }
|
||||
{ CHAR: - [ CHAR: - <constant> push-stack ] }
|
||||
{ CHAR: [ [ CHAR: [ push-constant ] }
|
||||
{ CHAR: ] [ CHAR: ] push-constant ] }
|
||||
{ CHAR: - [ CHAR: - push-constant ] }
|
||||
[ push1 ]
|
||||
} case ;
|
||||
|
||||
: parse-character-class-first ( -- )
|
||||
read1 {
|
||||
{ CHAR: ^ [ caret push-stack parse-character-class-second ] }
|
||||
{ CHAR: [ [ CHAR: [ <constant> push-stack ] }
|
||||
{ CHAR: ] [ CHAR: ] <constant> push-stack ] }
|
||||
{ CHAR: - [ CHAR: - <constant> push-stack ] }
|
||||
{ CHAR: [ [ CHAR: [ push-constant ] }
|
||||
{ CHAR: ] [ CHAR: ] push-constant ] }
|
||||
{ CHAR: - [ CHAR: - push-constant ] }
|
||||
[ push1 ]
|
||||
} case ;
|
||||
|
||||
|
|
@ -431,7 +433,7 @@ DEFER: handle-left-bracket
|
|||
drop
|
||||
handle-back-anchor f
|
||||
] [
|
||||
<constant> push-stack t
|
||||
push-constant t
|
||||
] if
|
||||
]
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -25,12 +25,13 @@ TUPLE: default ;
|
|||
: <default-transition> ( from to -- transition )
|
||||
t default-transition make-transition ;
|
||||
|
||||
TUPLE: transition-table transitions start-state final-states ;
|
||||
TUPLE: transition-table transitions start-state final-states flags ;
|
||||
|
||||
: <transition-table> ( -- transition-table )
|
||||
transition-table new
|
||||
H{ } clone >>transitions
|
||||
H{ } clone >>final-states ;
|
||||
H{ } clone >>final-states
|
||||
H{ } clone >>flags ;
|
||||
|
||||
: maybe-initialize-key ( key hashtable -- )
|
||||
2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ;
|
||||
|
|
|
|||
|
|
@ -82,6 +82,7 @@ M: end-of-input flag-action ( dfa-traverser flag -- )
|
|||
drop
|
||||
dup end-of-text? [ t >>match-failed? ] unless drop ;
|
||||
|
||||
|
||||
M: beginning-of-line flag-action ( dfa-traverser flag -- )
|
||||
drop
|
||||
dup {
|
||||
|
|
@ -96,6 +97,7 @@ M: end-of-line flag-action ( dfa-traverser flag -- )
|
|||
[ next-text-character terminator-class class-member? ]
|
||||
} 1|| [ t >>match-failed? ] unless drop ;
|
||||
|
||||
|
||||
M: word-boundary flag-action ( dfa-traverser flag -- )
|
||||
drop
|
||||
dup {
|
||||
|
|
@ -103,6 +105,7 @@ M: word-boundary flag-action ( dfa-traverser flag -- )
|
|||
[ current-text-character terminator-class class-member? ]
|
||||
} 1|| [ t >>match-failed? ] unless drop ;
|
||||
|
||||
|
||||
M: lookahead-on flag-action ( dfa-traverser flag -- )
|
||||
drop
|
||||
lookahead-counters>> 0 swap push ;
|
||||
|
|
|
|||
|
|
@ -614,3 +614,9 @@ M: object infer-call*
|
|||
\ modify-code-heap { array object } { } define-primitive
|
||||
|
||||
\ unimplemented { } { } define-primitive
|
||||
|
||||
\ gc-reset { } { } define-primitive
|
||||
|
||||
\ gc-stats { } { array } define-primitive
|
||||
|
||||
\ jit-compile { quotation } { } define-primitive
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -1,56 +0,0 @@
|
|||
USING: kernel state-tables tools.test ;
|
||||
IN: state-tables.tests
|
||||
|
||||
: test-table
|
||||
<table>
|
||||
"a" "c" "z" <entry> over set-entry
|
||||
"a" "o" "y" <entry> over set-entry
|
||||
"a" "l" "x" <entry> over set-entry
|
||||
"b" "o" "y" <entry> over set-entry
|
||||
"b" "l" "x" <entry> over set-entry
|
||||
"b" "s" "u" <entry> over set-entry ;
|
||||
|
||||
[
|
||||
T{
|
||||
table
|
||||
f
|
||||
H{
|
||||
{ "a" H{ { "l" "x" } { "c" "z" } { "o" "y" } } }
|
||||
{ "b" H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
|
||||
}
|
||||
H{ { "l" t } { "s" t } { "c" t } { "o" t } }
|
||||
f
|
||||
H{ }
|
||||
}
|
||||
] [ test-table ] unit-test
|
||||
|
||||
[ "x" t ] [ "a" "l" test-table get-entry ] unit-test
|
||||
[ "har" t ] [
|
||||
"a" "z" "har" <entry> test-table [ set-entry ] keep
|
||||
>r "a" "z" r> get-entry
|
||||
] unit-test
|
||||
|
||||
: vector-test-table
|
||||
<vector-table>
|
||||
"a" "c" "z" <entry> over add-entry
|
||||
"a" "c" "r" <entry> over add-entry
|
||||
"a" "o" "y" <entry> over add-entry
|
||||
"a" "l" "x" <entry> over add-entry
|
||||
"b" "o" "y" <entry> over add-entry
|
||||
"b" "l" "x" <entry> over add-entry
|
||||
"b" "s" "u" <entry> over add-entry ;
|
||||
|
||||
[
|
||||
T{ vector-table f
|
||||
H{
|
||||
{ "a"
|
||||
H{ { "l" "x" } { "c" V{ "z" "r" } } { "o" "y" } } }
|
||||
{ "b"
|
||||
H{ { "l" "x" } { "s" "u" } { "o" "y" } } }
|
||||
}
|
||||
H{ { "l" t } { "s" t } { "c" t } { "o" t } }
|
||||
f
|
||||
H{ }
|
||||
}
|
||||
] [ vector-test-table ] unit-test
|
||||
|
||||
|
|
@ -1,123 +0,0 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces make sequences vectors assocs accessors ;
|
||||
IN: state-tables
|
||||
|
||||
TUPLE: table rows columns start-state final-states ;
|
||||
TUPLE: entry row-key column-key value ;
|
||||
|
||||
GENERIC: add-entry ( entry table -- )
|
||||
|
||||
: make-table ( class -- obj )
|
||||
new
|
||||
H{ } clone >>rows
|
||||
H{ } clone >>columns
|
||||
H{ } clone >>final-states ;
|
||||
|
||||
: <table> ( -- obj )
|
||||
table make-table ;
|
||||
|
||||
C: <entry> entry
|
||||
|
||||
: (add-row) ( row-key table -- row )
|
||||
2dup rows>> at* [
|
||||
2nip
|
||||
] [
|
||||
drop H{ } clone [ -rot rows>> set-at ] keep
|
||||
] if ;
|
||||
|
||||
: add-row ( row-key table -- )
|
||||
(add-row) drop ;
|
||||
|
||||
: add-column ( column-key table -- )
|
||||
t -rot columns>> set-at ;
|
||||
|
||||
: set-row ( row row-key table -- )
|
||||
rows>> set-at ;
|
||||
|
||||
: lookup-row ( row-key table -- row/f ? )
|
||||
rows>> at* ;
|
||||
|
||||
: row-exists? ( row-key table -- ? )
|
||||
lookup-row nip ;
|
||||
|
||||
: lookup-column ( column-key table -- column/f ? )
|
||||
columns>> at* ;
|
||||
|
||||
: column-exists? ( column-key table -- ? )
|
||||
lookup-column nip ;
|
||||
|
||||
ERROR: no-row key ;
|
||||
ERROR: no-column key ;
|
||||
|
||||
: get-row ( row-key table -- row )
|
||||
dupd lookup-row [
|
||||
nip
|
||||
] [
|
||||
drop no-row
|
||||
] if ;
|
||||
|
||||
: get-column ( column-key table -- column )
|
||||
dupd lookup-column [
|
||||
nip
|
||||
] [
|
||||
drop no-column
|
||||
] if ;
|
||||
|
||||
: get-entry ( row-key column-key table -- obj ? )
|
||||
swapd lookup-row [
|
||||
at*
|
||||
] [
|
||||
2drop f f
|
||||
] if ;
|
||||
|
||||
: (set-entry) ( entry table -- value column-key row )
|
||||
[ >r column-key>> r> add-column ] 2keep
|
||||
dupd >r row-key>> r> (add-row)
|
||||
>r [ value>> ] keep column-key>> r> ;
|
||||
|
||||
: set-entry ( entry table -- )
|
||||
(set-entry) set-at ;
|
||||
|
||||
: delete-entry ( entry table -- )
|
||||
>r [ column-key>> ] [ row-key>> ] bi r>
|
||||
lookup-row [ delete-at ] [ 2drop ] if ;
|
||||
|
||||
: swap-rows ( row-key1 row-key2 table -- )
|
||||
[ tuck get-row >r get-row r> ] 3keep
|
||||
>r >r rot r> r> [ set-row ] keep set-row ;
|
||||
|
||||
: member?* ( obj obj -- bool )
|
||||
2dup = [ 2drop t ] [ member? ] if ;
|
||||
|
||||
: find-by-column ( column-key data table -- seq )
|
||||
swapd 2dup lookup-column 2drop
|
||||
[
|
||||
rows>> [
|
||||
pick swap at* [
|
||||
>r pick r> member?* [ , ] [ drop ] if
|
||||
] [
|
||||
2drop
|
||||
] if
|
||||
] assoc-each
|
||||
] { } make 2nip ;
|
||||
|
||||
|
||||
TUPLE: vector-table < table ;
|
||||
: <vector-table> ( -- obj )
|
||||
vector-table make-table ;
|
||||
|
||||
: add-hash-vector ( value key hash -- )
|
||||
2dup at* [
|
||||
dup vector? [
|
||||
2nip push
|
||||
] [
|
||||
V{ } clone [ push ] keep
|
||||
-rot >r >r [ push ] keep r> r> set-at
|
||||
] if
|
||||
] [
|
||||
drop set-at
|
||||
] if ;
|
||||
|
||||
M: vector-table add-entry ( entry table -- )
|
||||
(set-entry) add-hash-vector ;
|
||||
|
|
@ -321,20 +321,27 @@ IN: tools.deploy.shaker
|
|||
] with-compilation-unit
|
||||
] unless ;
|
||||
|
||||
: compress ( pred string -- )
|
||||
: compress ( pred post-process string -- )
|
||||
"Compressing " prepend show
|
||||
instances
|
||||
dup H{ } clone [ [ ] cache ] curry map
|
||||
[ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
|
||||
become ; inline
|
||||
|
||||
: compress-byte-arrays ( -- )
|
||||
[ byte-array? ] "byte arrays" compress ;
|
||||
[ byte-array? ] [ ] "byte arrays" compress ;
|
||||
|
||||
: remain-compiled ( old new -- old new )
|
||||
#! Quotations which were formerly compiled must remain
|
||||
#! compiled.
|
||||
2dup [
|
||||
2dup [ compiled>> ] [ compiled>> not ] bi* and
|
||||
[ nip jit-compile ] [ 2drop ] if
|
||||
] 2each ;
|
||||
|
||||
: compress-quotations ( -- )
|
||||
[ quotation? ] "quotations" compress ;
|
||||
[ quotation? ] [ remain-compiled ] "quotations" compress ;
|
||||
|
||||
: compress-strings ( -- )
|
||||
[ string? ] "strings" compress ;
|
||||
[ string? ] [ ] "strings" compress ;
|
||||
|
||||
: finish-deploy ( final-image -- )
|
||||
"Finishing up" show
|
||||
|
|
|
|||
|
|
@ -533,6 +533,7 @@ tuple
|
|||
{ "dll-valid?" "alien" }
|
||||
{ "unimplemented" "kernel.private" }
|
||||
{ "gc-reset" "memory" }
|
||||
{ "jit-compile" "quotations" }
|
||||
}
|
||||
[ [ first2 ] dip make-primitive ] each-index
|
||||
|
||||
|
|
|
|||
|
|
@ -1,14 +1,15 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-c-types? f }
|
||||
{ deploy-name "Hello world (console)" }
|
||||
{ deploy-threads? f }
|
||||
{ deploy-name "Hello world (console)" }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-reflection 2 }
|
||||
{ deploy-io 2 }
|
||||
{ deploy-math? f }
|
||||
{ deploy-ui? f }
|
||||
{ deploy-compiler? f }
|
||||
{ deploy-io 2 }
|
||||
{ deploy-math? f }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-unicode? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-c-types? f }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -117,7 +117,7 @@ DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
|
|||
DEF(void,lazy_jit_compile,(CELL quot)):
|
||||
mov r1,sp /* save stack pointer */
|
||||
PROLOGUE
|
||||
bl MANGLE(primitive_jit_compile)
|
||||
bl MANGLE(lazy_jit_compile_impl)
|
||||
EPILOGUE
|
||||
JUMP_QUOT /* call the quotation */
|
||||
|
||||
|
|
|
|||
|
|
@ -165,7 +165,7 @@ DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
|
|||
DEF(void,lazy_jit_compile,(CELL quot)):
|
||||
mr r4,r1 /* save stack pointer */
|
||||
PROLOGUE
|
||||
bl MANGLE(primitive_jit_compile)
|
||||
bl MANGLE(lazy_jit_compile_impl)
|
||||
EPILOGUE
|
||||
JUMP_QUOT /* call the quotation */
|
||||
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
|
|||
DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
|
||||
mov STACK_REG,ARG1 /* Save stack pointer */
|
||||
sub $STACK_PADDING,STACK_REG
|
||||
call MANGLE(primitive_jit_compile)
|
||||
call MANGLE(lazy_jit_compile_impl)
|
||||
mov RETURN_REG,ARG0 /* No-op on 32-bit */
|
||||
add $STACK_PADDING,STACK_REG
|
||||
jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
|
||||
|
|
|
|||
|
|
@ -140,4 +140,5 @@ void *primitives[] = {
|
|||
primitive_dll_validp,
|
||||
primitive_unimplemented,
|
||||
primitive_gc_reset,
|
||||
primitive_jit_compile,
|
||||
};
|
||||
|
|
|
|||
|
|
@ -493,7 +493,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
|
|||
return -1;
|
||||
}
|
||||
|
||||
F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack)
|
||||
F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack)
|
||||
{
|
||||
stack_chain->callstack_top = stack;
|
||||
REGISTER_ROOT(quot);
|
||||
|
|
@ -502,6 +502,11 @@ F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack)
|
|||
return quot;
|
||||
}
|
||||
|
||||
void primitive_jit_compile(void)
|
||||
{
|
||||
jit_compile(dpop(),true);
|
||||
}
|
||||
|
||||
/* push a new quotation on the stack */
|
||||
void primitive_array_to_quotation(void)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code);
|
||||
void jit_compile(CELL quot, bool relocate);
|
||||
F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack);
|
||||
F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack);
|
||||
F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);
|
||||
void primitive_array_to_quotation(void);
|
||||
void primitive_quotation_xt(void);
|
||||
void primitive_jit_compile(void);
|
||||
|
|
|
|||
Loading…
Reference in New Issue