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

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

db4
John Benediktsson 2008-12-09 06:50:07 -08:00
parent e73d78be88 43fe6c56a2
commit 92834c3aba
203 changed files with 1765 additions and 1242 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alarms/alarms.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar combinators generic init
kernel math namespaces sequences heaps boxes threads debugger
kernel math namespaces sequences heaps boxes threads
quotations assocs math.order ;
IN: alarms

14
basis/alien/prettyprint/prettyprint.factor Normal file
View File

@ -0,0 +1,14 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators alien alien.strings alien.syntax
prettyprint.backend prettyprint.custom prettyprint.sections ;
IN: alien.prettyprint
M: alien pprint*
{
{ [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
[ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
} cond ;
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;

4
basis/alien/strings/strings-docs.factor
View File

@ -31,10 +31,6 @@ HELP: string>symbol
$nl
"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
HELP: utf16n
{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
{ $see-also "encodings-introduction" } ;
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl

2
basis/alien/strings/strings-tests.factor
View File

@ -1,6 +1,6 @@
USING: alien.strings tools.test kernel libc
io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
io.encodings.ascii alien io.encodings.string ;
io.encodings.utf16n io.encodings.ascii alien io.encodings.string ;
IN: alien.strings.tests
[ "\u0000ff" ]

29
basis/alien/strings/strings.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays sequences kernel accessors math alien.accessors
alien.c-types byte-arrays words io io.encodings
io.streams.byte-array io.streams.memory io.encodings.utf8
io.encodings.utf16 system alien strings cpu.architecture fry ;
io.encodings.utf8 io.streams.byte-array io.streams.memory system
alien strings cpu.architecture fry vocabs.loader combinators ;
IN: alien.strings
GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
@ -88,27 +88,22 @@ M: string-type c-type-getter
M: string-type c-type-setter
drop [ set-alien-cell ] ;
! Native-order UTF-16
HOOK: alien>native-string os ( alien -- string )
SINGLETON: utf16n
: utf16n ( -- descriptor )
little-endian? utf16le utf16be ? ; foldable
M: utf16n <decoder> drop utf16n <decoder> ;
M: utf16n <encoder> drop utf16n <encoder> ;
: alien>native-string ( alien -- string )
os windows? [ utf16n ] [ utf8 ] if alien>string ;
HOOK: native-string>alien os ( string -- alien )
: dll-path ( dll -- string )
path>> alien>native-string ;
: string>symbol ( str -- alien )
[ os wince? [ utf16n ] [ utf8 ] if string>alien ]
over string? [ call ] [ map ] if ;
dup string?
[ native-string>alien ]
[ [ native-string>alien ] map ] if ;
{ "char*" utf8 } "char*" typedef
{ "char*" utf16n } "wchar_t*" typedef
"char*" "uchar*" typedef
{
{ [ os windows? ] [ "alien.strings.windows" require ] }
{ [ os unix? ] [ "alien.strings.unix" require ] }
} cond

8
basis/alien/strings/unix/unix.factor Normal file
View File

@ -0,0 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.strings io.encodings.utf8 system ;
IN: alien.strings.unix
M: unix alien>native-string utf8 alien>string ;
M: unix native-string>alien utf8 string>alien ;

13
basis/alien/strings/windows/windows.factor Normal file
View File

@ -0,0 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.strings alien.c-types io.encodings.utf8
io.encodings.utf16n system ;
IN: alien.strings.windows
M: windows alien>native-string utf16n alien>string ;
M: wince native-string>alien utf16n string>alien ;
M: winnt native-string>alien utf8 string>alien ;
{ "char*" utf16n } "wchar_t*" typedef

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

@ -3,8 +3,7 @@
USING: accessors arrays alien alien.c-types alien.structs
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
effects prettyprint prettyprint.sections prettyprint.backend
assocs combinators lexer strings.parser alien.parser ;
effects assocs combinators lexer strings.parser alien.parser ;
IN: alien.syntax
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
@ -34,12 +33,3 @@ IN: alien.syntax
dup length
[ [ create-in ] dip 1quotation define ] 2each ;
parsing
M: alien pprint*
{
{ [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
[ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
} cond ;
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;

6
basis/bit-arrays/bit-arrays.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types accessors math alien.accessors kernel
kernel.private locals sequences sequences.private byte-arrays
parser prettyprint.backend fry ;
parser prettyprint.custom fry ;
IN: bit-arrays
TUPLE: bit-array
@ -73,11 +73,11 @@ M: bit-array byte-length length 7 + -3 shift ;
:: integer>bit-array ( n -- bit-array )
n zero? [ 0 <bit-array> ] [
[let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
[ n' zero? not ] [
[ n' zero? ] [
n' out underlying>> i set-alien-unsigned-1
n' -8 shift n'!
i 1+ i!
] [ ] while
] [ ] until
out
]
] if ;

2
basis/bit-vectors/bit-vectors.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable bit-arrays prettyprint.backend
sequences.private growable bit-arrays prettyprint.custom
parser accessors ;
IN: bit-vectors

8
basis/bootstrap/bootstrap-error.factor Normal file
View File

@ -0,0 +1,8 @@
USING: continuations kernel io debugger vocabs words system namespaces ;
:c
:error
"listener" vocab
[ restarts. vocab-main execute ]
[ die ] if*
1 exit

11
basis/bootstrap/compiler/compiler.factor
View File

@ -5,17 +5,22 @@ sequences namespaces parser kernel kernel.private classes
classes.private arrays hashtables vectors classes.tuple sbufs
hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words command-line vocabs io
io.encodings.string prettyprint libc splitting math.parser
io.encodings.string libc splitting math.parser
compiler.units math.order compiler.tree.builder
compiler.tree.optimizer compiler.cfg.optimizer ;
IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a
! reference to 'eval' in a global variable
"deploy-vocab" get [
"deploy-vocab" get "staging" get or [
"alien.remote-control" require
] unless
"prettyprint" vocab [
"stack-checker.errors.prettyprint" require
"alien.prettyprint" require
] when
"cpu." cpu name>> append require
enable-compiler
@ -86,7 +91,7 @@ nl
"." write flush
{
. malloc calloc free memcpy
malloc calloc free memcpy
} compile-uncompiled
"." write flush

16
basis/bootstrap/finish-bootstrap.factor Normal file
View File

@ -0,0 +1,16 @@
USING: init command-line debugger system continuations
namespaces eval kernel vocabs.loader io ;
[
boot
do-init-hooks
[
(command-line) parse-command-line
load-vocab-roots
run-user-init
"e" get [ eval ] when*
ignore-cli-args? not script get and
[ run-script ] [ "run" get run ] if*
output-stream get [ stream-flush ] when*
] [ print-error 1 exit ] recover
] set-boot-quot

10
basis/bootstrap/finish-staging.factor Normal file
View File

@ -0,0 +1,10 @@
USING: init command-line system namespaces kernel vocabs.loader
io ;
[
boot
do-init-hooks
(command-line) parse-command-line
"run" get run
output-stream get [ stream-flush ] when*
] set-boot-quot

4
basis/bootstrap/math/math.factor
View File

@ -1,5 +1,7 @@
USE: vocabs.loader
USING: vocabs vocabs.loader kernel ;
"math.ratios" require
"math.floats" require
"math.complex" require
"prettyprint" vocab [ "math.complex.prettyprint" require ] when

29
basis/bootstrap/stage2.factor
View File

@ -2,10 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors init namespaces words io
kernel.private math memory continuations kernel io.files
io.backend system parser vocabs sequences prettyprint
io.backend system parser vocabs sequences
vocabs.loader combinators splitting source-files strings
definitions assocs compiler.errors compiler.units
math.parser generic sets debugger command-line ;
math.parser generic sets command-line ;
IN: bootstrap.stage2
SYMBOL: core-bootstrap-time
@ -86,25 +86,18 @@ SYMBOL: bootstrap-time
f error set-global
f error-continuation set-global
millis swap - bootstrap-time set-global
print-report
"deploy-vocab" get [
"tools.deploy.shaker" run
] [
[
boot
do-init-hooks
handle-command-line
] set-boot-quot
millis swap - bootstrap-time set-global
print-report
"staging" get [
"resource:basis/bootstrap/finish-staging.factor" run-file
] [
"resource:basis/bootstrap/finish-bootstrap.factor" run-file
] if
"output-image" get save-image-and-exit
] if
] [
:c
dup print-error flush
"listener" vocab
[ restarts. vocab-main execute ]
[ die ] if*
1 exit
] recover
] [ drop "resource:basis/bootstrap/bootstrap-error.factor" run-file ] recover

6
basis/bootstrap/threads/threads.factor
View File

@ -1,7 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: vocabs vocabs.loader kernel ;
IN: bootstrap.threads
USE: io.thread
USE: threads
USE: debugger.threads
"debugger" vocab [
"debugger.threads" require
] when

0
core/byte-vectors/byte-vectors-docs.factor → basis/byte-vectors/byte-vectors-docs.factor
View File

0
core/byte-vectors/byte-vectors-tests.factor → basis/byte-vectors/byte-vectors-tests.factor
View File

9
core/byte-vectors/byte-vectors.factor → basis/byte-vectors/byte-vectors.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable byte-arrays accessors ;
sequences.private growable byte-arrays accessors parser
prettyprint.custom ;
IN: byte-vectors
TUPLE: byte-vector
@ -41,4 +42,10 @@ M: byte-array like
M: byte-array new-resizable drop <byte-vector> ;
: BV{ \ } [ >byte-vector ] parse-literal ; parsing
M: byte-vector pprint* pprint-object ;
M: byte-vector pprint-delims drop \ BV{ \ } ;
M: byte-vector >pprint-sequence ;
INSTANCE: byte-vector growable

0
core/byte-vectors/summary.txt → basis/byte-vectors/summary.txt
View File

0
core/byte-vectors/tags.txt → basis/byte-vectors/tags.txt
View File

11
basis/calendar/format/format.factor
View File

@ -1,7 +1,8 @@
USING: math math.order math.parser math.functions kernel sequences io
accessors arrays io.streams.string splitting
combinators accessors debugger
calendar calendar.format.macros ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.order math.parser math.functions kernel
sequences io accessors arrays io.streams.string splitting
combinators accessors calendar calendar.format.macros present ;
IN: calendar.format
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ;
@ -288,3 +289,5 @@ ERROR: invalid-timestamp-format ;
]
} formatted
] with-string-writer ;
M: timestamp present timestamp>string ;

4
basis/checksums/md5/md5.factor
View File

@ -4,7 +4,7 @@ USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting grouping strings
sequences byte-arrays locals sequences.private
io.encodings.binary symbols math.bitwise checksums
checksums.common ;
checksums.common checksums.stream ;
IN: checksums.md5
! See http://www.faqs.org/rfcs/rfc1321.html
@ -180,7 +180,7 @@ PRIVATE>
SINGLETON: md5
INSTANCE: md5 checksum
INSTANCE: md5 stream-checksum
M: md5 checksum-stream ( stream -- byte-array )
drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ;

5
basis/checksums/openssl/openssl.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays alien.c-types kernel continuations
destructors sequences io openssl openssl.libcrypto checksums ;
destructors sequences io openssl openssl.libcrypto checksums
checksums.stream ;
IN: checksums.openssl
ERROR: unknown-digest name ;
@ -12,7 +13,7 @@ TUPLE: openssl-checksum name ;
: openssl-sha1 T{ openssl-checksum f "sha1" } ;
INSTANCE: openssl-checksum checksum
INSTANCE: openssl-checksum stream-checksum
C: <openssl-checksum> openssl-checksum

5
basis/checksums/sha1/sha1.factor
View File

@ -3,7 +3,8 @@
USING: arrays combinators kernel io io.encodings.binary io.files
io.streams.byte-array math.vectors strings sequences namespaces
make math parser sequences assocs grouping vectors io.binary
hashtables symbols math.bitwise checksums checksums.common ;
hashtables symbols math.bitwise checksums checksums.common
checksums.stream ;
IN: checksums.sha1
! Implemented according to RFC 3174.
@ -113,7 +114,7 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
SINGLETON: sha1
INSTANCE: sha1 checksum
INSTANCE: sha1 stream-checksum
M: sha1 checksum-stream ( stream -- sha1 )
drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;

12
basis/checksums/stream/stream.factor Normal file
View File

@ -0,0 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.binary io.streams.byte-array kernel
checksums ;
IN: checksums.stream
MIXIN: stream-checksum
M: stream-checksum checksum-bytes
[ binary <byte-reader> ] dip checksum-stream ;
INSTANCE: stream-checksum checksum

6
basis/cocoa/application/application.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2007 Slava Pestov
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
core-foundation.run-loop cocoa.messages cocoa cocoa.classes
cocoa.runtime sequences threads debugger init summary
kernel.private assocs ;
cocoa.runtime sequences threads init summary kernel.private
assocs ;
IN: cocoa.application
: <NSString> ( str -- alien ) <CFString> -> autorelease ;

40
basis/cocoa/messages/messages.factor
View File

@ -2,21 +2,17 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
continuations combinators compiler compiler.alien kernel math
namespaces make parser prettyprint prettyprint.sections
quotations sequences strings words cocoa.runtime io macros
memoize debugger io.encodings.ascii effects libc libc.private
parser lexer init core-foundation fry generalizations
specialized-arrays.direct.alien ;
namespaces make parser quotations sequences strings words
cocoa.runtime io macros memoize io.encodings.utf8
effects libc libc.private parser lexer init core-foundation fry
generalizations specialized-arrays.direct.alien ;
IN: cocoa.messages
: make-sender ( method function -- quot )
[ over first , f , , second , \ alien-invoke , ] [ ] make ;
: sender-stub-name ( method function -- string )
[ % "_" % unparse % ] "" make ;
: sender-stub ( method function -- word )
[ sender-stub-name f <word> dup ] 2keep
[ "( sender-stub )" f <word> dup ] 2dip
over first large-struct? [ "_stret" append ] when
make-sender define ;
@ -78,12 +74,8 @@ MACRO: (send) ( selector super? -- quot )
: send ( receiver args... selector -- return... ) f (send) ; inline
\ send soft "break-after" set-word-prop
: super-send ( receiver args... selector -- return... ) t (send) ; inline
\ super-send soft "break-after" set-word-prop
! Runtime introspection
SYMBOL: class-init-hooks
@ -188,7 +180,7 @@ assoc-union alien>objc-types set-global
: method-arg-type ( method i -- type )
method_copyArgumentType
[ ascii alien>string parse-objc-type ] keep
[ utf8 alien>string parse-objc-type ] keep
(free) ;
: method-arg-types ( method -- args )
@ -197,7 +189,7 @@ assoc-union alien>objc-types set-global
: method-return-type ( method -- ctype )
method_copyReturnType
[ ascii alien>string parse-objc-type ] keep
[ utf8 alien>string parse-objc-type ] keep
(free) ;
: register-objc-method ( method -- )
@ -216,17 +208,6 @@ assoc-union alien>objc-types set-global
: register-objc-methods ( class -- )
[ register-objc-method ] each-method-in-class ;
: method. ( method -- )
{
[ method_getName sel_getName ]
[ method-return-type ]
[ method-arg-types ]
[ method_getImplementation ]
} cleave 4array . ;
: methods. ( class -- )
[ method. ] each-method-in-class ;
: class-exists? ( string -- class ) objc_getClass >boolean ;
: define-objc-class-word ( quot name -- )
@ -238,11 +219,8 @@ assoc-union alien>objc-types set-global
: import-objc-class ( name quot -- )
over define-objc-class-word
'[
_
[ objc-class register-objc-methods ]
[ objc-meta-class register-objc-methods ] bi
] try ;
[ objc-class register-objc-methods ]
[ objc-meta-class register-objc-methods ] bi ;
: root-class ( class -- root )
dup class_getSuperclass [ root-class ] [ ] ?if ;

4
basis/cocoa/subclassing/subclassing.factor
View File

@ -3,12 +3,12 @@
USING: alien alien.c-types alien.strings arrays assocs
combinators compiler hashtables kernel libc math namespaces
parser sequences words cocoa.messages cocoa.runtime locals
compiler.units io.encodings.ascii continuations make fry ;
compiler.units io.encodings.utf8 continuations make fry ;
IN: cocoa.subclassing
: init-method ( method -- sel imp types )
first3 swap
[ sel_registerName ] [ execute ] [ ascii string>alien ]
[ sel_registerName ] [ execute ] [ utf8 string>alien ]
tri* ;
: throw-if-false ( obj what -- )

21
basis/command-line/command-line.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init continuations debugger hashtables io
io.encodings.utf8 io.files kernel kernel.private namespaces
parser sequences strings system splitting eval vocabs.loader ;
USING: init continuations hashtables io io.encodings.utf8
io.files kernel kernel.private namespaces parser sequences
strings system splitting vocabs.loader ;
IN: command-line
SYMBOL: script
@ -31,8 +31,6 @@ SYMBOL: command-line
] [ drop ] if
] when ;
<PRIVATE
: var-param ( name value -- ) swap set-global ;
: bool-param ( name -- ) "no-" ?head not var-param ;
@ -43,8 +41,6 @@ SYMBOL: command-line
: run-script ( file -- )
t "quiet" set-global run-file ;
PRIVATE>
: parse-command-line ( args -- )
[ command-line off script off ] [
unclip "-" ?head
@ -76,15 +72,4 @@ SYMBOL: main-vocab-hook
: script-mode ( -- ) ;
: handle-command-line ( -- )
[
(command-line) parse-command-line
load-vocab-roots
run-user-init
"e" get [ eval ] when*
ignore-cli-args? not script get and
[ run-script ] [ "run" get run ] if*
output-stream get [ stream-flush ] when*
] [ print-error 1 exit ] recover ;
[ default-cli-args ] "command-line" add-init-hook

4
basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
View File

@ -1,6 +1,6 @@
USING: compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.alias-analysis cpu.architecture tools.test
kernel ;
compiler.cfg.alias-analysis compiler.cfg.debugger
cpu.architecture tools.test kernel ;
IN: compiler.cfg.alias-analysis.tests
[ ] [

3
basis/compiler/cfg/dead-code/dead-code-tests.factor
View File

@ -1,5 +1,6 @@
USING: compiler.cfg.dead-code compiler.cfg.instructions
compiler.cfg.registers cpu.architecture tools.test ;
compiler.cfg.registers compiler.cfg.debugger
cpu.architecture tools.test ;
IN: compiler.cfg.dead-code.tests
[ { } ] [

20
basis/compiler/cfg/debugger/debugger.factor
View File

@ -2,10 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io
classes.tuple accessors prettyprint prettyprint.config
compiler.tree.builder compiler.tree.optimizer
prettyprint.backend prettyprint.custom prettyprint.sections
parser compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.stack-frame compiler.cfg.linear-scan
compiler.cfg.two-operand compiler.cfg.optimizer ;
compiler.cfg.registers compiler.cfg.stack-frame
compiler.cfg.linear-scan compiler.cfg.two-operand
compiler.cfg.optimizer ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
@ -40,3 +42,15 @@ SYMBOL: allocate-registers?
instructions>> [ insn. ] each
nl
] each ;
! Prettyprinting
M: vreg pprint*
<block
\ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
block> ;
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
M: ds-loc pprint* \ D pprint-loc ;
M: rs-loc pprint* \ R pprint-loc ;

17
basis/compiler/cfg/registers/registers.factor
View File

@ -1,7 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces kernel arrays
parser prettyprint.backend prettyprint.sections ;
USING: accessors namespaces kernel arrays parser ;
IN: compiler.cfg.registers
! Virtual registers, used by CFG and machine IRs
@ -18,20 +17,6 @@ C: <ds-loc> ds-loc
TUPLE: rs-loc < loc ;
C: <rs-loc> rs-loc
! Prettyprinting
: V scan-word scan-word vreg boa parsed ; parsing
M: vreg pprint*
<block
\ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
block> ;
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
: D scan-word <ds-loc> parsed ; parsing
M: ds-loc pprint* \ D pprint-loc ;
: R scan-word <rs-loc> parsed ; parsing
M: rs-loc pprint* \ R pprint-loc ;

5
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -1,7 +1,8 @@
IN: compiler.cfg.value-numbering.tests
USING: compiler.cfg.value-numbering compiler.cfg.instructions
compiler.cfg.registers cpu.architecture tools.test kernel math
combinators.short-circuit accessors sequences ;
compiler.cfg.registers compiler.cfg.debugger cpu.architecture
tools.test kernel math combinators.short-circuit accessors
sequences ;
: trim-temps ( insns -- insns )
[

3
basis/compiler/cfg/write-barrier/write-barrier-tests.factor
View File

@ -1,5 +1,6 @@
USING: compiler.cfg.write-barrier compiler.cfg.instructions
compiler.cfg.registers cpu.architecture arrays tools.test ;
compiler.cfg.registers compiler.cfg.debugger cpu.architecture
arrays tools.test ;
IN: compiler.cfg.write-barrier.tests
[

10
basis/compiler/codegen/fixup/fixup.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system
combinators math.bitwise words.private math.order accessors
growable cpu.architecture compiler.constants ;
USING: arrays byte-arrays byte-vectors generic assocs hashtables
io.binary kernel kernel.private math namespaces make sequences
words quotations strings alien.accessors alien.strings layouts
system combinators math.bitwise words.private math.order
accessors growable cpu.architecture compiler.constants ;
IN: compiler.codegen.fixup
GENERIC: fixup* ( obj -- )

21
basis/compiler/compiler.factor
View File

@ -1,15 +1,14 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io debugger
words fry continuations vocabs assocs dlists definitions
math threads graphs generic combinators deques search-deques
prettyprint io stack-checker stack-checker.state
stack-checker.inlining compiler.errors compiler.units
compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.optimizer
compiler.cfg.linearization compiler.cfg.two-operand
compiler.cfg.linear-scan compiler.cfg.stack-frame
compiler.codegen ;
USING: accessors kernel namespaces arrays sequences io
words fry continuations vocabs assocs dlists definitions math
threads graphs generic combinators deques search-deques io
stack-checker stack-checker.state stack-checker.inlining
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder
compiler.cfg.optimizer compiler.cfg.linearization
compiler.cfg.two-operand compiler.cfg.linear-scan
compiler.cfg.stack-frame compiler.codegen ;
IN: compiler
SYMBOL: compile-queue
@ -45,7 +44,7 @@ SYMBOL: +failed+
2bi ;
: start ( word -- )
"trace-compilation" get [ dup . flush ] when
"trace-compilation" get [ dup name>> print flush ] when
H{ } clone dependencies set
H{ } clone generic-dependencies set
f swap compiler-error ;

27
basis/compiler/tree/dead-code/recursive/recursive.factor
View File

@ -22,14 +22,11 @@ M: #call-recursive compute-live-values*
[ out-d>> ] [ label>> return>> in-d>> ] bi look-at-mapping ;
:: drop-dead-inputs ( inputs outputs -- #shuffle )
[let* | live-inputs [ inputs filter-live ]
new-live-inputs [ outputs inputs filter-corresponding make-values ] |
live-inputs
new-live-inputs
outputs
inputs
drop-values
] ;
inputs filter-live
outputs inputs filter-corresponding make-values
outputs
inputs
drop-values ;
M: #enter-recursive remove-dead-code*
[ filter-live ] change-out-d ;
@ -79,12 +76,12 @@ M: #call-recursive remove-dead-code*
bi
] ;
M:: #recursive remove-dead-code* ( node -- nodes )
[let* | drop-inputs [ node drop-recursive-inputs ]
drop-outputs [ node drop-recursive-outputs ] |
node [ (remove-dead-code) ] change-child drop
node label>> [ filter-live ] change-enter-out drop
{ drop-inputs node drop-outputs }
] ;
M: #recursive remove-dead-code* ( node -- nodes )
[ drop-recursive-inputs ]
[
[ (remove-dead-code) ] change-child
dup label>> [ filter-live ] change-enter-out drop
]
[ drop-recursive-outputs ] tri 3array ;
M: #return-recursive remove-dead-code* ;

5
basis/compiler/tree/debugger/debugger.factor
View File

@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.sections math words
combinators combinators.short-circuit io sorting hints qualified
prettyprint prettyprint.backend prettyprint.custom
prettyprint.sections math words combinators
combinators.short-circuit io sorting hints qualified
compiler.tree
compiler.tree.recursive
compiler.tree.normalization

8
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -48,9 +48,11 @@ M: callable splicing-nodes
] [ 2drop f >>method f >>body f >>class drop f ] if ;
: inlining-standard-method ( #call word -- class/f method/f )
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
[ swap nth value-info class>> dup ] dip
specific-method ;
dup "methods" word-prop assoc-empty? [ 2drop f f ] [
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
[ swap nth value-info class>> dup ] dip
specific-method
] if ;
: inline-standard-method ( #call word -- ? )
dupd inlining-standard-method eliminate-dispatch ;

2
basis/concurrency/combinators/combinators.factor
View File

@ -22,7 +22,7 @@ PRIVATE>
] (parallel-each) ; inline
: parallel-filter ( seq quot -- newseq )
over [ pusher [ each ] dip ] dip like ; inline
over [ pusher [ parallel-each ] dip ] dip like ; inline
<PRIVATE

9
basis/core-foundation/core-foundation-tests.factor Normal file
View File

@ -0,0 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: core-foundation tools.test kernel ;
IN: core-foundation
[ ] [ "Hello" <CFString> CFRelease ] unit-test
[ "Hello" ] [ "Hello" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
[ "Hello\u003456" ] [ "Hello\u003456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
[ "Hello\u013456" ] [ "Hello\u013456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test

58
basis/core-foundation/core-foundation.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences io.encodings.utf16 destructors accessors combinators ;
math sequences io.encodings.utf8 destructors accessors
combinators byte-arrays ;
IN: core-foundation
TYPEDEF: void* CFAllocatorRef
@ -69,12 +70,53 @@ FUNCTION: CFURLRef CFURLCreateWithString ( CFAllocatorRef allocator, CFStringRef
FUNCTION: CFURLRef CFURLCopyFileSystemPath ( CFURLRef url, int pathStyle ) ;
FUNCTION: CFStringRef CFStringCreateWithCharacters ( CFAllocatorRef allocator, wchar_t* cStr, CFIndex numChars ) ;
TYPEDEF: int CFStringEncoding
: kCFStringEncodingMacRoman HEX: 0 ;
: kCFStringEncodingWindowsLatin1 HEX: 0500 ;
: kCFStringEncodingISOLatin1 HEX: 0201 ;
: kCFStringEncodingNextStepLatin HEX: 0B01 ;
: kCFStringEncodingASCII HEX: 0600 ;
: kCFStringEncodingUnicode HEX: 0100 ;
: kCFStringEncodingUTF8 HEX: 08000100 ;
: kCFStringEncodingNonLossyASCII HEX: 0BFF ;
: kCFStringEncodingUTF16 HEX: 0100 ;
: kCFStringEncodingUTF16BE HEX: 10000100 ;
: kCFStringEncodingUTF16LE HEX: 14000100 ;
: kCFStringEncodingUTF32 HEX: 0c000100 ;
: kCFStringEncodingUTF32BE HEX: 18000100 ;
: kCFStringEncodingUTF32LE HEX: 1c000100 ;
FUNCTION: CFStringRef CFStringCreateFromExternalRepresentation (
CFAllocatorRef alloc,
CFDataRef data,
CFStringEncoding encoding
) ;
FUNCTION: CFStringRef CFStringCreateWithBytes (
CFAllocatorRef alloc,
UInt8* bytes,
CFIndex numBytes,
CFStringEncoding encoding,
Boolean isExternalRepresentation
) ;
FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ;
FUNCTION: Boolean CFStringGetCString (
CFStringRef theString,
char* buffer,
CFIndex bufferSize,
CFStringEncoding encoding
) ;
FUNCTION: CFStringRef CFStringCreateWithCString (
CFAllocatorRef alloc,
char* cStr,
CFStringEncoding encoding
) ;
FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFIndex length ) ;
@ -97,12 +139,16 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
[ [ dupd ] dip CFArraySetValueAtIndex ] 2each ;
: <CFString> ( string -- alien )
f swap dup length CFStringCreateWithCharacters ;
f swap utf8 string>alien kCFStringEncodingUTF8 CFStringCreateWithCString
[ "CFStringCreateWithCString failed" throw ] unless* ;
: CF>string ( alien -- string )
dup CFStringGetLength 1+ "ushort" <c-array> [
[ 0 over CFStringGetLength ] dip CFStringGetCharacters
] keep utf16n alien>string ;
dup CFStringGetLength 4 * 1 + <byte-array> [
dup length
kCFStringEncodingUTF8
CFStringGetCString
[ "CFStringGetCString failed" throw ] unless
] keep utf8 alien>string ;
: CF>string-array ( alien -- seq )
CF>array [ CF>string ] map ;

11
basis/core-foundation/run-loop/run-loop.factor
View File

@ -1,7 +1,6 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel threads init namespaces alien
core-foundation calendar ;
USING: alien alien.syntax core-foundation kernel namespaces ;
IN: core-foundation.run-loop
: kCFRunLoopRunFinished 1 ; inline
@ -40,11 +39,3 @@ FUNCTION: void CFRunLoopAddSource (
"kCFRunLoopDefaultMode" <CFString>
dup \ CFRunLoopDefaultMode set-global
] when ;
: run-loop-thread ( -- )
CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless
run-loop-thread ;
: start-run-loop-thread ( -- )
[ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;

10
basis/core-foundation/run-loop/thread/thread.factor
View File

@ -1,8 +1,16 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: init core-foundation.run-loop ;
USING: calendar core-foundation.run-loop init kernel threads ;
IN: core-foundation.run-loop.thread
! Load this vocabulary if you need a run loop running.
: run-loop-thread ( -- )
CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless
run-loop-thread ;
: start-run-loop-thread ( -- )
[ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
[ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook

2
basis/cpu/x86/assembler/assembler.factor
View File

@ -346,7 +346,7 @@ M: label JUMPcc (JUMPcc) label-fixup ;
: LEAVE ( -- ) HEX: c9 , ;
: RET ( n -- )
dup zero? [ drop HEX: c3 , ] [ HEX: C2 , 2, ] if ;
dup zero? [ drop HEX: c3 , ] [ HEX: c2 , 2, ] if ;
! Arithmetic

6
basis/debugger/debugger.factor
View File

@ -22,9 +22,6 @@ M: tuple error-help class ;
M: string error. print ;
: :error ( -- )
error get error. ;
: :s ( -- )
error-continuation get data>> stack. ;
@ -63,6 +60,9 @@ M: string error. print ;
[ global [ "Error in print-error!" print drop ] bind ]
recover ;
: :error ( -- )
error get print-error ;
: print-error-and-restarts ( error -- )
print-error
restarts.

4
basis/delegate/delegate.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors parser generic kernel classes classes.tuple
words slots assocs sequences arrays vectors definitions
prettyprint math hashtables sets generalizations namespaces make ;
math hashtables sets generalizations namespaces make ;
IN: delegate
: protocol-words ( protocol -- words )
@ -100,6 +100,4 @@ M: protocol definition protocol-words show-words ;
M: protocol definer drop \ PROTOCOL: \ ; ;
M: protocol synopsis* word-synopsis ; ! Necessary?
M: protocol group-words protocol-words ;

5
basis/delegate/protocols/protocols.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: delegate sequences.private sequences assocs
prettyprint.sections io definitions kernel continuations
listener ;
io definitions kernel continuations ;
IN: delegate.protocols
PROTOCOL: sequence-protocol
@ -16,7 +15,7 @@ PROTOCOL: assoc-protocol
PROTOCOL: input-stream-protocol
stream-read1 stream-read stream-read-partial stream-readln
stream-read-until stream-read-quot ;
stream-read-until ;
PROTOCOL: output-stream-protocol
stream-flush stream-write1 stream-write stream-format

2
basis/environment/winnt/winnt.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.strings fry io.encodings.utf16 kernel
USING: alien.strings fry io.encodings.utf16n kernel
splitting windows windows.kernel32 system environment
alien.c-types sequences windows.errors io.streams.memory
io.encodings io ;

12
basis/functors/functors.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel locals.private quotations classes.tuple make
combinators generic words interpolate namespaces sequences
io.streams.string fry classes.mixin effects lexer parser
classes.tuple.parser effects.parser ;
USING: kernel quotations classes.tuple make combinators generic
words interpolate namespaces sequences io.streams.string fry
classes.mixin effects lexer parser classes.tuple.parser
effects.parser locals.types locals.parser locals.rewrite.closures ;
IN: functors
: scan-param ( -- obj )
@ -99,8 +99,8 @@ DEFER: ;FUNCTOR delimiter
: (FUNCTOR:) ( -- word def )
CREATE
parse-locals
parse-locals dup push-locals
parse-functor-body swap pop-locals <lambda>
lambda-rewrite first ;
rewrite-closures first ;
: FUNCTOR: (FUNCTOR:) define ; parsing

15
basis/generalizations/generalizations-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.syntax help.markup kernel sequences quotations
math arrays ;
math arrays combinators ;
IN: generalizations
HELP: nsequence
@ -234,6 +234,18 @@ HELP: napply
}
} ;
HELP: ncleave
{ $values { "quots" "a sequence of quotations" } { "n" integer } }
{ $description "A generalization of " { $link cleave } " and " { $link 2cleave } " that can work for any quotation arity."
}
{ $examples
"Some core words expressed in terms of " { $link ncleave } ":"
{ $table
{ { $link cleave } { $snippet "1 ncleave" } }
{ { $link 2cleave } { $snippet "2 ncleave" } }
}
} ;
HELP: mnswap
{ $values { "m" integer } { "n" integer } }
{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }
@ -269,6 +281,7 @@ $nl
{ $subsection nslip }
{ $subsection nkeep }
{ $subsection napply }
{ $subsection ncleave }
"Generalized quotation construction:"
{ $subsection ncurry }
{ $subsection nwith } ;

4
basis/generalizations/generalizations.factor
View File

@ -69,6 +69,10 @@ MACRO: ncurry ( n -- )
MACRO: nwith ( n -- )
[ with ] n*quot ;
MACRO: ncleave ( quots n -- )
[ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
compose ;
MACRO: napply ( n -- )
2 [a,b]
[ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ]

3
basis/help/definitions/definitions.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors definitions help help.topics help.syntax
prettyprint.backend prettyprint words kernel effects ;
prettyprint.backend prettyprint.custom prettyprint words kernel
effects ;
IN: help.definitions
! Definition protocol implementation

4
basis/help/handbook/handbook.factor
View File

@ -1,7 +1,7 @@
USING: help help.markup help.syntax help.definitions help.topics
namespaces words sequences classes assocs vocabs kernel arrays
prettyprint.backend kernel.private io generic math system
strings sbufs vectors byte-arrays quotations
prettyprint.backend prettyprint.custom kernel.private io generic
math system strings sbufs vectors byte-arrays quotations
io.streams.byte-array classes.builtin parser lexer
classes.predicate classes.union classes.intersection
classes.singleton classes.tuple tools.vocabs.browser math.parser

2
basis/help/lint/lint.factor
View File

@ -150,7 +150,7 @@ M: help-error error.
] [
[
swap vocab-heading.
[ error. nl ] each
[ print-error nl ] each
] assoc-each
] if-empty ;

16
basis/http/client/client.factor
View File

@ -3,14 +3,14 @@
USING: accessors assocs kernel math math.parser namespaces make
sequences io io.sockets io.streams.string io.files io.timeouts
strings splitting calendar continuations accessors vectors
math.order hashtables byte-arrays prettyprint destructors
math.order hashtables byte-arrays destructors
io.encodings
io.encodings.string
io.encodings.ascii
io.encodings.8-bit
io.encodings.binary
io.streams.duplex
fry debugger summary ascii urls urls.encoding present
fry ascii urls urls.encoding present
http http.parsers ;
IN: http.client
@ -84,10 +84,6 @@ M: f >post-data ;
ERROR: too-many-redirects ;
M: too-many-redirects summary
drop
[ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
<PRIVATE
DEFER: (with-http-request)
@ -161,10 +157,6 @@ PRIVATE>
ERROR: download-failed response ;
M: download-failed error.
"HTTP request failed:" print nl
response>> . ;
: check-response ( response -- response )
dup code>> success? [ download-failed ] unless ;
@ -203,3 +195,7 @@ M: download-failed error.
: http-post ( post-data url -- response data )
<post-request> http-request ;
USING: vocabs vocabs.loader ;
"debugger" vocab [ "http.client.debugger" require ] when

13
basis/http/client/debugger/debugger.factor Normal file
View File

@ -0,0 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel summary debugger io make math.parser
prettyprint http.client accessors ;
IN: http.client.debugger
M: too-many-redirects summary
drop
[ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
M: download-failed error.
"HTTP request failed:" print nl
response>> . ;

8
basis/http/http.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel combinators math namespaces make
assocs sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format present urls
USING: accessors kernel combinators math namespaces make assocs
sequences splitting sorting sets strings vectors hashtables
quotations arrays byte-arrays math.parser calendar
calendar.format present urls
io io.encodings io.encodings.iana io.encodings.binary
io.encodings.8-bit

6
basis/io/encodings/utf16/utf16-tests.factor
View File

@ -23,9 +23,3 @@ IN: io.encodings.utf16.tests
[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test
[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test
: correct-endian
code>> little-endian? [ utf16le = ] [ utf16be = ] if ;
[ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test
[ t ] [ utf16n <byte-writer> correct-endian ] unit-test

6
basis/io/encodings/utf16n/utf16n-docs.factor Normal file
View File

@ -0,0 +1,6 @@
USING: help.markup help.syntax ;
IN: io.encodings.utf16n
HELP: utf16n
{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
{ $see-also "encodings-introduction" } ;

9
basis/io/encodings/utf16n/utf16n-tests.factor Normal file
View File

@ -0,0 +1,9 @@
USING: accessors alien.c-types kernel
io.encodings.utf16 io.streams.byte-array tools.test ;
IN: io.encodings.utf16n
: correct-endian
code>> little-endian? [ utf16le = ] [ utf16be = ] if ;
[ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test
[ t ] [ utf16n <byte-writer> correct-endian ] unit-test

15
basis/io/encodings/utf16n/utf16n.factor Normal file
View File

@ -0,0 +1,15 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.encodings io.encodings.utf16 kernel ;
IN: io.encodings.utf16n
! Native-order UTF-16
SINGLETON: utf16n
: utf16n ( -- descriptor )
little-endian? utf16le utf16be ? ; foldable
M: utf16n <decoder> drop utf16n <decoder> ;
M: utf16n <encoder> drop utf16n <encoder> ;

5
basis/io/files/unique/backend/backend.factor
View File

@ -1,5 +0,0 @@
USING: io.backend ;
IN: io.files.unique.backend
HOOK: (make-unique-file) io-backend ( path -- )
HOOK: temporary-path io-backend ( -- path )

36
basis/io/files/unique/unique-docs.factor
View File

@ -2,12 +2,40 @@ USING: help.markup help.syntax io io.ports kernel math
io.files.unique.private math.parser io.files ;
IN: io.files.unique
HELP: temporary-path
{ $values
{ "path" "a pathname string" }
}
{ $description "A hook that returns the path of the temporary directory in a platform-specific way. Does not guarantee that path is writable by your user." } ;
HELP: touch-unique-file
{ $values
{ "path" "a pathname string" }
}
{ $description "Creates a unique file in a platform-specific way. The file is guaranteed not to exist and is openable by your user." } ;
HELP: unique-length
{ $description "A symbol storing the number of random characters inserted between the prefix and suffix of a random file name." } ;
HELP: unique-retries
{ $description "The number of times to try creating a unique file in case of a name collision. The odds of a name collision are extremely low with a sufficient " { $link unique-length } "." } ;
{ unique-length unique-retries } related-words
HELP: make-unique-file ( prefix suffix -- path )
{ $values { "prefix" "a string" } { "suffix" "a string" }
{ "path" "a pathname string" } }
{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." }
{ $errors "Throws an error if a new unique file cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." }
{ $see-also with-unique-file } ;
{ $errors "Throws an error if a new unique file cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ;
HELP: make-unique-file*
{ $values
{ "prefix" null } { "suffix" null }
{ "path" "a pathname string" }
}
{ $description "Creates a file that is guaranteed not to exist in the directory in the " { $link current-directory } " variable. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } ;
{ make-unique-file make-unique-file* with-unique-file } related-words
HELP: with-unique-file ( prefix suffix quot: ( path -- ) -- )
{ $values { "prefix" "a string" } { "suffix" "a string" }
@ -18,8 +46,7 @@ HELP: with-unique-file ( prefix suffix quot: ( path -- ) -- )
HELP: make-unique-directory ( -- path )
{ $values { "path" "a pathname string" } }
{ $description "Creates a directory that is guaranteed not to exist in a platform-specific temporary directory and returns the full pathname." }
{ $errors "Throws an error if the directory cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." }
{ $see-also with-unique-directory } ;
{ $errors "Throws an error if the directory cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ;
HELP: with-unique-directory ( quot -- )
{ $values { "quot" "a quotation" } }
@ -30,6 +57,7 @@ ARTICLE: "io.files.unique" "Temporary files"
"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform temporary file creation in a high-level and secure way." $nl
"Files:"
{ $subsection make-unique-file }
{ $subsection make-unique-file* }
{ $subsection with-unique-file }
"Directories:"
{ $subsection make-unique-directory }

25
basis/io/files/unique/unique.factor
View File

@ -1,11 +1,13 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.bitwise math.parser
random sequences continuations namespaces
io.files io arrays io.files.unique.backend system
combinators vocabs.loader fry ;
USING: kernel math math.bitwise math.parser random sequences
continuations namespaces io.files io arrays system
combinators vocabs.loader fry io.backend ;
IN: io.files.unique
HOOK: touch-unique-file io-backend ( path -- )
HOOK: temporary-path io-backend ( -- path )
SYMBOL: unique-length
SYMBOL: unique-retries
@ -26,12 +28,17 @@ SYMBOL: unique-retries
PRIVATE>
: (make-unique-file) ( path prefix suffix -- path )
'[
_ _ _ unique-length get random-name glue append-path
dup touch-unique-file
] unique-retries get retry ;
: make-unique-file ( prefix suffix -- path )
temporary-path -rot
[
unique-length get random-name glue append-path
dup (make-unique-file)
] 3curry unique-retries get retry ;
[ temporary-path ] 2dip (make-unique-file) ;
: make-unique-file* ( prefix suffix -- path )
[ current-directory get ] 2dip (make-unique-file) ;
: with-unique-file ( prefix suffix quot: ( path -- ) -- )
[ make-unique-file ] dip [ delete-file ] bi ; inline

0
extra/io/paths/authors.txt → basis/io/paths/authors.txt
View File

11
basis/io/paths/paths-tests.factor Normal file
View File

@ -0,0 +1,11 @@
USING: io.paths kernel tools.test io.files.unique sequences
io.files namespaces sorting ;
IN: io.paths.tests
[ t ] [
[
10 [ "io.paths.test" "gogogo" make-unique-file* ] replicate
current-directory get t [ ] find-all-files
] with-unique-directory
[ natural-sort ] bi@ =
] unit-test

2
extra/io/paths/paths.factor → basis/io/paths/paths.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays deques dlists io.files io.paths.private
USING: accessors arrays deques dlists io.files
kernel sequences system vocabs.loader fry continuations ;
IN: io.paths

0
extra/io/paths/windows/authors.txt → basis/io/paths/windows/authors.txt
View File

0
extra/io/paths/windows/tags.txt → basis/io/paths/windows/tags.txt
View File

0
extra/io/paths/windows/windows.factor → basis/io/paths/windows/windows.factor
View File

2
basis/io/ports/ports.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel io sequences io.buffers io.timeouts generic
byte-vectors system io.encodings math.order io.backend
continuations debugger classes byte-arrays namespaces splitting
continuations classes byte-arrays namespaces splitting
grouping dlists assocs io.encodings.binary summary accessors
destructors combinators ;
IN: io.ports

2
basis/io/servers/connection/connection.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors kernel math math.parser
namespaces parser sequences strings prettyprint debugger
namespaces parser sequences strings prettyprint
quotations combinators logging calendar assocs present
fry accessors arrays io io.sockets io.encodings.ascii
io.sockets.secure io.files io.streams.duplex io.timeouts

4
basis/io/sockets/secure/openssl/openssl.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays kernel debugger sequences
USING: accessors byte-arrays kernel sequences
namespaces math math.order combinators init alien alien.c-types
alien.strings libc continuations destructors debugger summary
alien.strings libc continuations destructors summary
splitting assocs random math.parser locals unicode.case openssl
openssl.libcrypto openssl.libssl io.backend io.ports io.files
io.encodings.8-bit io.timeouts io.sockets.secure ;

2
basis/io/sockets/sockets.factor
View File

@ -4,7 +4,7 @@
USING: generic kernel io.backend namespaces continuations
sequences arrays io.encodings io.ports io.streams.duplex
io.encodings.ascii alien.strings io.binary accessors destructors
classes debugger byte-arrays system combinators parser
classes byte-arrays system combinators parser
alien.c-types math.parser splitting grouping math assocs summary
system vocabs.loader combinators present fry ;
IN: io.sockets

0
core/io/streams/byte-array/byte-array-docs.factor → basis/io/streams/byte-array/byte-array-docs.factor
View File

0
core/io/streams/byte-array/byte-array-tests.factor → basis/io/streams/byte-array/byte-array-tests.factor
View File

0
core/io/streams/byte-array/byte-array.factor → basis/io/streams/byte-array/byte-array.factor
View File

4
basis/io/streams/duplex/duplex.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations destructors io io.encodings
io.encodings.private io.timeouts io.ports debugger summary
listener accessors delegate delegate.protocols ;
io.encodings.private io.timeouts io.ports summary
accessors delegate delegate.protocols ;
IN: io.streams.duplex
TUPLE: duplex-stream in out ;

2
basis/io/streams/limited/limited.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math io io.encodings destructors accessors
sequences namespaces ;
sequences namespaces byte-vectors ;
IN: io.streams.limited
TUPLE: limited-stream stream count limit ;

10
basis/io/styles/styles.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io colors ;
USING: hashtables io colors summary make accessors splitting
kernel ;
IN: io.styles
SYMBOL: plain
@ -43,4 +44,11 @@ TUPLE: input string ;
C: <input> input
M: input summary
[
"Input: " %
string>> "\n" split1 swap %
"..." "" ? %
] "" make ;
: write-object ( str obj -- ) presented associate format ;

4
basis/io/unix/files/unique/unique.factor
View File

@ -1,13 +1,13 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.ports io.unix.backend math.bitwise
unix io.files.unique.backend system ;
unix system io.files.unique ;
IN: io.unix.files.unique
: open-unique-flags ( -- flags )
{ O_RDWR O_CREAT O_EXCL } flags ;
M: unix (make-unique-file) ( path -- )
M: unix touch-unique-file ( path -- )
open-unique-flags file-mode open-file close-file ;
M: unix temporary-path ( -- path ) "/tmp" ;

7
basis/io/unix/launcher/launcher.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces math system sequences debugger
USING: kernel namespaces math system sequences
continuations arrays assocs combinators alien.c-types strings
threads accessors environment
io io.backend io.launcher io.ports io.files
@ -36,9 +36,6 @@ USE: unix
: redirect-fd ( oldfd fd -- )
2dup = [ 2drop ] [ dup2 io-error ] if ;
: redirect-inherit ( obj mode fd -- )
3drop ;
: redirect-file ( obj mode fd -- )
[ [ normalize-path ] dip file-mode open-file ] dip redirect-fd ;
@ -50,7 +47,7 @@ USE: unix
: redirect ( obj mode fd -- )
{
{ [ pick not ] [ redirect-inherit ] }
{ [ pick not ] [ 3drop ] }
{ [ pick string? ] [ redirect-file ] }
{ [ pick appender? ] [ redirect-file-append ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }

2
basis/io/unix/sockets/secure/secure.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors unix byte-arrays kernel debugger sequences
USING: accessors unix byte-arrays kernel sequences
namespaces math math.order combinators init alien alien.c-types
alien.strings libc continuations destructors openssl
openssl.libcrypto openssl.libssl io io.files io.ports

8
basis/io/windows/files/files.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.binary io.backend io.files io.buffers
io.windows kernel math splitting fry alien.strings
windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces make words symbols system
io.ports destructors accessors math.bitwise continuations
io.encodings.utf16n io.ports io.windows kernel math splitting
fry alien.strings windows windows.kernel32 windows.time calendar
combinators math.functions sequences namespaces make words
symbols system destructors accessors math.bitwise continuations
windows.errors arrays byte-arrays ;
IN: io.windows.files

8
basis/io/windows/files/unique/unique.factor
View File

@ -1,9 +1,9 @@
USING: kernel system io.files.unique.backend
windows.kernel32 io.windows io.windows.files io.ports windows
destructors environment ;
USING: kernel system windows.kernel32 io.windows
io.windows.files io.ports windows destructors environment
io.files.unique ;
IN: io.windows.files.unique
M: windows (make-unique-file) ( path -- )
M: windows touch-unique-file ( path -- )
GENERIC_WRITE CREATE_NEW 0 open-file dispose ;
M: windows temporary-path ( -- path )

12
basis/io/windows/nt/files/files.factor Normal file → Executable file
View File

@ -1,10 +1,10 @@
USING: continuations destructors io.buffers io.files io.backend
io.timeouts io.ports io.windows io.windows.files
io.windows.nt.backend windows windows.kernel32
kernel libc math threads system environment
alien.c-types alien.arrays alien.strings sequences combinators
combinators.short-circuit ascii splitting alien strings
assocs namespaces make io.files.private accessors tr ;
io.timeouts io.ports io.files.private io.windows
io.windows.files io.windows.nt.backend io.encodings.utf16n
windows windows.kernel32 kernel libc math threads system
environment alien.c-types alien.arrays alien.strings sequences
combinators combinators.short-circuit ascii splitting alien
strings assocs namespaces make accessors tr ;
IN: io.windows.nt.files
M: winnt cwd

4
basis/io/windows/nt/monitors/monitors.factor
View File

@ -5,8 +5,8 @@ kernel math assocs namespaces make continuations sequences
hashtables sorting arrays combinators math.bitwise strings
system accessors threads splitting io.backend io.windows
io.windows.nt.backend io.windows.nt.files io.monitors io.ports
io.buffers io.files io.timeouts io.encodings.string io
windows windows.kernel32 windows.types ;
io.buffers io.files io.timeouts io.encodings.string
io.encodings.utf16n io windows windows.kernel32 windows.types ;
IN: io.windows.nt.monitors
: open-directory ( path -- handle )

57
basis/locals/definitions/definitions.factor Normal file
View File

@ -0,0 +1,57 @@
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors definitions effects generic kernel locals
macros memoize prettyprint prettyprint.backend words ;
IN: locals.definitions
PREDICATE: lambda-word < word "lambda" word-prop >boolean ;
M: lambda-word definer drop \ :: \ ; ;
M: lambda-word definition
"lambda" word-prop body>> ;
M: lambda-word reset-word
[ call-next-method ] [ f "lambda" set-word-prop ] bi ;
INTERSECTION: lambda-macro macro lambda-word ;
M: lambda-macro definer drop \ MACRO:: \ ; ;
M: lambda-macro definition
"lambda" word-prop body>> ;
M: lambda-macro reset-word
[ call-next-method ] [ f "lambda" set-word-prop ] bi ;
INTERSECTION: lambda-method method-body lambda-word ;
M: lambda-method definer drop \ M:: \ ; ;
M: lambda-method definition
"lambda" word-prop body>> ;
M: lambda-method reset-word
[ call-next-method ] [ f "lambda" set-word-prop ] bi ;
INTERSECTION: lambda-memoized memoized lambda-word ;
M: lambda-memoized definer drop \ MEMO:: \ ; ;
M: lambda-memoized definition
"lambda" word-prop body>> ;
M: lambda-memoized reset-word
[ call-next-method ] [ f "lambda" set-word-prop ] bi ;
: method-stack-effect ( method -- effect )
dup "lambda" word-prop vars>>
swap "method-generic" word-prop stack-effect
dup [ out>> ] when
<effect> ;
M: lambda-method synopsis*
dup dup dup definer.
"method-class" word-prop pprint-word
"method-generic" word-prop pprint-word
method-stack-effect effect>string comment. ;

40
basis/locals/errors/errors.factor Normal file
View File

@ -0,0 +1,40 @@
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel summary ;
IN: locals.errors
ERROR: >r/r>-in-lambda-error ;
M: >r/r>-in-lambda-error summary
drop
"Explicit retain stack manipulation is not permitted in lambda bodies" ;
ERROR: binding-form-in-literal-error ;
M: binding-form-in-literal-error summary
drop "[let, [let* and [wlet not permitted inside literals" ;
ERROR: local-writer-in-literal-error ;
M: local-writer-in-literal-error summary
drop "Local writer words not permitted inside literals" ;
ERROR: local-word-in-literal-error ;
M: local-word-in-literal-error summary
drop "Local words not permitted inside literals" ;
ERROR: :>-outside-lambda-error ;
M: :>-outside-lambda-error summary
drop ":> cannot be used outside of lambda expressions" ;
ERROR: bad-lambda-rewrite output ;
M: bad-lambda-rewrite summary
drop "You have found a bug in locals. Please report." ;
ERROR: bad-local args obj ;
M: bad-local summary
drop "You have bound a bug in locals. Please report." ;

18
basis/locals/fry/fry.factor Normal file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors fry fry.private generalizations kernel
locals.types make sequences ;
IN: locals.fry
! Support for mixing locals with fry
M: binding-form count-inputs body>> count-inputs ;
M: lambda count-inputs body>> count-inputs ;
M: lambda deep-fry
clone [ shallow-fry swap ] change-body
[ [ vars>> length ] keep '[ _ _ mnswap @ ] , ] [ drop [ncurry] % ] 2bi ;
M: binding-form deep-fry
clone [ fry '[ @ call ] ] change-body , ;

29
basis/locals/locals-docs.factor
View File

@ -63,6 +63,33 @@ HELP: [wlet
}
} ;
HELP: :>
{ $syntax ":> binding" }
{ $description "Introduces a new binding, lexically scoped to the enclosing quotation or definition." }
{ $notes
"Lambda and let forms are really just syntax sugar for " { $link POSTPONE: :> } "."
$nl
"Lambdas desugar as follows:"
{ $code
"[| a b | a b + b / ]"
"[ :> b :> a a b + b / ]"
}
"Let forms desugar as follows:"
{ $code
"[|let | x [ 10 random ] | { x x } ]"
"10 random :> x { x x }"
}
}
{ $examples
{ $code
"USING: locals math kernel ;"
"IN: scratchpad"
":: quadratic ( a b c -- x y )"
" b sq 4 a c * * - sqrt :> disc"
" b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@ ;"
}
} ;
HELP: ::
{ $syntax ":: word ( bindings... -- outputs... ) body... ;" }
{ $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." }
@ -209,6 +236,8 @@ $nl
{ $subsection POSTPONE: [wlet }
"Lambda abstractions:"
{ $subsection POSTPONE: [| }
"Lightweight binding form:"
{ $subsection POSTPONE: :> }
"Additional topics:"
{ $subsection "locals-literals" }
{ $subsection "locals-mutable" }

10
basis/locals/locals-tests.factor
View File

@ -441,6 +441,16 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval ] must-fail
[ "USE: locals [| | { :> a } ]" eval ] must-fail
[ "USE: locals 3 :> a" eval ] must-fail
[ 3 ] [ 3 [| | :> a a ] call ] unit-test
[ 3 ] [ 3 [| | :> a! a ] call ] unit-test
[ 3 ] [ 2 [| | :> a! a 1+ a! a ] call ] unit-test
:: wlet-&&-test ( a -- ? )
[wlet | is-integer? [ a integer? ]
is-even? [ a even? ]

510
basis/locals/locals.factor
View File

@ -1,397 +1,13 @@
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces make sequences sequences.private assocs
math vectors strings classes.tuple generalizations parser words
quotations debugger macros arrays macros splitting combinators
prettyprint.backend definitions prettyprint hashtables
prettyprint.sections sets sequences.private effects
effects.parser generic generic.parser compiler.units accessors
locals.backend memoize macros.expander lexer classes summary fry
fry.private ;
USING: lexer macros memoize parser sequences vocabs
vocabs.loader words kernel namespaces locals.parser locals.types
locals.errors ;
IN: locals
ERROR: >r/r>-in-lambda-error ;
M: >r/r>-in-lambda-error summary
drop
"Explicit retain stack manipulation is not permitted in lambda bodies" ;
ERROR: binding-form-in-literal-error ;
M: binding-form-in-literal-error summary
drop "[let, [let* and [wlet not permitted inside literals" ;
ERROR: local-writer-in-literal-error ;
M: local-writer-in-literal-error summary
drop "Local writer words not permitted inside literals" ;
ERROR: local-word-in-literal-error ;
M: local-word-in-literal-error summary
drop "Local words not permitted inside literals" ;
ERROR: bad-lambda-rewrite output ;
M: bad-lambda-rewrite summary
drop "You have found a bug in locals. Please report." ;
<PRIVATE
TUPLE: lambda vars body ;
C: <lambda> lambda
TUPLE: binding-form bindings body ;
TUPLE: let < binding-form ;
C: <let> let
TUPLE: let* < binding-form ;
C: <let*> let*
TUPLE: wlet < binding-form ;
C: <wlet> wlet
M: lambda expand-macros clone [ expand-macros ] change-body ;
M: lambda expand-macros* expand-macros literal ;
M: binding-form expand-macros
clone
[ [ expand-macros ] assoc-map ] change-bindings
[ expand-macros ] change-body ;
M: binding-form expand-macros* expand-macros literal ;
PREDICATE: local < word "local?" word-prop ;
: <local> ( name -- word )
#! Create a local variable identifier
f <word>
dup t "local?" set-word-prop ;
PREDICATE: local-word < word "local-word?" word-prop ;
: <local-word> ( name -- word )
f <word> dup t "local-word?" set-word-prop ;
PREDICATE: local-reader < word "local-reader?" word-prop ;
: <local-reader> ( name -- word )
f <word>
dup t "local-reader?" set-word-prop ;
PREDICATE: local-writer < word "local-writer?" word-prop ;
: <local-writer> ( reader -- word )
dup name>> "!" append f <word> {
[ nip t "local-writer?" set-word-prop ]
[ swap "local-reader" set-word-prop ]
[ "local-writer" set-word-prop ]
[ nip ]
} 2cleave ;
TUPLE: quote local ;
C: <quote> quote
: local-index ( obj args -- n )
[ dup quote? [ local>> ] when eq? ] with find drop ;
: read-local-quot ( obj args -- quot )
local-index neg [ get-local ] curry ;
GENERIC# localize 1 ( obj args -- quot )
M: local localize read-local-quot ;
M: quote localize [ local>> ] dip read-local-quot ;
M: local-word localize read-local-quot [ call ] append ;
M: local-reader localize read-local-quot [ local-value ] append ;
M: local-writer localize
[ "local-reader" word-prop ] dip
read-local-quot [ set-local-value ] append ;
M: object localize drop 1quotation ;
UNION: special local quote local-word local-reader local-writer ;
: load-locals-quot ( args -- quot )
[ [ ] ] [
dup [ local-reader? ] contains? [
dup [ local-reader? [ 1array ] [ ] ? ] map spread>quot
] [ [ ] ] if swap length [ load-locals ] curry append
] if-empty ;
: drop-locals-quot ( args -- quot )
[ [ ] ] [ length [ drop-locals ] curry ] if-empty ;
: point-free-body ( quot args -- newquot )
[ but-last-slice ] dip '[ _ localize ] map concat ;
: point-free-end ( quot args -- newquot )
over peek special?
[ dup drop-locals-quot [ [ peek ] dip localize ] dip append ]
[ drop-locals-quot swap peek suffix ]
if ;
: (point-free) ( quot args -- newquot )
[ nip load-locals-quot ]
[ reverse point-free-body ]
[ reverse point-free-end ]
2tri [ ] 3append-as ;
: point-free ( quot args -- newquot )
over empty? [ nip length '[ _ ndrop ] ] [ (point-free) ] if ;
UNION: lexical local local-reader local-writer local-word ;
GENERIC: free-vars* ( form -- )
: free-vars ( form -- vars )
[ free-vars* ] { } make prune ;
M: local-writer free-vars* "local-reader" word-prop , ;
M: lexical free-vars* , ;
M: quote free-vars* , ;
M: object free-vars* drop ;
M: quotation free-vars* [ free-vars* ] each ;
M: lambda free-vars* [ vars>> ] [ body>> ] bi free-vars swap diff % ;
GENERIC: lambda-rewrite* ( obj -- )
GENERIC: local-rewrite* ( obj -- )
: lambda-rewrite ( form -- form' )
expand-macros
[ local-rewrite* ] [ ] make
[ [ lambda-rewrite* ] each ] [ ] make ;
UNION: block callable lambda ;
GENERIC: block-vars ( block -- seq )
GENERIC: block-body ( block -- quot )
M: callable block-vars drop { } ;
M: callable block-body ;
M: callable local-rewrite*
[ [ local-rewrite* ] each ] [ ] make , ;
M: lambda block-vars vars>> ;
M: lambda block-body body>> ;
M: lambda local-rewrite*
[ vars>> ] [ body>> ] bi
[ [ local-rewrite* ] each ] [ ] make <lambda> , ;
M: block lambda-rewrite*
#! Turn free variables into bound variables, curry them
#! onto the body
dup free-vars [ <quote> ] map dup % [
over block-vars prepend
swap block-body [ [ lambda-rewrite* ] each ] [ ] make
swap point-free ,
] keep length \ curry <repetition> % ;
GENERIC: rewrite-literal? ( obj -- ? )
M: special rewrite-literal? drop t ;
M: array rewrite-literal? [ rewrite-literal? ] contains? ;
M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
M: wrapper rewrite-literal? drop t ;
M: hashtable rewrite-literal? drop t ;
M: vector rewrite-literal? drop t ;
M: tuple rewrite-literal? drop t ;
M: object rewrite-literal? drop f ;
GENERIC: rewrite-element ( obj -- )
: rewrite-elements ( seq -- )
[ rewrite-element ] each ;
: rewrite-sequence ( seq -- )
[ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ;
M: array rewrite-element
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
M: vector rewrite-element rewrite-sequence ;
M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
M: tuple rewrite-element
[ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
M: quotation rewrite-element local-rewrite* ;
M: lambda rewrite-element local-rewrite* ;
M: binding-form rewrite-element binding-form-in-literal-error ;
M: local rewrite-element , ;
M: local-reader rewrite-element , ;
M: local-writer rewrite-element
local-writer-in-literal-error ;
M: local-word rewrite-element
local-word-in-literal-error ;
M: word rewrite-element literalize , ;
M: wrapper rewrite-element
dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ;
M: object rewrite-element , ;
M: array local-rewrite* rewrite-element ;
M: vector local-rewrite* rewrite-element ;
M: tuple local-rewrite* rewrite-element ;
M: hashtable local-rewrite* rewrite-element ;
M: wrapper local-rewrite* rewrite-element ;
M: word local-rewrite*
dup { >r r> load-locals get-local drop-locals } memq?
[ >r/r>-in-lambda-error ] [ call-next-method ] if ;
M: object lambda-rewrite* , ;
M: object local-rewrite* , ;
: make-local ( name -- word )
"!" ?tail [
<local-reader>
dup <local-writer> dup name>> set
] [ <local> ] if
dup dup name>> set ;
: make-locals ( seq -- words assoc )
[ [ make-local ] map ] H{ } make-assoc ;
: make-local-word ( name def -- word )
[ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
"local-word-def" set-word-prop ;
: push-locals ( assoc -- )
use get push ;
: pop-locals ( assoc -- )
use get delete ;
SYMBOL: in-lambda?
: (parse-lambda) ( assoc end -- quot )
t in-lambda? [ parse-until ] with-variable
>quotation swap pop-locals ;
: parse-lambda ( -- lambda )
"|" parse-tokens make-locals dup push-locals
\ ] (parse-lambda) <lambda> ;
: parse-binding ( end -- pair/f )
scan {
{ [ dup not ] [ unexpected-eof ] }
{ [ 2dup = ] [ 2drop f ] }
[ nip scan-object 2array ]
} cond ;
: (parse-bindings) ( end -- )
dup parse-binding dup [
first2 [ make-local ] dip 2array ,
(parse-bindings)
] [ 2drop ] if ;
: parse-bindings ( end -- bindings vars )
[
[ (parse-bindings) ] H{ } make-assoc
dup push-locals
] { } make swap ;
: parse-bindings* ( end -- words assoc )
[
[
namespace push-locals
(parse-bindings)
] { } make-assoc
] { } make swap ;
: (parse-wbindings) ( end -- )
dup parse-binding dup [
first2 [ make-local-word ] keep 2array ,
(parse-wbindings)
] [ 2drop ] if ;
: parse-wbindings ( end -- bindings vars )
[
[ (parse-wbindings) ] H{ } make-assoc
dup push-locals
] { } make swap ;
: let-rewrite ( body bindings -- )
<reversed> [
[ 1array ] dip spin <lambda> '[ @ @ ]
] assoc-each local-rewrite* \ call , ;
M: let local-rewrite*
[ body>> ] [ bindings>> ] bi let-rewrite ;
M: let* local-rewrite*
[ body>> ] [ bindings>> ] bi let-rewrite ;
M: wlet local-rewrite*
[ body>> ] [ bindings>> ] bi
[ '[ _ ] ] assoc-map
let-rewrite ;
: parse-locals ( -- vars assoc )
"(" expect ")" parse-effect
word [ over "declared-effect" set-word-prop ] when*
in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
: parse-locals-definition ( word -- word quot )
parse-locals \ ; (parse-lambda) <lambda>
2dup "lambda" set-word-prop
lambda-rewrite dup length 1 = [ first ] [ bad-lambda-rewrite ] if ;
: (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
: (M::) ( -- word def )
CREATE-METHOD
[ parse-locals-definition ] with-method-definition ;
: parsed-lambda ( accum form -- accum )
in-lambda? get [ parsed ] [ lambda-rewrite over push-all ] if ;
PRIVATE>
: :>
scan locals get [ :>-outside-lambda-error ] unless*
[ make-local ] bind <def> parsed ; parsing
: [| parse-lambda parsed-lambda ; parsing
@ -415,110 +31,12 @@ PRIVATE>
: MEMO:: (::) define-memoized ; parsing
<PRIVATE
{
"locals.macros"
"locals.fry"
} [ require ] each
! Pretty-printing locals
SYMBOL: |
: pprint-var ( var -- )
#! Prettyprint a read/write local as its writer, just like
#! in the input syntax: [| x! | ... x 3 + x! ]
dup local-reader? [
"local-writer" word-prop
] when pprint-word ;
: pprint-vars ( vars -- ) [ pprint-var ] each ;
M: lambda pprint*
<flow
\ [| pprint-word
dup vars>> pprint-vars
\ | pprint-word
f <inset body>> pprint-elements block>
\ ] pprint-word
block> ;
: pprint-let ( let word -- )
pprint-word
[ body>> ] [ bindings>> ] bi
\ | pprint-word
t <inset
<block
[ <block [ pprint-var ] dip pprint* block> ] assoc-each
block>
\ | pprint-word
<block pprint-elements block>
block>
\ ] pprint-word ;
M: let pprint* \ [let pprint-let ;
M: wlet pprint* \ [wlet pprint-let ;
M: let* pprint* \ [let* pprint-let ;
PREDICATE: lambda-word < word "lambda" word-prop >boolean ;
M: lambda-word definer drop \ :: \ ; ;
M: lambda-word definition
"lambda" word-prop body>> ;
M: lambda-word reset-word
[ call-next-method ] [ f "lambda" set-word-prop ] bi ;
INTERSECTION: lambda-macro macro lambda-word ;
M: lambda-macro definer drop \ MACRO:: \ ; ;
M: lambda-macro definition
"lambda" word-prop body>> ;
M: lambda-macro reset-word
[ call-next-method ] [ f "lambda" set-word-prop ] bi ;
INTERSECTION: lambda-method method-body lambda-word ;
M: lambda-method definer drop \ M:: \ ; ;
M: lambda-method definition
"lambda" word-prop body>> ;
M: lambda-method reset-word
[ call-next-method ] [ f "lambda" set-word-prop ] bi ;
INTERSECTION: lambda-memoized memoized lambda-word ;
M: lambda-memoized definer drop \ MEMO:: \ ; ;
M: lambda-memoized definition
"lambda" word-prop body>> ;
M: lambda-memoized reset-word
[ call-next-method ] [ f "lambda" set-word-prop ] bi ;
: method-stack-effect ( method -- effect )
dup "lambda" word-prop vars>>
swap "method-generic" word-prop stack-effect
dup [ out>> ] when
<effect> ;
M: lambda-method synopsis*
dup dup dup definer.
"method-class" word-prop pprint-word
"method-generic" word-prop pprint-word
method-stack-effect effect>string comment. ;
PRIVATE>
! Locals and fry
M: binding-form count-inputs body>> count-inputs ;
M: lambda count-inputs body>> count-inputs ;
M: lambda deep-fry
clone [ shallow-fry swap ] change-body
[ [ vars>> length ] keep '[ _ _ mnswap @ ] , ] [ drop [ncurry] % ] 2bi ;
M: binding-form deep-fry
clone [ fry '[ @ call ] ] change-body , ;
"prettyprint" vocab [
"locals.definitions" require
"locals.prettyprint" require
] when

16
basis/locals/macros/macros.factor Normal file
View File

@ -0,0 +1,16 @@
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel locals.types macros.expander ;
IN: locals.macros
M: lambda expand-macros clone [ expand-macros ] change-body ;
M: lambda expand-macros* expand-macros literal ;
M: binding-form expand-macros
clone
[ [ expand-macros ] assoc-map ] change-bindings
[ expand-macros ] change-body ;
M: binding-form expand-macros* expand-macros literal ;

101
basis/locals/parser/parser.factor Normal file
View File

@ -0,0 +1,101 @@
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators effects.parser
generic.parser kernel lexer locals.errors
locals.rewrite.closures locals.types make namespaces parser
quotations sequences splitting words ;
IN: locals.parser
: make-local ( name -- word )
"!" ?tail [
<local-reader>
dup <local-writer> dup name>> set
] [ <local> ] if
dup dup name>> set ;
: make-locals ( seq -- words assoc )
[ [ make-local ] map ] H{ } make-assoc ;
: make-local-word ( name def -- word )
[ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
"local-word-def" set-word-prop ;
SYMBOL: locals
: push-locals ( assoc -- )
use get push ;
: pop-locals ( assoc -- )
use get delete ;
SYMBOL: in-lambda?
: (parse-lambda) ( assoc end -- quot )
[
in-lambda? on
over locals set
over push-locals
parse-until >quotation
swap pop-locals
] with-scope ;
: parse-lambda ( -- lambda )
"|" parse-tokens make-locals
\ ] (parse-lambda) <lambda> ;
: parse-binding ( end -- pair/f )
scan {
{ [ dup not ] [ unexpected-eof ] }
{ [ 2dup = ] [ 2drop f ] }
[ nip scan-object 2array ]
} cond ;
: (parse-bindings) ( end -- )
dup parse-binding dup [
first2 [ make-local ] dip 2array ,
(parse-bindings)
] [ 2drop ] if ;
: parse-bindings ( end -- bindings vars )
[
[ (parse-bindings) ] H{ } make-assoc
] { } make swap ;
: parse-bindings* ( end -- words assoc )
[
[
namespace push-locals
(parse-bindings)
namespace pop-locals
] { } make-assoc
] { } make swap ;
: (parse-wbindings) ( end -- )
dup parse-binding dup [
first2 [ make-local-word ] keep 2array ,
(parse-wbindings)
] [ 2drop ] if ;
: parse-wbindings ( end -- bindings vars )
[
[ (parse-wbindings) ] H{ } make-assoc
] { } make swap ;
: parse-locals ( -- vars assoc )
"(" expect ")" parse-effect
word [ over "declared-effect" set-word-prop ] when*
in>> [ dup pair? [ first ] when ] map make-locals ;
: parse-locals-definition ( word -- word quot )
parse-locals \ ; (parse-lambda) <lambda>
2dup "lambda" set-word-prop
rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ;
: (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
: (M::) ( -- word def )
CREATE-METHOD
[ parse-locals-definition ] with-method-definition ;
: parsed-lambda ( accum form -- accum )
in-lambda? get [ parsed ] [ rewrite-closures over push-all ] if ;

48
basis/locals/prettyprint/prettyprint.factor Normal file
View File

@ -0,0 +1,48 @@
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel locals locals.types
prettyprint.backend prettyprint.sections prettyprint.custom
sequences words ;
IN: locals.prettyprint
SYMBOL: |
: pprint-var ( var -- )
#! Prettyprint a read/write local as its writer, just like
#! in the input syntax: [| x! | ... x 3 + x! ]
dup local-reader? [
"local-writer" word-prop
] when pprint-word ;
: pprint-vars ( vars -- ) [ pprint-var ] each ;
M: lambda pprint*
<flow
\ [| pprint-word
dup vars>> pprint-vars
\ | pprint-word
f <inset body>> pprint-elements block>
\ ] pprint-word
block> ;
: pprint-let ( let word -- )
pprint-word
[ body>> ] [ bindings>> ] bi
\ | pprint-word
t <inset
<block
[ <block [ pprint-var ] dip pprint* block> ] assoc-each
block>
\ | pprint-word
<block pprint-elements block>
block>
\ ] pprint-word ;
M: let pprint* \ [let pprint-let ;
M: wlet pprint* \ [wlet pprint-let ;
M: let* pprint* \ [let* pprint-let ;
M: def pprint*
<block \ :> pprint-word local>> pprint-word block> ;

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