]> gitweb.factorcode.org Git - factor.git/commitdiff
Merge branch 'master' of git://factorcode.org/git/factor
authorSlava Pestov <slava@shill.internal.stack-effects.com>
Thu, 21 May 2009 05:08:52 +0000 (00:08 -0500)
committerSlava Pestov <slava@shill.internal.stack-effects.com>
Thu, 21 May 2009 05:08:52 +0000 (00:08 -0500)
21 files changed:
basis/checksums/md5/md5.factor
basis/furnace/actions/actions.factor
basis/html/templates/fhtml/fhtml-tests.factor
basis/html/templates/fhtml/fhtml.factor
basis/math/vectors/vectors.factor
basis/random/windows/windows.factor
basis/windows/advapi32/advapi32.factor [changed mode: 0644->0755]
extra/galois-talk/galois-talk.factor
extra/grid-meshes/grid-meshes.factor [new file with mode: 0644]
extra/html/parser/parser-tests.factor
extra/html/parser/parser.factor
extra/minneapolis-talk/minneapolis-talk.factor
extra/spheres/spheres.factor
extra/terrain/authors.txt [new file with mode: 0644]
extra/terrain/summary.txt [new file with mode: 0644]
extra/terrain/terrain.factor
misc/factor.vim.fgen
misc/vim/syntax/factor.vim
vm/callstack.cpp
vm/callstack.hpp
vm/layouts.hpp

index 89ff5d46a264f3eb94b3e105a9d6f302655f9e1f..c74aa550d269e58769ba93baaa6a33e0f20c8835 100644 (file)
@@ -5,7 +5,7 @@ math.functions math.parser namespaces splitting grouping strings
 sequences byte-arrays locals sequences.private macros fry
 io.encodings.binary math.bitwise checksums accessors
 checksums.common checksums.stream combinators combinators.smart
-specialized-arrays.uint literals ;
+specialized-arrays.uint literals hints ;
 IN: checksums.md5
 
 SINGLETON: md5
@@ -28,7 +28,7 @@ M: md5 initialize-checksum-state drop <md5-state> ;
 
 : update-md5 ( md5 -- )
     [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
-    [ (>>old-state) ] [ (>>state) ] bi ; inline
+    [ (>>old-state) ] [ (>>state) ] bi ;
 
 CONSTANT: T
     $[
@@ -106,7 +106,7 @@ MACRO: with-md5-round ( ops quot -- )
         [ d a b c 13 S12 14 ]
         [ c d a b 14 S13 15 ]
         [ b c d a 15 S14 16 ]
-    } [ F ] with-md5-round ; inline
+    } [ F ] with-md5-round ;
 
 : (process-md5-block-G) ( block state -- )
     {
@@ -126,7 +126,7 @@ MACRO: with-md5-round ( ops quot -- )
         [ d a b c 2  S22 30 ]
         [ c d a b 7  S23 31 ]
         [ b c d a 12 S24 32 ]
-    } [ G ] with-md5-round ; inline
+    } [ G ] with-md5-round ;
 
 : (process-md5-block-H) ( block state -- )
     {
@@ -146,7 +146,7 @@ MACRO: with-md5-round ( ops quot -- )
         [ d a b c 12 S32 46 ]
         [ c d a b 15 S33 47 ]
         [ b c d a 2  S34 48 ]
-    } [ H ] with-md5-round ; inline
+    } [ H ] with-md5-round ;
 
 : (process-md5-block-I) ( block state -- )
     {
@@ -166,7 +166,12 @@ MACRO: with-md5-round ( ops quot -- )
         [ d a b c 11 S42 62 ]
         [ c d a b 2  S43 63 ]
         [ b c d a 9  S44 64 ]
-    } [ I ] with-md5-round ; inline
+    } [ I ] with-md5-round ;
+
+HINTS: (process-md5-block-F) { uint-array md5-state } ;
+HINTS: (process-md5-block-G) { uint-array md5-state } ;
+HINTS: (process-md5-block-H) { uint-array md5-state } ;
+HINTS: (process-md5-block-I) { uint-array md5-state } ;
 
 M: md5-state checksum-block ( block state -- )
     [
index c7893117d16f8ae609275cad7bb989d46cb794b6..06e743e967a78926a891c90e8fb2ea0978fe195c 100644 (file)
@@ -12,7 +12,6 @@ furnace.conversations
 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
index 55cf90c2dd18744b7d14ab413a42aed82bb26157..427b3215c14062a44c437b421d13f57089f6eefc 100644 (file)
@@ -1,5 +1,5 @@
 USING: io io.files io.streams.string io.encodings.utf8
-html.templates html.templates.fhtml kernel
+html.templates html.templates.fhtml kernel multiline
 tools.test sequences parser splitting prettyprint ;
 IN: html.templates.fhtml.tests
 
@@ -17,3 +17,14 @@ IN: html.templates.fhtml.tests
 [
     [ ] [ "<%\n%>" parse-template drop ] unit-test
 ] with-file-vocabs
+
+[
+    [ ] [
+        <"
+            <%
+            IN: html.templates.fhtml.tests
+            : test-word ( -- ) ;
+            %>
+        "> parse-template drop
+    ] unit-test
+] with-file-vocabs
index 6c5e78e917b7f75a0f30bb11238427595c9e800e..ceb2e72478d964cf5f3444f0fb6e33ff44489889 100644 (file)
@@ -4,7 +4,7 @@
 USING: continuations sequences kernel namespaces debugger
 combinators math quotations generic strings splitting accessors
 assocs fry vocabs.parser parser parser.notes lexer io io.files
-io.streams.string io.encodings.utf8 html.templates ;
+io.streams.string io.encodings.utf8 html.templates compiler.units ;
 IN: html.templates.fhtml
 
 ! We use a custom lexer so that %> ends a token even if not
@@ -58,11 +58,13 @@ SYNTAX: %> lexer get parse-%> ;
 
 : parse-template ( string -- quot )
     [
+        [
         "quiet" on
         parser-notes off
         "html.templates.fhtml" use-vocab
         string-lines parse-template-lines
-    ] with-file-vocabs ;
+        ] with-file-vocabs
+    ] with-compilation-unit ;
 
 : eval-template ( string -- )
     parse-template call( -- ) ;
index bad2733bbf1176585d608c759c3ffbc2e4742388..0fe1404516a62ca1f451d25ae5ac9fdbc85fa770 100644 (file)
@@ -58,6 +58,10 @@ IN: math.vectors
 : vnlerp ( a b t -- a_t )
     [ lerp ] curry 2map ;
 
+: vbilerp ( aa ba ab bb {t,u} -- a_tu )
+    [ first vnlerp ] [ second vnlerp ] bi-curry
+    [ 2bi@ ] [ call ] bi* ;
+
 HINTS: vneg { array } ;
 HINTS: norm-sq { array } ;
 HINTS: norm { array } ;
index 488deef41fe71b5e8ece12067d3e779de5df7f4f..6dce078d671a1181b72e86c0e344183153680e21 100644 (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
old mode 100644 (file)
new mode 100755 (executable)
index fd037cb..6d80534
@@ -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
 
index ba929867e99c56adeea3f03583bc5a19f09bc70f..0d2a5a73d8ae49fe6bd110486325fb2010a69d44 100644 (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
diff --git a/extra/grid-meshes/grid-meshes.factor b/extra/grid-meshes/grid-meshes.factor
new file mode 100644 (file)
index 0000000..19c4568
--- /dev/null
@@ -0,0 +1,48 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays destructors kernel math opengl
+opengl.gl sequences sequences.product specialized-arrays.float ;
+IN: grid-meshes
+
+TUPLE: grid-mesh dim buffer row-length ;
+
+<PRIVATE
+
+: vertex-array-vertex ( dim x z -- vertex )
+    [ swap first /f ]
+    [ swap second /f ] bi-curry* bi
+    [ 0 ] dip float-array{ } 3sequence ;
+
+: vertex-array-row ( dim z -- vertices )
+    dup 1 + 2array
+    over first 1 + iota
+    2array [ first2 swap vertex-array-vertex ] with product-map
+    concat ;
+
+: vertex-array ( dim -- vertices )
+    dup second iota
+    [ vertex-array-row ] with map concat ;
+
+: >vertex-buffer ( bytes -- buffer )
+    [ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW <gl-buffer> ;
+
+: draw-vertex-buffer-row ( grid-mesh i -- )
+    swap [ GL_TRIANGLE_STRIP ] 2dip
+    row-length>> [ * ] keep
+    glDrawArrays ;
+
+PRIVATE>
+
+: draw-grid-mesh ( grid-mesh -- )
+    GL_ARRAY_BUFFER over buffer>> [
+        [ 3 GL_FLOAT 0 f glVertexPointer ] dip
+        dup dim>> second iota [ draw-vertex-buffer-row ] with each
+    ] with-gl-buffer ;
+
+: <grid-mesh> ( dim -- grid-mesh )
+    [ ] [ vertex-array >vertex-buffer ] [ first 1 + 2 * ] tri
+    grid-mesh boa ;
+
+M: grid-mesh dispose
+    [ [ delete-gl-buffer ] when* f ] change-buffer
+    drop ;
+
index ca276fc54e069fd645570062add13e24c0a79ea7..2876d03b163205ebf0dce8f95997ecd9cd5544a2 100644 (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
index d95c79dd887b053d129fe51630d2cc4857c2e032..948bd0c954907eab4317306f411a635ca6ac5214 100644 (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&&
index 6f1df44bfb69f2d5ab00acabbf60e4837404e35c..a96bb2ce2033fd0615c30541167e8fe7df941602 100755 (executable)
@@ -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
index 1a8f41b4a2e974f5ec2ee4a38cc163f6a212d55c..b07b7a5ad1ede354ed7053112c80f1005078ab61 100755 (executable)
@@ -3,7 +3,6 @@ opengl.shaders opengl.framebuffers opengl.capabilities multiline
 ui.gadgets accessors sequences ui.render ui math locals arrays
 generalizations combinators ui.gadgets.worlds
 literals ui.pixel-formats ;
-FROM: opengl.demo-support => rect-vertices ;
 IN: spheres
 
 STRING: plane-vertex-shader
@@ -117,11 +116,11 @@ TUPLE: spheres-world < demo-world
     reflection-framebuffer reflection-depthbuffer
     reflection-texture ;
 
-M: spheres-world near-plane ( gadget -- z )
+M: spheres-world near-plane
     drop 1.0 ;
-M: spheres-world far-plane ( gadget -- z )
+M: spheres-world far-plane
     drop 512.0 ;
-M: spheres-world distance-step ( gadget -- dz )
+M: spheres-world distance-step
     drop 0.5 ;
 
 : (reflection-dim) ( -- w h )
@@ -175,6 +174,9 @@ M: spheres-world distance-step ( gadget -- dz )
 M: spheres-world begin-world
     "2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions
     { "GL_EXT_framebuffer_object" } require-gl-extensions
+    GL_DEPTH_TEST glEnable
+    GL_VERTEX_ARRAY glEnableClientState
+    0.15 0.15 1.0 1.0 glClearColor 
     20.0 10.0 20.0 set-demo-orientation
     (plane-program) >>plane-program
     (solid-sphere-program) >>solid-sphere-program
@@ -194,13 +196,13 @@ M: spheres-world end-world
         [ plane-program>> [ delete-gl-program ] when* ]
     } cleave ;
 
-M: spheres-world pref-dim* ( gadget -- dim )
+M: spheres-world pref-dim*
     drop { 640 480 } ;
 
 :: (draw-sphere) ( program center radius -- )
     program "center" glGetAttribLocation center first3 glVertexAttrib3f
     program "radius" glGetAttribLocation radius glVertexAttrib1f
-    { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ;
+    { -1.0 -1.0 } { 2.0 2.0 } gl-fill-rect ;
     
 :: (draw-colored-sphere) ( program center radius surfacecolor -- )
     program "surface_color" glGetAttribLocation surfacecolor first4 glVertexAttrib4f
@@ -283,9 +285,7 @@ M: spheres-world pref-dim* ( gadget -- dim )
     } cleave ] with-framebuffer ;
 
 M: spheres-world draw-world*
-    GL_DEPTH_TEST glEnable
-    GL_SCISSOR_TEST glDisable
-    0.15 0.15 1.0 1.0 glClearColor {
+    {
         [ (draw-reflection-texture) ]
         [ demo-world-set-matrix ]
         [ sphere-scene ]
diff --git a/extra/terrain/authors.txt b/extra/terrain/authors.txt
new file mode 100644 (file)
index 0000000..0bc3c5a
--- /dev/null
@@ -0,0 +1,2 @@
+Joe Groff
+Doug Coleman
diff --git a/extra/terrain/summary.txt b/extra/terrain/summary.txt
new file mode 100644 (file)
index 0000000..3244803
--- /dev/null
@@ -0,0 +1 @@
+Walk around on procedurally generated terrain
index cfacfeb700d27f9505233998a0da60343f111b5e..5847426faea30543b0000c041bbe3f0588afb225 100644 (file)
@@ -1,3 +1,4 @@
+! (c)2009 Joe Groff, Doug Coleman. bsd license
 USING: accessors arrays combinators game-input game-loop
 game-input.scancodes grouping kernel literals locals
 math math.constants math.functions math.matrices math.order
@@ -6,7 +7,8 @@ opengl.shaders opengl.textures opengl.textures.private
 sequences sequences.product specialized-arrays.float
 terrain.generation terrain.shaders ui ui.gadgets
 ui.gadgets.worlds ui.pixel-formats game-worlds method-chains
-math.affine-transforms noise ui.gestures combinators.short-circuit ;
+math.affine-transforms noise ui.gestures combinators.short-circuit
+destructors grid-meshes ;
 IN: terrain
 
 CONSTANT: FOV $[ 2.0 sqrt 1+ ]
@@ -26,8 +28,6 @@ CONSTANT: SKY-PERIOD 1200
 CONSTANT: SKY-SPEED 0.0005
 
 CONSTANT: terrain-vertex-size { 512 512 }
-CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] }
-CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ]
 
 TUPLE: player
     location yaw pitch velocity velocity-modifier
@@ -37,7 +37,7 @@ TUPLE: terrain-world < game-world
     player
     sky-image sky-texture sky-program
     terrain terrain-segment terrain-texture terrain-program
-    terrain-vertex-buffer
+    terrain-mesh
     history ;
 
 : <player> ( -- player )
@@ -65,35 +65,6 @@ M: terrain-world tick-length
     [ yaw>> 0.0 1.0 0.0 glRotatef ]
     [ location>> vneg first3 glTranslatef ] tri ;
 
-: vertex-array-vertex ( x z -- vertex )
-    [ terrain-vertex-distance first * ]
-    [ terrain-vertex-distance second * ] bi*
-    [ 0 ] dip float-array{ } 3sequence ;
-
-: vertex-array-row ( z -- vertices )
-    dup 1 + 2array
-    terrain-vertex-size first 1 + iota
-    2array [ first2 swap vertex-array-vertex ] product-map
-    concat ;
-
-: vertex-array ( -- vertices )
-    terrain-vertex-size second iota
-    [ vertex-array-row ] map concat ;
-
-: >vertex-buffer ( bytes -- buffer )
-    [ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW <gl-buffer> ;
-
-: draw-vertex-buffer-row ( i -- )
-    [ GL_TRIANGLE_STRIP ] dip
-    terrain-vertex-row-length * terrain-vertex-row-length
-    glDrawArrays ;
-
-: draw-vertex-buffer ( buffer -- )
-    [ GL_ARRAY_BUFFER ] dip [
-        3 GL_FLOAT 0 f glVertexPointer
-        terrain-vertex-size second iota [ draw-vertex-buffer-row ] each
-    ] with-gl-buffer ;
-
 : degrees ( deg -- rad )
     pi 180.0 / * ;
 
@@ -119,7 +90,6 @@ M: terrain-world tick-length
 : clamp-pitch ( pitch -- pitch' )
     90.0 min -90.0 max ;
 
-
 : walk-forward ( player -- )
     dup forward-vector [ v+ ] curry change-velocity drop ;
 : walk-backward ( player -- )
@@ -274,12 +244,12 @@ BEFORE: terrain-world begin-world
     >>sky-program
     terrain-vertex-shader terrain-pixel-shader <simple-gl-program>
     >>terrain-program
-    vertex-array >vertex-buffer >>terrain-vertex-buffer
+    terrain-vertex-size <grid-mesh> >>terrain-mesh
     drop ;
 
 AFTER: terrain-world end-world
     {
-        [ terrain-vertex-buffer>> delete-gl-buffer ]
+        [ terrain-mesh>> dispose ]
         [ terrain-program>> delete-gl-program ]
         [ terrain-texture>> delete-texture ]
         [ sky-program>> delete-gl-program ]
@@ -306,7 +276,7 @@ M: terrain-world draw-world*
         [ GL_DEPTH_TEST glEnable dup terrain-program>> [
             [ "heightmap" glGetUniformLocation 0 glUniform1i ]
             [ "component_scale" glGetUniformLocation COMPONENT-SCALE first4 glUniform4f ] bi
-            terrain-vertex-buffer>> draw-vertex-buffer
+            terrain-mesh>> draw-grid-mesh
         ] with-gl-program ]
     } cleave gl-error ;
 
index b0d61b8dd0c8cfdc61eb5ecc4dd87f0ac3799638..af1e9e600ae9c243ca510a4ab04e81ab82788c4a 100644 (file)
@@ -1,15 +1,26 @@
-<% USING: kernel io prettyprint vocabs sequences ;
-%>" Vim syntax file
-" Language:    factor
-" Maintainer:  Alex Chapman <chapman.alex@gmail.com>
-" Last Change: 2008 Apr 28
+<%
+USING: kernel io prettyprint vocabs sequences multiline ;
+IN: factor.vim.fgen
+
+: print-keywords ( vocab -- )
+    words [
+        "syn keyword factorKeyword " write
+        [ bl ] [ pprint ] interleave nl
+    ] when* ;
+
+%>
+" Vim syntax file
+" Language: factor
+" Maintainer: Alex Chapman <chapman.alex@gmail.com>
+" Last Change: 2009 May 19
+" To run: USE: html.templates.fhtml "resource:misc/factor.vim.fgen" <fhtml> call-template
 
 " For version 5.x: Clear all syntax items
 " For version 6.x: Quit when a syntax file was already loaded
 if version < 600
-  syntax clear
+    syntax clear
 elseif exists("b:current_syntax")
-  finish
+    finish
 endif
 
 " factor is case sensitive.
@@ -47,25 +58,27 @@ syn keyword factorBoolean boolean f general-t t
 syn keyword factorCompileDirective inline foldable parsing
 
 <%
+
 ! uncomment this if you want all words from all vocabularies highlighted. Note
 ! that this changes factor.vim from around 8k to around 100k (and is a bit
 ! broken)
 
-! vocabs [ words [ "syn keyword factorKeyword " write [ pprint " " write ] each "\n" write ] when* ] each
+! vocabs [ print-keywords ] each
+
+    {
+        "kernel" "assocs" "combinators" "math" "sequences"
+        "namespaces" "arrays" "io" "strings" "vectors"
+        "continuations"
+    } [ print-keywords ] each
 %>
 
-" kernel vocab keywords
-<% { "kernel" "assocs" "combinators" "math" "sequences" "namespaces" "arrays" "io" "strings" "vectors" "continuations" } [
-       words "syn keyword factorKeyword " write [ pprint " " write ] each "\n" write
-   ] each %>
-
-syn cluster factorReal   contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal
-syn cluster factorNumber contains=@factorReal,factorComplex
-syn cluster factorNumErr contains=factorBinErr,factorHexErr,factorOctErr
-syn match   factorInt          /\<-\=\d\+\>/
-syn match   factorFloat                /\<-\=\d*\.\d\+\>/
-syn match   factorRatio                /\<-\=\d*\.*\d\+\/-\=\d*\.*\d\+\>/
-syn region  factorComplex      start=/\<C{\>/ end=/\<}\>/ contains=@factorReal
+syn cluster factorReal          contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal
+syn cluster factorNumber        contains=@factorReal,factorComplex
+syn cluster factorNumErr        contains=factorBinErr,factorHexErr,factorOctErr
+syn match   factorInt           /\<-\=\d\+\>/
+syn match   factorFloat         /\<-\=\d*\.\d\+\>/
+syn match   factorRatio         /\<-\=\d*\.*\d\+\/-\=\d*\.*\d\+\>/
+syn region  factorComplex       start=/\<C{\>/ end=/\<}\>/ contains=@factorReal
 syn match   factorBinErr        /\<BIN:\s\+[01]*[^\s01]\S*\>/
 syn match   factorBinary        /\<BIN:\s\+[01]\+\>/
 syn match   factorHexErr        /\<HEX:\s\+\x*[^\x\s]\S*\>/
@@ -73,31 +86,36 @@ syn match   factorHex           /\<HEX:\s\+\x\+\>/
 syn match   factorOctErr        /\<OCT:\s\+\o*[^\o\s]\S*\>/
 syn match   factorOctal         /\<OCT:\s\+\o\+\>/
 
-syn match factorIn /\<IN:\s\+\S\+\>/
-syn match factorUse /\<USE:\s\+\S\+\>/
+syn match   factorIn            /\<IN:\s\+\S\+\>/
+syn match   factorUse           /\<USE:\s\+\S\+\>/
+syn match   factorUnuse         /\<UNUSE:\s\+\S\+\>/
 
-syn match factorCharErr /\<CHAR:\s\+\S\+/
-syn match factorChar /\<CHAR:\s\+\\\=\S\>/
+syn match   factorCharErr       /\<CHAR:\s\+\S\+/
+syn match   factorChar          /\<CHAR:\s\+\\\=\S\>/
 
-syn match factorBackslash /\<\\\>\s\+\S\+\>/
+syn match   factorBackslash     /\<\\\>\s\+\S\+\>/
 
-syn region factorUsing start=/\<USING:\>/ end=/;/
-syn region factorRequires start=/\<REQUIRES:\>/ end=/;/
+syn region  factorUsing         start=/\<USING:\>/       end=/;/
+syn region  factorSingletons    start=/\<SINGLETONS:\>/  end=/;/
+syn match   factorSymbol        /\<SYMBOL:\s\+\S\+\>/
+syn region  factorSymbols       start=/\<SYMBOLS:\>/     end=/;/
+syn region  factorConstructor2  start=/\<CONSTRUCTOR:\?/ end=/;/
+syn region  factorTuple         start=/\<TUPLE:\>/ end=/\<;\>/
 
-syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
-syn match factorSymbol /\<SYMBOL:\s\+\S\+\>/
-syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/
-syn match factorDefer /\<DEFER:\s\+\S\+\>/
-syn match factorForget /\<FORGET:\s\+\S\+\>/
-syn match factorMixin /\<MIXIN:\s\+\S\+\>/
-syn match factorInstance /\<INSTANCE:\s\+\S\+\s\+\S\+\>/
-syn match factorHook /\<HOOK:\s\+\S\+\s\+\S\+\>/
-syn match factorMain /\<MAIN:\s\+\S\+\>/
-syn match factorConstructor /\<C:\s\+\S\+\s\+\S\+\>/
+syn match   factorConstant      /\<CONSTANT:\s\+\S\+\>/
+syn match   factorSingleton     /\<SINGLETON:\s\+\S\+\>/
+syn match   factorPostpone      /\<POSTPONE:\s\+\S\+\>/
+syn match   factorDefer         /\<DEFER:\s\+\S\+\>/
+syn match   factorForget        /\<FORGET:\s\+\S\+\>/
+syn match   factorMixin         /\<MIXIN:\s\+\S\+\>/
+syn match   factorInstance      /\<INSTANCE:\s\+\S\+\s\+\S\+\>/
+syn match   factorHook          /\<HOOK:\s\+\S\+\s\+\S\+\>/
+syn match   factorMain          /\<MAIN:\s\+\S\+\>/
+syn match   factorConstructor   /\<C:\s\+\S\+\s\+\S\+\>/
+syn match   factorAlien         /\<ALIEN:\s\+\d\+\>/
 
-syn match factorAlien /\<ALIEN:\s\+\d\+\>/
+syn cluster factorWordOps       contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
 
-syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
 
 "TODO:
 "misc:
@@ -116,6 +134,12 @@ syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
 " TYPEDEF:
 " LIBRARY:
 " C-UNION:
+"QUALIFIED:
+"QUALIFIED-WITH:
+"FROM:
+"ALIAS:
+"! POSTPONE: "
+"#\ "
 
 syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline
 syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline
@@ -165,88 +189,92 @@ syn sync lines=100
 
 if version >= 508 || !exists("did_factor_syn_inits")
     if version <= 508
-       let did_factor_syn_inits = 1
-       command -nargs=+ HiLink hi link <args>
+        let did_factor_syn_inits = 1
+        command -nargs=+ HiLink hi link <args>
     else
-       command -nargs=+ HiLink hi def link <args>
+        command -nargs=+ HiLink hi def link <args>
     endif
 
-    HiLink factorComment       Comment
-    HiLink factorStackEffect   Typedef
-    HiLink factorTodo          Todo
-    HiLink factorInclude       Include
-    HiLink factorRepeat                Repeat
-    HiLink factorConditional   Conditional
-    HiLink factorKeyword       Keyword
-    HiLink factorOperator      Operator
-    HiLink factorBoolean       Boolean
-    HiLink factorDefnDelims    Typedef
-    HiLink factorMethodDelims  Typedef
-    HiLink factorGenericDelims        Typedef
-    HiLink factorGenericNDelims        Typedef
-    HiLink factorConstructor   Typedef
-    HiLink factorPrivate       Special
-    HiLink factorPrivateDefnDelims     Special
-    HiLink factorPrivateMethodDelims   Special
-    HiLink factorPGenericDelims        Special
+    HiLink factorComment                Comment
+    HiLink factorStackEffect            Typedef
+    HiLink factorTodo                   Todo
+    HiLink factorInclude                Include
+    HiLink factorRepeat                 Repeat
+    HiLink factorConditional            Conditional
+    HiLink factorKeyword                Keyword
+    HiLink factorOperator               Operator
+    HiLink factorBoolean                Boolean
+    HiLink factorDefnDelims             Typedef
+    HiLink factorMethodDelims           Typedef
+    HiLink factorGenericDelims          Typedef
+    HiLink factorGenericNDelims         Typedef
+    HiLink factorConstructor            Typedef
+    HiLink factorConstructor2           Typedef
+    HiLink factorPrivate                Special
+    HiLink factorPrivateDefnDelims      Special
+    HiLink factorPrivateMethodDelims    Special
+    HiLink factorPGenericDelims         Special
     HiLink factorPGenericNDelims        Special
-    HiLink factorString                String
-    HiLink factorSbuf          String
-    HiLink factorMultiStringContents           String
-    HiLink factorMultiStringDelims Typedef
-    HiLink factorBracketErr     Error
-    HiLink factorComplex       Number
-    HiLink factorRatio          Number
-    HiLink factorBinary         Number
-    HiLink factorBinErr         Error
-    HiLink factorHex            Number
-    HiLink factorHexErr         Error
-    HiLink factorOctal          Number
-    HiLink factorOctErr         Error
-    HiLink factorFloat         Float
-    HiLink factorInt           Number
-    HiLink factorUsing          Include
-    HiLink factorUse            Include
-    HiLink factorRequires       Include
-    HiLink factorIn             Define
-    HiLink factorChar           Character
-    HiLink factorCharErr        Error
-    HiLink factorDelimiter      Delimiter
-    HiLink factorBackslash      Special
-    HiLink factorCompileDirective Typedef
-    HiLink factorSymbol         Define
-    HiLink factorMixin         Typedef
-    HiLink factorInstance         Typedef
-    HiLink factorHook         Typedef
-    HiLink factorMain         Define
-    HiLink factorPostpone       Define
-    HiLink factorDefer          Define
-    HiLink factorForget         Define
-    HiLink factorAlien          Define
-    HiLink factorTuple          Typedef
+    HiLink factorString                 String
+    HiLink factorSbuf                   String
+    HiLink factorMultiStringContents    String
+    HiLink factorMultiStringDelims      Typedef
+    HiLink factorBracketErr             Error
+    HiLink factorComplex                Number
+    HiLink factorRatio                  Number
+    HiLink factorBinary                 Number
+    HiLink factorBinErr                 Error
+    HiLink factorHex                    Number
+    HiLink factorHexErr                 Error
+    HiLink factorOctal                  Number
+    HiLink factorOctErr                 Error
+    HiLink factorFloat                  Float
+    HiLink factorInt                    Number
+    HiLink factorUsing                  Include
+    HiLink factorUse                    Include
+    HiLink factorUnuse                  Include
+    HiLink factorIn                     Define
+    HiLink factorChar                   Character
+    HiLink factorCharErr                Error
+    HiLink factorDelimiter              Delimiter
+    HiLink factorBackslash              Special
+    HiLink factorCompileDirective       Typedef
+    HiLink factorSymbol                 Define
+    HiLink factorConstant               Define
+    HiLink factorSingleton              Define
+    HiLink factorSingletons             Define
+    HiLink factorMixin                  Typedef
+    HiLink factorInstance               Typedef
+    HiLink factorHook                   Typedef
+    HiLink factorMain                   Define
+    HiLink factorPostpone               Define
+    HiLink factorDefer                  Define
+    HiLink factorForget                 Define
+    HiLink factorAlien                  Define
+    HiLink factorTuple                  Typedef
 
     if &bg == "dark"
-       hi   hlLevel0 ctermfg=red         guifg=red1
-       hi   hlLevel1 ctermfg=yellow      guifg=orange1
-       hi   hlLevel2 ctermfg=green       guifg=yellow1
-       hi   hlLevel3 ctermfg=cyan        guifg=greenyellow
-       hi   hlLevel4 ctermfg=magenta     guifg=green1
-       hi   hlLevel5 ctermfg=red         guifg=springgreen1
-       hi   hlLevel6 ctermfg=yellow      guifg=cyan1
-       hi   hlLevel7 ctermfg=green       guifg=slateblue1
-       hi   hlLevel8 ctermfg=cyan        guifg=magenta1
-       hi   hlLevel9 ctermfg=magenta     guifg=purple1
+        hi   hlLevel0 ctermfg=red         guifg=red1
+        hi   hlLevel1 ctermfg=yellow      guifg=orange1
+        hi   hlLevel2 ctermfg=green       guifg=yellow1
+        hi   hlLevel3 ctermfg=cyan        guifg=greenyellow
+        hi   hlLevel4 ctermfg=magenta     guifg=green1
+        hi   hlLevel5 ctermfg=red         guifg=springgreen1
+        hi   hlLevel6 ctermfg=yellow      guifg=cyan1
+        hi   hlLevel7 ctermfg=green       guifg=slateblue1
+        hi   hlLevel8 ctermfg=cyan        guifg=magenta1
+        hi   hlLevel9 ctermfg=magenta     guifg=purple1
     else
-       hi   hlLevel0 ctermfg=red         guifg=red3
-       hi   hlLevel1 ctermfg=darkyellow  guifg=orangered3
-       hi   hlLevel2 ctermfg=darkgreen   guifg=orange2
-       hi   hlLevel3 ctermfg=blue        guifg=yellow3
-       hi   hlLevel4 ctermfg=darkmagenta guifg=olivedrab4
-       hi   hlLevel5 ctermfg=red         guifg=green4
-       hi   hlLevel6 ctermfg=darkyellow  guifg=paleturquoise3
-       hi   hlLevel7 ctermfg=darkgreen   guifg=deepskyblue4
-       hi   hlLevel8 ctermfg=blue        guifg=darkslateblue
-       hi   hlLevel9 ctermfg=darkmagenta guifg=darkviolet
+        hi   hlLevel0 ctermfg=red         guifg=red3
+        hi   hlLevel1 ctermfg=darkyellow  guifg=orangered3
+        hi   hlLevel2 ctermfg=darkgreen   guifg=orange2
+        hi   hlLevel3 ctermfg=blue        guifg=yellow3
+        hi   hlLevel4 ctermfg=darkmagenta guifg=olivedrab4
+        hi   hlLevel5 ctermfg=red         guifg=green4
+        hi   hlLevel6 ctermfg=darkyellow  guifg=paleturquoise3
+        hi   hlLevel7 ctermfg=darkgreen   guifg=deepskyblue4
+        hi   hlLevel8 ctermfg=blue        guifg=darkslateblue
+        hi   hlLevel9 ctermfg=darkmagenta guifg=darkviolet
     endif
 
     delcommand HiLink
index 7d847c723829d8f92bb74c37b3d12ae013730b1d..86f4f191476cd3e3b70c38137e7ee59eb3141972 100755 (executable)
@@ -1,14 +1,15 @@
 " Vim syntax file
-" Language:    factor
-" Maintainer:  Alex Chapman <chapman.alex@gmail.com>
-" Last Change: 2008 Apr 28
+" Language: factor
+" Maintainer: Alex Chapman <chapman.alex@gmail.com>
+" Last Change: 2009 May 19
+" To run: USE: html.templates.fhtml "resource:misc/factor.vim.fgen" <fhtml> call-template
 
 " For version 5.x: Clear all syntax items
 " For version 6.x: Quit when a syntax file was already loaded
 if version < 600
-  syntax clear
+    syntax clear
 elseif exists("b:current_syntax")
-  finish
+    finish
 endif
 
 " factor is case sensitive.
@@ -45,29 +46,26 @@ syn region None matchgroup=factorPrivate start=/\<<PRIVATE\>/ end=/\<PRIVATE>\>/
 syn keyword factorBoolean boolean f general-t t
 syn keyword factorCompileDirective inline foldable parsing
 
-
-
-" kernel vocab keywords
-syn keyword factorKeyword or construct-delegate set-slots tuck 2bi 2tri while wrapper nip bi* wrapper? hashcode callstack>array both? die set-delegate dupd callstack callstack? 3dup tri@ pick curry build prepose 3bi >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep construct clear 2dup when not tuple? 3compose dup 2bi* call object bi@ wrapped unless* if* >r curry-quot drop when* retainstack -rot 2bi@ delegate boa with 3slip slip compose-first compose-second 3drop either? bi curry? datastack curry-obj over 3curry roll throw swap and 2nip set-retainstack (clone) hashcode* get-slots compose spin if 3tri unless compose? tuple keep 2curry equal? set-datastack 2slip tri 2drop most <wrapper> identity-tuple? null r> new set-callstack dip xor rot -roll identity-tuple 
-syn keyword factorKeyword assoc? assoc-clone-like delete-any assoc= delete-at* new-assoc subassoc? assoc-size map>assoc search-alist assoc-like key? assoc-intersect update assoc-union at* assoc-empty? at+ set-enum-seq set-at assoc-all? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at (assoc-stack) enum? at cache assoc>map assoc-any? <enum> assoc assoc-map assoc-pusher (assoc>map) enum assoc-push-if remove-all >alist (substitute) substitute-here clear-assoc assoc-stack substitute assoc-filter delete-at assoc-find enum-seq keys 
-syn keyword factorKeyword case dispatch-case-quot with-datastack <buckets> no-cond no-case? 3cleave>quot (distribute-buckets) contiguous-range? 2cleave cond>quot no-cond? cleave>quot no-case recursive-hashcode case>quot 3cleave alist>quot dispatch-case hash-case-table hash-case-quot case-find cond cleave distribute-buckets 2cleave>quot linear-case-quot spread spread>quot hash-dispatch-quot 
-syn keyword factorKeyword byte-array>bignum sgn >bignum number= each-integer next-power-of-2 ?1+ imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum (all-integers?) times denominator find-last-integer (each-integer) bit? * + power-of-2? - / >= bitand find-integer complex < real > log2 integer? number bits>double double>bits bitor 2/ zero? rem all-integers? (find-integer) real-part align bits>float float? shift float 1+ 1- fp-nan? ratio? bitxor even? ratio <= /mod >integer odd? rational? bitnot real? >fixnum complex? (next-power-of-2) /i numerator /f 
-syn keyword factorKeyword slice-to append left-trim find-last-from clone-like 3sequence map-as last-index-from reversed index-from pad-left cut* nth sequence slice? <slice> tail-slice empty? tail* find-from member? virtual-sequence? unclip set-length drop-prefix bounds-error? set-slice-seq map start open-slice midpoint@ set-immutable-seq move-forward rest-slice prepend fourth delete set-slice-to new-sequence follow all-eq? monotonic? set-reversed-seq like delete-nth first4 repetition-len (open-slice) reverse slice padding virtual@ repetition? index 4sequence max-length set-second first2 first3 (3append) supremum unclip-slice move-backward tail 3append sequence-hashcode-step right-trim reversed-seq pad-right suffix concat set-slice-from flip filter sum immutable? 2sequence delete-all start* immutable-sequence? (append) check-slice sequence? head set-slice-error-reason reduce set-bounds-error-index reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check immutable find remove ((append)) set-fourth peek any? reversed? shorter? push-new find-last head-slice pop* immutable-seq tail-slice* accumulate each pusher all-equal? new-resizable cut-slice head-slice* 2reverse-each pop memq? set-nth ?nth <flat-slice> second change-each join set-repetition-len <reversed> all? virtual-sequence set-repetition-elt subseq? immutable-sequence slice-error-reason new-like length last-index push-if 2all? lengthen joined-length copy set-bounds-error-seq cache-nth move third first slice-from repetition-elt tail? set-first prefix bounds-error bounds-error-seq bounds-error-index <repetition> unfold exchange slice-seq cut 2reduce change-nth min-length set-third (delete) push-all head? delete-slice rest sum-lengths 2each head* infimum sequence-hashcode slice-error subseq replace-slice repetition push trim mismatch 
-syn keyword factorKeyword global +@ set-namestack with-variable on set bind dec namestack get get-global change init-namespaces with-scope off set-global namespace % make , inc counter building make-assoc 
-syn keyword factorKeyword <array> 3array >array 4array pair? array pair 2array 1array resize-array array? 
-syn keyword factorKeyword readln stream-read-until stream-read-partial stderr with-stream read with-stream* print contents make-span-stream write1 stream-write1 stream-format make-block-stream stream-copy with-cell stream-write format with-row stream-print stream-read with-nesting (stream-copy) bl write-object nl stream-nl write stdio flush read-until tabular-output make-cell-stream write-cell stream-flush read1 lines stream-read1 stream-write-table with-style stream-readln 
-syn keyword factorKeyword resize-string >string <string> 1string string string? 
-syn keyword factorKeyword vector? <vector> ?push vector >vector 1vector 
-syn keyword factorKeyword rethrow-restarts restarts recover set-restart-name set-continuation-name condition-continuation <restart> ifcc continuation-name condition-error set-restart-continuation ignore-errors continuation-retain continue <continuation> restart-continuation with-disposal set-continuation-catch set-condition-error restart-obj error thread-error-hook set-continuation-retain continuation rethrow callcc1 callcc0 condition continuation? continuation-call continuation-data set-condition-restarts set-catchstack >continuation< error-continuation cleanup restart? compute-restarts condition? error-thread set-continuation-call set-condition-continuation <condition> set-restart-obj dispose set-continuation-data throw-restarts catchstack continue-with attempt-all restart restart-name continuation-catch condition-restarts 
-
-
-syn cluster factorReal   contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal
-syn cluster factorNumber contains=@factorReal,factorComplex
-syn cluster factorNumErr contains=factorBinErr,factorHexErr,factorOctErr
-syn match   factorInt          /\<-\=\d\+\>/
-syn match   factorFloat                /\<-\=\d*\.\d\+\>/
-syn match   factorRatio                /\<-\=\d*\.*\d\+\/-\=\d*\.*\d\+\>/
-syn region  factorComplex      start=/\<C{\>/ end=/\<}\>/ contains=@factorReal
+syn keyword factorKeyword or tuck 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry roll tri-curry* swap tri-curry@ 2nip and throw set-retainstack bi-curry (clone) hashcode* compose spin 2dip if 3tri unless compose? tuple keep 2curry equal? set-datastack assert tri 2drop most <wrapper> boolean? identity-tuple? null new set-callstack dip bi-curry@ rot -roll xor identity-tuple boolean
+syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map <enum> assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? at-default unzip
+syn keyword factorKeyword case execute-effect dispatch-case-quot <buckets> no-cond no-case? 3cleave>quot contiguous-range? 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case hash-dispatch-quot case>quot 3cleave wrong-values alist>quot hash-case-table hash-case-quot case-find (distribute-buckets) cond cleave distribute-buckets call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot
+syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex <fp-nan> < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float 1+ 1- fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f
+syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter-here last-index-from prepare-index reversed index-from cut* pad-tail (indices) concat-as remq but-last snip trim-tail nths nth 2pusher sequence slice? <slice> partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length delq drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift delete sigma new-sequence follow like delete-nth first4 1sequence reverse slice unless-empty padding virtual@ repetition? index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head replicate set-fourth peek shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode memq? pop set-nth ?nth <flat-slice> second change-each join when-empty accumulator immutable-sequence? <reversed> all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? <repetition> trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim
+syn keyword factorKeyword global +@ change set-namestack change-global init-namespaces on off set-global namespace set with-scope bind with-variable inc dec counter initialize namestack get get-global make-assoc
+syn keyword factorKeyword <array> 2array 3array pair >array 1array 4array pair? array resize-array array?
+syn keyword factorKeyword +character+ bad-seek-type? readln stream-seek read print with-output-stream contents write1 stream-write1 stream-copy stream-element-type with-input-stream stream-print stream-read stream-contents bl seek-output bad-seek-type nl stream-nl write flush stream-lines +byte+ stream-flush read1 seek-absolute? stream-read1 lines stream-readln stream-read-until each-line seek-end with-output-stream* seek-absolute with-streams seek-input seek-relative? input-stream stream-write read-partial seek-end? seek-relative error-stream read-until with-input-stream* with-streams* each-block output-stream stream-read-partial
+syn keyword factorKeyword resize-string >string <string> 1string string string?
+syn keyword factorKeyword vector? <vector> ?push vector >vector 1vector
+syn keyword factorKeyword with-return restarts return-continuation with-datastack recover rethrow-restarts <restart> ifcc set-catchstack >continuation< cleanup ignore-errors restart? compute-restarts attempt-all-error error-thread continue <continuation> attempt-all-error? condition? <condition> throw-restarts error catchstack continue-with thread-error-hook continuation rethrow callcc1 error-continuation callcc0 attempt-all condition continuation? restart return
+
+
+syn cluster factorReal          contains=factorInt,factorFloat,factorRatio,factorBinary,factorHex,factorOctal
+syn cluster factorNumber        contains=@factorReal,factorComplex
+syn cluster factorNumErr        contains=factorBinErr,factorHexErr,factorOctErr
+syn match   factorInt           /\<-\=\d\+\>/
+syn match   factorFloat         /\<-\=\d*\.\d\+\>/
+syn match   factorRatio         /\<-\=\d*\.*\d\+\/-\=\d*\.*\d\+\>/
+syn region  factorComplex       start=/\<C{\>/ end=/\<}\>/ contains=@factorReal
 syn match   factorBinErr        /\<BIN:\s\+[01]*[^\s01]\S*\>/
 syn match   factorBinary        /\<BIN:\s\+[01]\+\>/
 syn match   factorHexErr        /\<HEX:\s\+\x*[^\x\s]\S*\>/
@@ -75,31 +73,36 @@ syn match   factorHex           /\<HEX:\s\+\x\+\>/
 syn match   factorOctErr        /\<OCT:\s\+\o*[^\o\s]\S*\>/
 syn match   factorOctal         /\<OCT:\s\+\o\+\>/
 
-syn match factorIn /\<IN:\s\+\S\+\>/
-syn match factorUse /\<USE:\s\+\S\+\>/
+syn match   factorIn            /\<IN:\s\+\S\+\>/
+syn match   factorUse           /\<USE:\s\+\S\+\>/
+syn match   factorUnuse         /\<UNUSE:\s\+\S\+\>/
 
-syn match factorCharErr /\<CHAR:\s\+\S\+/
-syn match factorChar /\<CHAR:\s\+\\\=\S\>/
+syn match   factorCharErr       /\<CHAR:\s\+\S\+/
+syn match   factorChar          /\<CHAR:\s\+\\\=\S\>/
 
-syn match factorBackslash /\<\\\>\s\+\S\+\>/
+syn match   factorBackslash     /\<\\\>\s\+\S\+\>/
 
-syn region factorUsing start=/\<USING:\>/ end=/;/
-syn region factorRequires start=/\<REQUIRES:\>/ end=/;/
+syn region  factorUsing         start=/\<USING:\>/       end=/;/
+syn region  factorSingletons    start=/\<SINGLETONS:\>/  end=/;/
+syn match   factorSymbol        /\<SYMBOL:\s\+\S\+\>/
+syn region  factorSymbols       start=/\<SYMBOLS:\>/     end=/;/
+syn region  factorConstructor2  start=/\<CONSTRUCTOR:\?/ end=/;/
+syn region  factorTuple         start=/\<TUPLE:\>/ end=/\<;\>/
 
-syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
-syn match factorSymbol /\<SYMBOL:\s\+\S\+\>/
-syn match factorPostpone /\<POSTPONE:\s\+\S\+\>/
-syn match factorDefer /\<DEFER:\s\+\S\+\>/
-syn match factorForget /\<FORGET:\s\+\S\+\>/
-syn match factorMixin /\<MIXIN:\s\+\S\+\>/
-syn match factorInstance /\<INSTANCE:\s\+\S\+\s\+\S\+\>/
-syn match factorHook /\<HOOK:\s\+\S\+\s\+\S\+\>/
-syn match factorMain /\<MAIN:\s\+\S\+\>/
-syn match factorConstructor /\<C:\s\+\S\+\s\+\S\+\>/
+syn match   factorConstant      /\<CONSTANT:\s\+\S\+\>/
+syn match   factorSingleton     /\<SINGLETON:\s\+\S\+\>/
+syn match   factorPostpone      /\<POSTPONE:\s\+\S\+\>/
+syn match   factorDefer         /\<DEFER:\s\+\S\+\>/
+syn match   factorForget        /\<FORGET:\s\+\S\+\>/
+syn match   factorMixin         /\<MIXIN:\s\+\S\+\>/
+syn match   factorInstance      /\<INSTANCE:\s\+\S\+\s\+\S\+\>/
+syn match   factorHook          /\<HOOK:\s\+\S\+\s\+\S\+\>/
+syn match   factorMain          /\<MAIN:\s\+\S\+\>/
+syn match   factorConstructor   /\<C:\s\+\S\+\s\+\S\+\>/
+syn match   factorAlien         /\<ALIEN:\s\+\d\+\>/
 
-syn match factorAlien /\<ALIEN:\s\+\d\+\>/
+syn cluster factorWordOps       contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor
 
-syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
 
 "TODO:
 "misc:
@@ -118,6 +121,12 @@ syn region factorTuple start=/\<TUPLE:\>/ end=/\<;\>/
 " TYPEDEF:
 " LIBRARY:
 " C-UNION:
+"QUALIFIED:
+"QUALIFIED-WITH:
+"FROM:
+"ALIAS:
+"! POSTPONE: "
+"#\ "
 
 syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline
 syn region factorSbuf start=/SBUF" / skip=/\\"/ end=/"/ oneline
@@ -131,18 +140,18 @@ syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained
 
 "adapted from lisp.vim
 if exists("g:factor_norainbow") 
-    syn region factorQuotation0 matchgroup=factorDelimiter start=/\<\'\?\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
+    syn region factorQuotation matchgroup=factorDelimiter start=/\<\[\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
 else
-    syn region factorQuotation0           matchgroup=hlLevel0 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
-    syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
-    syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
-    syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
-    syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
-    syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
-    syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
-    syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
-    syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
-    syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\'\?\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
+    syn region factorQuotation0           matchgroup=hlLevel0 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
+    syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
+    syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
+    syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
+    syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
+    syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
+    syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
+    syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
+    syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
+    syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\[\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
 endif
 
 if exists("g:factor_norainbow") 
@@ -167,88 +176,92 @@ syn sync lines=100
 
 if version >= 508 || !exists("did_factor_syn_inits")
     if version <= 508
-       let did_factor_syn_inits = 1
-       command -nargs=+ HiLink hi link <args>
+        let did_factor_syn_inits = 1
+        command -nargs=+ HiLink hi link <args>
     else
-       command -nargs=+ HiLink hi def link <args>
+        command -nargs=+ HiLink hi def link <args>
     endif
 
-    HiLink factorComment       Comment
-    HiLink factorStackEffect   Typedef
-    HiLink factorTodo          Todo
-    HiLink factorInclude       Include
-    HiLink factorRepeat                Repeat
-    HiLink factorConditional   Conditional
-    HiLink factorKeyword       Keyword
-    HiLink factorOperator      Operator
-    HiLink factorBoolean       Boolean
-    HiLink factorDefnDelims    Typedef
-    HiLink factorMethodDelims  Typedef
-    HiLink factorGenericDelims        Typedef
-    HiLink factorGenericNDelims        Typedef
-    HiLink factorConstructor   Typedef
-    HiLink factorPrivate       Special
-    HiLink factorPrivateDefnDelims     Special
-    HiLink factorPrivateMethodDelims   Special
-    HiLink factorPGenericDelims        Special
+    HiLink factorComment                Comment
+    HiLink factorStackEffect            Typedef
+    HiLink factorTodo                   Todo
+    HiLink factorInclude                Include
+    HiLink factorRepeat                 Repeat
+    HiLink factorConditional            Conditional
+    HiLink factorKeyword                Keyword
+    HiLink factorOperator               Operator
+    HiLink factorBoolean                Boolean
+    HiLink factorDefnDelims             Typedef
+    HiLink factorMethodDelims           Typedef
+    HiLink factorGenericDelims          Typedef
+    HiLink factorGenericNDelims         Typedef
+    HiLink factorConstructor            Typedef
+    HiLink factorConstructor2           Typedef
+    HiLink factorPrivate                Special
+    HiLink factorPrivateDefnDelims      Special
+    HiLink factorPrivateMethodDelims    Special
+    HiLink factorPGenericDelims         Special
     HiLink factorPGenericNDelims        Special
-    HiLink factorString                String
-    HiLink factorSbuf          String
-    HiLink factorMultiStringContents           String
-    HiLink factorMultiStringDelims Typedef
-    HiLink factorBracketErr     Error
-    HiLink factorComplex       Number
-    HiLink factorRatio          Number
-    HiLink factorBinary         Number
-    HiLink factorBinErr         Error
-    HiLink factorHex            Number
-    HiLink factorHexErr         Error
-    HiLink factorOctal          Number
-    HiLink factorOctErr         Error
-    HiLink factorFloat         Float
-    HiLink factorInt           Number
-    HiLink factorUsing          Include
-    HiLink factorUse            Include
-    HiLink factorRequires       Include
-    HiLink factorIn             Define
-    HiLink factorChar           Character
-    HiLink factorCharErr        Error
-    HiLink factorDelimiter      Delimiter
-    HiLink factorBackslash      Special
-    HiLink factorCompileDirective Typedef
-    HiLink factorSymbol         Define
-    HiLink factorMixin         Typedef
-    HiLink factorInstance         Typedef
-    HiLink factorHook         Typedef
-    HiLink factorMain         Define
-    HiLink factorPostpone       Define
-    HiLink factorDefer          Define
-    HiLink factorForget         Define
-    HiLink factorAlien          Define
-    HiLink factorTuple          Typedef
+    HiLink factorString                 String
+    HiLink factorSbuf                   String
+    HiLink factorMultiStringContents    String
+    HiLink factorMultiStringDelims      Typedef
+    HiLink factorBracketErr             Error
+    HiLink factorComplex                Number
+    HiLink factorRatio                  Number
+    HiLink factorBinary                 Number
+    HiLink factorBinErr                 Error
+    HiLink factorHex                    Number
+    HiLink factorHexErr                 Error
+    HiLink factorOctal                  Number
+    HiLink factorOctErr                 Error
+    HiLink factorFloat                  Float
+    HiLink factorInt                    Number
+    HiLink factorUsing                  Include
+    HiLink factorUse                    Include
+    HiLink factorUnuse                  Include
+    HiLink factorIn                     Define
+    HiLink factorChar                   Character
+    HiLink factorCharErr                Error
+    HiLink factorDelimiter              Delimiter
+    HiLink factorBackslash              Special
+    HiLink factorCompileDirective       Typedef
+    HiLink factorSymbol                 Define
+    HiLink factorConstant               Define
+    HiLink factorSingleton              Define
+    HiLink factorSingletons             Define
+    HiLink factorMixin                  Typedef
+    HiLink factorInstance               Typedef
+    HiLink factorHook                   Typedef
+    HiLink factorMain                   Define
+    HiLink factorPostpone               Define
+    HiLink factorDefer                  Define
+    HiLink factorForget                 Define
+    HiLink factorAlien                  Define
+    HiLink factorTuple                  Typedef
 
     if &bg == "dark"
-       hi   hlLevel0 ctermfg=red         guifg=red1
-       hi   hlLevel1 ctermfg=yellow      guifg=orange1
-       hi   hlLevel2 ctermfg=green       guifg=yellow1
-       hi   hlLevel3 ctermfg=cyan        guifg=greenyellow
-       hi   hlLevel4 ctermfg=magenta     guifg=green1
-       hi   hlLevel5 ctermfg=red         guifg=springgreen1
-       hi   hlLevel6 ctermfg=yellow      guifg=cyan1
-       hi   hlLevel7 ctermfg=green       guifg=slateblue1
-       hi   hlLevel8 ctermfg=cyan        guifg=magenta1
-       hi   hlLevel9 ctermfg=magenta     guifg=purple1
+        hi   hlLevel0 ctermfg=red         guifg=red1
+        hi   hlLevel1 ctermfg=yellow      guifg=orange1
+        hi   hlLevel2 ctermfg=green       guifg=yellow1
+        hi   hlLevel3 ctermfg=cyan        guifg=greenyellow
+        hi   hlLevel4 ctermfg=magenta     guifg=green1
+        hi   hlLevel5 ctermfg=red         guifg=springgreen1
+        hi   hlLevel6 ctermfg=yellow      guifg=cyan1
+        hi   hlLevel7 ctermfg=green       guifg=slateblue1
+        hi   hlLevel8 ctermfg=cyan        guifg=magenta1
+        hi   hlLevel9 ctermfg=magenta     guifg=purple1
     else
-       hi   hlLevel0 ctermfg=red         guifg=red3
-       hi   hlLevel1 ctermfg=darkyellow  guifg=orangered3
-       hi   hlLevel2 ctermfg=darkgreen   guifg=orange2
-       hi   hlLevel3 ctermfg=blue        guifg=yellow3
-       hi   hlLevel4 ctermfg=darkmagenta guifg=olivedrab4
-       hi   hlLevel5 ctermfg=red         guifg=green4
-       hi   hlLevel6 ctermfg=darkyellow  guifg=paleturquoise3
-       hi   hlLevel7 ctermfg=darkgreen   guifg=deepskyblue4
-       hi   hlLevel8 ctermfg=blue        guifg=darkslateblue
-       hi   hlLevel9 ctermfg=darkmagenta guifg=darkviolet
+        hi   hlLevel0 ctermfg=red         guifg=red3
+        hi   hlLevel1 ctermfg=darkyellow  guifg=orangered3
+        hi   hlLevel2 ctermfg=darkgreen   guifg=orange2
+        hi   hlLevel3 ctermfg=blue        guifg=yellow3
+        hi   hlLevel4 ctermfg=darkmagenta guifg=olivedrab4
+        hi   hlLevel5 ctermfg=red         guifg=green4
+        hi   hlLevel6 ctermfg=darkyellow  guifg=paleturquoise3
+        hi   hlLevel7 ctermfg=darkgreen   guifg=deepskyblue4
+        hi   hlLevel8 ctermfg=blue        guifg=darkslateblue
+        hi   hlLevel9 ctermfg=darkmagenta guifg=darkviolet
     endif
 
     delcommand HiLink
@@ -262,4 +275,3 @@ set expandtab
 set autoindent " annoying?
 
 " vim: syntax=vim
-
index 608a5c39e5c1b0d777408e2b4158ec39b20e3349..39988ae976406eb35033402ea5a336a684ddf3b1 100755 (executable)
@@ -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);
-
-                       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());
        }
 };
 
@@ -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)
index d92e5f69e0edd2bb31b3f42d1d8423bf0a43618e..a3cc058e2b63476a4a9bdec4ee983fde53d6ef59 100755 (executable)
@@ -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);
+       }
 }
 
 }
index 3fe89cb5582dbf2a643d7fa6509534c72e88d5e4..7736143c50cf924c9cb921ee84e226843e99e332 100755 (executable)
@@ -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)); }
 };