! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io io.binary io.files io.streams.byte-array math
+USING: alien.c-types kernel io io.binary io.files io.streams.byte-array math
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
: update-md5 ( md5 -- )
[ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
- [ (>>old-state) ] [ (>>state) ] bi ; inline
+ [ (>>old-state) ] [ (>>state) ] bi ;
CONSTANT: T
$[
[ 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 -- )
{
[ 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 -- )
{
[ 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 -- )
{
[ 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 } ;
+
+: byte-array>le ( byte-array -- byte-array )
+ little-endian? [
+ dup 4 <sliced-groups> [
+ [ [ 1 2 ] dip exchange-unsafe ]
+ [ [ 0 3 ] dip exchange-unsafe ] bi
+ ] each
+ ] unless ;
+
+: byte-array>uint-array-le ( byte-array -- uint-array )
+ byte-array>le byte-array>uint-array ;
+
+HINTS: byte-array>uint-array-le byte-array ;
+
+: uint-array>byte-array-le ( uint-array -- byte-array )
+ underlying>> byte-array>le ;
+
+HINTS: uint-array>byte-array-le uint-array ;
M: md5-state checksum-block ( block state -- )
[
- [ byte-array>uint-array ] [ state>> ] bi* {
+ [ byte-array>uint-array-le ] [ state>> ] bi* {
[ (process-md5-block-F) ]
[ (process-md5-block-G) ]
[ (process-md5-block-H) ]
nip update-md5
] 2bi ;
-: md5>checksum ( md5 -- bytes ) state>> underlying>> ;
+: md5>checksum ( md5 -- bytes ) state>> uint-array>byte-array-le ;
M: md5-state clone ( md5 -- new-md5 )
call-next-method
\ +-integer-fixnum inlined?
] unit-test
-[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
-
[ t ] [
[
[ no-cond ] 1
: eliminate-phi-introductions ( introductions seq terminated -- seq' )
[
[ nip ] [
- dup [ +bottom+ eq? ] trim-head
+ dup [ +top+ eq? ] trim-head
[ [ length ] bi@ - tail* ] keep append
] if
] 3map ;
[ flatten-values ] change-in-r ;
M: #phi unbox-tuples*
+ ! pad-with-bottom is only needed if some branches are terminated,
+ ! which means all output values are bottom
[ [ flatten-values ] map pad-with-bottom ] change-phi-in-d
[ flatten-values ] change-out-d ;
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
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
[
[ ] [ "<%\n%>" parse-template drop ] unit-test
] with-file-vocabs
+
+[
+ [ ] [
+ <"
+ <%
+ IN: html.templates.fhtml.tests
+ : test-word ( -- ) ;
+ %>
+ "> parse-template drop
+ ] unit-test
+] with-file-vocabs
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
: 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( -- ) ;
: 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 ;
{ $code\r
"USE: io.monitors"\r
": watch-loop ( monitor -- )"\r
- " dup next-change . nl nl flush watch-loop ;"\r
+ " dup next-change path>> print nl nl flush watch-loop ;"\r
""\r
": watch-directory ( path -- )"\r
- " [ t [ watch-loop ] with-monitor ] with-monitors"\r
+ " [ t [ watch-loop ] with-monitor ] with-monitors ;"\r
} ;\r
\r
ABOUT: "io.monitors"\r
: run-monitor ( path recursive? quot -- )
'[ [ @ t ] loop ] with-monitor ; inline
-: spawn-monitor ( path recursive? quot -- )
- [ '[ _ _ _ run-monitor ] ] [ 2drop "Monitoring " prepend ] 3bi
- spawn drop ;
{
{ [ os macosx? ] [ "io.monitors.macosx" require ] }
{ [ os linux? ] [ "io.monitors.linux" require ] }
: 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* ;
+
+: v~ ( a b epsilon -- ? )
+ [ ~ ] curry 2all? ;
+
HINTS: vneg { array } ;
HINTS: norm-sq { array } ;
HINTS: norm { array } ;
-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 math.bitwise ;
IN: random.windows
TUPLE: windows-rng provider type ;
M: windows-crypto-context dispose ( tuple -- )
handle>> 0 CryptReleaseContext win32-error=0/f ;
-: factor-crypto-container ( -- string ) "FactorCryptoContainer" ; inline
+CONSTANT: factor-crypto-container "FactorCryptoContainer"
-:: (acquire-crypto-context) ( provider type flags -- handle )
- [let | handle [ "HCRYPTPROV" <c-object> ] |
- handle
- factor-crypto-container
- provider
- type
- flags
- CryptAcquireContextW win32-error=0/f
- handle *void* ] ;
+:: (acquire-crypto-context) ( provider type flags -- handle ret )
+ "HCRYPTPROV" <c-object> :> handle
+ handle
+ factor-crypto-container
+ provider
+ type
+ flags
+ CryptAcquireContextW handle swap ;
: acquire-crypto-context ( provider type -- handle )
- [ 0 (acquire-crypto-context) ]
- [ drop CRYPT_NEWKEYSET (acquire-crypto-context) ] recover ;
+ CRYPT_MACHINE_KEYSET
+ (acquire-crypto-context)
+ 0 = [
+ GetLastError NTE_BAD_KEYSET =
+ [ drop f ] [ win32-error-string throw ] if
+ ] [
+ *void*
+ ] if ;
+: create-crypto-context ( provider type -- handle )
+ { CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET } flags
+ (acquire-crypto-context) win32-error=0/f *void* ;
+
+ERROR: acquire-crypto-context-failed provider type ;
+
+: attempt-crypto-context ( provider type -- handle )
+ {
+ [ acquire-crypto-context ]
+ [ create-crypto-context ]
+ [ acquire-crypto-context-failed ]
+ } 2|| ;
: windows-crypto-context ( provider type -- context )
- acquire-crypto-context <windows-crypto-context> ;
+ attempt-crypto-context <windows-crypto-context> ;
M: windows-rng random-bytes* ( n tuple -- bytes )
[
MS_DEF_PROV
PROV_RSA_FULL <windows-rng> system-random-generator set-global
- MS_STRONG_PROV
- PROV_RSA_FULL <windows-rng> secure-random-generator set-global
+ [ MS_STRONG_PROV PROV_RSA_FULL <windows-rng> ]
+ [ drop MS_ENH_RSA_AES_PROV PROV_RSA_AES <windows-rng> ] recover
+ secure-random-generator set-global
- ! MS_ENH_RSA_AES_PROV
- ! PROV_RSA_AES <windows-rng> secure-random-generator set-global
] "random.windows" add-init-hook
: balanced? ( pairs -- ? )
[ second ] filter [ first2 length - ] map all-equal? ;
-SYMBOL: +bottom+
+SYMBOLS: +bottom+ +top+ ;
: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
- dup [ [ - +bottom+ <repetition> ] dip append ] [ 3drop f ] if ;
+ ! Introduced values can be anything, and don't unify with
+ ! literals.
+ dup [ [ - +top+ <repetition> ] dip append ] [ 3drop f ] if ;
: pad-with-bottom ( seq -- newseq )
+ ! Terminated branches are padded with bottom values which
+ ! unify with literals.
dup empty? [
dup [ length ] [ max ] map-reduce
'[ _ +bottom+ pad-head ] map
\ compose f "no-compile" set-word-prop
! More words not to compile
-\ call t "no-compile" set-word-prop
-\ execute t "no-compile" set-word-prop
\ clear t "no-compile" set-word-prop
: non-inline-word ( word -- )
[ [ bi ] infer ] must-fail
[ at ] must-infer
-[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer
\ No newline at end of file
+[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer
+
+! Found during code review
+[ [ [ drop [ ] ] when call ] infer ] must-fail
+[ swap [ [ drop [ ] ] when call ] infer ] must-fail
\ No newline at end of file
: compose-n ( quot n -- ) "OOPS" throw ;
<<
-: compose-n-quot ( word n -- quot' ) <repetition> >quotation ;
+: compose-n-quot ( n word -- quot' ) <repetition> >quotation ;
\ compose-n [ compose-n-quot ] 2 define-transform
\ compose-n t "no-compile" set-word-prop
>>
--- /dev/null
+IN: tuple-arrays
+USING: help.markup help.syntax sequences ;
+
+HELP: TUPLE-ARRAY:
+{ $syntax "TUPLE-ARRAY: class" }
+{ $description "Generates a new data type in the current vocabulary named " { $snippet { $emphasis "class" } "-array" } " for holding instances of " { $snippet "class" } ", which must be a tuple class word. Together with the class itself, this also generates words named " { $snippet "<" { $emphasis "class" } "-array>" } " and " { $snippet ">" { $emphasis "class" } "-array" } ", for creating new instances of this tuple array type." } ;
+
+ARTICLE: "tuple-arrays" "Tuple arrays"
+"The " { $vocab-link "tuple-arrays" } " vocabulary implements space-efficient unboxed tuple arrays. Whereas an ordinary array of tuples would consist of pointers to heap-allocated objects, a tuple array stores its elements inline. Calling " { $link nth } " copies an element into a new tuple, and calling " { $link set-nth } " copies an existing tuple's slots into an array."
+$nl
+"Since value semantics differ from reference semantics, it is best to use tuple arrays with tuples where all slots are declared " { $link read-only } "."
+$nl
+"Tuple arrays should not be used with inheritance; storing an instance of a subclass in a tuple array will slice off the subclass slots, and getting the same value out again will yield an instance of the superclass. Also, tuple arrays do not get updated if tuples are redefined to add or remove slots, so caution should be exercised when doing interactive development on code that uses tuple arrays."
+{ $subsection POSTPONE: TUPLE-ARRAY: }
+"An example:"
+{ $example
+ "USE: tuple-arrays"
+ "IN: scratchpad"
+ "TUPLE: point x y ;"
+ "TUPLE-ARRAY: point"
+ "{ T{ point f 1 2 } T{ point f 1 3 } T{ point f 2 3 } } >point-array first short."
+ "T{ point f 1 2 }"
+} ;
+
+ABOUT: "tuple-arrays"
\ No newline at end of file
[ new ] [ smart-tuple>array ] bi ; inline
: tuple-slice ( n seq -- slice )
- [ n>> [ * dup ] keep + ] [ seq>> ] bi { array } declare slice boa ; inline
+ [ n>> [ * dup ] keep + ] [ seq>> ] bi slice boa ; inline
: read-tuple ( slice class -- tuple )
'[ _ boa-unsafe ] input<sequence-unsafe ; inline
{ samples { $ WGL_SAMPLES_ARB } }
}
-MEMO: (has-wglChoosePixelFormatARB?) ( dc -- ? )
- { "WGL_ARB_pixel_format" } has-wgl-extensions? ;
: has-wglChoosePixelFormatARB? ( world -- ? )
- handle>> hDC>> (has-wglChoosePixelFormatARB?) ;
+ drop f ;
: arb-make-pixel-format ( world attributes -- pf )
[ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 0 <int> 0 <int>
-USING: alien.syntax kernel math windows.types math.bitwise ;
+USING: alien.syntax kernel math windows.types windows.kernel32
+math.bitwise ;
IN: windows.advapi32
LIBRARY: advapi32
CONSTANT: SE_GROUP_OWNER 8
CONSTANT: SE_GROUP_LOGON_ID -1073741824
+CONSTANT: NTE_BAD_UID HEX: 80090001
+CONSTANT: NTE_BAD_HASH HEX: 80090002
+CONSTANT: NTE_BAD_KEY HEX: 80090003
+CONSTANT: NTE_BAD_LEN HEX: 80090004
+CONSTANT: NTE_BAD_DATA HEX: 80090005
+CONSTANT: NTE_BAD_SIGNATURE HEX: 80090006
+CONSTANT: NTE_BAD_VER HEX: 80090007
+CONSTANT: NTE_BAD_ALGID HEX: 80090008
+CONSTANT: NTE_BAD_FLAGS HEX: 80090009
+CONSTANT: NTE_BAD_TYPE HEX: 8009000A
+CONSTANT: NTE_BAD_KEY_STATE HEX: 8009000B
+CONSTANT: NTE_BAD_HASH_STATE HEX: 8009000C
+CONSTANT: NTE_NO_KEY HEX: 8009000D
+CONSTANT: NTE_NO_MEMORY HEX: 8009000E
+CONSTANT: NTE_EXISTS HEX: 8009000F
+CONSTANT: NTE_PERM HEX: 80090010
+CONSTANT: NTE_NOT_FOUND HEX: 80090011
+CONSTANT: NTE_DOUBLE_ENCRYPT HEX: 80090012
+CONSTANT: NTE_BAD_PROVIDER HEX: 80090013
+CONSTANT: NTE_BAD_PROV_TYPE HEX: 80090014
+CONSTANT: NTE_BAD_PUBLIC_KEY HEX: 80090015
+CONSTANT: NTE_BAD_KEYSET HEX: 80090016
+CONSTANT: NTE_PROV_TYPE_NOT_DEF HEX: 80090017
+CONSTANT: NTE_PROV_TYPE_ENTRY_BAD HEX: 80090018
+CONSTANT: NTE_KEYSET_NOT_DEF HEX: 80090019
+CONSTANT: NTE_KEYSET_ENTRY_BAD HEX: 8009001A
+CONSTANT: NTE_PROV_TYPE_NO_MATCH HEX: 8009001B
+CONSTANT: NTE_SIGNATURE_FILE_BAD HEX: 8009001C
+CONSTANT: NTE_PROVIDER_DLL_FAIL HEX: 8009001D
+CONSTANT: NTE_PROV_DLL_NOT_FOUND HEX: 8009001E
+CONSTANT: NTE_BAD_KEYSET_PARAM HEX: 8009001F
+CONSTANT: NTE_FAIL HEX: 80090020
+CONSTANT: NTE_SYS_ERR HEX: 80090021
+
! SID is a variable length structure
TYPEDEF: void* PSID
{ $heading "Utilities for simple make patterns" }
"Sometimes, an existing word already implements a specific " { $link make } " usage. For example, " { $link suffix } " is equivalent to the following, with the added caveat that the below example always outputs an array:"
{ $code "[ , % ] { } make" }
-"The existing utility words can in some cases express intent better than an arbitrary-looking string or " { $link , } " and " { $link % } "."
+"The existing utility words can in some cases express intent better than a bunch of " { $link , } " and " { $link % } "."
{ $heading "Constructing quotations" }
"Simple quotation construction can often be accomplished using " { $link "fry" } " and " { $link "compositional-combinators" } "."
$nl
[ f ] [ 0 <fp-nan> fp-nan? ] unit-test
[ t ] [ 0 <fp-nan> fp-infinity? ] unit-test
+[ t ] [ 0.0 neg -0.0 fp-bitwise= ] unit-test
+[ t ] [ -0.0 neg 0.0 fp-bitwise= ] unit-test
+
[ 0.0 ] [ -0.0 next-float ] unit-test
[ t ] [ 1.0 dup next-float < ] unit-test
[ t ] [ -1.0 dup next-float < ] unit-test
: 1- ( x -- y ) 1 - ; inline
: 2/ ( x -- y ) -1 shift ; inline
: sq ( x -- y ) dup * ; inline
-: neg ( x -- -x ) 0 swap - ; inline
+: neg ( x -- -x ) -1 * ; inline
: recip ( x -- y ) 1 swap / ; inline
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
: ?1+ ( x -- y ) [ 1 + ] [ 0 ] if* ; inline
[
"USE: kernel UNUSE: kernel dup" <string-reader> "unuse-test" parse-stream
-] [ error>> error>> error>> no-word-error? ] must-fail-with
\ No newline at end of file
+] [ error>> error>> error>> no-word-error? ] must-fail-with
+
+[ ] [ [ "vocabs.loader.test.l" forget-vocab ] with-compilation-unit ] unit-test
+
+[
+ [ "vocabs.loader.test.l" use-vocab ] must-fail
+ [ f ] [ "vocabs.loader.test.l" manifest get search-vocab-names>> key? ] unit-test
+ [ ] [ "vocabs.loader.test.l" unuse-vocab ] unit-test
+ [ f ] [ "vocabs.loader.test.l" manifest get search-vocab-names>> key? ] unit-test
+] with-file-vocabs
--- /dev/null
+IN: vocabs.loader.test.l
+USE: kernel
+
+"Oops" throw
\ No newline at end of file
--- /dev/null
+unportable
dup using-vocab?
[ vocab-name "Already using ``" "'' vocabulary" surround note. ] [
manifest get
- [ [ vocab-name ] dip search-vocab-names>> conjoin ]
[ [ load-vocab ] dip search-vocabs>> push ]
+ [ [ vocab-name ] dip search-vocab-names>> conjoin ]
2bi
] if ;
: unuse-vocab ( vocab -- )
dup using-vocab? [
manifest get
- [ [ vocab-name ] dip search-vocab-names>> delete-at ]
[ [ load-vocab ] dip search-vocabs>> delq ]
+ [ [ vocab-name ] dip search-vocab-names>> delete-at ]
2bi
] [ drop ] if ;
! 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
--- /dev/null
+! (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 ;
+
T{ tag f "head" H{ } f t }
}
] [ "<head<title>Spagna</title></head" parse-html ] unit-test
+
+[
+V{
+ T{ tag
+ { name dtd }
+ { text
+ "DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Draft//EN\""
+ }
+ }
+}
+]
+[
+ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Draft//EN\">"
+ parse-html
+] unit-test
+
+[
+V{
+ T{ tag { name comment } { text "comment" } }
+}
+] [
+ "<!--comment-->" parse-html
+] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables sequence-parser
-html.parser.utils kernel namespaces sequences
+html.parser.utils kernel namespaces sequences math
unicode.case unicode.categories combinators.short-circuit
quoting fry ;
IN: html.parser
[ blank? ] trim ;
: read-comment ( sequence-parser -- )
- "-->" take-until-sequence comment new-tag push-tag ;
+ [ "-->" take-until-sequence comment new-tag push-tag ]
+ [ '[ _ advance drop ] 3 swap times ] bi ;
: read-dtd ( sequence-parser -- )
- ">" take-until-sequence dtd new-tag push-tag ;
+ [ ">" take-until-sequence dtd new-tag push-tag ]
+ [ advance drop ] bi ;
: read-bang ( sequence-parser -- )
advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel calendar io.directories io.encodings.utf8
-io.files io.launcher namespaces prettyprint mason.child mason.cleanup
-mason.common mason.help mason.release mason.report mason.email
-mason.notify ;
-IN: mason.build
-
+io.files io.launcher namespaces prettyprint combinators mason.child
+mason.cleanup mason.common mason.help mason.release mason.report
+mason.email mason.notify ;
QUALIFIED: continuations
+IN: mason.build
: create-build-dir ( -- )
now datestamp stamp set
"git" "clone" builds/factor 3array short-running-process ;
: begin-build ( -- )
- "factor" [ git-id ] with-directory
- [ "git-id" to-file ]
- [ current-git-id set ]
- [ notify-begin-build ]
- tri ;
+ "factor" [ git-id ] with-directory {
+ [ "git-id" to-file ]
+ [ "factor/git-id" to-file ]
+ [ current-git-id set ]
+ [ notify-begin-build ]
+ } cleave ;
: build ( -- )
create-build-dir
MACRO: recover-cond ( alist -- )
dup { [ length 1 = ] [ first callable? ] } 1&&
- [ first ] [ [ first first2 ] [ rest ] bi '[ _ _ [ _ recover-cond ] recover-else ] ] if ;
+ [ first ] [
+ [ first first2 ] [ rest ] bi
+ '[ _ _ [ _ recover-cond ] recover-else ]
+ ] if ;
: build-child ( -- status )
copy-image
-! 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
io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
combinators.short-circuit parser combinators calendar
calendar.format arrays mason.config locals debugger fry
-continuations strings ;
+continuations strings io.sockets ;
IN: mason.common
+: short-host-name ( -- string )
+ host-name "." split1 drop ;
+
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 -- )
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 )
[
"ssh" , status-host get , "-l" , status-username get ,
"./mason-notify" ,
- host-name ,
+ short-host-name ,
target-cpu get ,
target-os get ,
] { } make prepend
[ 5 ] 2dip '[
<process>
- _ [ +closed+ ] unless* >>stdin
+ _ >>stdin
_ >>command
short-running-process
] retry
] bi ;
: notify-release ( archive-name -- )
- "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ;
+ [ "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ]
+ [ f swap "release" swap 2array status-notify ]
+ bi ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.smart command-line db
-db.sqlite db.tuples db.types io kernel namespaces sequences ;
+db.sqlite db.tuples db.types io io.encodings.utf8 io.files
+present kernel namespaces sequences calendar ;
IN: mason.notify.server
CONSTANT: +starting+ "starting"
CONSTANT: +make-vm+ "make-vm"
CONSTANT: +boot+ "boot"
CONSTANT: +test+ "test"
-CONSTANT: +clean+ "clean"
-CONSTANT: +dirty+ "dirty"
-
-TUPLE: builder host-name os cpu clean-git-id last-git-id last-report current-git-id status ;
+CONSTANT: +clean+ "status-clean"
+CONSTANT: +dirty+ "status-dirty"
+CONSTANT: +error+ "status-error"
+
+TUPLE: builder
+host-name os cpu
+clean-git-id clean-timestamp
+last-release release-git-id
+last-git-id last-timestamp last-report
+current-git-id current-timestamp
+status ;
builder "BUILDERS" {
{ "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
{ "os" "OS" TEXT +user-assigned-id+ }
{ "cpu" "CPU" TEXT +user-assigned-id+ }
+
{ "clean-git-id" "CLEAN_GIT_ID" TEXT }
+ { "clean-timestamp" "CLEAN_TIMESTAMP" TIMESTAMP }
+
+ { "last-release" "LAST_RELEASE" TEXT }
+ { "release-git-id" "RELEASE_GIT_ID" TEXT }
+
{ "last-git-id" "LAST_GIT_ID" TEXT }
+ { "last-timestamp" "LAST_TIMESTAMP" TIMESTAMP }
{ "last-report" "LAST_REPORT" TEXT }
+
{ "current-git-id" "CURRENT_GIT_ID" TEXT }
+ ! Can't name it CURRENT_TIMESTAMP because of bug in db library
+ { "current-timestamp" "CURR_TIMESTAMP" TIMESTAMP }
{ "status" "STATUS" TEXT }
} define-persistent
: make-vm ( builder -- ) +make-vm+ >>status drop ;
-: boot ( report -- ) +boot+ >>status drop ;
+: boot ( builder -- ) +boot+ >>status drop ;
-: test ( report -- ) +test+ >>status drop ;
+: test ( builder -- ) +test+ >>status drop ;
: report ( builder status content -- )
[ >>status ] [ >>last-report ] bi*
- dup status>> +clean+ = [ dup current-git-id>> >>clean-git-id ] when
+ dup status>> +clean+ = [
+ dup current-git-id>> >>clean-git-id
+ dup current-timestamp>> >>clean-timestamp
+ ] when
dup current-git-id>> >>last-git-id
+ dup current-timestamp>> >>last-timestamp
+ drop ;
+
+: release ( builder name -- )
+ >>last-release
+ dup clean-git-id>> >>release-git-id
drop ;
: update-builder ( builder -- )
{ "boot" [ boot ] }
{ "test" [ test ] }
{ "report" [ message-arg get contents report ] }
+ { "release" [ message-arg get release ] }
} case ;
: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
-: handle-update ( command-line -- )
+: handle-update ( command-line timestamp -- )
mason-db [
- parse-args find-builder
+ [ parse-args find-builder ] dip >>current-timestamp
[ update-builder ] [ update-tuple ] bi
] with-db ;
+CONSTANT: log-file "resource:mason.log"
+
+: log-update ( command-line timestamp -- )
+ log-file utf8 [
+ present write ": " write " " join print
+ ] with-file-appender ;
+
: main ( -- )
- command-line get handle-update ;
+ command-line get now [ log-update ] [ handle-update ] 2bi ;
MAIN: main
io.encodings.utf8 io.files io.sockets io.streams.string kernel
locals mason.common mason.config mason.platform math namespaces
prettyprint sequences xml.syntax xml.writer combinators.short-circuit
-literals ;
+literals splitting ;
IN: mason.report
: common-report ( -- xml )
target-os get
target-cpu get
- host-name
+ short-host-name
build-dir
current-git-id get
[XML
"test-log" "Tests failed" failed-report ;
: timings-table ( -- xml )
- {
- $ boot-time-file
- $ load-time-file
- $ test-time-file
- $ help-lint-time-file
- $ benchmark-time-file
- $ html-help-time-file
+ ${
+ boot-time-file
+ load-time-file
+ test-time-file
+ help-lint-time-file
+ benchmark-time-file
+ html-help-time-file
} [
dup eval-file milli-seconds>time
[XML <tr><td><-></td><td><-></td></tr> XML]
] with-report ;
: build-clean? ( -- ? )
- {
- [ load-all-vocabs-file eval-file empty? ]
- [ test-all-vocabs-file eval-file empty? ]
- [ help-lint-vocabs-file eval-file empty? ]
- [ compiler-errors-file eval-file empty? ]
- [ benchmark-error-vocabs-file eval-file empty? ]
- } 0&& ;
+ ${
+ load-all-vocabs-file
+ test-all-vocabs-file
+ help-lint-vocabs-file
+ compiler-errors-file
+ benchmark-error-vocabs-file
+ } [ eval-file empty? ] all? ;
: success ( -- status )
successful-report build-clean? status-clean status-dirty ? ;
\ No newline at end of file
} 2cleave
[ [ 2array ] 2bi@ ] dip <affine-transform> ;
-: v~ ( a b epsilon -- ? )
- [ ~ ] curry 2all? ;
-
: a~ ( a b epsilon -- ? )
{
[ [ [ x>> ] bi@ ] dip v~ ]
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: math.vectors.homogeneous tools.test ;
+IN: math.vectors.homogeneous.tests
+
+[ { 1.0 2.0 1.0 } ] [ { 1.0 0.0 1.0 } { 0.0 2.0 1.0 } h+ ] unit-test
+[ { 1.0 -2.0 1.0 } ] [ { 1.0 0.0 1.0 } { 0.0 2.0 1.0 } h- ] unit-test
+[ { 2.0 2.0 2.0 } ] [ { 1.0 0.0 1.0 } { 0.0 2.0 2.0 } h+ ] unit-test
+[ { 1.0 2.0 2.0 } ] [ { 1.0 0.0 2.0 } { 0.0 2.0 2.0 } h+ ] unit-test
+
+[ { 2.0 4.0 2.0 } ] [ 2.0 { 1.0 2.0 2.0 } n*h ] unit-test
+[ { 2.0 4.0 2.0 } ] [ { 1.0 2.0 2.0 } 2.0 h*n ] unit-test
+
+[ { 0.5 1.5 } ] [ { 1.0 3.0 2.0 } h>v ] unit-test
+[ { 0.5 1.5 1.0 } ] [ { 0.5 1.5 } v>h ] unit-test
+[ { 0.5 1.5 1.0 } ] [ { 0.5 1.5 } v>h ] unit-test
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: kernel math math.vectors sequences ;
+IN: math.vectors.homogeneous
+
+: (homogeneous-xyz) ( h -- xyz )
+ 1 head* ; inline
+: (homogeneous-w) ( h -- w )
+ peek ; inline
+
+: h+ ( a b -- c )
+ 2dup [ (homogeneous-w) ] bi@ over =
+ [ [ [ (homogeneous-xyz) ] bi@ v+ ] dip suffix ] [
+ drop
+ [ [ (homogeneous-xyz) ] [ (homogeneous-w) ] bi* v*n ]
+ [ [ (homogeneous-w) ] [ (homogeneous-xyz) ] bi* n*v v+ ]
+ [ [ (homogeneous-w) ] [ (homogeneous-w) ] bi* * suffix ] 2tri
+ ] if ;
+
+: n*h ( n h -- nh )
+ [ (homogeneous-xyz) n*v ] [ (homogeneous-w) suffix ] bi ;
+
+: h*n ( h n -- nh )
+ swap n*h ;
+
+: hneg ( h -- -h )
+ -1.0 swap n*h ;
+
+: h- ( a b -- c )
+ hneg h+ ;
+
+: v>h ( v -- h )
+ 1.0 suffix ;
+
+: h>v ( h -- v )
+ [ (homogeneous-xyz) ] [ (homogeneous-w) ] bi v/n ;
+
--- /dev/null
+Homogeneous coordinate math
USING: slides help.markup math arrays hashtables namespaces
-sequences kernel sequences parser memoize ;
+sequences kernel parser memoize ;
IN: minneapolis-talk
CONSTANT: minneapolis-slides
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: literals math math.functions math.vectors namespaces
+nurbs tools.test ;
+IN: nurbs.tests
+
+SYMBOL: test-nurbs
+
+CONSTANT: √2/2 $[ 0.5 sqrt ]
+CONSTANT: -√2/2 $[ 0.5 sqrt neg ]
+
+! unit circle as NURBS
+3 {
+ { 1.0 0.0 1.0 }
+ { $ √2/2 $ √2/2 $ √2/2 }
+ { 0.0 1.0 1.0 }
+ { $ -√2/2 $ √2/2 $ √2/2 }
+ { -1.0 0.0 1.0 }
+ { $ -√2/2 $ -√2/2 $ √2/2 }
+ { 0.0 -1.0 1.0 }
+ { $ √2/2 $ -√2/2 $ √2/2 }
+ { 1.0 0.0 1.0 }
+} { 0.0 0.0 0.0 0.25 0.25 0.5 0.5 0.75 0.75 1.0 1.0 1.0 } <nurbs-curve> test-nurbs set
+
+[ t ] [ test-nurbs get 0.0 eval-nurbs { 1.0 0.0 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.25 eval-nurbs { 0.0 1.0 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.5 eval-nurbs { -1.0 0.0 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.75 eval-nurbs { 0.0 -1.0 } 0.00001 v~ ] unit-test
+
+[ t ] [ test-nurbs get 0.125 eval-nurbs { $ √2/2 $ √2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.375 eval-nurbs { $ -√2/2 $ √2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.625 eval-nurbs { $ -√2/2 $ -√2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.875 eval-nurbs { $ √2/2 $ -√2/2 } 0.00001 v~ ] unit-test
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays grouping kernel locals math math.order
+math.ranges math.vectors math.vectors.homogeneous sequences
+specialized-arrays.float ;
+IN: nurbs
+
+TUPLE: nurbs-curve
+ { order integer }
+ control-points
+ knots
+ (knot-constants) ;
+
+: ?recip ( n -- 1/n )
+ dup zero? [ recip ] unless ;
+
+:: order-index-knot-constants ( curve order index -- knot-constants )
+ curve knots>> :> knots
+ index order 1 - + knots nth :> knot_i+k-1
+ index knots nth :> knot_i
+ index order + knots nth :> knot_i+k
+ index 1 + knots nth :> knot_i+1
+
+ knot_i+k-1 knot_i - ?recip :> c1
+ knot_i+1 knot_i+k - ?recip :> c2
+
+ knot_i c1 * neg :> c3
+ knot_i+k c2 * neg :> c4
+
+ c1 c2 c3 c4 float-array{ } 4sequence ;
+
+: order-knot-constants ( curve order -- knot-constants )
+ 2dup [ knots>> length ] dip - iota
+ [ order-index-knot-constants ] with with map ;
+
+: knot-constants ( curve -- knot-constants )
+ 2 over order>> [a,b]
+ [ order-knot-constants ] with map ;
+
+: update-knots ( curve -- curve )
+ dup knot-constants >>(knot-constants) ;
+
+: <nurbs-curve> ( order control-points knots -- nurbs-curve )
+ f nurbs-curve boa update-knots ;
+
+: knot-interval ( nurbs-curve t -- index )
+ [ knots>> ] dip [ > ] curry find drop 1 - ;
+
+: clip-range ( from to sequence -- from' to' )
+ length min [ 0 max ] dip ;
+
+:: eval-base ( knot-constants bases t -- base )
+ knot-constants first t * knot-constants third + bases first *
+ knot-constants second t * knot-constants fourth + bases second *
+ + ;
+
+: (eval-curve) ( base-values control-points -- value )
+ [ n*v ] 2map { 0.0 0.0 0.0 } [ v+ ] binary-reduce h>v ;
+
+:: (eval-bases) ( curve t interval values order -- values' )
+ order 2 - curve (knot-constants)>> nth :> all-knot-constants
+ interval order interval + all-knot-constants clip-range :> to :> from
+ from to all-knot-constants subseq :> knot-constants
+ values { 0.0 } { 0.0 } surround 2 <clumps> :> bases
+
+ knot-constants bases [ t eval-base ] 2map :> values'
+ order curve order>> =
+ [ values' from to curve control-points>> subseq (eval-curve) ]
+ [ curve t interval 1 - values' order 1 + (eval-bases) ] if ;
+
+: eval-nurbs ( nurbs-curve t -- value )
+ 2dup knot-interval 1 - { 1.0 } 2 (eval-bases) ;
+
+
--- /dev/null
+NURBS curve evaluation
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
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 )
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
[ 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
} 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 ]
--- /dev/null
+Joe Groff
+Doug Coleman
--- /dev/null
+Walk around on procedurally generated terrain
+! (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
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+ ]
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
player
sky-image sky-texture sky-program
terrain terrain-segment terrain-texture terrain-program
- terrain-vertex-buffer
+ terrain-mesh
history ;
: <player> ( -- player )
[ 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 / * ;
: clamp-pitch ( pitch -- pitch' )
90.0 min -90.0 max ;
-
: walk-forward ( player -- )
dup forward-vector [ v+ ] curry change-velocity drop ;
: walk-backward ( player -- )
>>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 ]
[ 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 ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <link rel="stylesheet" href="http://factorcode.org/css/master.css" type="text/css" media="screen" title="no title" charset="utf-8" />
+ <title>Factor binary package for <t:label t:name="platform" /></title>
+ </head>
+ <body>
+ <div><img src="http://factorcode.org/graphics/logo.png" alt="Logo" /></div>
+
+ <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>
+
+ <h1>Build machine information</h1>
+
+ <table border="1">
+ <tr><td>Host name:</td><td><t:xml t:name="host-name" /></td></tr>
+ <tr><td>Current status:</td><td><t:xml t:name="status" /></td></tr>
+ <tr><td>Last build:</td><td><t:xml t:name="last-build" /></td></tr>
+ <tr><td>Last clean build:</td><td><t:xml t:name="last-clean-build" /></td></tr>
+ <tr><td>Binaries:</td><td><t:xml t:name="binaries" /></td></tr>
+ <tr><td>Clean images:</td><td><t:xml t:name="clean-images" /></td></tr>
+ </table>
+
+ <p><t:xml t:name="last-report" /></p>
+ </body>
+</html>
+
+</t:chloe>
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators db db.tuples furnace.actions
-http.server.responses kernel mason.platform mason.notify.server
-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 urls ;
+FROM: assocs => at keys values ;
IN: webapps.mason
-: log-file ( -- path ) home "mason.log" append-path ;
+TUPLE: mason-app < dispatcher ;
-: recent-events ( -- xml )
- log-file utf8 file-lines 10 short tail* "\n" join [XML <pre><-></pre> XML] ;
+: link ( url label -- xml )
+ [XML <a href=<->><-></a> XML] ;
+
+: download-link ( builder label -- xml )
+ [
+ [ URL" http://builds.factorcode.org/download" ] dip
+ [ os>> "os" set-query-param ]
+ [ cpu>> "cpu" set-query-param ] bi
+ ] dip link ;
+
+: download-grid-cell ( cpu os -- xml )
+ builder new swap >>os swap >>cpu select-tuple [
+ dup last-release>> dup
+ [ "." split1 drop 16 tail* 6 head* download-link ] [ 2drop f ] if
+ [XML <td class="supported"><div class="bigdiv"><-></div></td> XML]
+ ] [
+ [XML <td class="doesnotexist" /> XML]
+ ] if* ;
+
+CONSTANT: oses
+{
+ { "winnt" "Windows" }
+ { "macosx" "Mac OS X" }
+ { "linux" "Linux" }
+ { "freebsd" "FreeBSD" }
+ { "netbsd" "NetBSD" }
+ { "openbsd" "OpenBSD" }
+}
+
+CONSTANT: cpus
+{
+ { "x86.32" "x86" }
+ { "x86.64" "x86-64" }
+ { "ppc" "PowerPC" }
+}
+
+: download-grid ( -- xml )
+ oses
+ [ values [ [XML <th align='center' scope='col'><-></th> XML] ] map ]
+ [
+ keys
+ cpus [
+ [ nip second ] [ first ] 2bi [
+ swap download-grid-cell
+ ] curry map
+ [XML <tr><th align='center' scope='row'><-></th><-></tr> XML]
+ ] with map
+ ] bi
+ [XML
+ <table id="downloads" cellspacing="0">
+ <tr><th class="nobg">OS/CPU</th><-></tr>
+ <->
+ </table>
+ XML] ;
+
+: <download-grid-action> ( -- action )
+ <action>
+ [ download-grid xml>string "text/html" <content> ] >>display ;
+
+: 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 ;
: git-link ( id -- link )
[ "http://github.com/slavapestov/factor/commit/" prepend ] keep
swap current-git-id>> git-link
[XML <-> for <-> XML] ;
-: current-status ( builder -- xml )
+: status-string ( builder -- string )
dup status>> {
- { "dirty" [ drop "Dirty" ] }
- { "clean" [ drop "Clean" ] }
- { "starting" [ "Starting" building ] }
- { "make-vm" [ "Compiling VM" building ] }
- { "boot" [ "Bootstrapping" building ] }
- { "test" [ "Testing" building ] }
+ { +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-status ( builder -- xml )
+ [ status-string ]
+ [ 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 ;
+
+: latest-binary-link ( builder -- xml )
+ [ binaries-url ] [ last-release>> ] bi [ "/" glue ] keep link ;
+
: binaries-link ( builder -- link )
- [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend
- dup [XML <a href=<->><-></a> XML] ;
+ binaries-url dup 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 dup link ;
-: machine-table ( builder -- xml )
- {
- [ os>> ]
- [ cpu>> ]
- [ host-name>> "." split1 drop ]
- [ current-status ]
- [ last-git-id>> dup [ git-link ] when ]
- [ clean-git-id>> dup [ git-link ] when ]
- [ binaries-link ]
- [ clean-image-link ]
- } cleave
- [XML
- <h2><-> / <-></h2>
- <table border="1">
- <tr><td>Host name:</td><td><-></td></tr>
- <tr><td>Current status:</td><td><-></td></tr>
- <tr><td>Last build:</td><td><-></td></tr>
- <tr><td>Last clean build:</td><td><-></td></tr>
- <tr><td>Binaries:</td><td><-></td></tr>
- <tr><td>Clean images:</td><td><-></td></tr>
- </table>
- XML] ;
+: report-link ( builder -- xml )
+ [ URL" report" ] dip
+ [ os>> "os" set-query-param ]
+ [ cpu>> "cpu" set-query-param ] bi
+ [XML <a href=<->>Latest build report</a> XML] ;
-: machine-report ( -- xml )
- builder new select-tuples
- [ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort
- [ machine-table ] map ;
+: requirements ( builder -- xml )
+ [
+ os>> {
+ { "winnt" "Windows XP (also tested on Vista)" }
+ { "macosx" "Mac OS X 10.5 Leopard" }
+ { "linux" "Ubuntu Linux 9.04 (other distributions may also work)" }
+ { "freebsd" "FreeBSD 7.0" }
+ { "netbsd" "NetBSD 4.0" }
+ { "openbsd" "OpenBSD 4.4" }
+ } at
+ ] [
+ dup cpu>> "x86.32" = [
+ os>> {
+ { [ dup { "winnt" "linux" "freebsd" } 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 { "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] ;
-: build-farm-report ( -- xml )
- recent-events
- machine-report
- [XML
- <html>
- <head><title>Factor build farm</title></head>
- <body><h1>Recent events</h1><-> <h1>Machine status</h1><-></body>
- </html>
- XML] ;
+: last-build-status ( builder -- xml )
+ [ last-git-id>> ] [ last-timestamp>> ] bi build-status ;
+
+: clean-build-status ( builder -- xml )
+ [ clean-git-id>> ] [ clean-timestamp>> ] bi build-status ;
+
+: <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 ]
+ [ host-name>> "host-name" set-value ]
+ [ current-status "status" set-value ]
+ [ last-build-status "last-build" set-value ]
+ [ clean-build-status "last-clean-build" set-value ]
+ [ binaries-link "binaries" set-value ]
+ [ clean-image-link "clean-images" set-value ]
+ [ report-link "last-report" set-value ]
+ } cleave
+ ] >>init
+ { mason-app "download" } >>template ;
+
+: <mason-app> ( -- dispatcher )
+ mason-app new-dispatcher
+ <build-report-action> "report" add-responder
+ <download-binary-action> "download" add-responder
+ <download-grid-action> "grid" add-responder
+ mason-db <db-persistence> ;
-: <build-farm-report-action> ( -- action )
- <action>
- [
- mason-db [ build-farm-report xml>string ] with-db
- "text/html" <content>
- ] >>display ;
\ No newline at end of file
webapps.planet
webapps.wiki
webapps.user-admin
-webapps.help ;
+webapps.help
+webapps.mason ;
IN: websites.concatenative
: test-db ( -- db ) "resource:test.db" <sqlite-db> ;
<planet> <login-config> <factor-boilerplate> test-db <alloy> "planet.factorcode.org" add-responder
home "docs" append-path <help-webapp> test-db <alloy> "docs.factorcode.org" add-responder
home "cgi" append-path <gitweb> "gitweb.factorcode.org" add-responder
+ <mason-app> "builds.factorcode.org" add-responder
main-responder set-global ;
: <factor-secure-config> ( -- config )
-<% 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.
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*\>/
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:
" 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
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
" 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.
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*\>/
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:
" 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
"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")
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
set autoindent " annoying?
" vim: syntax=vim
-
/* Allocates memory */
cell frame_scan(stack_frame *frame)
{
- if(frame_type(frame) == QUOTATION_TYPE)
+ switch(frame_type(frame))
{
- cell quot = frame_executing(frame);
- if(quot == F)
- return F;
- else
+ case QUOTATION_TYPE:
{
- char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame);
- char *quot_xt = (char *)(frame_code(frame) + 1);
-
- return tag_fixnum(quot_code_offset_to_scan(
- quot,(cell)(return_addr - quot_xt)));
+ cell quot = frame_executing(frame);
+ if(quot == F)
+ return F;
+ else
+ {
+ char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame);
+ char *quot_xt = (char *)(frame_code(frame) + 1);
+
+ return tag_fixnum(quot_code_offset_to_scan(
+ quot,(cell)(return_addr - quot_xt)));
+ }
}
- }
- else
+ case WORD_TYPE:
return F;
+ default:
+ critical_error("Bad frame type",frame_type(frame));
+ return F;
+ }
}
namespace
{
-struct stack_frame_counter {
- cell count;
- stack_frame_counter() : count(0) {}
- void operator()(stack_frame *frame) { count += 2; }
-};
-
struct stack_frame_accumulator {
- cell index;
- gc_root<array> frames;
- stack_frame_accumulator(cell count) : index(0), frames(allot_array(count,F)) {}
+ growable_array frames;
+
void operator()(stack_frame *frame)
{
- set_array_nth(frames.untagged(),index++,frame_executing(frame));
- set_array_nth(frames.untagged(),index++,frame_scan(frame));
+ gc_root<object> executing(frame_executing(frame));
+ gc_root<object> scan(frame_scan(frame));
+
+ frames.add(executing.value());
+ frames.add(scan.value());
}
};
{
gc_root<callstack> callstack(dpop());
- stack_frame_counter counter;
- iterate_callstack_object(callstack.untagged(),counter);
-
- stack_frame_accumulator accum(counter.count);
+ stack_frame_accumulator accum;
iterate_callstack_object(callstack.untagged(),accum);
+ accum.frames.trim();
- dpush(accum.frames.value());
+ dpush(accum.frames.elements.value());
}
stack_frame *innermost_stack_frame(callstack *stack)
}
}
-template<typename T> void iterate_callstack_object(callstack *stack, T &iterator)
+/* This is a little tricky. The iterator may allocate memory, so we
+keep the callstack in a GC root and use relative offsets */
+template<typename T> void iterate_callstack_object(callstack *stack_, T &iterator)
{
- iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator);
+ gc_root<callstack> stack(stack_);
+ fixnum frame_offset = untag_fixnum(stack->length) - sizeof(stack_frame);
+
+ while(frame_offset >= 0)
+ {
+ stack_frame *frame = stack->frame_at(frame_offset);
+ frame_offset -= frame->size;
+ iterator(frame);
+ }
}
}
/* tagged */
cell length;
+ stack_frame *frame_at(cell offset)
+ {
+ return (stack_frame *)((char *)(this + 1) + offset);
+ }
+
stack_frame *top() { return (stack_frame *)(this + 1); }
stack_frame *bottom() { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); }
};
projects / factor.git / commitdiff