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

Merge git://factorcode.org/git/factor

db4
Aaron Schaefer 2008-01-20 19:24:08 -05:00
parent 6812eac271 74329237e6
commit eddacad4b3
182 changed files with 4162 additions and 2663 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -140,7 +140,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
clean:
rm -f vm/*.o
rm -f libfactor.a
rm -f factor*.dll libfactor*.*
vm/resources.o:
windres vm/factor.rs vm/resources.o

3
core/alien/c-types/c-types.factor
View File

@ -358,4 +358,7 @@ M: long-long-type box-return ( type -- )
"ushort*" define-primitive-type
[ string>u16-alien ] "ushort*" c-type set-c-type-prep
win64? "longlong" "long" ? "ptrdiff_t" typedef
] with-compilation-unit

17
core/alien/syntax/syntax-docs.factor
View File

@ -1,5 +1,6 @@
USING: alien alien.c-types alien.structs alien.syntax
alien.syntax.private help.markup help.syntax ;
IN: alien.syntax
USING: alien alien.c-types alien.structs alien.syntax.private
help.markup help.syntax ;
HELP: DLL"
{ $syntax "DLL\" path\"" }
@ -50,7 +51,13 @@ $nl
HELP: TYPEDEF:
{ $syntax "TYPEDEF: old new" }
{ $values { "old" "a C type" } { "new" "a C type" } }
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
HELP: TYPEDEF-IF:
{ $syntax "TYPEDEF-IF: word old new" }
{ $values { "word" "a word with stack effect " { $snippet "( -- ? )" } } { "old" "a C type" } { "new" "a C type" } }
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if " { $snippet "word" } " evaluates to a true value." }
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
HELP: C-STRUCT:
@ -81,7 +88,9 @@ HELP: typedef
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
{ $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ;
{ typedef POSTPONE: TYPEDEF: } related-words
{ typedef POSTPONE: TYPEDEF: POSTPONE: TYPEDEF-IF: } related-words
{ POSTPONE: TYPEDEF: typedef POSTPONE: TYPEDEF-IF: } related-words
{ POSTPONE: TYPEDEF-IF: POSTPONE: TYPEDEF: typedef } related-words
HELP: c-struct?
{ $values { "type" "a string" } { "?" "a boolean" } }

12
core/alien/syntax/syntax.factor
View File

@ -23,6 +23,15 @@ IN: alien.syntax
PRIVATE>
: indirect-quot ( function-ptr-quot return types abi -- quot )
[ alien-indirect ] 3curry compose ;
: define-indirect ( abi return function-ptr-quot function-name parameters -- )
>r pick r> parse-arglist
rot create-in dup reset-generic
>r >r swapd roll indirect-quot r> r>
-rot define-declared ;
: DLL" skip-blank parse-string dlopen parsed ; parsing
: ALIEN: scan string>number <alien> parsed ; parsing
@ -37,6 +46,9 @@ PRIVATE>
: TYPEDEF:
scan scan typedef ; parsing
: TYPEDEF-IF:
scan-word execute scan scan rot [ typedef ] [ 2drop ] if ; parsing
: C-STRUCT:
scan in get
parse-definition

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

@ -19,4 +19,4 @@ IN: compiler.constants
: class-hash-offset bootstrap-cell object tag-number - ;
: word-xt-offset 8 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-2 word-xt eq?
\ x-2 word-xt =
] unit-test
] 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
\ g-test-3 word-xt eq?
\ g-test-3 word-xt =
] unit-test
DEFER: g-test-5

6
core/compiler/test/simple.factor
View File

@ -63,3 +63,9 @@ IN: temporary
! Regression
[ ] [ [ callstack ] compile-call drop ] unit-test
! Regression
: empty ;
[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test

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-generator ] unit-test
[ ] [ init-generator ] unit-test
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test

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

@ -51,8 +51,8 @@ HOOK: %save-dispatch-xt compiler-backend ( -- )
M: object %save-dispatch-xt %save-word-xt ;
! Call another label
HOOK: %call-label compiler-backend ( label -- )
! Call another word
HOOK: %call compiler-backend ( word -- )
! Local jump for branches
HOOK: %jump-label compiler-backend ( label -- )
@ -60,10 +60,11 @@ HOOK: %jump-label compiler-backend ( label -- )
! Test if vreg is 'f' or not
HOOK: %jump-t compiler-backend ( label -- )
! We pass the offset of the jump table start in the world table
HOOK: %call-dispatch compiler-backend ( word-table# -- )
HOOK: %call-dispatch compiler-backend ( -- label )
HOOK: %jump-dispatch compiler-backend ( word-table# -- )
HOOK: %jump-dispatch compiler-backend ( -- )
HOOK: %dispatch-label compiler-backend ( word -- )
! Return to caller
HOOK: %return compiler-backend ( -- )

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

@ -97,36 +97,40 @@ M: ppc-backend %epilogue ( n -- )
1 1 rot ADDI
0 MTLR ;
: (%call) 11 MTLR BLRL ;
: (%jump) 11 MTCTR BCTR ;
: %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
M: ppc-backend %call-label ( label -- ) BL ;
M: ppc-backend %call ( label -- ) BL ;
M: ppc-backend %jump-label ( label -- ) B ;
M: ppc-backend %jump-t ( label -- )
0 "flag" operand f v>operand CMPI BNE ;
: (%call) 11 MTLR BLRL ;
: dispatch-template ( word-table# quot -- )
[
>r
"offset" operand "n" operand 1 SRAWI
0 11 LOAD32 rc-absolute-ppc-2/2 rel-dispatch
11 dup "offset" operand LWZX
11 dup word-xt-offset LWZ
r> call
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ; inline
: (%dispatch) ( len -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
"offset" operand "n" operand 1 SRAWI
11 11 "offset" operand ADD
11 dup rot cells LWZ ;
M: ppc-backend %call-dispatch ( word-table# -- )
[ (%call) ] dispatch-template ;
[ 7 (%dispatch) (%call) <label> dup B ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;
M: ppc-backend %jump-dispatch ( word-table# -- )
[ %epilogue-later 11 MTCTR BCTR ] dispatch-template ;
M: ppc-backend %jump-dispatch ( -- )
[ %epilogue-later 6 (%dispatch) (%jump) ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;
M: ppc-backend %dispatch-label ( word -- )
0 , rc-absolute-cell rel-word ;
M: ppc-backend %return ( -- ) %epilogue-later BLR ;
@ -271,7 +275,7 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ;
: %tag-fixnum ( src dest -- ) tag-bits get SLWI ;
: %untag-fixnum ( src dest -- ) tag-bits get SRAWI ;
: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
M: ppc-backend value-structs?
#! On Linux/PPC, value structs are passed in the same way

38
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -23,8 +23,8 @@ IN: cpu.ppc.intrinsics
: %slot-any
"obj" operand "scratch" operand %untag
"n" operand dup 1 SRAWI
"scratch" operand "val" operand "n" operand ;
"offset" operand "n" operand 1 SRAWI
"scratch" operand "val" operand "offset" operand ;
\ slot {
! Slot number is literal and the tag is known
@ -47,9 +47,8 @@ IN: cpu.ppc.intrinsics
{
[ %slot-any LWZX ] H{
{ +input+ { { f "obj" } { f "n" } } }
{ +scratch+ { { f "val" } { f "scratch" } } }
{ +scratch+ { { f "val" } { f "scratch" } { f "offset" } } }
{ +output+ { "val" } }
{ +clobber+ { "n" } }
}
}
} define-intrinsics
@ -88,33 +87,34 @@ IN: cpu.ppc.intrinsics
{
[ %slot-any STWX %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { f "n" } } }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "val" "n" } }
{ +scratch+ { { f "scratch" } { f "offset" } } }
{ +clobber+ { "val" } }
}
}
} define-intrinsics
: (%char-slot)
"offset" operand "n" operand 2 SRAWI
"offset" operand dup "obj" operand ADD ;
\ char-slot [
"out" operand "obj" operand MR
"n" operand dup 2 SRAWI
"n" operand "obj" operand "n" operand ADD
"out" operand "n" operand string-offset LHZ
(%char-slot)
"out" operand "offset" operand string-offset LHZ
"out" operand dup %tag-fixnum
] H{
{ +input+ { { f "n" } { f "obj" } } }
{ +scratch+ { { f "out" } } }
{ +scratch+ { { f "out" } { f "offset" } } }
{ +output+ { "out" } }
{ +clobber+ { "n" } }
} define-intrinsic
\ set-char-slot [
(%char-slot)
"val" operand dup %untag-fixnum
"slot" operand dup 2 SRAWI
"slot" operand dup "obj" operand ADD
"val" operand "slot" operand string-offset STH
"val" operand "offset" operand string-offset STH
] H{
{ +input+ { { f "val" } { f "slot" } { f "obj" } } }
{ +clobber+ { "val" "slot" } }
{ +input+ { { f "val" } { f "n" } { f "obj" } } }
{ +scratch+ { { f "offset" } } }
{ +clobber+ { "val" } }
} define-intrinsic
: fixnum-register-op ( op -- pair )
@ -185,10 +185,10 @@ IN: cpu.ppc.intrinsics
{
[
{ "positive" "end" } [ define-label ] each
"y" operand "out" operand swap %untag-fixnum
"out" operand "y" operand %untag-fixnum
0 "y" operand 0 CMPI
"positive" get BGE
"y" operand dup NEG
"out" operand dup NEG
"out" operand "x" operand "out" operand SRAW
"end" get B
"positive" resolve-label

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

@ -70,37 +70,40 @@ M: x86-backend %prepare-alien-invoke
temp-reg v>operand 2 cells [+] ds-reg MOV
temp-reg v>operand 3 cells [+] rs-reg MOV ;
M: x86-backend %call-label ( label -- ) CALL ;
M: x86-backend %call ( label -- ) CALL ;
M: x86-backend %jump-label ( label -- ) JMP ;
M: x86-backend %jump-t ( label -- )
"flag" operand f v>operand CMP JNE ;
: (%dispatch) ( word-table# -- )
! Untag and multiply to get a jump table offset
"n" operand fixnum>slot@
! Add to jump table base. We use a temporary register
: (%dispatch) ( n -- operand )
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
"scratch" operand HEX: ffffffff MOV rc-absolute-cell rel-dispatch
"n" operand "n" operand "scratch" operand [+] MOV
"n" operand dup word-xt-offset [+] MOV ;
: dispatch-template ( word-table# quot -- )
[
>r (%dispatch) "n" operand r> call
] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "scratch" } } }
{ +clobber+ { "n" } }
} with-template ; inline
! Untag and multiply to get a jump table offset
"n" operand fixnum>slot@
! Add jump table base
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
"n" operand "offset" operand ADD
"n" operand swap bootstrap-cell 8 = 14 9 ? + [+] ;
M: x86-backend %call-dispatch ( word-table# -- )
[ CALL ] dispatch-template ;
[ 5 (%dispatch) CALL <label> dup JMP ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
{ +clobber+ { "n" } }
} with-template ;
M: x86-backend %jump-dispatch ( word-table# -- )
[ %epilogue-later JMP ] dispatch-template ;
M: x86-backend %jump-dispatch ( -- )
[ %epilogue-later 0 (%dispatch) JMP ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
{ +clobber+ { "n" } }
} with-template ;
M: x86-backend %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
M: x86-backend %unbox-float ( dst src -- )
[ v>operand ] 2apply float-offset [+] MOVSD ;

98
core/cpu/x86/assembler/assembler.factor
View File

@ -11,78 +11,42 @@ IN: cpu.x86.assembler
! In 64-bit mode, { 1234 } is RIP-relative.
! Beware!
! Register operands -- eg, ECX
: define-register ( symbol num size -- )
>r dupd "register" set-word-prop r>
"register-size" set-word-prop ;
! x86 registers
SYMBOL: AL \ AL 0 8 define-register
SYMBOL: CL \ CL 1 8 define-register
SYMBOL: DL \ DL 2 8 define-register
SYMBOL: BL \ BL 3 8 define-register
SYMBOL: AX \ AX 0 16 define-register
SYMBOL: CX \ CX 1 16 define-register
SYMBOL: DX \ DX 2 16 define-register
SYMBOL: BX \ BX 3 16 define-register
SYMBOL: SP \ SP 4 16 define-register
SYMBOL: BP \ BP 5 16 define-register
SYMBOL: SI \ SI 6 16 define-register
SYMBOL: DI \ DI 7 16 define-register
SYMBOL: EAX \ EAX 0 32 define-register
SYMBOL: ECX \ ECX 1 32 define-register
SYMBOL: EDX \ EDX 2 32 define-register
SYMBOL: EBX \ EBX 3 32 define-register
SYMBOL: ESP \ ESP 4 32 define-register
SYMBOL: EBP \ EBP 5 32 define-register
SYMBOL: ESI \ ESI 6 32 define-register
SYMBOL: EDI \ EDI 7 32 define-register
SYMBOL: XMM0 \ XMM0 0 128 define-register
SYMBOL: XMM1 \ XMM1 1 128 define-register
SYMBOL: XMM2 \ XMM2 2 128 define-register
SYMBOL: XMM3 \ XMM3 3 128 define-register
SYMBOL: XMM4 \ XMM4 4 128 define-register
SYMBOL: XMM5 \ XMM5 5 128 define-register
SYMBOL: XMM6 \ XMM6 6 128 define-register
SYMBOL: XMM7 \ XMM7 7 128 define-register
! AMD64 registers
SYMBOL: RAX \ RAX 0 64 define-register
SYMBOL: RCX \ RCX 1 64 define-register
SYMBOL: RDX \ RDX 2 64 define-register
SYMBOL: RBX \ RBX 3 64 define-register
SYMBOL: RSP \ RSP 4 64 define-register
SYMBOL: RBP \ RBP 5 64 define-register
SYMBOL: RSI \ RSI 6 64 define-register
SYMBOL: RDI \ RDI 7 64 define-register
SYMBOL: R8 \ R8 8 64 define-register
SYMBOL: R9 \ R9 9 64 define-register
SYMBOL: R10 \ R10 10 64 define-register
SYMBOL: R11 \ R11 11 64 define-register
SYMBOL: R12 \ R12 12 64 define-register
SYMBOL: R13 \ R13 13 64 define-register
SYMBOL: R14 \ R14 14 64 define-register
SYMBOL: R15 \ R15 15 64 define-register
SYMBOL: XMM8 \ XMM8 8 128 define-register
SYMBOL: XMM9 \ XMM9 9 128 define-register
SYMBOL: XMM10 \ XMM10 10 128 define-register
SYMBOL: XMM11 \ XMM11 11 128 define-register
SYMBOL: XMM12 \ XMM12 12 128 define-register
SYMBOL: XMM13 \ XMM13 13 128 define-register
SYMBOL: XMM14 \ XMM14 14 128 define-register
SYMBOL: XMM15 \ XMM15 15 128 define-register
<PRIVATE
: n, >le % ; inline
: 4, 4 n, ; inline
: 2, 2 n, ; inline
: cell, bootstrap-cell n, ; inline
! Register operands -- eg, ECX
<<
: define-register ( name num size -- )
>r >r "cpu.x86.assembler" create dup define-symbol r> r>
>r dupd "register" set-word-prop r>
"register-size" set-word-prop ;
: define-registers ( names size -- )
>r dup length r> [ define-register ] curry 2each ;
: REGISTERS:
scan-word ";" parse-tokens swap define-registers ; parsing
>>
REGISTERS: 8 AL CL DL BL ;
REGISTERS: 16 AX CX DX BX SP BP SI DI ;
REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI ;
REGISTERS: 64
RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
REGISTERS: 128
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
<PRIVATE
#! Extended AMD64 registers (R8-R15) return true.
GENERIC: extended? ( op -- ? )

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

@ -13,13 +13,6 @@ HELP: add-literal
{ $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 } "." } ;
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
{ $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."

17
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.
USING: arrays generic assocs hashtables
kernel kernel.private math namespaces sequences words
@ -69,6 +69,7 @@ SYMBOL: label-table
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
: rt-here 5 ;
: rt-label 6 ;
TUPLE: label-fixup label class ;
@ -109,10 +110,6 @@ SYMBOL: literal-table
: 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 )
wince? [ string>u16-alien ] [ string>char-alien ] if ;
@ -124,10 +121,11 @@ SYMBOL: word-table
add-dlsym-literals
r> r> rt-dlsym rel-fixup ;
: rel-dispatch ( word-table# class -- ) rt-dispatch rel-fixup ;
: rel-word ( word class -- )
>r add-word r> rt-xt rel-fixup ;
>r add-literal r> rt-xt rel-fixup ;
: rel-primitive ( word class -- )
>r word-def first r> rt-primitive rel-fixup ;
: rel-literal ( literal class -- )
>r add-literal r> rt-literal rel-fixup ;
@ -135,6 +133,9 @@ SYMBOL: word-table
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
: rel-here ( class -- )
0 swap rt-here rel-fixup ;
: init-fixup ( -- )
V{ } clone relocation-table set
V{ } clone label-table set ;

60
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.
USING: arrays assocs classes combinators cpu.architecture
effects generator.fixup generator.registers generic hashtables
inference inference.backend inference.dataflow io kernel
kernel.private layouts math namespaces optimizer prettyprint
quotations sequences system threads words ;
quotations sequences system threads words vectors ;
IN: generator
SYMBOL: compile-queue
SYMBOL: compiled
: 5array 3array >r 2array r> append ;
: begin-compiling ( word -- )
f swap compiled get set-at ;
: finish-compiling ( word literals words relocation labels code -- )
5array swap compiled get set-at ;
: finish-compiling ( word literals relocation labels code -- )
4array swap compiled get set-at ;
: queue-compile ( word -- )
{
@ -38,20 +36,18 @@ SYMBOL: current-label-start
: compiled-stack-traces? ( -- ? ) 36 getenv ;
: init-generator ( compiling -- )
V{ } clone literal-table set
V{ } clone word-table set
compiled-stack-traces? swap f ?
literal-table get push ;
: init-generator ( -- )
compiled-stack-traces?
compiling-word get f ?
1vector literal-table set ;
: generate-1 ( word label node quot -- )
pick begin-compiling [
roll compiling-word set
pick compiling-label set
compiling-word get init-generator
init-generator
call
literal-table get >array
word-table get >array
] { } make fixup finish-compiling ;
GENERIC: generate-node ( node -- next )
@ -104,14 +100,10 @@ UNION: #terminal
! node
M: node generate-node drop iterate-next ;
: %call ( word -- ) %call-label ;
: %jump ( word -- )
dup compiling-label get eq? [
drop current-label-start get %jump-label
] [
%epilogue-later %jump-label
] if ;
dup compiling-label get eq?
[ drop current-label-start get ] [ %epilogue-later ] if
%jump-label ;
: generate-call ( label -- next )
dup maybe-compile
@ -162,22 +154,22 @@ M: #if generate-node
] generate-1
] keep ;
: dispatch-branches ( node -- syms )
node-children
[ compiling-word get dispatch-branch ] map
word-table get push-all ;
: %dispatch ( word-table# -- )
tail-call? [
%jump-dispatch
] [
0 frame-required
%call-dispatch
] if ;
: dispatch-branches ( node -- )
node-children [
compiling-word get dispatch-branch %dispatch-label
] each ;
M: #dispatch generate-node
word-table get length %dispatch
dispatch-branches init-templates iterate-next ;
#! The order here is important, dispatch-branches must
#! run after %dispatch, so that each branch gets the
#! correct register state
tail-call? [
%jump-dispatch dispatch-branches
] [
0 frame-required
%call-dispatch >r dispatch-branches r> resolve-label
] if
init-templates iterate-next ;
! #call
: define-intrinsics ( word intrinsics -- )

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

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

21
core/inference/class/class-tests.factor
View File

@ -3,7 +3,8 @@ USING: arrays math.private kernel math compiler inference
inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units ;
slots.private combinators definitions compiler.units
system ;
! Make sure these compile even though this is invalid code
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
@ -251,12 +252,14 @@ M: fixnum annotate-entry-test-1 drop ;
\ fixnum-shift inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ shift inlined?
] unit-test
cell-bits 32 = [
[ t ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ shift inlined?
] unit-test
[ f ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ fixnum-shift inlined?
] unit-test
[ f ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
\ fixnum-shift inlined?
] unit-test
] when

4
core/inference/transforms/transforms-tests.factor
View File

@ -1,6 +1,6 @@
IN: temporary
USING: sequences inference.transforms tools.test math kernel
quotations ;
quotations tools.test.inference ;
: compose-n-quot <repetition> >quotation ;
: compose-n compose-n-quot call ;
@ -18,3 +18,5 @@ quotations ;
[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
\ construct-empty must-infer

26
core/inference/transforms/transforms.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
inference.dataflow inference.state tuples.private ;
inference.dataflow inference.state tuples.private effects ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )
@ -61,11 +61,21 @@ M: pair (bitfield-quot) ( spec -- quot )
\ set-slots [ <reversed> [get-slots] ] 1 define-transform
: [construct] ( word quot -- newquot )
>r dup +inlined+ depends-on dup tuple-size r> 2curry ;
\ construct-boa [
dup +inlined+ depends-on
dup tuple-size [ <tuple-boa> ] 2curry
] 1 define-transform
\ construct-boa
[ [ <tuple-boa> ] [construct] ] 1 define-transform
\ construct-empty [
1 ensure-values
peek-d value? [
pop-literal
dup +inlined+ depends-on
dup tuple-size [ <tuple> ] 2curry
swap infer-quot
] [
\ construct-empty declared-infer
] if
] "infer" set-word-prop
\ construct-empty
[ [ <tuple> ] [construct] ] 1 define-transform
\ construct-empty 1 1 <effect> "inferred-effect" set-word-prop

3
core/io/io.factor
View File

@ -35,6 +35,9 @@ GENERIC: stream-write-table ( table-cells style stream -- )
! Default stream
SYMBOL: stdio
! Default error stream
SYMBOL: stderr
: close ( -- ) stdio get stream-close ;
: readln ( -- str/f ) stdio get stream-readln ;

15
core/io/streams/c/c-docs.factor
View File

@ -14,9 +14,10 @@ ARTICLE: "io.streams.c" "ANSI C streams"
{ $subsection fclose }
{ $subsection fgetc }
{ $subsection fread }
"Two standard file handles:"
{ $subsection stdin }
{ $subsection stdout } ;
"The three standard file handles:"
{ $subsection stdin-handle }
{ $subsection stdout-handle }
{ $subsection stderr-handle } ;
ABOUT: "io.streams.c"
@ -64,10 +65,14 @@ HELP: fread ( n alien -- str/f )
{ $description "Reads a sequence of characters from a C FILE* handle, and outputs " { $link f } " on end of file." }
{ $errors "Throws an error if the input operation failed." } ;
HELP: stdin
HELP: stdin-handle
{ $values { "in" "a C FILE* handle" } }
{ $description "Outputs the console standard input file handle." } ;
HELP: stdout
HELP: stdout-handle
{ $values { "out" "a C FILE* handle" } }
{ $description "Outputs the console standard output file handle." } ;
HELP: stderr-handle
{ $values { "out" "a C FILE* handle" } }
{ $description "Outputs the console standard error file handle." } ;

9
core/io/streams/c/c.factor
View File

@ -56,12 +56,13 @@ M: c-reader stream-close
M: object init-io ;
: stdin 11 getenv ;
: stdout 12 getenv ;
: stdin-handle 11 getenv ;
: stdout-handle 12 getenv ;
: stderr-handle 38 getenv ;
M: object init-stdio
stdin stdout <duplex-c-stream> stdio set-global ;
stdin-handle stdout-handle <duplex-c-stream> stdio set-global
stderr-handle <c-writer> <plain-writer> stderr set-global ;
M: object io-multiplex (sleep) ;

4
core/kernel/kernel-docs.factor
View File

@ -49,7 +49,7 @@ ARTICLE: "basic-combinators" "Basic combinators"
{ $subsection execute }
"These words are used to implement " { $emphasis "combinators" } ", which are words that take code from the stack. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
{ $code
": keep ( x quot -- x | quot: x -- )"
": keep ( x quot -- x )"
" over >r call r> ; inline"
}
"Word inlining is documented in " { $link "declarations" } "."
@ -557,7 +557,7 @@ HELP: dip
HELP: while
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "body" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
{ $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used."
$nl
"Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:"

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

@ -1,6 +1,6 @@
USING: arrays byte-arrays kernel kernel.private math memory
namespaces sequences tools.test math.private quotations
continuations prettyprint io.streams.string debugger ;
continuations prettyprint io.streams.string debugger assocs ;
IN: temporary
[ 0 ] [ f size ] unit-test
@ -108,3 +108,13 @@ IN: temporary
[ drop foo ] unit-test-fails
[ ] [ :c ] unit-test
! Regression
: (loop) ( a b c d -- )
>r pick r> swap >r pick r> swap
< [ >r >r >r 1+ r> r> r> (loop) ] [ 2drop 2drop ] if ; inline
: loop ( obj obj -- )
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
[ loop ] unit-test-fails

8
core/namespaces/namespaces.factor
View File

@ -15,16 +15,16 @@ IN: namespaces
PRIVATE>
: namespace ( -- namespace ) namestack* peek ;
: namestack ( -- namestack ) namestack* clone ; inline
: set-namestack ( namestack -- ) >vector 0 setenv ; inline
: namestack ( -- namestack ) namestack* clone ;
: set-namestack ( namestack -- ) >vector 0 setenv ;
: global ( -- g ) 21 getenv { hashtable } declare ; inline
: init-namespaces ( -- ) global 1array set-namestack ;
: get ( variable -- value ) namestack* assoc-stack ; flushable
: set ( value variable -- ) namespace set-at ;
: on ( variable -- ) t swap set ; inline
: off ( variable -- ) f swap set ; inline
: get-global ( variable -- value ) global at ; inline
: set-global ( value variable -- ) global set-at ; inline
: get-global ( variable -- value ) global at ;
: set-global ( value variable -- ) global set-at ;
: change ( variable quot -- )
>r dup get r> rot slip set ; inline

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

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.known-words
USING: alien arrays generic hashtables inference.dataflow
@ -14,8 +14,8 @@ float-arrays combinators.private combinators ;
! its second-to-last input
{ <tuple> <tuple-boa> } [
[
node-in-d dup length 2 - swap nth dup value?
[ value-literal ] [ drop tuple ] if 1array f
dup node-in-d dup length 2 - swap nth node-literal
dup class? [ drop tuple ] unless 1array f
] "output-classes" set-word-prop
] each
@ -149,6 +149,10 @@ float-arrays combinators.private combinators ;
\ >array { { string vector } } "specializer" set-word-prop
\ >vector { { array vector } } "specializer" set-word-prop
\ >sbuf { string } "specializer" set-word-prop
\ crc32 { string } "specializer" set-word-prop
\ split, { string string } "specializer" set-word-prop

9
core/prettyprint/prettyprint-tests.factor
View File

@ -290,6 +290,14 @@ unit-test
[ ] [ \ effect-in synopsis drop ] unit-test
! Regression
[ t ] [
"IN: temporary\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
dup eval
"generic-decl-test" "temporary" lookup
[ see ] string-out =
] unit-test
[ [ + ] ] [
[ \ + (step-into) ] (remove-breakpoints)
] unit-test
@ -313,4 +321,3 @@ unit-test
[ [ 2 . ] ] [
[ 2 \ break (step-into) . ] (remove-breakpoints)
] unit-test

1
core/prettyprint/prettyprint.factor
View File

@ -207,6 +207,7 @@ M: word declarations.
POSTPONE: delimiter
POSTPONE: inline
POSTPONE: foldable
POSTPONE: flushable
} [ declaration. ] with each ;
: pprint-; \ ; pprint-word ;

2
core/sequences/sequences.factor
View File

@ -199,7 +199,7 @@ TUPLE: slice-error reason ;
: <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when
check-slice
slice construct-boa ;
slice construct-boa ; inline
M: slice virtual-seq slice-seq ;
M: slice virtual@ [ slice-from + ] keep slice-seq ;

0
core/strings/strings-docs.factor Normal file → Executable file
View File

5
core/syntax/syntax.factor
View File

@ -170,5 +170,8 @@ IN: bootstrap.syntax
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
"<<" [ \ >> parse-until >quotation call ] define-syntax
"<<" [
[ \ >> parse-until >quotation ] with-compilation-unit
call
] define-syntax
] with-compilation-unit

2
core/vectors/vectors.factor
View File

@ -7,7 +7,7 @@ IN: vectors
: <vector> ( n -- vector ) f <array> 0 array>vector ; inline
: >vector ( seq -- vector ) V{ } clone-like ; inline
: >vector ( seq -- vector ) V{ } clone-like ;
M: vector like
drop dup vector? [

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

@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double.
! 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
HELP: run

7
extra/benchmark/sha1/sha1.factor Normal file
View File

@ -0,0 +1,7 @@
USING: crypto.sha1 io.files kernel ;
IN: benchmark.sha1
: sha1-primes-list ( -- )
"extra/math/primes/list/list.factor" resource-path file>sha1 drop ;
MAIN: sha1-primes-list

1
extra/cel-shading/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

152
extra/cel-shading/cel-shading.factor Normal file
View File

@ -0,0 +1,152 @@
USING: arrays bunny io io.files kernel
math math.functions math.vectors multiline
namespaces
opengl opengl.gl
prettyprint
sequences ui ui.gadgets ui.gestures ui.render ;
IN: cel-shading
: NEAR-PLANE 1.0 64.0 / ; inline
: FAR-PLANE 4.0 ; inline
: FOV 2.0 sqrt 1+ ; inline
: MOUSE-MOTION-SCALE 0.5 ; inline
: MOUSE-DISTANCE-SCALE 1.0 64.0 / ; inline
: KEY-ROTATE-STEP 1.0 ; inline
: KEY-DISTANCE-STEP 1.0 64.0 / ; inline
: DIMS { 640 480 } ; inline
: FOV-RATIO ( -- fov ) DIMS dup first2 min v/n ;
SYMBOL: last-drag-loc
TUPLE: cel-shading-gadget yaw pitch distance model program ;
: <cel-shading-gadget> ( -- cel-shading-gadget )
cel-shading-gadget construct-gadget
0.0 over set-cel-shading-gadget-yaw
0.0 over set-cel-shading-gadget-pitch
0.375 over set-cel-shading-gadget-distance
maybe-download read-model over set-cel-shading-gadget-model ;
: yaw-cel-shading-gadget ( yaw gadget -- )
[ [ cel-shading-gadget-yaw + ] keep set-cel-shading-gadget-yaw ] keep relayout-1 ;
: pitch-cel-shading-gadget ( pitch gadget -- )
[ [ cel-shading-gadget-pitch + ] keep set-cel-shading-gadget-pitch ] keep relayout-1 ;
: zoom-cel-shading-gadget ( distance gadget -- )
[ [ cel-shading-gadget-distance + ] keep set-cel-shading-gadget-distance ] keep relayout-1 ;
M: cel-shading-gadget pref-dim* ( gadget -- dim )
drop DIMS ;
: -+ ( x -- -x x )
dup neg swap ;
: cel-shading-frustum ( -- -x x -y y near far )
FOV-RATIO NEAR-PLANE FOV / v*n
first2 [ -+ ] 2apply NEAR-PLANE FAR-PLANE ;
STRING: cel-shading-vertex-shader-source
varying vec3 position, normal;
void
main()
{
gl_Position = ftransform();
position = gl_Vertex.xyz;
normal = gl_Normal;
}
;
STRING: cel-shading-fragment-shader-source
varying vec3 position, normal;
uniform vec3 light_direction;
uniform vec4 color;
uniform vec4 ambient, diffuse;
float
smooth_modulate(vec3 direction, vec3 normal)
{
return clamp(dot(direction, normal), 0.0, 1.0);
}
float
modulate(vec3 direction, vec3 normal)
{
float m = smooth_modulate(direction, normal);
return smoothstep(0.0, 0.01, m) * 0.4 + smoothstep(0.49, 0.5, m) * 0.5;
}
void
main()
{
vec3 direction = normalize(light_direction - position);
gl_FragColor = ambient + diffuse * color * vec4(vec3(modulate(direction, normal)), 1);
}
;
: cel-shading-program ( -- program )
cel-shading-vertex-shader-source <vertex-shader> check-gl-shader
cel-shading-fragment-shader-source <fragment-shader> check-gl-shader
2array <gl-program> check-gl-program ;
M: cel-shading-gadget graft* ( gadget -- )
0.0 0.0 0.0 1.0 glClearColor
GL_CULL_FACE glEnable
GL_DEPTH_TEST glEnable
cel-shading-program swap set-cel-shading-gadget-program ;
M: cel-shading-gadget ungraft* ( gadget -- )
cel-shading-gadget-program delete-gl-program ;
: cel-shading-draw-setup ( gadget -- gadget )
GL_PROJECTION glMatrixMode
glLoadIdentity
cel-shading-frustum glFrustum
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
GL_MODELVIEW glMatrixMode
glLoadIdentity
[ >r 0.0 0.0 r> cel-shading-gadget-distance neg glTranslatef ] keep
[ cel-shading-gadget-pitch 1.0 0.0 0.0 glRotatef ] keep
[ cel-shading-gadget-yaw 0.0 1.0 0.0 glRotatef ] keep
[ cel-shading-gadget-program [ "light_direction" glGetUniformLocation -25.0 45.0 80.0 glUniform3f ] keep
[ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ] keep
[ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ] keep
"diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ] keep ;
M: cel-shading-gadget draw-gadget* ( gadget -- )
dup cel-shading-gadget-program [
cel-shading-draw-setup
0.0 -0.12 0.0 glTranslatef
cel-shading-gadget-model first3 draw-bunny
] with-gl-program ;
: reset-last-drag-rel ( -- )
{ 0 0 } last-drag-loc set ;
: last-drag-rel ( -- rel )
drag-loc [ last-drag-loc get v- ] keep last-drag-loc set ;
: drag-yaw-pitch ( -- yaw pitch )
last-drag-rel MOUSE-MOTION-SCALE v*n first2 ;
cel-shading-gadget H{
{ T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-cel-shading-gadget ] }
{ T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-cel-shading-gadget ] }
{ T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-cel-shading-gadget ] }
{ T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-cel-shading-gadget ] }
{ T{ key-down f f "=" } [ KEY-DISTANCE-STEP neg swap zoom-cel-shading-gadget ] }
{ T{ key-down f f "-" } [ KEY-DISTANCE-STEP swap zoom-cel-shading-gadget ] }
{ T{ button-down f f 1 } [ drop reset-last-drag-rel ] }
{ T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-cel-shading-gadget ] keep yaw-cel-shading-gadget ] }
{ T{ mouse-scroll } [ scroll-direction get second MOUSE-DISTANCE-SCALE * swap zoom-cel-shading-gadget ] }
} set-gestures
: cel-shading-window ( -- )
[ <cel-shading-gadget> "Cel Shading" open-window ] with-ui ;
MAIN: cel-shading-window

1
extra/cel-shading/summary.txt Normal file
View File

@ -0,0 +1 @@
Stanford Bunny rendered with a cel-shading GLSL program

3
extra/cel-shading/tags.txt Normal file
View File

@ -0,0 +1,3 @@
demos
opengl
glsl

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

@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup channels ;
USING: help.syntax help.markup ;
IN: channels
HELP: <channel>

4
extra/channels/remote/remote-docs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup channels channels.remote concurrency.distributed ;
USING: help.syntax help.markup channels concurrency.distributed ;
IN: channels.remote
HELP: <remote-channel>
@ -59,4 +59,4 @@ $nl
{ $snippet "\"myhost.com\" 9001 <node> \"ID123456\" <remote-channel>\n\"hello\" over to" }
;
ABOUT: { "remote-channels" "remote-channels" }
ABOUT: { "remote-channels" "remote-channels" }

3
extra/channels/sniffer/backend/backend.factor Normal file
View File

@ -0,0 +1,3 @@
USING: io.backend ;
HOOK: sniff-channel io-backend ( -- channel )

5
extra/channels/sniffer/bsd/bsd.factor
View File

@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
!
! Wrap a sniffer in a channel
USING: kernel channels channels.sniffer concurrency io
io.sniffer io.sniffer.bsd io.unix.backend ;
USING: kernel channels channels.sniffer.backend concurrency io
io.sniffer.backend io.sniffer.bsd io.unix.backend ;
IN: channels.sniffer.bsd
M: unix-io sniff-channel ( -- channel )
"/dev/bpf0" "en1" <sniffer-spec> <sniffer> <channel> [

4
extra/channels/sniffer/sniffer.factor
View File

@ -3,11 +3,9 @@
!
! Wrap a sniffer in a channel
USING: kernel channels concurrency io io.backend
io.sniffer system vocabs.loader ;
io.sniffer io.sniffer.backend system vocabs.loader ;
: (sniff-channel) ( stream channel -- )
4096 pick stream-read-partial over to (sniff-channel) ;
HOOK: sniff-channel io-backend ( -- channel )
bsd? [ "channels.sniffer.bsd" require ] when

5
extra/coroutines/coroutines-docs.factor
View File

@ -1,5 +1,6 @@
! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
USING: help.markup help.syntax coroutines ;
USING: help.markup help.syntax ;
IN: coroutines
HELP: cocreate
{ $values { "quot" "a quotation with stack effect ( value -- )" } { "co" "a coroutine" } }
@ -51,4 +52,4 @@ HELP: coterminate
HELP: current-coro
{ $description "Variable which contains the currently executing coroutine, or " { $link f } " if none is executing. User code should treat this variable as read-only." }
{ $see-also cocreate coresume coyield }
;
;

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

@ -1,39 +1,8 @@
! Copyright (C) 2007 Chris Double.
! 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
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"
"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

7
extra/cryptlib/libcl/libcl.factor
View File

@ -12,14 +12,11 @@ USING: alien kernel system combinators alien.syntax ;
IN: cryptlib.libcl
: load-libcl ( -- )
"libcl" {
<< "libcl" {
{ [ win32? ] [ "cl32.dll" "stdcall" ] }
{ [ macosx? ] [ "libcl.dylib" "cdecl" ] }
{ [ unix? ] [ "libcl.so" "cdecl" ] }
} cond add-library ; parsing
load-libcl
} cond add-library >>
! ===============================================
! Machine-dependant types

3
extra/crypto/md5/md5-docs.factor
View File

@ -1,5 +1,6 @@
USING: help.markup help.syntax kernel math sequences quotations
crypto.common crypto.md5 ;
crypto.common ;
IN: crypto.md5
HELP: stream>md5
{ $values { "stream" "a stream" } { "byte-array" "md5 hash" } }

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

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

2
extra/factory/factory-menus
View File

@ -1,6 +1,6 @@
! -*-factor-*-
USING: kernel unix vars mortar slot-accessors
USING: kernel unix vars mortar mortar.sugar slot-accessors
x.widgets.wm.menu x.widgets.wm.unmapped-frames-menu
factory.commands factory.load ;

2
extra/factory/factory.factor
View File

@ -1,6 +1,6 @@
USING: kernel parser io io.files namespaces sequences editors threads vars
mortar slot-accessors
mortar mortar.sugar slot-accessors
x
x.widgets.wm.root
x.widgets.wm.frame

14
extra/hardware-info/backend/backend.factor Normal file
View File

@ -0,0 +1,14 @@
IN: hardware-info.backend
SYMBOL: os
HOOK: cpus os ( -- n )
HOOK: memory-load os ( -- n )
HOOK: physical-mem os ( -- n )
HOOK: available-mem os ( -- n )
HOOK: total-page-file os ( -- n )
HOOK: available-page-file os ( -- n )
HOOK: total-virtual-mem os ( -- n )
HOOK: available-virtual-mem os ( -- n )
HOOK: available-virtual-extended-mem os ( -- n )

21
extra/hardware-info/hardware-info.factor
View File

@ -1,26 +1,15 @@
USING: alien.syntax math prettyprint system combinators
vocabs.loader ;
USING: alien.syntax kernel math prettyprint system
combinators vocabs.loader hardware-info.backend ;
IN: hardware-info
SYMBOL: os
HOOK: cpus os ( -- n )
HOOK: memory-load os ( -- n )
HOOK: physical-mem os ( -- n )
HOOK: available-mem os ( -- n )
HOOK: total-page-file os ( -- n )
HOOK: available-page-file os ( -- n )
HOOK: total-virtual-mem os ( -- n )
HOOK: available-virtual-mem os ( -- n )
HOOK: available-virtual-extended-mem os ( -- n )
: kb. ( x -- ) 10 2^ /f . ;
: megs. ( x -- ) 20 2^ /f . ;
: gigs. ( x -- ) 30 2^ /f . ;
{
<< {
{ [ windows? ] [ "hardware-info.windows" ] }
{ [ linux? ] [ "hardware-info.linux" ] }
{ [ macosx? ] [ "hardware-info.macosx" ] }
} cond require
{ [ t ] [ f ] }
} cond [ require ] when* >>

2
extra/hardware-info/macosx/macosx.factor
View File

@ -1,5 +1,5 @@
USING: alien alien.c-types alien.syntax byte-arrays kernel
namespaces sequences unix hardware-info ;
namespaces sequences unix hardware-info.backend ;
IN: hardware-info.macosx
TUPLE: macosx ;

5
extra/hardware-info/windows/ce/ce.factor
View File

@ -1,5 +1,6 @@
USING: alien.c-types hardware-info hardware-info.windows
kernel math namespaces windows windows.kernel32 ;
kernel math namespaces windows windows.kernel32
hardware-info.backend ;
IN: hardware-info.windows.ce
T{ wince } os set-global
@ -29,5 +30,3 @@ M: wince total-virtual-mem ( -- n )
M: wince available-virtual-mem ( -- n )
memory-status MEMORYSTATUS-dwAvailVirtual ;

2
extra/hardware-info/windows/nt/nt.factor
View File

@ -1,5 +1,5 @@
USING: alien alien.c-types hardware-info hardware-info.windows
kernel libc math namespaces
kernel libc math namespaces hardware-info.backend
windows windows.advapi32 windows.kernel32 ;
IN: hardware-info.windows.nt

9
extra/hardware-info/windows/windows.factor
View File

@ -1,6 +1,6 @@
USING: alien alien.c-types kernel libc math namespaces
windows windows.kernel32 windows.advapi32 hardware-info
words combinators vocabs.loader ;
windows windows.kernel32 windows.advapi32
words combinators vocabs.loader hardware-info.backend ;
IN: hardware-info.windows
TUPLE: wince ;
@ -70,7 +70,8 @@ M: windows cpus ( -- n )
: system-windows-directory ( -- str )
\ GetSystemWindowsDirectory get-directory ;
{
<< {
{ [ wince? ] [ "hardware-info.windows.ce" ] }
{ [ winnt? ] [ "hardware-info.windows.nt" ] }
} cond require
{ [ t ] [ f ] }
} cond [ require ] when* >>

1
extra/html/parser/utils/utils.factor
View File

@ -2,7 +2,6 @@ USING: assocs circular combinators continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
state-parser strings ;
USING: html.parser ;
IN: html.parser.utils
: string-parse-end?

5
extra/http/basic-authentication/basic-authentication-docs.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax http.basic-authentication crypto.sha2 ;
USING: help.markup help.syntax crypto.sha2 ;
IN: http.basic-authentication
HELP: realms
{ $description
@ -65,4 +66,4 @@ $nl
"it is best to use Basic Authentication with SSL." ;
IN: http.basic-authentication
ABOUT: { "http-authentication" "basic-authentication" }
ABOUT: { "http-authentication" "basic-authentication" }

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

@ -1,6 +1,7 @@
! Coyright (C) 2007 Adam Wendt
! See http://factorcode.org/license.txt for BSD license.
USING: id3 help.syntax help.markup ;
USING: help.syntax help.markup ;
IN: id3
ARTICLE: "id3-tags" "ID3 Tags"
"The " { $vocab-link "id3" } " vocabulary is used to read ID3 tags from MP3 audio streams."

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

@ -1,4 +1,5 @@
USING: inverse help.syntax help.markup ;
USING: help.syntax help.markup ;
IN: inverse
HELP: [undo]
{ $values { "quot" "a quotation" } { "undo" "the inverse of the quotation" } }

4
extra/inverse/inverse.factor
View File

@ -63,7 +63,9 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
{
{ [ dup word? not over symbol? or ] [ , ] }
{ [ dup explicit-inverse? ] [ , ] }
{ [ dup compound? over { if dispatch } member? not and ]
! { [ dup compound? over { if dispatch } member? not and ]
! [ word-def [ inline-word ] each ] }
{ [ dup word? over { if dispatch } member? not and ]
[ word-def [ inline-word ] each ] }
{ [ drop t ] [ "Quotation is not invertible" throw ] }
} cond ;

2
extra/io/launcher/launcher-docs.factor
View File

@ -85,7 +85,7 @@ HELP: run-detached
HELP: <process-stream>
{ $values { "obj" object } { "stream" "a bidirectional stream" } }
{ $description "Launches a process and redirects its input and output via a paper of pipes which may be read and written as a stream." }
{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream." }
{ $notes "Closing the stream will block until the process exits." } ;
{ run-process run-detached <process-stream> } related-words

6
extra/io/sniffer/backend/backend.factor Normal file
View File

@ -0,0 +1,6 @@
USING: io.backend kernel system vocabs.loader ;
IN: io.sniffer.backend
SYMBOL: sniffer-type
TUPLE: sniffer ;
HOOK: <sniffer> io-backend ( obj -- sniffer )

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

@ -1,9 +1,9 @@
! Copyright (C) 2007 Elie Chaftari, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax destructors hexdump io
io.buffers io.nonblocking io.sniffer io.sockets io.streams.lines
io.buffers io.nonblocking io.sockets io.streams.lines
io.unix.backend io.unix.files kernel libc locals math qualified
sequences ;
sequences io.sniffer.backend ;
QUALIFIED: unix
IN: io.sniffer.bsd
@ -17,7 +17,7 @@ TUPLE: sniffer-spec path ifname ;
C: <sniffer-spec> sniffer-spec
: IOCPARM_MASK HEX: 1fff ; inline
: IOCPARM_MAX IOCPARM_MASK 1 + ; inline
: IOCPARM_MAX IOCPARM_MASK 1+ ; inline
: IOC_VOID HEX: 20000000 ; inline
: IOC_OUT HEX: 40000000 ; inline
: IOC_IN HEX: 80000000 ; inline

17
extra/io/sniffer/filter/backend/backend.factor Normal file
View File

@ -0,0 +1,17 @@
USING: byte-arrays combinators io io.backend
io.sockets.headers io.sniffer.backend kernel
prettyprint sequences ;
IN: io.sniffer.filter.backend
HOOK: sniffer-loop io-backend ( stream -- )
HOOK: packet. io-backend ( string -- )
: (packet.) ( string -- )
dup 14 head >byte-array
"--Ethernet Header--" print
dup etherneth.
dup etherneth-type {
! HEX: 800 [ ] ! IP
! HEX: 806 [ ] ! ARP
[ "Unknown type: " write .h ]
} case 2drop ;

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

@ -1,14 +1,15 @@
USING: alien.c-types hexdump io io.backend io.sockets.headers
io.sockets.headers.bsd kernel io.sniffer io.sniffer.bsd
io.sniffer.filter io.streams.string io.unix.backend math
sequences system byte-arrays ;
io.streams.string io.unix.backend math
sequences system byte-arrays io.sniffer.filter.backend
io.sniffer.filter.backend io.sniffer.backend ;
IN: io.sniffer.filter.bsd
! http://www.iana.org/assignments/ethernet-numbers
: bpf-align ( n -- n' )
#! Align to next higher word size
"long" heap-size 1- [ + ] keep bitnot bitand ;
"long" heap-size align ;
M: unix-io packet. ( string -- )
18 cut swap >byte-array bpfh.

15
extra/io/sniffer/filter/filter.factor
View File

@ -1,19 +1,8 @@
USING: alien.c-types byte-arrays combinators hexdump io
io.backend io.streams.string io.sockets.headers kernel math
prettyprint io.sniffer sequences system vocabs.loader ;
prettyprint io.sniffer sequences system vocabs.loader
io.sniffer.filter.backend ;
IN: io.sniffer.filter
HOOK: sniffer-loop io-backend ( stream -- )
HOOK: packet. io-backend ( string -- )
: (packet.) ( string -- )
dup 14 head >byte-array
"--Ethernet Header--" print
dup etherneth.
dup etherneth-type {
! HEX: 800 [ ] ! IP
! HEX: 806 [ ] ! ARP
[ "Unknown type: " write .h ]
} case 2drop ;
bsd? [ "io.sniffer.filter.bsd" require ] when

6
extra/io/sniffer/sniffer.factor
View File

@ -1,10 +1,4 @@
USING: io.backend kernel system vocabs.loader ;
IN: io.sniffer
SYMBOL: sniffer-type
TUPLE: sniffer ;
HOOK: <sniffer> io-backend ( obj -- sniffer )
bsd? [ "io.sniffer.bsd" require ] when

131
extra/io/unix/backend/backend.factor
View File

@ -1,21 +1,24 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien bit-arrays generic assocs io kernel
kernel.private math io.nonblocking sequences strings structs
sbufs threads unix vectors io.buffers io.backend
io.streams.duplex math.parser continuations system libc ;
USING: alien generic assocs kernel kernel.private math
io.nonblocking sequences strings structs sbufs threads unix
vectors io.buffers io.backend io.streams.duplex math.parser
continuations system libc qualified namespaces ;
QUALIFIED: io
IN: io.unix.backend
! Multiplexer protocol
SYMBOL: unix-io-backend
HOOK: init-unix-io unix-io-backend ( -- )
HOOK: register-io-task unix-io-backend ( task -- )
HOOK: unregister-io-task unix-io-backend ( task -- )
HOOK: unix-io-multiplex unix-io-backend ( timeval -- )
TUPLE: unix-io ;
! We want namespaces::bind to shadow the bind system call from
! unix
USING: namespaces ;
! Global variables
SYMBOL: read-fdset
SYMBOL: read-tasks
SYMBOL: write-fdset
SYMBOL: write-tasks
! Some general stuff
@ -53,9 +56,9 @@ M: integer close-handle ( fd -- )
! port to finish I/O
TUPLE: io-task port callbacks ;
: <io-task> ( port class -- task )
>r V{ } clone io-task construct-boa
{ set-delegate } r> construct ; inline
: <io-task> ( port continuation class -- task )
>r 1vector io-task construct-boa r> construct-delegate ;
inline
! Multiplexer
GENERIC: do-io-task ( task -- ? )
@ -63,58 +66,30 @@ GENERIC: task-container ( task -- vector )
: io-task-fd io-task-port port-handle ;
: add-io-task ( callback task -- )
[ io-task-callbacks push ] keep
dup io-task-fd over task-container 2dup at [
: check-io-task ( task -- )
dup io-task-fd swap task-container at [
"Cannot perform multiple reads from the same port" throw
] when set-at ;
] when ;
: add-io-task ( task -- )
dup check-io-task
dup register-io-task
dup io-task-fd over task-container set-at ;
: remove-io-task ( task -- )
dup io-task-fd swap task-container delete-at ;
dup io-task-fd over task-container delete-at
unregister-io-task ;
: pop-callbacks ( task -- )
dup io-task-callbacks swap remove-io-task
[ schedule-thread ] each ;
dup remove-io-task
io-task-callbacks [ schedule-thread ] each ;
: handle-fd ( task -- )
dup io-task-port touch-port
dup do-io-task [ pop-callbacks ] [ drop ] if ;
: handle-fdset ( fdset tasks -- )
swap [
swap dup io-task-port timeout? [
dup io-task-port "Timeout" swap report-error
nip pop-callbacks
] [
tuck io-task-fd swap nth
[ handle-fd ] [ drop ] if
] if drop
] curry assoc-each ;
: init-fdset ( fdset tasks -- )
swap dup clear-bits
[ >r drop t swap r> set-nth ] curry assoc-each ;
: read-fdset/tasks
read-fdset get-global read-tasks get-global ;
: write-fdset/tasks
write-fdset get-global write-tasks get-global ;
: init-fdsets ( -- read write except )
read-fdset/tasks dupd init-fdset
write-fdset/tasks dupd init-fdset
f ;
: (io-multiplex) ( ms -- )
>r FD_SETSIZE init-fdsets r> make-timeval select 0 < [
err_no ignorable-error? [ (io-error) ] unless
] when ;
M: unix-io io-multiplex ( ms -- )
(io-multiplex)
read-fdset/tasks handle-fdset
write-fdset/tasks handle-fdset ;
: handle-timeout ( task -- )
"Timeout" over io-task-port report-error pop-callbacks ;
! Readers
: reader-eof ( reader -- )
@ -137,17 +112,18 @@ M: unix-io io-multiplex ( ms -- )
TUPLE: read-task ;
: <read-task> ( port -- task ) read-task <io-task> ;
: <read-task> ( port continuation -- task )
read-task <io-task> ;
M: read-task do-io-task
io-task-port dup refill
[ [ reader-eof ] [ drop ] if ] keep ;
M: read-task task-container drop read-tasks get-global ;
M: read-task task-container
drop read-tasks get-global ;
M: input-port (wait-to-read)
[ swap <read-task> add-io-task stop ] callcc0
pending-error ;
[ <read-task> add-io-task stop ] callcc0 pending-error ;
! Writers
: write-step ( port -- ? )
@ -156,35 +132,38 @@ M: input-port (wait-to-read)
TUPLE: write-task ;
: <write-task> ( port -- task ) write-task <io-task> ;
: <write-task> ( port continuation -- task )
write-task <io-task> ;
M: write-task do-io-task
io-task-port dup buffer-empty? over port-error or
[ 0 swap buffer-reset t ] [ write-step ] if ;
M: write-task task-container drop write-tasks get-global ;
M: write-task task-container
drop write-tasks get-global ;
: add-write-io-task ( callback task -- )
dup io-task-fd write-tasks get-global at
[ io-task-callbacks push ] [ add-io-task ] ?if ;
: add-write-io-task ( port continuation -- )
over port-handle write-tasks get-global at
[ io-task-callbacks push drop ]
[ <write-task> add-io-task ] if* ;
: (wait-to-write) ( port -- )
[ swap <write-task> add-write-io-task stop ] callcc0 drop ;
[ add-write-io-task stop ] callcc0 drop ;
M: port port-flush ( port -- )
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
USE: io
M: unix-io io-multiplex ( ms -- )
unix-io-multiplex ;
M: unix-io init-io ( -- )
#! Should only be called on startup. Calling this at any
#! other time can have unintended consequences.
global [
H{ } clone read-tasks set
FD_SETSIZE 8 * <bit-array> read-fdset set
H{ } clone write-tasks set
FD_SETSIZE 8 * <bit-array> write-fdset set
] bind ;
H{ } clone read-tasks set-global
H{ } clone write-tasks set-global
init-unix-io ;
M: unix-io init-stdio ( -- )
0 1 handle>duplex-stream stdio set-global ;
0 1 handle>duplex-stream io:stdio set-global
2 <writer> io:stderr set-global ;
: multiplexer-error ( n -- )
0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;

106
extra/io/unix/backend/kqueue/kqueue.factor Normal file
View File

@ -0,0 +1,106 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel io.nonblocking io.unix.backend
io.unix.sockets sequences assocs unix unix.kqueue math
namespaces classes combinators ;
IN: io.unix.backend.kqueue
TUPLE: unix-kqueue-io ;
! Global variables
SYMBOL: kqueue-fd
SYMBOL: kqueue-added
SYMBOL: kqueue-deleted
SYMBOL: kqueue-events
: max-events ( -- n )
#! We read up to 256 events at a time. This is an arbitrary
#! constant...
256 ; inline
M: unix-kqueue-io init-unix-io ( -- )
H{ } clone kqueue-added set-global
H{ } clone kqueue-deleted set-global
max-events "kevent" <c-array> kqueue-events set-global
kqueue dup io-error kqueue-fd set-global ;
M: unix-kqueue-io register-io-task ( task -- )
dup io-task-fd kqueue-added get-global key? [ drop ] [
dup io-task-fd kqueue-deleted get-global key? [
io-task-fd kqueue-deleted get-global delete-at
] [
dup io-task-fd kqueue-added get-global set-at
] if
] if ;
M: unix-kqueue-io unregister-io-task ( task -- )
dup io-task-fd kqueue-deleted get-global key? [ drop ] [
dup io-task-fd kqueue-added get-global key? [
io-task-fd kqueue-added get-global delete-at
] [
dup io-task-fd kqueue-deleted get-global set-at
] if
] if ;
: io-task-filter ( task -- n )
class {
{ read-task [ EVFILT_READ ] }
{ accept-task [ EVFILT_READ ] }
{ receive-task [ EVFILT_READ ] }
{ write-task [ EVFILT_WRITE ] }
{ connect-task [ EVFILT_WRITE ] }
{ send-task [ EVFILT_WRITE ] }
} case ;
: make-kevent ( task -- event )
"kevent" <c-object>
over io-task-fd over set-kevent-ident
swap io-task-filter over set-kevent-filter ;
: make-add-kevent ( task -- event )
make-kevent
EV_ADD over set-kevent-flags ;
: make-delete-kevent ( task -- event )
make-kevent
EV_DELETE over set-kevent-flags ;
: kqueue-additions ( -- kevents )
kqueue-added get-global
dup clear-assoc values
[ make-add-kevent ] map ;
: kqueue-deletions ( -- kevents )
kqueue-deleted get-global
dup clear-assoc values
[ make-delete-kevent ] map ;
: kqueue-changelist ( -- byte-array n )
kqueue-additions kqueue-deletions append
dup concat f like swap length ;
: kqueue-eventlist ( -- byte-array n )
kqueue-events get-global max-events ;
: do-kevent ( timespec -- n )
>r
kqueue-fd get-global
kqueue-changelist
kqueue-eventlist
r> kevent dup multiplexer-error ;
: kevent-task ( kevent -- task )
dup kevent-ident swap kevent-filter {
{ [ dup EVFILT_READ = ] [ read-tasks ] }
{ [ dup EVFILT_WRITE = ] [ write-tasks ] }
} cond nip get at ;
: handle-kevents ( n eventlist -- )
[ kevent-nth kevent-task handle-fd ] curry each ;
M: unix-kqueue-io unix-io-multiplex ( ms -- )
make-timespec
do-kevent
kqueue-events get-global handle-kevents ;
T{ unix-kqueue-io } unix-io-backend set-global

52
extra/io/unix/backend/select/select.factor Normal file
View File

@ -0,0 +1,52 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel io.nonblocking io.unix.backend
bit-arrays sequences assocs unix math namespaces ;
IN: io.unix.backend.select
TUPLE: unix-select-io ;
! Global variables
SYMBOL: read-fdset
SYMBOL: write-fdset
M: unix-select-io init-unix-io ( -- )
FD_SETSIZE 8 * <bit-array> read-fdset set-global
FD_SETSIZE 8 * <bit-array> write-fdset set-global ;
: handle-fdset ( fdset tasks -- )
swap [
swap dup io-task-port timeout? [
nip handle-timeout
] [
tuck io-task-fd swap nth
[ handle-fd ] [ drop ] if
] if drop
] curry assoc-each ;
: init-fdset ( fdset tasks -- )
swap dup clear-bits
[ >r drop t swap r> set-nth ] curry assoc-each ;
: read-fdset/tasks
read-fdset get-global read-tasks get-global ;
: write-fdset/tasks
write-fdset get-global write-tasks get-global ;
: init-fdsets ( -- read write except )
read-fdset/tasks dupd init-fdset
write-fdset/tasks dupd init-fdset
f ;
M: unix-select-io register-io-task ( task -- ) drop ;
M: unix-select-io unregister-io-task ( task -- ) drop ;
M: unix-select-io unix-io-multiplex ( timeval -- )
make-timeval >r FD_SETSIZE init-fdsets r>
select multiplexer-error
read-fdset/tasks handle-fdset
write-fdset/tasks handle-fdset ;
T{ unix-select-io } unix-io-backend set-global

20
extra/io/unix/sockets/sockets.factor
View File

@ -33,7 +33,8 @@ M: unix-io addrinfo-error ( n -- )
TUPLE: connect-task ;
: <connect-task> ( port -- task ) connect-task <io-task> ;
: <connect-task> ( port continuation -- task )
connect-task <io-task> ;
M: connect-task do-io-task
io-task-port dup port-handle f 0 write
@ -42,7 +43,7 @@ M: connect-task do-io-task
M: connect-task task-container drop write-tasks get-global ;
: wait-to-connect ( port -- )
[ swap <connect-task> add-io-task stop ] callcc0 drop ;
[ <connect-task> add-io-task stop ] callcc0 drop ;
M: unix-io (client) ( addrspec -- stream )
dup make-sockaddr/size >r >r
@ -66,7 +67,8 @@ USE: unix
TUPLE: accept-task ;
: <accept-task> ( port -- task ) accept-task <io-task> ;
: <accept-task> ( port continuation -- task )
accept-task <io-task> ;
M: accept-task task-container drop read-tasks get ;
@ -85,7 +87,7 @@ M: accept-task do-io-task
over 0 >= [ do-accept t ] [ 2drop defer-error ] if ;
: wait-to-accept ( server -- )
[ swap <accept-task> add-io-task stop ] callcc0 drop ;
[ <accept-task> add-io-task stop ] callcc0 drop ;
USE: io.sockets
@ -136,7 +138,8 @@ packet-size <byte-array> receive-buffer set-global
TUPLE: receive-task ;
: <receive-task> ( stream -- task ) receive-task <io-task> ;
: <receive-task> ( stream continuation -- task )
receive-task <io-task> ;
M: receive-task do-io-task
io-task-port
@ -152,7 +155,7 @@ M: receive-task do-io-task
M: receive-task task-container drop read-tasks get ;
: wait-receive ( stream -- )
[ swap <receive-task> add-io-task stop ] callcc0 drop ;
[ <receive-task> add-io-task stop ] callcc0 drop ;
M: unix-io receive ( datagram -- packet addrspec )
dup check-datagram-port
@ -166,7 +169,7 @@ M: unix-io receive ( datagram -- packet addrspec )
TUPLE: send-task packet sockaddr len ;
: <send-task> ( packet sockaddr len port -- task )
: <send-task> ( packet sockaddr len stream continuation -- task )
send-task <io-task> [
{
set-send-task-packet
@ -185,8 +188,7 @@ M: send-task do-io-task
M: send-task task-container drop write-tasks get ;
: wait-send ( packet sockaddr len stream -- )
[ >r <send-task> r> swap add-io-task stop ] callcc0
2drop 2drop ;
[ <send-task> add-io-task stop ] callcc0 2drop 2drop ;
M: unix-io send ( packet addrspec datagram -- )
3dup check-datagram-send

17
extra/io/unix/unix.factor
View File

@ -1,9 +1,12 @@
USE: io.unix.backend
USE: io.unix.files
USE: io.unix.sockets
USE: io.unix.launcher
USE: io.unix.mmap
USE: io.backend
USE: namespaces
USING: io.unix.backend io.unix.files io.unix.sockets
io.unix.launcher io.unix.mmap io.backend combinators namespaces
system vocabs.loader ;
{
! kqueue is a work in progress
! { [ macosx? ] [ "io.unix.backend.kqueue" ] }
! { [ bsd? ] [ "io.unix.backend.kqueue" ] }
{ [ unix? ] [ "io.unix.backend.select" ] }
} cond require
T{ unix-io } io-backend set-global

2
extra/jamshred/game/game.factor
View File

@ -1,4 +1,4 @@
USING: kernel opengl arrays sequences jamshred jamshred.tunnel
USING: kernel opengl arrays sequences jamshred.tunnel
jamshred.player math.vectors ;
IN: jamshred.game

2
extra/jamshred/player/player.factor
View File

@ -1,4 +1,4 @@
USING: colors jamshred.game jamshred.oint jamshred.tunnel kernel
USING: colors jamshred.oint jamshred.tunnel kernel
math math.constants sequences ;
IN: jamshred.player

5
extra/json/reader/reader-docs.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax json.reader ;
USING: help.markup help.syntax ;
IN: json.reader
HELP: json> "( string -- object )"
{ $values { "string" "a string in JSON format" } { "object" "yhe object deserialized from the JSON string" } }
{ $description "Deserializes the JSON formatted string into a Factor object. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ;
{ $description "Deserializes the JSON formatted string into a Factor object. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ;

3
extra/json/writer/writer-docs.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax json.writer ;
USING: help.markup help.syntax ;
IN: json.writer
HELP: >json "( obj -- string )"
{ $values { "obj" "an object" } { "string" "the object converted to JSON format" } }

2
extra/json/writer/writer.factor
View File

@ -13,7 +13,7 @@ GENERIC: json-print ( obj -- )
[ json-print ] string-out ;
M: f json-print ( f -- )
"false" write ;
drop "false" write ;
M: string json-print ( obj -- )
CHAR: " write1 "\"" split "\\\"" join CHAR: \r swap remove "\n" split "\\r\\n" join write CHAR: " write1 ;

4
extra/lisp/listener/listener.factor
View File

@ -5,7 +5,7 @@ USING: kernel parser namespaces io prettyprint math arrays sequences
IN: lisp.listener
: parse-stdio ( -- quot/f ) stdio get parse-interactive ;
: parse-stdio ( -- quot/f ) stdio get read-quot ;
: stuff? ( -- ? ) datastack length 0 > ;
@ -25,4 +25,4 @@ use [ clone ] change
{ "lisp" "lisp.syntax" } add-use
! [ listener-hook get call prompt. lisp-listen ] until-quit
until-quit
] with-scope ;
] with-scope ;

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

@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double.
! 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
HELP: run

7
extra/mad/mad.factor
View File

@ -4,14 +4,11 @@
USING: alien alien.c-types alien.syntax combinators kernel math system ;
IN: mad
: load-mad-library ( -- )
"mad" {
<< "mad" {
{ [ macosx? ] [ "libmad.0.dylib" ] }
{ [ unix? ] [ "libmad.so" ] }
{ [ windows? ] [ "mad.dll" ] }
} cond "cdecl" add-library ; parsing
load-mad-library
} cond "cdecl" add-library >>
LIBRARY: mad

3
extra/match/match.factor
View File

@ -3,7 +3,7 @@
!
! Based on pattern matching code from Paul Graham's book 'On Lisp'.
USING: parser kernel words namespaces sequences tuples
combinators macros assocs ;
combinators macros assocs math ;
IN: match
SYMBOL: _
@ -54,6 +54,7 @@ MACRO: match-cond ( assoc -- )
: replace-patterns ( object -- result )
{
{ [ dup number? ] [ ] }
{ [ dup match-var? ] [ get ] }
{ [ dup sequence? ] [ [ replace-patterns ] map ] }
{ [ 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
shuffle splitting ;
shuffle splitting sequences.lib ;
IN: math.polynomials
! Polynomials are vectors with the highest powers on the right:
@ -22,7 +22,7 @@ PRIVATE>
: p= ( p p -- ? ) pextend = ;
: ptrim ( p -- p )
dup length 1 = [ [ zero? ] right-trim ] unless ;
dup singleton? [ [ zero? ] right-trim ] unless ;
: 2ptrim ( p p -- p p ) [ ptrim ] 2apply ;
: p+ ( p p -- p ) pextend v+ ;

15
extra/mortar/mortar.factor
View File

@ -128,7 +128,7 @@ over object-class class-methods 1 head* assoc-stack call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: new* ( class -- object ) <<- create ;
! : new* ( class -- object ) <<- create ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -136,13 +136,20 @@ IN: slot-accessors
IN: mortar
! : generate-slot-getter ( name -- )
! "$" over append "slot-accessors" create swap [ slot-value ] curry
! define-compound ;
: generate-slot-getter ( name -- )
"$" over append "slot-accessors" create swap [ slot-value ] curry
define-compound ;
"$" over append "slot-accessors" create swap [ slot-value ] curry define ;
! : generate-slot-setter ( name -- )
! ">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
! define-compound ;
: generate-slot-setter ( name -- )
">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
define-compound ;
define ;
: generate-slot-accessors ( name -- )
dup

6
extra/mortar/sugar/sugar.factor Normal file
View File

@ -0,0 +1,6 @@
USING: mortar ;
IN: mortar.sugar
: new* ( class -- object ) <<- create ;

4
extra/multi-methods/multi-methods.factor
View File

@ -3,7 +3,7 @@
USING: kernel math sequences vectors classes combinators
arrays words assocs parser namespaces definitions
prettyprint prettyprint.backend quotations arrays.lib
debugger io ;
debugger io compiler.units ;
IN: multi-methods
TUPLE: method loc def ;
@ -217,5 +217,5 @@ syntax:M: method-spec synopsis*
dup definer.
unclip pprint* pprint* ;
syntax:M: method-spec forget
syntax:M: method-spec forget*
unclip [ delete-at ] with-methods ;

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

@ -1,4 +1,5 @@
USING: help.markup help.syntax multiline ;
USING: help.markup help.syntax ;
IN: multiline
HELP: STRING:
{ $syntax "STRING: name\nfoo\n;" }

2
extra/multiline/multiline.factor
View File

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

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

@ -1,6 +1,8 @@
! Copyright (C) 2007 Chris Double.
! 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
{ $values { "env" "an ODBC environment handle" } }

Some files were not shown because too many files have changed in this diff Show More