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

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

db4
Joe Groff 2008-01-17 20:44:18 -08:00
parent 7e53f873d6 1e265b001c
commit 0455603cbd
66 changed files with 2068 additions and 2055 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/compiler/constants/constants.factor
View File

@ -19,4 +19,4 @@ IN: compiler.constants
: class-hash-offset bootstrap-cell object tag-number - ; : class-hash-offset bootstrap-cell object tag-number - ;
: word-xt-offset 8 bootstrap-cells object tag-number - ; : word-xt-offset 8 bootstrap-cells object tag-number - ;
: word-code-offset 9 bootstrap-cells object tag-number - ; : word-code-offset 9 bootstrap-cells object tag-number - ;
: compiled-header-size 8 bootstrap-cells ; : compiled-header-size 4 bootstrap-cells ;

4
core/compiler/test/redefine.factor
View File

@ -17,7 +17,7 @@ DEFER: x-2
{ x-1 } compile { x-1 } compile
\ x-2 word-xt eq? \ x-2 word-xt =
] unit-test ] unit-test
] with-variable ] with-variable
@ -115,7 +115,7 @@ DEFER: g-test-3
"IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 3 + ;" eval "IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 3 + ;" eval
\ g-test-3 word-xt eq? \ g-test-3 word-xt =
] unit-test ] unit-test
DEFER: g-test-5 DEFER: g-test-5

2
core/compiler/test/templates-early.factor
View File

@ -44,7 +44,7 @@ words kernel math effects definitions compiler.units ;
[ [
[ ] [ init-templates ] unit-test [ ] [ init-templates ] unit-test
[ ] [ \ + init-generator ] unit-test [ ] [ init-generator ] unit-test
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test [ t ] [ [ end-basic-block ] { } make empty? ] unit-test

2
core/cpu/architecture/architecture.factor
View File

@ -72,8 +72,6 @@ HOOK: %jump-dispatch compiler-backend ( -- )
HOOK: %dispatch-label compiler-backend ( word -- ) HOOK: %dispatch-label compiler-backend ( word -- )
HOOK: %end-dispatch compiler-backend ( label -- )
! Return to caller ! Return to caller
HOOK: %return compiler-backend ( -- ) HOOK: %return compiler-backend ( -- )

3
core/cpu/ppc/architecture/architecture.factor
View File

@ -144,9 +144,6 @@ M: ppc-backend %jump-dispatch ( -- )
M: ppc-backend %dispatch-label ( word -- ) M: ppc-backend %dispatch-label ( word -- )
0 , rc-absolute-cell rel-word ; 0 , rc-absolute-cell rel-word ;
M: ppc-backend %end-dispatch ( label -- )
resolve-label ;
M: ppc-backend %return ( -- ) %epilogue-later BLR ; M: ppc-backend %return ( -- ) %epilogue-later BLR ;
M: ppc-backend %unwind drop %return ; M: ppc-backend %unwind drop %return ;

10
core/cpu/x86/architecture/architecture.factor
View File

@ -85,7 +85,7 @@ M: x86-backend %jump-label ( label -- ) JMP ;
M: x86-backend %jump-t ( label -- ) M: x86-backend %jump-t ( label -- )
"flag" operand f v>operand CMP JNE ; "flag" operand f v>operand CMP JNE ;
: (%dispatch) ( -- operand ) : (%dispatch) ( n -- operand )
! Load jump table base. We use a temporary register ! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On ! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant. ! x86, this is redundant.
@ -94,18 +94,20 @@ M: x86-backend %jump-t ( label -- )
! Add jump table base ! Add jump table base
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here "offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
"n" operand "offset" operand ADD "n" operand "offset" operand ADD
"n" operand bootstrap-cell 8 = 14 9 ? [+] ; "n" operand swap bootstrap-cell 8 = 14 9 ? + [+] ;
M: x86-backend %call-dispatch ( word-table# -- ) M: x86-backend %call-dispatch ( word-table# -- )
[ (%dispatch) CALL <label> dup JMP ] H{ [ 5 (%dispatch) CALL <label> dup JMP ] H{
{ +input+ { { f "n" } } } { +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } } { +scratch+ { { f "offset" } } }
{ +clobber+ { "n" } }
} with-template ; } with-template ;
M: x86-backend %jump-dispatch ( -- ) M: x86-backend %jump-dispatch ( -- )
[ %epilogue-later (%dispatch) JMP ] H{ [ %epilogue-later 0 (%dispatch) JMP ] H{
{ +input+ { { f "n" } } } { +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } } { +scratch+ { { f "offset" } } }
{ +clobber+ { "n" } }
} with-template ; } with-template ;
M: x86-backend %dispatch-label ( word -- ) M: x86-backend %dispatch-label ( word -- )

7
core/generator/fixup/fixup-docs.factor
View File

@ -13,13 +13,6 @@ HELP: add-literal
{ $values { "obj" object } { "n" integer } } { $values { "obj" object } { "n" integer } }
{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ; { $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
HELP: word-table
{ $var-description "Holds a vector of words called from the currently compiling word." } ;
HELP: add-word
{ $values { "word" word } { "n" integer } }
{ $description "Adds a word to the " { $link word-table } ", if it is not already there, and outputs the index of the word in the table. This literal can then be used as an argument for a " { $link rt-xt } " relocation with " { $link rel-fixup } "." } ;
HELP: string>symbol HELP: string>symbol
{ $values { "str" string } { "alien" alien } } { $values { "str" string } { "alien" alien } }
{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory." { $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."

10
core/generator/fixup/fixup.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables USING: arrays generic assocs hashtables
kernel kernel.private math namespaces sequences words kernel kernel.private math namespaces sequences words
@ -110,10 +110,6 @@ SYMBOL: literal-table
: add-literal ( obj -- n ) literal-table get push-new* ; : add-literal ( obj -- n ) literal-table get push-new* ;
SYMBOL: word-table
: add-word ( word -- n ) word-table get push-new* ;
: string>symbol ( str -- alien ) : string>symbol ( str -- alien )
wince? [ string>u16-alien ] [ string>char-alien ] if ; wince? [ string>u16-alien ] [ string>char-alien ] if ;
@ -125,10 +121,8 @@ SYMBOL: word-table
add-dlsym-literals add-dlsym-literals
r> r> rt-dlsym rel-fixup ; r> r> rt-dlsym rel-fixup ;
: rel-dispatch ( word-table# class -- ) rt-dispatch rel-fixup ;
: rel-word ( word class -- ) : rel-word ( word class -- )
>r add-word r> rt-xt rel-fixup ; >r add-literal r> rt-xt rel-fixup ;
: rel-primitive ( word class -- ) : rel-primitive ( word class -- )
>r word-def first r> rt-primitive rel-fixup ; >r word-def first r> rt-primitive rel-fixup ;

24
core/generator/generator.factor
View File

@ -1,22 +1,20 @@
! Copyright (C) 2004, 2007 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes combinators cpu.architecture USING: arrays assocs classes combinators cpu.architecture
effects generator.fixup generator.registers generic hashtables effects generator.fixup generator.registers generic hashtables
inference inference.backend inference.dataflow io kernel inference inference.backend inference.dataflow io kernel
kernel.private layouts math namespaces optimizer prettyprint kernel.private layouts math namespaces optimizer prettyprint
quotations sequences system threads words ; quotations sequences system threads words vectors ;
IN: generator IN: generator
SYMBOL: compile-queue SYMBOL: compile-queue
SYMBOL: compiled SYMBOL: compiled
: 5array 3array >r 2array r> append ;
: begin-compiling ( word -- ) : begin-compiling ( word -- )
f swap compiled get set-at ; f swap compiled get set-at ;
: finish-compiling ( word literals words relocation labels code -- ) : finish-compiling ( word literals relocation labels code -- )
5array swap compiled get set-at ; 4array swap compiled get set-at ;
: queue-compile ( word -- ) : queue-compile ( word -- )
{ {
@ -38,20 +36,18 @@ SYMBOL: current-label-start
: compiled-stack-traces? ( -- ? ) 36 getenv ; : compiled-stack-traces? ( -- ? ) 36 getenv ;
: init-generator ( compiling -- ) : init-generator ( -- )
V{ } clone literal-table set compiled-stack-traces?
V{ } clone word-table set compiling-word get f ?
compiled-stack-traces? swap f ? 1vector literal-table set ;
literal-table get push ;
: generate-1 ( word label node quot -- ) : generate-1 ( word label node quot -- )
pick begin-compiling [ pick begin-compiling [
roll compiling-word set roll compiling-word set
pick compiling-label set pick compiling-label set
compiling-word get init-generator init-generator
call call
literal-table get >array literal-table get >array
word-table get >array
] { } make fixup finish-compiling ; ] { } make fixup finish-compiling ;
GENERIC: generate-node ( node -- next ) GENERIC: generate-node ( node -- next )
@ -182,7 +178,7 @@ M: #dispatch generate-node
%jump-dispatch dispatch-branches %jump-dispatch dispatch-branches
] [ ] [
0 frame-required 0 frame-required
%call-dispatch >r dispatch-branches r> %end-dispatch %call-dispatch >r dispatch-branches r> resolve-label
] if ] if
init-templates iterate-next ; init-templates iterate-next ;

3
core/generic/standard/standard.factor
View File

@ -139,7 +139,8 @@ TUPLE: no-method object generic ;
M: standard-combination perform-combination M: standard-combination perform-combination
standard-combination-# (dispatch#) [ standard-combination-# (dispatch#) [
standard-methods single-combination [ standard-methods ] keep "inline" word-prop
[ small-generic ] [ single-combination ] if
] with-variable ; ] with-variable ;
: default-hook-method ( word -- pair ) : default-hook-method ( word -- pair )

2
core/kernel/kernel-tests.factor
View File

@ -1,6 +1,6 @@
USING: arrays byte-arrays kernel kernel.private math memory USING: arrays byte-arrays kernel kernel.private math memory
namespaces sequences tools.test math.private quotations namespaces sequences tools.test math.private quotations
continuations prettyprint io.streams.string debugger ; continuations prettyprint io.streams.string debugger assocs ;
IN: temporary IN: temporary
[ 0 ] [ f size ] unit-test [ 0 ] [ f size ] unit-test

4
core/optimizer/known-words/known-words.factor
View File

@ -14,8 +14,8 @@ float-arrays combinators.private combinators ;
! its second-to-last input ! its second-to-last input
{ <tuple> <tuple-boa> } [ { <tuple> <tuple-boa> } [
[ [
node-in-d dup length 2 - swap nth dup value? dup node-in-d dup length 2 - swap nth node-literal
[ value-literal ] [ drop tuple ] if 1array f dup class? [ drop tuple ] unless 1array f
] "output-classes" set-word-prop ] "output-classes" set-word-prop
] each ] each

2
extra/balloon-bomber/balloon-bomber-docs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup cpu.8080 ; USING: help.syntax help.markup cpu.8080.emulator ;
IN: balloon-bomber IN: balloon-bomber
HELP: run HELP: run

33
extra/cpu/8080/8080-docs.factor
View File

@ -1,39 +1,8 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax sequences strings ; USING: help.markup help.syntax sequences strings cpu.8080.emulator ;
IN: cpu.8080 IN: cpu.8080
HELP: load-rom
{ $values { "filename" string } { "cpu" cpu } }
{ $description
"Read the ROM file into the cpu's memory starting at address 0000. "
"The filename is relative to the path stored in the " { $link rom-root }
" variable. An exception is thrown if this variable is not set."
}
{ $see-also load-rom* } ;
HELP: load-rom*
{ $values { "seq" sequence } { "cpu" cpu } }
{ $description
"Loads one or more ROM files into the cpu's memory. Each file is "
"loaded at a particular starting address. 'seq' is a sequence of "
"2 element arrays. The first element is the address and the second "
"element is the file to load at that address." $nl
"The filenames are relative to the path stored in the " { $link rom-root }
" variable. An exception is thrown if this variable is not set."
}
{ $examples
{ $code "{ { HEX: 0000 \"invaders.rom\" } } <cpu> load-rom*" }
}
{ $see-also load-rom } ;
HELP: rom-root
{ $description
"Holds the path where the ROM files are stored. Used for expanding "
"the relative filenames passed to " { $link load-rom } " and "
{ $link load-rom* } "."
}
{ $see-also load-rom load-rom* } ;
ARTICLE: { "cpu-8080" "cpu-8080" } "Intel 8080 CPU Emulator" ARTICLE: { "cpu-8080" "cpu-8080" } "Intel 8080 CPU Emulator"
"The cpu-8080 library provides an emulator for the Intel 8080 CPU" "The cpu-8080 library provides an emulator for the Intel 8080 CPU"

1596
extra/cpu/8080/8080.factor
View File

File diff suppressed because it is too large Load Diff

1
extra/cpu/8080/authors.txt Normal file
View File

@ -0,0 +1 @@
Chris Double

1
extra/cpu/8080/emulator/authors.txt Normal file
View File

@ -0,0 +1 @@
Chris Double

36
extra/cpu/8080/emulator/emulator-docs.factor Normal file
View File

@ -0,0 +1,36 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax sequences strings ;
IN: cpu.8080.emulator
HELP: load-rom
{ $values { "filename" string } { "cpu" cpu } }
{ $description
"Read the ROM file into the cpu's memory starting at address 0000. "
"The filename is relative to the path stored in the " { $link rom-root }
" variable. An exception is thrown if this variable is not set."
}
{ $see-also load-rom* } ;
HELP: load-rom*
{ $values { "seq" sequence } { "cpu" cpu } }
{ $description
"Loads one or more ROM files into the cpu's memory. Each file is "
"loaded at a particular starting address. 'seq' is a sequence of "
"2 element arrays. The first element is the address and the second "
"element is the file to load at that address." $nl
"The filenames are relative to the path stored in the " { $link rom-root }
" variable. An exception is thrown if this variable is not set."
}
{ $examples
{ $code "{ { HEX: 0000 \"invaders.rom\" } } <cpu> load-rom*" }
}
{ $see-also load-rom } ;
HELP: rom-root
{ $description
"Holds the path where the ROM files are stored. Used for expanding "
"the relative filenames passed to " { $link load-rom } " and "
{ $link load-rom* } "."
}
{ $see-also load-rom load-rom* } ;

1356
extra/cpu/8080/emulator/emulator.factor Normal file
View File

File diff suppressed because it is too large Load Diff

1
extra/cpu/8080/emulator/summary.txt Normal file
View File

@ -0,0 +1 @@
Intel 8080 CPU Emulator

1
extra/cpu/8080/emulator/tags.txt Normal file
View File

@ -0,0 +1 @@
emulator

250
extra/cpu/8080/instructions/instructions.factor
View File

@ -1,250 +0,0 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: cpu.8080 ;
IN: cpu.8080.instructions
INSTRUCTION: NOP ; opcode 00 cycles 04
INSTRUCTION: LD BC,nn ; opcode 01 cycles 10
INSTRUCTION: LD (BC),A ; opcode 02 cycles 07
INSTRUCTION: INC BC ; opcode 03 cycles 06
INSTRUCTION: INC B ; opcode 04 cycles 05
INSTRUCTION: DEC B ; opcode 05 cycles 05
INSTRUCTION: LD B,n ; opcode 06 cycles 07
INSTRUCTION: RLCA ; opcode 07 cycles 04
! INSTRUCTION: NOP ; opcode 08 cycles 04
INSTRUCTION: ADD HL,BC ; opcode 09 cycles 11
INSTRUCTION: LD A,(BC) ; opcode 0A cycles 07
INSTRUCTION: DEC BC ; opcode 0B cycles 06
INSTRUCTION: INC C ; opcode 0C cycles 05
INSTRUCTION: DEC C ; opcode 0D cycles 05
INSTRUCTION: LD C,n ; opcode 0E cycles 07
INSTRUCTION: RRCA ; opcode 0F cycles 04
INSTRUCTION: LD DE,nn ; opcode 11 cycles 10
INSTRUCTION: LD (DE),A ; opcode 12 cycles 07
INSTRUCTION: INC DE ; opcode 13 cycles 06
INSTRUCTION: INC D ; opcode 14 cycles 05
INSTRUCTION: DEC D ; opcode 15 cycles 05
INSTRUCTION: LD D,n ; opcode 16 cycles 07
INSTRUCTION: RLA ; opcode 17 cycles 04
INSTRUCTION: ADD HL,DE ; opcode 19 cycles 11
INSTRUCTION: LD A,(DE) ; opcode 1A cycles 07
INSTRUCTION: DEC DE ; opcode 1B cycles 06
INSTRUCTION: INC E ; opcode 1C cycles 05
INSTRUCTION: DEC E ; opcode 1D cycles 05
INSTRUCTION: LD E,n ; opcode 1E cycles 07
INSTRUCTION: RRA ; opcode 1F cycles 04
INSTRUCTION: LD HL,nn ; opcode 21 cycles 10
INSTRUCTION: LD (nn),HL ; opcode 22 cycles 16
INSTRUCTION: INC HL ; opcode 23 cycles 06
INSTRUCTION: INC H ; opcode 24 cycles 05
INSTRUCTION: DEC H ; opcode 25 cycles 05
INSTRUCTION: LD H,n ; opcode 26 cycles 07
INSTRUCTION: DAA ; opcode 27 cycles 04
INSTRUCTION: ADD HL,HL ; opcode 29 cycles 11
INSTRUCTION: LD HL,(nn) ; opcode 2A cycles 16
INSTRUCTION: DEC HL ; opcode 2B cycles 06
INSTRUCTION: INC L ; opcode 2C cycles 05
INSTRUCTION: DEC L ; opcode 2D cycles 05
INSTRUCTION: LD L,n ; opcode 2E cycles 07
INSTRUCTION: CPL ; opcode 2F cycles 04
INSTRUCTION: LD SP,nn ; opcode 31 cycles 10
INSTRUCTION: LD (nn),A ; opcode 32 cycles 13
INSTRUCTION: INC SP ; opcode 33 cycles 06
INSTRUCTION: INC (HL) ; opcode 34 cycles 10
INSTRUCTION: DEC (HL) ; opcode 35 cycles 10
INSTRUCTION: LD (HL),n ; opcode 36 cycles 10
INSTRUCTION: SCF ; opcode 37 cycles 04
INSTRUCTION: ADD HL,SP ; opcode 39 cycles 11
INSTRUCTION: LD A,(nn) ; opcode 3A cycles 13
INSTRUCTION: DEC SP ; opcode 3B cycles 06
INSTRUCTION: INC A ; opcode 3C cycles 05
INSTRUCTION: DEC A ; opcode 3D cycles 05
INSTRUCTION: LD A,n ; opcode 3E cycles 07
INSTRUCTION: CCF ; opcode 3F cycles 04
INSTRUCTION: LD B,B ; opcode 40 cycles 05
INSTRUCTION: LD B,C ; opcode 41 cycles 05
INSTRUCTION: LD B,D ; opcode 42 cycles 05
INSTRUCTION: LD B,E ; opcode 43 cycles 05
INSTRUCTION: LD B,H ; opcode 44 cycles 05
INSTRUCTION: LD B,L ; opcode 45 cycles 05
INSTRUCTION: LD B,(HL) ; opcode 46 cycles 07
INSTRUCTION: LD B,A ; opcode 47 cycles 05
INSTRUCTION: LD C,B ; opcode 48 cycles 05
INSTRUCTION: LD C,C ; opcode 49 cycles 05
INSTRUCTION: LD C,D ; opcode 4A cycles 05
INSTRUCTION: LD C,E ; opcode 4B cycles 05
INSTRUCTION: LD C,H ; opcode 4C cycles 05
INSTRUCTION: LD C,L ; opcode 4D cycles 05
INSTRUCTION: LD C,(HL) ; opcode 4E cycles 07
INSTRUCTION: LD C,A ; opcode 4F cycles 05
INSTRUCTION: LD D,B ; opcode 50 cycles 05
INSTRUCTION: LD D,C ; opcode 51 cycles 05
INSTRUCTION: LD D,D ; opcode 52 cycles 05
INSTRUCTION: LD D,E ; opcode 53 cycles 05
INSTRUCTION: LD D,H ; opcode 54 cycles 05
INSTRUCTION: LD D,L ; opcode 55 cycles 05
INSTRUCTION: LD D,(HL) ; opcode 56 cycles 07
INSTRUCTION: LD D,A ; opcode 57 cycles 05
INSTRUCTION: LD E,B ; opcode 58 cycles 05
INSTRUCTION: LD E,C ; opcode 59 cycles 05
INSTRUCTION: LD E,D ; opcode 5A cycles 05
INSTRUCTION: LD E,E ; opcode 5B cycles 05
INSTRUCTION: LD E,H ; opcode 5C cycles 05
INSTRUCTION: LD E,L ; opcode 5D cycles 05
INSTRUCTION: LD E,(HL) ; opcode 5E cycles 07
INSTRUCTION: LD E,A ; opcode 5F cycles 05
INSTRUCTION: LD H,B ; opcode 60 cycles 05
INSTRUCTION: LD H,C ; opcode 61 cycles 05
INSTRUCTION: LD H,D ; opcode 62 cycles 05
INSTRUCTION: LD H,E ; opcode 63 cycles 05
INSTRUCTION: LD H,H ; opcode 64 cycles 05
INSTRUCTION: LD H,L ; opcode 65 cycles 05
INSTRUCTION: LD H,(HL) ; opcode 66 cycles 07
INSTRUCTION: LD H,A ; opcode 67 cycles 05
INSTRUCTION: LD L,B ; opcode 68 cycles 05
INSTRUCTION: LD L,C ; opcode 69 cycles 05
INSTRUCTION: LD L,D ; opcode 6A cycles 05
INSTRUCTION: LD L,E ; opcode 6B cycles 05
INSTRUCTION: LD L,H ; opcode 6C cycles 05
INSTRUCTION: LD L,L ; opcode 6D cycles 05
INSTRUCTION: LD L,(HL) ; opcode 6E cycles 07
INSTRUCTION: LD L,A ; opcode 6F cycles 05
INSTRUCTION: LD (HL),B ; opcode 70 cycles 07
INSTRUCTION: LD (HL),C ; opcode 71 cycles 07
INSTRUCTION: LD (HL),D ; opcode 72 cycles 07
INSTRUCTION: LD (HL),E ; opcode 73 cycles 07
INSTRUCTION: LD (HL),H ; opcode 74 cycles 07
INSTRUCTION: LD (HL),L ; opcode 75 cycles 07
INSTRUCTION: HALT ; opcode 76 cycles 07
INSTRUCTION: LD (HL),A ; opcode 77 cycles 07
INSTRUCTION: LD A,B ; opcode 78 cycles 05
INSTRUCTION: LD A,C ; opcode 79 cycles 05
INSTRUCTION: LD A,D ; opcode 7A cycles 05
INSTRUCTION: LD A,E ; opcode 7B cycles 05
INSTRUCTION: LD A,H ; opcode 7C cycles 05
INSTRUCTION: LD A,L ; opcode 7D cycles 05
INSTRUCTION: LD A,(HL) ; opcode 7E cycles 07
INSTRUCTION: LD A,A ; opcode 7F cycles 05
INSTRUCTION: ADD A,B ; opcode 80 cycles 04
INSTRUCTION: ADD A,C ; opcode 81 cycles 04
INSTRUCTION: ADD A,D ; opcode 82 cycles 04
INSTRUCTION: ADD A,E ; opcode 83 cycles 04
INSTRUCTION: ADD A,H ; opcode 84 cycles 04
INSTRUCTION: ADD A,L ; opcode 85 cycles 04
INSTRUCTION: ADD A,(HL) ; opcode 86 cycles 07
INSTRUCTION: ADD A,A ; opcode 87 cycles 04
INSTRUCTION: ADC A,B ; opcode 88 cycles 04
INSTRUCTION: ADC A,C ; opcode 89 cycles 04
INSTRUCTION: ADC A,D ; opcode 8A cycles 04
INSTRUCTION: ADC A,E ; opcode 8B cycles 04
INSTRUCTION: ADC A,H ; opcode 8C cycles 04
INSTRUCTION: ADC A,L ; opcode 8D cycles 04
INSTRUCTION: ADC A,(HL) ; opcode 8E cycles 07
INSTRUCTION: ADC A,A ; opcode 8F cycles 04
INSTRUCTION: SUB B ; opcode 90 cycles 04
INSTRUCTION: SUB C ; opcode 91 cycles 04
INSTRUCTION: SUB D ; opcode 92 cycles 04
INSTRUCTION: SUB E ; opcode 93 cycles 04
INSTRUCTION: SUB H ; opcode 94 cycles 04
INSTRUCTION: SUB L ; opcode 95 cycles 04
INSTRUCTION: SUB (HL) ; opcode 96 cycles 07
INSTRUCTION: SUB A ; opcode 97 cycles 04
INSTRUCTION: SBC A,B ; opcode 98 cycles 04
INSTRUCTION: SBC A,C ; opcode 99 cycles 04
INSTRUCTION: SBC A,D ; opcode 9A cycles 04
INSTRUCTION: SBC A,E ; opcode 9B cycles 04
INSTRUCTION: SBC A,H ; opcode 9C cycles 04
INSTRUCTION: SBC A,L ; opcode 9D cycles 04
INSTRUCTION: SBC A,(HL) ; opcode 9E cycles 07
INSTRUCTION: SBC A,A ; opcode 9F cycles 04
INSTRUCTION: AND B ; opcode A0 cycles 04
INSTRUCTION: AND C ; opcode A1 cycles 04
INSTRUCTION: AND D ; opcode A2 cycles 04
INSTRUCTION: AND E ; opcode A3 cycles 04
INSTRUCTION: AND H ; opcode A4 cycles 04
INSTRUCTION: AND L ; opcode A5 cycles 04
INSTRUCTION: AND (HL) ; opcode A6 cycles 07
INSTRUCTION: AND A ; opcode A7 cycles 04
INSTRUCTION: XOR B ; opcode A8 cycles 04
INSTRUCTION: XOR C ; opcode A9 cycles 04
INSTRUCTION: XOR D ; opcode AA cycles 04
INSTRUCTION: XOR E ; opcode AB cycles 04
INSTRUCTION: XOR H ; opcode AC cycles 04
INSTRUCTION: XOR L ; opcode AD cycles 04
INSTRUCTION: XOR (HL) ; opcode AE cycles 07
INSTRUCTION: XOR A ; opcode AF cycles 04
INSTRUCTION: OR B ; opcode B0 cycles 04
INSTRUCTION: OR C ; opcode B1 cycles 04
INSTRUCTION: OR D ; opcode B2 cycles 04
INSTRUCTION: OR E ; opcode B3 cycles 04
INSTRUCTION: OR H ; opcode B4 cycles 04
INSTRUCTION: OR L ; opcode B5 cycles 04
INSTRUCTION: OR (HL) ; opcode B6 cycles 07
INSTRUCTION: OR A ; opcode B7 cycles 04
INSTRUCTION: CP B ; opcode B8 cycles 04
INSTRUCTION: CP C ; opcode B9 cycles 04
INSTRUCTION: CP D ; opcode BA cycles 04
INSTRUCTION: CP E ; opcode BB cycles 04
INSTRUCTION: CP H ; opcode BC cycles 04
INSTRUCTION: CP L ; opcode BD cycles 04
INSTRUCTION: CP (HL) ; opcode BE cycles 07
INSTRUCTION: CP A ; opcode BF cycles 04
INSTRUCTION: RET NZ ; opcode C0 cycles 05
INSTRUCTION: POP BC ; opcode C1 cycles 10
INSTRUCTION: JP NZ,nn ; opcode C2 cycles 10
INSTRUCTION: JP nn ; opcode C3 cycles 10
INSTRUCTION: CALL NZ,nn ; opcode C4 cycles 11
INSTRUCTION: PUSH BC ; opcode C5 cycles 11
INSTRUCTION: ADD A,n ; opcode C6 cycles 07
INSTRUCTION: RST 0 ; opcode C7 cycles 11
INSTRUCTION: RET Z ; opcode C8 cycles 05
INSTRUCTION: RET nn ; opcode C9 cycles 10
INSTRUCTION: JP Z,nn ; opcode CA cycles 10
INSTRUCTION: CALL Z,nn ; opcode CC cycles 11
INSTRUCTION: CALL nn ; opcode CD cycles 17
INSTRUCTION: ADC A,n ; opcode CE cycles 07
INSTRUCTION: RST 8 ; opcode CF cycles 11
INSTRUCTION: RET NC ; opcode D0 cycles 05
INSTRUCTION: POP DE ; opcode D1 cycles 10
INSTRUCTION: JP NC,nn ; opcode D2 cycles 10
INSTRUCTION: OUT (n),A ; opcode D3 cycles 10
INSTRUCTION: CALL NC,nn ; opcode D4 cycles 11
INSTRUCTION: PUSH DE ; opcode D5 cycles 11
INSTRUCTION: SUB n ; opcode D6 cycles 07
INSTRUCTION: RST 10H ; opcode D7 cycles 11
INSTRUCTION: RET C ; opcode D8 cycles 05
INSTRUCTION: JP C,nn ; opcode DA cycles 10
INSTRUCTION: IN A,(n) ; opcode DB cycles 10
INSTRUCTION: CALL C,nn ; opcode DC cycles 11
INSTRUCTION: SBC A,n ; opcode DE cycles 07
INSTRUCTION: RST 18H ; opcode DF cycles 11
INSTRUCTION: RET PO ; opcode E0 cycles 05
INSTRUCTION: POP HL ; opcode E1 cycles 10
INSTRUCTION: JP PO,nn ; opcode E2 cycles 10
INSTRUCTION: EX (SP),HL ; opcode E3 cycles 04
INSTRUCTION: CALL PO,nn ; opcode E4 cycles 11
INSTRUCTION: PUSH HL ; opcode E5 cycles 11
INSTRUCTION: AND n ; opcode E6 cycles 07
INSTRUCTION: RST 20H ; opcode E7 cycles 11
INSTRUCTION: RET PE ; opcode E8 cycles 05
INSTRUCTION: JP (HL) ; opcode E9 cycles 04
INSTRUCTION: JP PE,nn ; opcode EA cycles 10
INSTRUCTION: EX DE,HL ; opcode EB cycles 04
INSTRUCTION: CALL PE,nn ; opcode EC cycles 11
INSTRUCTION: XOR n ; opcode EE cycles 07
INSTRUCTION: RST 28H ; opcode EF cycles 11
INSTRUCTION: RET P ; opcode F0 cycles 05
INSTRUCTION: POP AF ; opcode F1 cycles 10
INSTRUCTION: JP P,nn ; opcode F2 cycles 10
INSTRUCTION: DI ; opcode F3 cycles 04
INSTRUCTION: CALL P,nn ; opcode F4 cycles 11
INSTRUCTION: PUSH AF ; opcode F5 cycles 11
INSTRUCTION: OR n ; opcode F6 cycles 07
INSTRUCTION: RST 30H ; opcode F7 cycles 11
INSTRUCTION: RET M ; opcode F8 cycles 05
INSTRUCTION: LD SP,HL ; opcode F9 cycles 06
INSTRUCTION: JP M,nn ; opcode FA cycles 10
INSTRUCTION: EI ; opcode FB cycles 04
INSTRUCTION: CALL M,nn ; opcode FC cycles 11
INSTRUCTION: CP n ; opcode FE cycles 07
INSTRUCTION: RST 38H ; opcode FF cycles 11

1
extra/cpu/8080/summary.txt Normal file
View File

@ -0,0 +1 @@
Intel 8080 CPU Emulator

1
extra/cpu/8080/tags.txt Normal file
View File

@ -0,0 +1 @@
emulator

2
extra/crypto/sha1/sha1.factor
View File

@ -78,7 +78,7 @@ SYMBOL: K
K get nth , K get nth ,
A get 5 bitroll-32 , A get 5 bitroll-32 ,
E get , E get ,
] { } make sum 4294967295 bitand ; inline ] { } make sum >32-bit ; inline
: set-vars ( temp -- ) : set-vars ( temp -- )
! E = D; D = C; C = S^30(B); B = A; A = TEMP; ! E = D; D = C; C = S^30(B); B = A; A = TEMP;

2
extra/io/sniffer/bsd/bsd.factor
View File

@ -17,7 +17,7 @@ TUPLE: sniffer-spec path ifname ;
C: <sniffer-spec> sniffer-spec C: <sniffer-spec> sniffer-spec
: IOCPARM_MASK HEX: 1fff ; inline : IOCPARM_MASK HEX: 1fff ; inline
: IOCPARM_MAX IOCPARM_MASK 1 + ; inline : IOCPARM_MAX IOCPARM_MASK 1+ ; inline
: IOC_VOID HEX: 20000000 ; inline : IOC_VOID HEX: 20000000 ; inline
: IOC_OUT HEX: 40000000 ; inline : IOC_OUT HEX: 40000000 ; inline
: IOC_IN HEX: 80000000 ; inline : IOC_IN HEX: 80000000 ; inline

2
extra/io/sniffer/filter/bsd/bsd.factor
View File

@ -9,7 +9,7 @@ IN: io.sniffer.filter.bsd
: bpf-align ( n -- n' ) : bpf-align ( n -- n' )
#! Align to next higher word size #! Align to next higher word size
"long" heap-size 1- [ + ] keep bitnot bitand ; "long" heap-size align ;
M: unix-io packet. ( string -- ) M: unix-io packet. ( string -- )
18 cut swap >byte-array bpfh. 18 cut swap >byte-array bpfh.

2
extra/lunar-rescue/lunar-rescue-docs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup cpu.8080 ; USING: help.syntax help.markup cpu.8080.emulator ;
IN: lunar-rescue IN: lunar-rescue
HELP: run HELP: run

3
extra/match/match.factor
View File

@ -3,7 +3,7 @@
! !
! Based on pattern matching code from Paul Graham's book 'On Lisp'. ! Based on pattern matching code from Paul Graham's book 'On Lisp'.
USING: parser kernel words namespaces sequences tuples USING: parser kernel words namespaces sequences tuples
combinators macros assocs ; combinators macros assocs math ;
IN: match IN: match
SYMBOL: _ SYMBOL: _
@ -54,6 +54,7 @@ MACRO: match-cond ( assoc -- )
: replace-patterns ( object -- result ) : replace-patterns ( object -- result )
{ {
{ [ dup number? ] [ ] }
{ [ dup match-var? ] [ get ] } { [ dup match-var? ] [ get ] }
{ [ dup sequence? ] [ [ replace-patterns ] map ] } { [ dup sequence? ] [ [ replace-patterns ] map ] }
{ [ dup tuple? ] [ tuple>array replace-patterns >tuple ] } { [ dup tuple? ] [ tuple>array replace-patterns >tuple ] }

4
extra/math/polynomials/polynomials.factor
View File

@ -1,5 +1,5 @@
USING: arrays kernel sequences vectors math math.vectors namespaces USING: arrays kernel sequences vectors math math.vectors namespaces
shuffle splitting ; shuffle splitting sequences.lib ;
IN: math.polynomials IN: math.polynomials
! Polynomials are vectors with the highest powers on the right: ! Polynomials are vectors with the highest powers on the right:
@ -22,7 +22,7 @@ PRIVATE>
: p= ( p p -- ? ) pextend = ; : p= ( p p -- ? ) pextend = ;
: ptrim ( p -- p ) : ptrim ( p -- p )
dup length 1 = [ [ zero? ] right-trim ] unless ; dup singleton? [ [ zero? ] right-trim ] unless ;
: 2ptrim ( p p -- p p ) [ ptrim ] 2apply ; : 2ptrim ( p p -- p p ) [ ptrim ] 2apply ;
: p+ ( p p -- p ) pextend v+ ; : p+ ( p p -- p ) pextend v+ ;

2
extra/multiline/multiline.factor
View File

@ -16,7 +16,7 @@ IN: multiline
: STRING: : STRING:
CREATE dup reset-generic CREATE dup reset-generic
[ parse-here 1quotation define ] keep make-inline ; parsing parse-here 1quotation define ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index ) : (parse-multiline-string) ( start-index end-text -- end-index )
lexer get line-text 2dup start lexer get line-text 2dup start

4
extra/odbc/odbc-docs.factor
View File

@ -1,6 +1,8 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup odbc threads ; USING: help.syntax help.markup threads ;
IN: odbc
HELP: odbc-init HELP: odbc-init
{ $values { "env" "an ODBC environment handle" } } { $values { "env" "an ODBC environment handle" } }

15
extra/ogg/ogg.factor
View File

@ -4,14 +4,13 @@
USING: kernel system combinators alien alien.syntax ; USING: kernel system combinators alien alien.syntax ;
IN: ogg IN: ogg
: load-ogg-library ( -- ) <<
"ogg" { "ogg" {
{ [ win32? ] [ "ogg.dll" ] } { [ win32? ] [ "ogg.dll" ] }
{ [ macosx? ] [ "libogg.0.dylib" ] } { [ macosx? ] [ "libogg.0.dylib" ] }
{ [ unix? ] [ "libogg.so" ] } { [ unix? ] [ "libogg.so" ] }
} cond "cdecl" add-library ; parsing } cond "cdecl" add-library
>>
load-ogg-library
LIBRARY: ogg LIBRARY: ogg

15
extra/ogg/theora/theora.factor
View File

@ -4,14 +4,13 @@
USING: kernel system combinators alien alien.syntax ; USING: kernel system combinators alien alien.syntax ;
IN: ogg.theora IN: ogg.theora
: load-theora-library ( -- ) <<
"theora" { "theora" {
{ [ win32? ] [ "libtheora.dll" ] } { [ win32? ] [ "libtheora.dll" ] }
{ [ macosx? ] [ "libtheora.0.dylib" ] } { [ macosx? ] [ "libtheora.0.dylib" ] }
{ [ unix? ] [ "libtheora.so" ] } { [ unix? ] [ "libtheora.so" ] }
} cond "cdecl" add-library ; parsing } cond "cdecl" add-library
>>
load-theora-library
LIBRARY: theora LIBRARY: theora

15
extra/ogg/vorbis/vorbis.factor
View File

@ -4,14 +4,13 @@
USING: kernel system combinators alien alien.syntax ; USING: kernel system combinators alien alien.syntax ;
IN: ogg.vorbis IN: ogg.vorbis
: load-vorbis-library ( -- ) <<
"vorbis" { "vorbis" {
{ [ win32? ] [ "vorbis.dll" ] } { [ win32? ] [ "vorbis.dll" ] }
{ [ macosx? ] [ "libvorbis.0.dylib" ] } { [ macosx? ] [ "libvorbis.0.dylib" ] }
{ [ unix? ] [ "libvorbis.so" ] } { [ unix? ] [ "libvorbis.so" ] }
} cond "cdecl" add-library ; parsing } cond "cdecl" add-library
>>
load-vorbis-library
LIBRARY: vorbis LIBRARY: vorbis

9
extra/ori/ori.factor
View File

@ -1,7 +1,7 @@
USING: kernel namespaces USING: kernel namespaces
math math.constants math.functions math.matrices math.vectors math math.constants math.functions math.matrices math.vectors
sequences splitting self ; sequences splitting self math.trig ;
IN: ori IN: ori
@ -11,13 +11,6 @@ C: <ori> ori
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Temporarily defined here until math-contrib gets moved to extra/
: deg>rad pi * 180 / ; inline
: rad>deg 180 * pi / ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ori> ( -- val ) self> ori-val ; : ori> ( -- val ) self> ori-val ;
: >ori ( val -- ) self> set-ori-val ; : >ori ( val -- ) self> set-ori-val ;

266
extra/peg/peg.factor
View File

@ -1,12 +1,16 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle USING: kernel sequences strings namespaces math assocs shuffle
vectors arrays combinators.lib memoize math.parser ; vectors arrays combinators.lib memoize math.parser match ;
IN: peg IN: peg
TUPLE: parse-result remaining ast ; TUPLE: parse-result remaining ast ;
GENERIC: (parse) ( state parser -- result ) GENERIC: compile ( parser -- quot )
: (parse) ( state parser -- result )
compile call ;
<PRIVATE <PRIVATE
@ -72,135 +76,199 @@ PRIVATE>
TUPLE: token-parser symbol ; TUPLE: token-parser symbol ;
M: token-parser (parse) ( input parser -- result ) MATCH-VARS: ?token ;
token-parser-symbol 2dup head? [
dup >r length tail-slice r> <parse-result>
] [
2drop f
] if ;
TUPLE: satisfy-parser quot ;
M: satisfy-parser (parse) ( state parser -- result ) : token-pattern ( -- quot )
over empty? [ [
2drop f ?token 2dup head? [
] [ dup >r length tail-slice r> <parse-result>
satisfy-parser-quot [ unclip-slice dup ] dip call [
<parse-result>
] [ ] [
2drop f 2drop f
] if ] if
] if ; ] ;
M: token-parser compile ( parser -- quot )
token-parser-symbol \ ?token token-pattern match-replace ;
TUPLE: satisfy-parser quot ;
MATCH-VARS: ?quot ;
: satisfy-pattern ( -- quot )
[
dup empty? [
drop f
] [
unclip-slice dup ?quot call [
<parse-result>
] [
2drop f
] if
] if
] ;
M: satisfy-parser compile ( parser -- quot )
satisfy-parser-quot \ ?quot satisfy-pattern match-replace ;
TUPLE: range-parser min max ; TUPLE: range-parser min max ;
M: range-parser (parse) ( state parser -- result ) MATCH-VARS: ?min ?max ;
over empty? [
2drop f : range-pattern ( -- quot )
] [ [
0 pick nth dup rot dup empty? [
{ range-parser-min range-parser-max } get-slots between? [ drop f
[ 1 tail-slice ] dip <parse-result>
] [ ] [
2drop f 0 over nth dup
] if ?min ?max between? [
] if ; [ 1 tail-slice ] dip <parse-result>
] [
2drop f
] if
] if
] ;
M: range-parser compile ( parser -- quot )
T{ range-parser _ ?min ?max } range-pattern match-replace ;
TUPLE: seq-parser parsers ; TUPLE: seq-parser parsers ;
: do-seq-parser ( result parser -- result ) : seq-pattern ( -- quot )
[ dup parse-result-remaining ] dip parse [ [
[ parse-result-remaining swap set-parse-result-remaining ] 2keep dup [
parse-result-ast dup ignore = [ drop ] [ swap [ parse-result-ast push ] keep ] if dup parse-result-remaining ?quot call [
] [ [ parse-result-remaining swap set-parse-result-remaining ] 2keep
drop f parse-result-ast dup ignore = [
] if* ; drop
] [
swap [ parse-result-ast push ] keep
] if
] [
drop f
] if*
] [
drop f
] if
] ;
: (seq-parser) ( result parsers -- result ) M: seq-parser compile ( parser -- quot )
dup empty? not pick and [ [
unclip swap [ do-seq-parser ] dip (seq-parser) [ V{ } clone <parse-result> ] %
] [ seq-parser-parsers [ compile \ ?quot seq-pattern match-replace % ] each
drop ] [ ] make ;
] if ;
M: seq-parser (parse) ( state parser -- result )
seq-parser-parsers [ V{ } clone <parse-result> ] dip (seq-parser) ;
TUPLE: choice-parser parsers ; TUPLE: choice-parser parsers ;
: (choice-parser) ( state parsers -- result )
dup empty? [
2drop f
] [
unclip pick swap parse [
2nip
] [
(choice-parser)
] if*
] if ;
M: choice-parser (parse) ( state parser -- result ) : choice-pattern ( -- quot )
choice-parser-parsers (choice-parser) ; [
dup [
] [
drop dup ?quot call
] if
] ;
M: choice-parser compile ( parser -- quot )
[
f ,
choice-parser-parsers [ compile \ ?quot choice-pattern match-replace % ] each
\ nip ,
] [ ] make ;
TUPLE: repeat0-parser p1 ; TUPLE: repeat0-parser p1 ;
: (repeat-parser) ( parser result -- result ) : (repeat0) ( quot result -- result )
2dup parse-result-remaining swap parse [ 2dup parse-result-remaining swap call [
[ parse-result-remaining swap set-parse-result-remaining ] 2keep [ parse-result-remaining swap set-parse-result-remaining ] 2keep
parse-result-ast swap [ parse-result-ast push ] keep parse-result-ast swap [ parse-result-ast push ] keep
(repeat-parser) (repeat0)
] [ ] [
nip nip
] if* ; ] if* ; inline
: clone-result ( result -- result ) : repeat0-pattern ( -- quot )
{ parse-result-remaining parse-result-ast } [
get-slots 1vector <parse-result> ; ?quot swap (repeat0)
] ;
M: repeat0-parser (parse) ( state parser -- result ) M: repeat0-parser compile ( parser -- quot )
repeat0-parser-p1 2dup parse [ [
nipd clone-result (repeat-parser) [ V{ } clone <parse-result> ] %
] [ repeat0-parser-p1 compile \ ?quot repeat0-pattern match-replace %
drop V{ } clone <parse-result> ] [ ] make ;
] if* ;
TUPLE: repeat1-parser p1 ; TUPLE: repeat1-parser p1 ;
M: repeat1-parser (parse) ( state parser -- result ) : repeat1-pattern ( -- quot )
repeat1-parser-p1 tuck parse dup [ clone-result (repeat-parser) ] [ nip ] if ; [
?quot swap (repeat0) [
dup parse-result-ast empty? [
drop f
] when
] [
f
] if*
] ;
M: repeat1-parser compile ( parser -- quot )
[
[ V{ } clone <parse-result> ] %
repeat1-parser-p1 compile \ ?quot repeat1-pattern match-replace %
] [ ] make ;
TUPLE: optional-parser p1 ; TUPLE: optional-parser p1 ;
M: optional-parser (parse) ( state parser -- result ) : optional-pattern ( -- quot )
dupd optional-parser-p1 parse swap f <parse-result> or ; [
dup ?quot call swap f <parse-result> or
] ;
M: optional-parser compile ( parser -- quot )
optional-parser-p1 compile \ ?quot optional-pattern match-replace ;
TUPLE: ensure-parser p1 ; TUPLE: ensure-parser p1 ;
M: ensure-parser (parse) ( state parser -- result ) : ensure-pattern ( -- quot )
dupd ensure-parser-p1 parse [ [
ignore <parse-result> dup ?quot call [
] [ ignore <parse-result>
drop f ] [
] if ; drop f
] if
] ;
M: ensure-parser compile ( parser -- quot )
ensure-parser-p1 compile \ ?quot ensure-pattern match-replace ;
TUPLE: ensure-not-parser p1 ; TUPLE: ensure-not-parser p1 ;
M: ensure-not-parser (parse) ( state parser -- result ) : ensure-not-pattern ( -- quot )
dupd ensure-not-parser-p1 parse [ [
drop f dup ?quot call [
] [ drop f
ignore <parse-result> ] [
] if ; ignore <parse-result>
] if
] ;
M: ensure-not-parser compile ( parser -- quot )
ensure-not-parser-p1 compile \ ?quot ensure-not-pattern match-replace ;
TUPLE: action-parser p1 quot ; TUPLE: action-parser p1 quot ;
M: action-parser (parse) ( state parser -- result ) MATCH-VARS: ?action ;
tuck action-parser-p1 parse dup [
dup parse-result-ast rot action-parser-quot call : action-pattern ( -- quot )
swap [ set-parse-result-ast ] keep [
] [ ?quot call dup [
nip dup parse-result-ast ?action call
] if ; swap [ set-parse-result-ast ] keep
] when
] ;
M: action-parser compile ( parser -- quot )
{ action-parser-p1 action-parser-quot } get-slots [ compile ] dip
2array { ?quot ?action } action-pattern match-replace ;
: left-trim-slice ( string -- string ) : left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace #! Return a new string without any leading whitespace
@ -211,13 +279,17 @@ M: action-parser (parse) ( state parser -- result )
TUPLE: sp-parser p1 ; TUPLE: sp-parser p1 ;
M: sp-parser (parse) ( state parser -- result ) M: sp-parser compile ( parser -- quot )
[ left-trim-slice ] dip sp-parser-p1 parse ; [
\ left-trim-slice , sp-parser-p1 compile %
] [ ] make ;
TUPLE: delay-parser quot ; TUPLE: delay-parser quot ;
M: delay-parser (parse) ( state parser -- result ) M: delay-parser compile ( parser -- quot )
delay-parser-quot call parse ; [
delay-parser-quot % \ compile , \ call ,
] [ ] make ;
PRIVATE> PRIVATE>

3
extra/peg/search/search-docs.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup peg peg.search ; USING: help.syntax help.markup peg ;
IN: peg.search
HELP: tree-write HELP: tree-write
{ $values { $values

15
extra/postgresql/libpq/libpq.factor
View File

@ -8,14 +8,13 @@
USING: alien alien.syntax combinators system ; USING: alien alien.syntax combinators system ;
IN: postgresql.libpq IN: postgresql.libpq
: load-postgresql-library ( -- ) <<
"postgresql" { "postgresql" {
{ [ win32? ] [ "libpq.dll" ] } { [ win32? ] [ "libpq.dll" ] }
{ [ macosx? ] [ "/opt/local/lib/postgresql81/libpq.dylib" ] } { [ macosx? ] [ "/opt/local/lib/postgresql81/libpq.dylib" ] }
{ [ unix? ] [ "libpq.so" ] } { [ unix? ] [ "libpq.so" ] }
} cond "cdecl" add-library ; parsing } cond "cdecl" add-library
>>
load-postgresql-library
! ConnSatusType ! ConnSatusType
: CONNECTION_OK HEX: 0 ; inline : CONNECTION_OK HEX: 0 ; inline

2
extra/space-invaders/space-invaders-docs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup cpu.8080 ; USING: help.syntax help.markup cpu.8080.emulator ;
IN: space-invaders IN: space-invaders
HELP: run HELP: run

2
extra/space-invaders/space-invaders.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! !
USING: cpu.8080 openal math alien.c-types sequences kernel USING: cpu.8080 cpu.8080.emulator openal math alien.c-types sequences kernel
shuffle arrays io.files combinators kernel.private shuffle arrays io.files combinators kernel.private
ui.gestures ui.gadgets ui.render opengl.gl system ui.gestures ui.gadgets ui.render opengl.gl system
threads concurrency match ui byte-arrays combinators.lib threads concurrency match ui byte-arrays combinators.lib

15
extra/sqlite/lib/lib.factor
View File

@ -12,14 +12,13 @@ IN: sqlite.lib
USING: alien compiler kernel math namespaces sequences strings alien.syntax USING: alien compiler kernel math namespaces sequences strings alien.syntax
system combinators ; system combinators ;
: load-sqlite-library ( -- ) <<
"sqlite" { "sqlite" {
{ [ win32? ] [ "sqlite3.dll" ] } { [ win32? ] [ "sqlite3.dll" ] }
{ [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] } { [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
{ [ unix? ] [ "libsqlite3.so" ] } { [ unix? ] [ "libsqlite3.so" ] }
} cond "cdecl" add-library ; parsing } cond "cdecl" add-library
>>
load-sqlite-library
! Return values from sqlite functions ! Return values from sqlite functions
: SQLITE_OK 0 ; inline ! Successful result : SQLITE_OK 0 ; inline ! Successful result

2
extra/sqlite/sqlite-docs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help sqlite help.syntax help.markup ; USING: help help.syntax help.markup ;
IN: sqlite IN: sqlite
HELP: sqlite-open HELP: sqlite-open

2
extra/sqlite/tuple-db/tuple-db-docs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help sqlite sqlite.tuple-db help.syntax help.markup ; USING: help sqlite help.syntax help.markup ;
IN: sqlite.tuple-db IN: sqlite.tuple-db
ARTICLE: { "sqlite" "tuple-db-loading" } "Loading" ARTICLE: { "sqlite" "tuple-db-loading" } "Loading"

4
extra/trees/avl/avl-docs.factor
View File

@ -1,4 +1,5 @@
USING: help.syntax help.markup trees.avl assocs ; USING: help.syntax help.markup assocs ;
IN: trees.avl
HELP: AVL{ HELP: AVL{
{ $syntax "AVL{ { key value }... }" } { $syntax "AVL{ { key value }... }" }
@ -23,5 +24,4 @@ ARTICLE: { "avl" "intro" } "AVL trees"
{ $subsection >avl } { $subsection >avl }
{ $subsection POSTPONE: AVL{ } ; { $subsection POSTPONE: AVL{ } ;
IN: trees.avl
ABOUT: { "avl" "intro" } ABOUT: { "avl" "intro" }

12
extra/trees/avl/avl.factor
View File

@ -6,10 +6,10 @@ IN: trees.avl
TUPLE: avl ; TUPLE: avl ;
INSTANCE: avl assoc INSTANCE: avl tree-mixin
: <avl> ( -- tree ) : <avl> ( -- tree )
avl construct-empty <tree> over set-delegate ; avl construct-tree ;
TUPLE: avl-node balance ; TUPLE: avl-node balance ;
@ -148,11 +148,3 @@ M: avl assoc-like
\ } [ >avl ] parse-literal ; parsing \ } [ >avl ] parse-literal ; parsing
M: avl pprint-delims drop \ AVL{ \ } ; M: avl pprint-delims drop \ AVL{ \ } ;
! When tuple inheritance is used, the following lines won't be necessary
M: avl assoc-size tree-count ;
M: avl clear-assoc delegate clear-assoc ;
M: avl assoc-find >r tree-root r> find-node ;
M: avl clone dup assoc-clone-like ;
M: avl >pprint-sequence >alist ;
M: avl pprint-narrow? drop t ;

4
extra/trees/splay/splay-docs.factor
View File

@ -1,4 +1,5 @@
USING: help.syntax help.markup trees.splay assocs ; USING: help.syntax help.markup assocs ;
IN: trees.splay
HELP: SPLAY{ HELP: SPLAY{
{ $syntax "SPLAY{ { key value }... }" } { $syntax "SPLAY{ { key value }... }" }
@ -23,5 +24,4 @@ ARTICLE: { "splay" "intro" } "Splay trees"
{ $subsection >splay } { $subsection >splay }
{ $subsection POSTPONE: SPLAY{ } ; { $subsection POSTPONE: SPLAY{ } ;
IN: trees.splay
ABOUT: { "splay" "intro" } ABOUT: { "splay" "intro" }

19
extra/trees/splay/splay.factor
View File

@ -1,5 +1,5 @@
! Copyright (c) 2005 Mackenzie Straight. ! Copyright (c) 2005 Mackenzie Straight.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces sequences assocs parser USING: arrays kernel math namespaces sequences assocs parser
prettyprint.backend trees generic ; prettyprint.backend trees generic ;
IN: trees.splay IN: trees.splay
@ -7,10 +7,9 @@ IN: trees.splay
TUPLE: splay ; TUPLE: splay ;
: <splay> ( -- splay-tree ) : <splay> ( -- splay-tree )
\ splay construct-empty splay construct-tree ;
<tree> over set-delegate ;
INSTANCE: splay assoc INSTANCE: splay tree-mixin
: rotate-right ( node -- node ) : rotate-right ( node -- node )
dup node-left dup node-left
@ -138,16 +137,6 @@ M: splay new-assoc
\ } [ >splay ] parse-literal ; parsing \ } [ >splay ] parse-literal ; parsing
M: splay assoc-like M: splay assoc-like
drop dup splay? [ drop dup splay? [ >splay ] unless ;
dup tree? [ <splay> tuck set-delegate ] [ >splay ] if
] unless ;
M: splay pprint-delims drop \ SPLAY{ \ } ; M: splay pprint-delims drop \ SPLAY{ \ } ;
! When tuple inheritance is used, the following lines won't be necessary
M: splay assoc-size tree-count ;
M: splay clear-assoc delegate clear-assoc ;
M: splay assoc-find >r tree-root r> find-node ;
M: splay clone dup assoc-clone-like ;
M: splay >pprint-sequence >alist ;
M: splay pprint-narrow? drop t ;

3
extra/trees/trees-docs.factor
View File

@ -1,4 +1,5 @@
USING: help.syntax help.markup trees assocs ; USING: help.syntax help.markup assocs ;
IN: trees
HELP: TREE{ HELP: TREE{
{ $syntax "TREE{ { key value }... }" } { $syntax "TREE{ { key value }... }" }

31
extra/trees/trees.factor
View File

@ -5,11 +5,19 @@ prettyprint.private kernel.private assocs random combinators
parser prettyprint.backend ; parser prettyprint.backend ;
IN: trees IN: trees
MIXIN: tree-mixin
TUPLE: tree root count ; TUPLE: tree root count ;
: <tree> ( -- tree ) : <tree> ( -- tree )
f 0 tree construct-boa ; f 0 tree construct-boa ;
INSTANCE: tree assoc : construct-tree ( class -- tree )
construct-empty <tree> over set-delegate ; inline
INSTANCE: tree tree-mixin
INSTANCE: tree-mixin assoc
TUPLE: node key value left right ; TUPLE: node key value left right ;
: <node> ( key value -- node ) : <node> ( key value -- node )
@ -111,16 +119,13 @@ M: tree set-at ( value key tree -- )
{ [ t ] [ >r node-right r> find-node ] } { [ t ] [ >r node-right r> find-node ] }
} cond ; inline } cond ; inline
M: tree assoc-find ( tree quot -- key value ? ) M: tree-mixin assoc-find ( tree quot -- key value ? )
>r tree-root r> find-node ; >r tree-root r> find-node ;
M: tree clear-assoc M: tree-mixin clear-assoc
0 over set-tree-count 0 over set-tree-count
f swap set-tree-root ; f swap set-tree-root ;
M: tree assoc-size
tree-count ;
: copy-node-contents ( new old -- ) : copy-node-contents ( new old -- )
dup node-key pick set-node-key node-value swap set-node-value ; dup node-key pick set-node-key node-value swap set-node-value ;
@ -189,16 +194,14 @@ M: tree clone dup assoc-clone-like ;
: >tree ( assoc -- tree ) : >tree ( assoc -- tree )
T{ tree f f 0 } assoc-clone-like ; T{ tree f f 0 } assoc-clone-like ;
GENERIC: tree-assoc-like ( assoc -- tree ) M: tree-mixin assoc-like drop dup tree? [ >tree ] unless ;
M: tuple tree-assoc-like ! will need changes for tuple inheritance
dup delegate dup tree? [ nip ] [ drop >tree ] if ;
M: tree tree-assoc-like ;
M: assoc tree-assoc-like >tree ;
M: tree assoc-like drop tree-assoc-like ;
: TREE{ : TREE{
\ } [ >tree ] parse-literal ; parsing \ } [ >tree ] parse-literal ; parsing
M: tree pprint-delims drop \ TREE{ \ } ; M: tree pprint-delims drop \ TREE{ \ } ;
M: tree >pprint-sequence >alist ;
M: tree pprint-narrow? drop t ; M: tree-mixin assoc-size tree-count ;
M: tree-mixin clone dup assoc-clone-like ;
M: tree-mixin >pprint-sequence >alist ;
M: tree-mixin pprint-narrow? drop t ;

3
extra/tuple-syntax/tuple-syntax-docs.factor
View File

@ -1,4 +1,5 @@
USING: help.markup help.syntax tuple-syntax ; USING: help.markup help.syntax ;
IN: tuple-syntax
HELP: TUPLE{ HELP: TUPLE{
{ $syntax "TUPLE{ class slot-name: value... }" } { $syntax "TUPLE{ class slot-name: value... }" }

10
extra/webapps/cgi/cgi.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs io.files combinators USING: namespaces kernel assocs io.files combinators
arrays io.launcher io http.server.responders webapps.file arrays io.launcher io http.server.responders webapps.file
sequences strings ; sequences strings math.parser ;
IN: webapps.cgi IN: webapps.cgi
SYMBOL: cgi-root SYMBOL: cgi-root
@ -12,6 +12,8 @@ SYMBOL: cgi-root
: cgi-variables ( name -- assoc ) : cgi-variables ( name -- assoc )
#! This needs some work. #! This needs some work.
[ [
cgi-root get over path+ "PATH_TRANSLATED" set
cgi-root get over path+ "SCRIPT_FILENAME" set
"SCRIPT_NAME" set "SCRIPT_NAME" set
"CGI/1.0" "GATEWAY_INTERFACE" set "CGI/1.0" "GATEWAY_INTERFACE" set
@ -29,13 +31,14 @@ SYMBOL: cgi-root
"method" get >upper "REQUEST_METHOD" set "method" get >upper "REQUEST_METHOD" set
"raw-query" get "QUERY_STRING" set "raw-query" get "QUERY_STRING" set
"Cookie" header-param "HTTP_COOKIE" set
"User-Agent" header-param "HTTP_USER_AGENT" set "User-Agent" header-param "HTTP_USER_AGENT" set
"Accept" header-param "HTTP_ACCEPT" set "Accept" header-param "HTTP_ACCEPT" set
post? [ post? [
"Content-Type" header-param "CONTENT_TYPE" set "Content-Type" header-param "CONTENT_TYPE" set
"raw-response" get length "CONTENT_LENGTH" set "raw-response" get length number>string "CONTENT_LENGTH" set
] when ] when
] H{ } make-assoc ; ] H{ } make-assoc ;
@ -49,8 +52,7 @@ SYMBOL: cgi-root
"200 CGI output follows" response "200 CGI output follows" response
stdio get swap cgi-descriptor <process-stream> [ stdio get swap cgi-descriptor <process-stream> [
post? [ post? [
"raw-response" get "raw-response" get write flush
stream-write stream-flush
] when ] when
stdio get swap (stream-copy) stdio get swap (stream-copy)
] with-stream ; ] with-stream ;

103
extra/xmode/loader/loader.factor
View File

@ -1,59 +1,11 @@
USING: xmode.tokens xmode.rules xmode.keyword-map xml.data USING: xmode.loader.syntax xmode.tokens xmode.rules
xml.utilities xml assocs kernel combinators sequences xmode.keyword-map xml.data xml.utilities xml assocs kernel
math.parser namespaces parser xmode.utilities regexp io.files ; combinators sequences math.parser namespaces parser
xmode.utilities regexp io.files ;
IN: xmode.loader IN: xmode.loader
! Based on org.gjt.sp.jedit.XModeHandler ! Based on org.gjt.sp.jedit.XModeHandler
SYMBOL: ignore-case?
! Attribute utilities
: string>boolean ( string -- ? ) "TRUE" = ;
: string>match-type ( string -- obj )
{
{ "RULE" [ f ] }
{ "CONTEXT" [ t ] }
[ string>token ]
} case ;
: string>rule-set-name "MAIN" or ;
! PROP, PROPS
: parse-prop-tag ( tag -- key value )
"NAME" over at "VALUE" rot at ;
: parse-props-tag ( tag -- assoc )
child-tags
[ parse-prop-tag ] H{ } map>assoc ;
: position-attrs ( tag -- at-line-start? at-whitespace-end? at-word-start? )
! XXX Wrong logic!
{ "AT_LINE_START" "AT_WHITESPACE_END" "AT_WORD_START" }
swap [ at string>boolean ] curry map first3 ;
: parse-literal-matcher ( tag -- matcher )
dup children>string
ignore-case? get <string-matcher>
swap position-attrs <matcher> ;
: parse-regexp-matcher ( tag -- matcher )
dup children>string ignore-case? get <regexp>
swap position-attrs <matcher> ;
! SPAN's children
<TAGS: parse-begin/end-tag
TAG: BEGIN
! XXX
parse-literal-matcher swap set-rule-start ;
TAG: END
! XXX
parse-literal-matcher swap set-rule-end ;
TAGS>
! RULES and its children ! RULES and its children
<TAGS: parse-rule-tag <TAGS: parse-rule-tag
@ -66,56 +18,12 @@ TAG: IMPORT ( rule-set tag -- )
TAG: TERMINATE ( rule-set tag -- ) TAG: TERMINATE ( rule-set tag -- )
"AT_CHAR" swap at string>number swap set-rule-set-terminate-char ; "AT_CHAR" swap at string>number swap set-rule-set-terminate-char ;
: (parse-rule-tag) ( rule-set tag specs class -- )
construct-rule swap init-from-tag swap add-rule ; inline
: RULE:
scan scan-word
parse-definition { } make
swap [ (parse-rule-tag) ] 2curry (TAG:) ; parsing
: shared-tag-attrs
{ "TYPE" string>token set-rule-body-token } , ; inline
: delegate-attr
{ "DELEGATE" f set-rule-delegate } , ;
: regexp-attr
{ "HASH_CHAR" f set-rule-chars } , ;
: match-type-attr
{ "MATCH_TYPE" string>match-type set-rule-match-token } , ;
: span-attrs
{ "NO_LINE_BREAK" string>boolean set-rule-no-line-break? } ,
{ "NO_WORD_BREAK" string>boolean set-rule-no-word-break? } ,
{ "NO_ESCAPE" string>boolean set-rule-no-escape? } , ;
: literal-start
[ parse-literal-matcher swap set-rule-start ] , ;
: regexp-start
[ parse-regexp-matcher swap set-rule-start ] , ;
: literal-end
[ parse-literal-matcher swap set-rule-end ] , ;
RULE: SEQ seq-rule RULE: SEQ seq-rule
shared-tag-attrs delegate-attr literal-start ; shared-tag-attrs delegate-attr literal-start ;
RULE: SEQ_REGEXP seq-rule RULE: SEQ_REGEXP seq-rule
shared-tag-attrs delegate-attr regexp-attr regexp-start ; shared-tag-attrs delegate-attr regexp-attr regexp-start ;
: parse-begin/end-tags
[
! XXX: handle position attrs on span tag itself
child-tags [ parse-begin/end-tag ] with each
] , ;
: init-span-tag [ drop init-span ] , ;
: init-eol-span-tag [ drop init-eol-span ] , ;
RULE: SPAN span-rule RULE: SPAN span-rule
shared-tag-attrs delegate-attr match-type-attr span-attrs parse-begin/end-tags init-span-tag ; shared-tag-attrs delegate-attr match-type-attr span-attrs parse-begin/end-tags init-span-tag ;
@ -134,9 +42,6 @@ RULE: MARK_FOLLOWING mark-following-rule
RULE: MARK_PREVIOUS mark-previous-rule RULE: MARK_PREVIOUS mark-previous-rule
shared-tag-attrs match-type-attr literal-start ; shared-tag-attrs match-type-attr literal-start ;
: parse-keyword-tag ( tag keyword-map -- )
>r dup name-tag string>token swap children>string r> set-at ;
TAG: KEYWORDS ( rule-set tag -- key value ) TAG: KEYWORDS ( rule-set tag -- key value )
ignore-case? get <keyword-map> ignore-case? get <keyword-map>
swap child-tags [ over parse-keyword-tag ] each swap child-tags [ over parse-keyword-tag ] each

101
extra/xmode/loader/syntax/syntax.factor Normal file
View File

@ -0,0 +1,101 @@
USING: xmode.tokens xmode.rules xmode.keyword-map xml.data
xml.utilities xml assocs kernel combinators sequences
math.parser namespaces parser xmode.utilities regexp io.files ;
IN: xmode.loader.syntax
SYMBOL: ignore-case?
! Rule tag parsing utilities
: (parse-rule-tag) ( rule-set tag specs class -- )
construct-rule swap init-from-tag swap add-rule ; inline
: RULE:
scan scan-word
parse-definition { } make
swap [ (parse-rule-tag) ] 2curry (TAG:) ; parsing
! Attribute utilities
: string>boolean ( string -- ? ) "TRUE" = ;
: string>match-type ( string -- obj )
{
{ "RULE" [ f ] }
{ "CONTEXT" [ t ] }
[ string>token ]
} case ;
: string>rule-set-name "MAIN" or ;
! PROP, PROPS
: parse-prop-tag ( tag -- key value )
"NAME" over at "VALUE" rot at ;
: parse-props-tag ( tag -- assoc )
child-tags
[ parse-prop-tag ] H{ } map>assoc ;
: position-attrs ( tag -- at-line-start? at-whitespace-end? at-word-start? )
! XXX Wrong logic!
{ "AT_LINE_START" "AT_WHITESPACE_END" "AT_WORD_START" }
swap [ at string>boolean ] curry map first3 ;
: parse-literal-matcher ( tag -- matcher )
dup children>string
ignore-case? get <string-matcher>
swap position-attrs <matcher> ;
: parse-regexp-matcher ( tag -- matcher )
dup children>string ignore-case? get <regexp>
swap position-attrs <matcher> ;
: shared-tag-attrs
{ "TYPE" string>token set-rule-body-token } , ; inline
: delegate-attr
{ "DELEGATE" f set-rule-delegate } , ;
: regexp-attr
{ "HASH_CHAR" f set-rule-chars } , ;
: match-type-attr
{ "MATCH_TYPE" string>match-type set-rule-match-token } , ;
: span-attrs
{ "NO_LINE_BREAK" string>boolean set-rule-no-line-break? } ,
{ "NO_WORD_BREAK" string>boolean set-rule-no-word-break? } ,
{ "NO_ESCAPE" string>boolean set-rule-no-escape? } , ;
: literal-start
[ parse-literal-matcher swap set-rule-start ] , ;
: regexp-start
[ parse-regexp-matcher swap set-rule-start ] , ;
: literal-end
[ parse-literal-matcher swap set-rule-end ] , ;
! SPAN's children
<TAGS: parse-begin/end-tag
TAG: BEGIN
! XXX
parse-literal-matcher swap set-rule-start ;
TAG: END
! XXX
parse-literal-matcher swap set-rule-end ;
TAGS>
: parse-begin/end-tags
[
! XXX: handle position attrs on span tag itself
child-tags [ parse-begin/end-tag ] with each
] , ;
: init-span-tag [ drop init-span ] , ;
: init-eol-span-tag [ drop init-eol-span ] , ;
: parse-keyword-tag ( tag keyword-map -- )
>r dup name-tag string>token swap children>string r> set-at ;

16
extra/xmode/tokens/tokens.factor
View File

@ -1,20 +1,18 @@
USING: parser words sequences namespaces kernel assocs ; USING: parser words sequences namespaces kernel assocs
compiler.units ;
IN: xmode.tokens IN: xmode.tokens
! Based on org.gjt.sp.jedit.syntax.Token ! Based on org.gjt.sp.jedit.syntax.Token
SYMBOL: tokens SYMBOL: tokens
: string>token ( string -- id ) tokens get at ; [
{ "COMMENT1" "COMMENT2" "COMMENT3" "COMMENT4" "DIGIT" "FUNCTION" "INVALID" "KEYWORD1" "KEYWORD2" "KEYWORD3" "KEYWORD4" "LABEL" "LITERAL1" "LITERAL2" "LITERAL3" "LITERAL4" "MARKUP" "OPERATOR" "END" "NULL" } [
: TOKENS:
";" parse-tokens [
create-in dup define-symbol create-in dup define-symbol
dup word-name swap dup word-name swap
] H{ } map>assoc tokens set-global ; parsing ] H{ } map>assoc tokens set-global
] with-compilation-unit
TOKENS: COMMENT1 COMMENT2 COMMENT3 COMMENT4 DIGIT FUNCTION : string>token ( string -- id ) tokens get at ;
INVALID KEYWORD1 KEYWORD2 KEYWORD3 KEYWORD4 LABEL LITERAL1
LITERAL2 LITERAL3 LITERAL4 MARKUP OPERATOR END NULL ;
TUPLE: token str id ; TUPLE: token str id ;

2
extra/xmode/utilities/utilities.factor
View File

@ -55,4 +55,4 @@ SYMBOL: tag-handler-word
: TAGS> : TAGS>
tag-handler-word get tag-handler-word get
tag-handlers get >alist [ >r dup name-tag r> case ] curry tag-handlers get >alist [ >r dup name-tag r> case ] curry
define-compound ; parsing define ; parsing

3
extra/yahoo/yahoo-docs.factor
View File

@ -1,4 +1,5 @@
USING: yahoo help.syntax help.markup ; USING: help.syntax help.markup ;
IN: yahoo
HELP: search-yahoo HELP: search-yahoo
{ $values { "search" "a string" } { "num" "a positive integer" } { "seq" "sequence of arrays of length 3" } } { $values { "search" "a string" } { "num" "a positive integer" } { "seq" "sequence of arrays of length 3" } }

2
misc/factor.el
View File

@ -102,7 +102,7 @@
(setq font-lock-defaults (setq font-lock-defaults
'(factor-font-lock-keywords nil nil nil nil)) '(factor-font-lock-keywords nil nil nil nil))
(set-syntax-table factor-mode-syntax-table) (set-syntax-table factor-mode-syntax-table)
(run-hooks 'factor-mode-hooks)) (run-hooks 'factor-mode-hook))
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode)) (add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))

6
vm/code_gc.c
View File

@ -245,17 +245,13 @@ void iterate_code_heap(CODE_HEAP_ITERATOR iter)
/* Copy all literals referenced from a code block to newspace */ /* Copy all literals referenced from a code block to newspace */
void collect_literals_step(F_COMPILED *compiled, CELL code_start, void collect_literals_step(F_COMPILED *compiled, CELL code_start,
CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end) CELL reloc_start, CELL literals_start)
{ {
CELL scan; CELL scan;
CELL literal_end = literals_start + compiled->literals_length; CELL literal_end = literals_start + compiled->literals_length;
for(scan = literals_start; scan < literal_end; scan += CELLS) for(scan = literals_start; scan < literal_end; scan += CELLS)
copy_handle((CELL*)scan); copy_handle((CELL*)scan);
for(scan = words_start; scan < words_end; scan += CELLS)
copy_handle((CELL*)scan);
} }
/* Copy literals referenced from all code blocks to newspace */ /* Copy literals referenced from all code blocks to newspace */

6
vm/code_gc.h
View File

@ -48,17 +48,15 @@ INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
F_HEAP code_heap; F_HEAP code_heap;
typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start, typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start,
CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end); CELL reloc_start, CELL literals_start);
INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter) INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter)
{ {
CELL code_start = (CELL)(compiled + 1); CELL code_start = (CELL)(compiled + 1);
CELL reloc_start = code_start + compiled->code_length; CELL reloc_start = code_start + compiled->code_length;
CELL literals_start = reloc_start + compiled->reloc_length; CELL literals_start = reloc_start + compiled->reloc_length;
CELL words_start = literals_start + compiled->literals_length;
CELL words_end = words_start + compiled->words_length;
iter(compiled,code_start,reloc_start,literals_start,words_start,words_end); iter(compiled,code_start,reloc_start,literals_start);
} }
INLINE F_BLOCK *compiled_to_block(F_COMPILED *compiled) INLINE F_BLOCK *compiled_to_block(F_COMPILED *compiled)

34
vm/code_heap.c
View File

@ -38,7 +38,7 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start)
/* Compute an address to store at a relocation */ /* Compute an address to store at a relocation */
INLINE CELL compute_code_rel(F_REL *rel, INLINE CELL compute_code_rel(F_REL *rel,
CELL code_start, CELL literals_start, CELL words_start) CELL code_start, CELL literals_start)
{ {
switch(REL_TYPE(rel)) switch(REL_TYPE(rel))
{ {
@ -48,10 +48,8 @@ INLINE CELL compute_code_rel(F_REL *rel,
return (CELL)get_rel_symbol(rel,literals_start); return (CELL)get_rel_symbol(rel,literals_start);
case RT_LITERAL: case RT_LITERAL:
return CREF(literals_start,REL_ARGUMENT(rel)); return CREF(literals_start,REL_ARGUMENT(rel));
case RT_DISPATCH:
return CREF(words_start,REL_ARGUMENT(rel));
case RT_XT: case RT_XT:
return (CELL)untag_word(get(CREF(words_start,REL_ARGUMENT(rel))))->xt; return (CELL)untag_word(get(CREF(literals_start,REL_ARGUMENT(rel))))->xt;
case RT_HERE: case RT_HERE:
return rel->offset + code_start; return rel->offset + code_start;
case RT_LABEL: case RT_LABEL:
@ -127,7 +125,7 @@ void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value)
/* Perform all fixups on a code block */ /* Perform all fixups on a code block */
void relocate_code_block(F_COMPILED *relocating, CELL code_start, void relocate_code_block(F_COMPILED *relocating, CELL code_start,
CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end) CELL reloc_start, CELL literals_start)
{ {
if(reloc_start != literals_start) if(reloc_start != literals_start)
{ {
@ -138,8 +136,8 @@ void relocate_code_block(F_COMPILED *relocating, CELL code_start,
{ {
CELL offset = rel->offset + code_start; CELL offset = rel->offset + code_start;
F_FIXNUM absolute_value = compute_code_rel(rel, F_FIXNUM absolute_value = compute_code_rel(
code_start,literals_start,words_start); rel,code_start,literals_start);
apply_relocation(REL_CLASS(rel),offset,absolute_value); apply_relocation(REL_CLASS(rel),offset,absolute_value);
@ -228,27 +226,23 @@ F_COMPILED *add_compiled_block(
F_ARRAY *code, F_ARRAY *code,
F_ARRAY *labels, F_ARRAY *labels,
F_ARRAY *relocation, F_ARRAY *relocation,
F_ARRAY *words,
F_ARRAY *literals) F_ARRAY *literals)
{ {
CELL code_format = compiled_code_format(); CELL code_format = compiled_code_format();
CELL code_length = align8(array_capacity(code) * code_format); CELL code_length = align8(array_capacity(code) * code_format);
CELL rel_length = array_capacity(relocation) * sizeof(unsigned int); CELL rel_length = array_capacity(relocation) * sizeof(unsigned int);
CELL words_length = (words ? array_capacity(words) * CELLS : 0);
CELL literals_length = array_capacity(literals) * CELLS; CELL literals_length = array_capacity(literals) * CELLS;
REGISTER_UNTAGGED(code); REGISTER_UNTAGGED(code);
REGISTER_UNTAGGED(labels); REGISTER_UNTAGGED(labels);
REGISTER_UNTAGGED(relocation); REGISTER_UNTAGGED(relocation);
REGISTER_UNTAGGED(words);
REGISTER_UNTAGGED(literals); REGISTER_UNTAGGED(literals);
CELL here = allot_code_block(sizeof(F_COMPILED) + code_length CELL here = allot_code_block(sizeof(F_COMPILED) + code_length
+ rel_length + literals_length + words_length); + rel_length + literals_length);
UNREGISTER_UNTAGGED(literals); UNREGISTER_UNTAGGED(literals);
UNREGISTER_UNTAGGED(words);
UNREGISTER_UNTAGGED(relocation); UNREGISTER_UNTAGGED(relocation);
UNREGISTER_UNTAGGED(labels); UNREGISTER_UNTAGGED(labels);
UNREGISTER_UNTAGGED(code); UNREGISTER_UNTAGGED(code);
@ -259,7 +253,6 @@ F_COMPILED *add_compiled_block(
header->code_length = code_length; header->code_length = code_length;
header->reloc_length = rel_length; header->reloc_length = rel_length;
header->literals_length = literals_length; header->literals_length = literals_length;
header->words_length = words_length;
here += sizeof(F_COMPILED); here += sizeof(F_COMPILED);
@ -277,13 +270,6 @@ F_COMPILED *add_compiled_block(
deposit_objects(here,literals); deposit_objects(here,literals);
here += literals_length; here += literals_length;
/* words */
if(words)
{
deposit_objects(here,words);
here += words_length;
}
/* fixup labels */ /* fixup labels */
if(labels) if(labels)
fixup_labels(labels,code_format,code_start); fixup_labels(labels,code_format,code_start);
@ -347,10 +333,9 @@ DEFINE_PRIMITIVE(modify_code_heap)
F_ARRAY *compiled_code = untag_array(data); F_ARRAY *compiled_code = untag_array(data);
F_ARRAY *literals = untag_array(array_nth(compiled_code,0)); F_ARRAY *literals = untag_array(array_nth(compiled_code,0));
F_ARRAY *words = untag_array(array_nth(compiled_code,1)); F_ARRAY *relocation = untag_array(array_nth(compiled_code,1));
F_ARRAY *relocation = untag_array(array_nth(compiled_code,2)); F_ARRAY *labels = untag_array(array_nth(compiled_code,2));
F_ARRAY *labels = untag_array(array_nth(compiled_code,3)); F_ARRAY *code = untag_array(array_nth(compiled_code,3));
F_ARRAY *code = untag_array(array_nth(compiled_code,4));
REGISTER_UNTAGGED(alist); REGISTER_UNTAGGED(alist);
REGISTER_UNTAGGED(word); REGISTER_UNTAGGED(word);
@ -360,7 +345,6 @@ DEFINE_PRIMITIVE(modify_code_heap)
code, code,
labels, labels,
relocation, relocation,
words,
literals); literals);
UNREGISTER_UNTAGGED(word); UNREGISTER_UNTAGGED(word);

3
vm/code_heap.h
View File

@ -54,7 +54,7 @@ typedef struct {
} F_REL; } F_REL;
void relocate_code_block(F_COMPILED *relocating, CELL code_start, void relocate_code_block(F_COMPILED *relocating, CELL code_start,
CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end); CELL reloc_start, CELL literals_start);
void default_word_code(F_WORD *word, bool relocate); void default_word_code(F_WORD *word, bool relocate);
@ -65,7 +65,6 @@ F_COMPILED *add_compiled_block(
F_ARRAY *code, F_ARRAY *code,
F_ARRAY *labels, F_ARRAY *labels,
F_ARRAY *rel, F_ARRAY *rel,
F_ARRAY *words,
F_ARRAY *literals); F_ARRAY *literals);
CELL compiled_code_format(void); CELL compiled_code_format(void);

12
vm/image.c
View File

@ -179,7 +179,7 @@ void fixup_word(F_WORD *word)
{ {
code_fixup((CELL)&word->code); code_fixup((CELL)&word->code);
if(word->profiling) code_fixup((CELL)&word->profiling); if(word->profiling) code_fixup((CELL)&word->profiling);
update_word_xt(word); code_fixup((CELL)&word->xt);
} }
} }
@ -262,7 +262,7 @@ void relocate_data()
} }
void fixup_code_block(F_COMPILED *relocating, CELL code_start, void fixup_code_block(F_COMPILED *relocating, CELL code_start,
CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end) CELL reloc_start, CELL literals_start)
{ {
/* relocate literal table data */ /* relocate literal table data */
CELL scan; CELL scan;
@ -271,14 +271,8 @@ void fixup_code_block(F_COMPILED *relocating, CELL code_start,
for(scan = literals_start; scan < literal_end; scan += CELLS) for(scan = literals_start; scan < literal_end; scan += CELLS)
data_fixup((CELL*)scan); data_fixup((CELL*)scan);
for(scan = words_start; scan < words_end; scan += CELLS)
data_fixup((CELL*)scan);
if(reloc_start != literals_start) if(reloc_start != literals_start)
{ relocate_code_block(relocating,code_start,reloc_start,literals_start);
relocate_code_block(relocating,code_start,reloc_start,
literals_start,words_start,words_end);
}
} }
void relocate_code() void relocate_code()

2
vm/layouts.h
View File

@ -151,8 +151,6 @@ typedef struct
CELL code_length; /* # bytes */ CELL code_length; /* # bytes */
CELL reloc_length; /* # bytes */ CELL reloc_length; /* # bytes */
CELL literals_length; /* # bytes */ CELL literals_length; /* # bytes */
CELL words_length; /* # bytes */
CELL padding[3];
} F_COMPILED; } F_COMPILED;
/* Assembly code makes assumptions about the layout of this struct */ /* Assembly code makes assumptions about the layout of this struct */

1
vm/profiler.c
View File

@ -25,7 +25,6 @@ F_COMPILED *compile_profiling_stub(F_WORD *word)
untag_object(code), untag_object(code),
NULL, /* no labels */ NULL, /* no labels */
untag_object(relocation), untag_object(relocation),
NULL, /* no words */
untag_object(literals)); untag_object(literals));
} }

12
vm/quotations.c
View File

@ -116,9 +116,6 @@ void jit_compile(CELL quot, bool relocate)
GROWABLE_ARRAY(literals); GROWABLE_ARRAY(literals);
REGISTER_ROOT(literals); REGISTER_ROOT(literals);
GROWABLE_ARRAY(words);
REGISTER_ROOT(words);
GROWABLE_ADD(literals,stack_traces_p() ? quot : F); GROWABLE_ADD(literals,stack_traces_p() ? quot : F);
bool stack_frame = jit_stack_frame_p(untag_object(array)); bool stack_frame = jit_stack_frame_p(untag_object(array));
@ -144,19 +141,19 @@ void jit_compile(CELL quot, bool relocate)
current stack frame. */ current stack frame. */
word = untag_object(obj); word = untag_object(obj);
GROWABLE_ADD(words,array_nth(untag_object(array),i)); GROWABLE_ADD(literals,array_nth(untag_object(array),i));
if(i == length - 1) if(i == length - 1)
{ {
if(stack_frame) if(stack_frame)
EMIT(JIT_EPILOG,0); EMIT(JIT_EPILOG,0);
EMIT(JIT_WORD_JUMP,words_count - 1); EMIT(JIT_WORD_JUMP,literals_count - 1);
tail_call = true; tail_call = true;
} }
else else
EMIT(JIT_WORD_CALL,words_count - 1); EMIT(JIT_WORD_CALL,literals_count - 1);
break; break;
case WRAPPER_TYPE: case WRAPPER_TYPE:
wrapper = untag_object(obj); wrapper = untag_object(obj);
@ -220,14 +217,12 @@ void jit_compile(CELL quot, bool relocate)
GROWABLE_TRIM(code); GROWABLE_TRIM(code);
GROWABLE_TRIM(relocation); GROWABLE_TRIM(relocation);
GROWABLE_TRIM(literals); GROWABLE_TRIM(literals);
GROWABLE_TRIM(words);
F_COMPILED *compiled = add_compiled_block( F_COMPILED *compiled = add_compiled_block(
QUOTATION_TYPE, QUOTATION_TYPE,
untag_object(code), untag_object(code),
NULL, NULL,
untag_object(relocation), untag_object(relocation),
untag_object(words),
untag_object(literals)); untag_object(literals));
set_quot_xt(untag_object(quot),compiled); set_quot_xt(untag_object(quot),compiled);
@ -235,7 +230,6 @@ void jit_compile(CELL quot, bool relocate)
if(relocate) if(relocate)
iterate_code_heap_step(compiled,relocate_code_block); iterate_code_heap_step(compiled,relocate_code_block);
UNREGISTER_ROOT(words);
UNREGISTER_ROOT(literals); UNREGISTER_ROOT(literals);
UNREGISTER_ROOT(relocation); UNREGISTER_ROOT(relocation);
UNREGISTER_ROOT(code); UNREGISTER_ROOT(code);