! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays assocs kernel kernel.private libc math
-namespaces make parser sequences strings words assocs splitting
-math.parser cpu.architecture alien alien.accessors alien.strings
-quotations layouts system compiler.units io io.files
-io.encodings.binary io.streams.memory accessors combinators effects
-continuations fry classes ;
+namespaces make parser sequences strings words splitting math.parser
+cpu.architecture alien alien.accessors alien.strings quotations
+layouts system compiler.units io io.files io.encodings.binary
+io.streams.memory accessors combinators effects continuations fry
+classes ;
IN: alien.c-types
DEFER: <int>
: *T ( alien -- z )
[ T-real ] [ T-imaginary ] bi rect> ; inline
-T in get
+T current-vocab
{ { N "real" } { N "imaginary" } }
define-struct
: define-fortran-record ( name vocab fields -- )
[ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
-SYNTAX: RECORD: scan in get parse-definition define-fortran-record ;
+SYNTAX: RECORD: scan current-vocab parse-definition define-fortran-record ;
: set-fortran-abi ( library -- )
library-fortran-abis get-global at fortran-abi set ;
-USING: accessors alien.c-types strings help.markup help.syntax
-alien.syntax sequences io arrays kernel words assocs namespaces
-accessors ;
+USING: alien.c-types strings help.markup help.syntax alien.syntax
+sequences io arrays kernel words assocs namespaces ;
IN: alien.structs
ARTICLE: "c-structs" "C structure types"
scan scan typedef ;
SYNTAX: C-STRUCT:
- scan in get parse-definition define-struct ;
+ scan current-vocab parse-definition define-struct ;
SYNTAX: C-UNION:
scan parse-definition define-union ;
widthed
bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
byte bs widthed>> |widthed :> new-byte
- new-byte #bits>> dup 8 > [ "oops" throw ] when 8 = [
+ new-byte #bits>> 8 = [
new-byte bits>> bs bytes>> push
zero-widthed bs (>>widthed)
remainder widthed>bytes
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors compiler cpu.architecture vocabs.loader system
+USING: accessors cpu.architecture vocabs.loader system
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 libc splitting math.parser memory
-compiler.units math.order compiler.tree.builder
-compiler.tree.optimizer compiler.cfg.optimizer ;
+io.encodings.string libc splitting math.parser memory compiler.units
+math.order compiler.tree.builder compiler.tree.optimizer
+compiler.cfg.optimizer ;
+FROM: compiler => enable-optimizer compile-word ;
IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays byte-arrays generic assocs hashtables assocs
-hashtables.private io io.binary io.files io.encodings.binary
-io.pathnames kernel kernel.private math namespaces make parser
-prettyprint sequences sequences.private strings sbufs vectors words
-quotations assocs system layouts splitting grouping growable classes
-classes.builtin classes.tuple classes.tuple.private vocabs
-vocabs.loader source-files definitions debugger quotations.private
-sequences.private combinators math.order math.private accessors
-slots.private generic.single.private compiler.units compiler.constants
-fry bootstrap.image.syntax ;
+USING: alien arrays byte-arrays generic hashtables hashtables.private
+io io.binary io.files io.encodings.binary io.pathnames kernel
+kernel.private math namespaces make parser prettyprint sequences
+strings sbufs vectors words quotations assocs system layouts splitting
+grouping growable classes classes.builtin classes.tuple
+classes.tuple.private vocabs vocabs.loader source-files definitions
+debugger quotations.private combinators math.order math.private
+accessors slots.private generic.single.private compiler.units
+compiler.constants fry bootstrap.image.syntax ;
IN: bootstrap.image
: arch ( os cpu -- arch )
! See http://factorcode.org/license.txt for BSD license.\r
USING: math math.order math.parser math.functions kernel\r
sequences io accessors arrays io.streams.string splitting\r
-combinators accessors calendar calendar.format.macros present ;\r
+combinators calendar calendar.format.macros present ;\r
IN: calendar.format\r
\r
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;\r
!
! Channels - based on ideas from newsqueak
USING: kernel sequences threads continuations
-random math accessors random ;
+random math accessors ;
IN: channels
TUPLE: channel receivers senders ;
"An error thrown if the digest name is unrecognized:"
{ $subsection unknown-digest }
"An example where we compute the SHA1 checksum of a string using the OpenSSL implementation of SHA1:"
-{ $example "USING: byte-arrays checksums checksums.openssl prettyprint ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" }
+{ $example "USING: byte-arrays checksums checksums.openssl ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" }
"If we use the Factor implementation, we get the same result, just slightly slower:"
-{ $example "USING: byte-arrays checksums checksums.sha1 prettyprint ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ;
+{ $example "USING: byte-arrays checksums checksums.sha1 ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ;
ABOUT: "checksums.openssl"
! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel io io.encodings.binary io.files
-io.streams.byte-array math.vectors strings sequences namespaces
+io.streams.byte-array math.vectors strings namespaces
make math parser sequences assocs grouping vectors io.binary
hashtables math.bitwise checksums checksums.common
checksums.stream ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
continuations combinators compiler compiler.alien stack-checker kernel
-math namespaces make parser quotations sequences strings words
+math namespaces make quotations sequences strings words
cocoa.runtime io macros memoize io.encodings.utf8 effects libc
-libc.private parser lexer init core-foundation fry generalizations
+libc.private lexer init core-foundation fry generalizations
specialized-arrays.direct.alien ;
IN: cocoa.messages
: ignore-cli-args? ( -- ? )
os macosx? "run" get "ui" = and ;
-: script-mode ( -- ) ;
-
[ default-cli-args ] "command-line" add-init-hook
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces make math sequences sets
-assocs fry compiler.cfg.instructions ;
+assocs fry compiler.cfg compiler.cfg.instructions ;
IN: compiler.cfg.rpo
SYMBOL: visited
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic
-generic.single combinators deques search-deques macros io
+generic.single combinators deques search-deques macros
source-files.errors stack-checker stack-checker.state
stack-checker.inlining stack-checker.errors combinators.short-circuit
compiler.errors compiler.units compiler.tree.builder
-USING: alien alien.c-types alien.syntax compiler kernel
-namespaces namespaces tools.test sequences stack-checker
-stack-checker.errors words arrays parser quotations
-continuations effects namespaces.private io io.streams.string
-memory system threads tools.test math accessors combinators
-specialized-arrays.float alien.libraries io.pathnames
+USING: alien alien.c-types alien.syntax compiler kernel namespaces
+sequences stack-checker stack-checker.errors words arrays parser
+quotations continuations effects namespaces.private io
+io.streams.string memory system threads tools.test math accessors
+combinators specialized-arrays.float alien.libraries io.pathnames
io.backend ;
IN: compiler.tests.alien
-USING: generalizations accessors arrays compiler kernel
-kernel.private math hashtables.private math.private namespaces
-sequences sequences.private tools.test namespaces.private
-slots.private sequences.private byte-arrays alien
+USING: generalizations accessors arrays compiler kernel kernel.private
+math hashtables.private math.private namespaces sequences tools.test
+namespaces.private slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make ;
+QUALIFIED: namespaces.private
IN: compiler.tests.codegen
! Originally, this file did black box testing of templating
[ 3 ]
[
global [ 3 \ foo set ] bind
- \ foo [ global >n get ndrop ] compile-call
+ \ foo [ global >n get namespaces.private:ndrop ] compile-call
] unit-test
: blech ( x -- ) drop ;
[ 3 ]
[
global [ 3 \ foo set ] bind
- \ foo [ global [ get ] swap >n call ndrop ] compile-call
+ \ foo [ global [ get ] swap >n call namespaces.private:ndrop ] compile-call
] unit-test
[ 3 ]
USING: accessors arrays compiler.units kernel kernel.private math
math.constants math.private sequences strings tools.test words
continuations sequences.private hashtables.private byte-arrays
-strings.private system random layouts vectors
+system random layouts vectors
sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings
-namespaces libc sequences.private io.encodings.ascii
+namespaces libc io.encodings.ascii
classes compiler ;
IN: compiler.tests.intrinsics
compiler.tree.optimizer
compiler.tree.combinators
compiler.tree.checker ;
+FROM: fry => _ ;
RENAME: _ match => __
IN: compiler.tree.debugger
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays namespaces assocs sequences kernel generic assocs
+USING: arrays namespaces sequences kernel generic assocs
classes vectors accessors combinators sets
stack-checker.state
stack-checker.branches
[ 0 ] [
[ { null } declare [ 1 ] [ 2 ] if ] count-unboxed-allocations
] unit-test
+
+! Doug found a regression
+
+TUPLE: empty-tuple ;
+
+[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
\ No newline at end of file
: slot-offset ( #call -- n/f )
dup in-d>>
- [ first node-value-info class>> ]
- [ second node-value-info literal>> ] 2bi
- dup fixnum? [
- {
- { [ over tuple class<= ] [ 2 - ] }
- { [ over complex class<= ] [ 1 - ] }
- [ drop f ]
- } cond nip
+ [ second node-value-info literal>> ]
+ [ first node-value-info class>> ] 2bi
+ 2dup [ fixnum? ] [ tuple class<= ] bi* and [
+ over 2 >= [ drop 2 - ] [ 2drop f ] if
] [ 2drop f ] if ;
: record-slot-call ( #call -- )
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces sequences math math.order accessors kernel arrays
-combinators compiler.utilities assocs
+combinators assocs
stack-checker.backend
stack-checker.branches
stack-checker.inlining
USING: accessors math math.intervals sequences classes.algebra
-math kernel tools.test compiler.tree.propagation.info arrays ;
+kernel tools.test compiler.tree.propagation.info arrays ;
IN: compiler.tree.propagation.info.tests
[ f ] [ 0.0 -0.0 eql? ] unit-test
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences accessors kernel assocs sequences
+USING: sequences accessors kernel assocs
compiler.tree
compiler.tree.propagation.copy
compiler.tree.propagation.info ;
IN: compiler.tree.tuple-unboxing.tests
-USING: tools.test compiler.tree.tuple-unboxing compiler.tree
+USING: tools.test compiler.tree
compiler.tree.builder compiler.tree.recursive
compiler.tree.normalization compiler.tree.propagation
compiler.tree.cleanup compiler.tree.escape-analysis
io.files.temp io.directories arrays io.sockets system
combinators threads math sequences concurrency.messaging
continuations accessors prettyprint ;
+FROM: concurrency.messaging => receive send ;
: test-node ( -- addrspec )
{
IN: concurrency.exchangers.tests\r
-USING: sequences tools.test concurrency.exchangers\r
+USING: tools.test concurrency.exchangers\r
concurrency.count-downs concurrency.promises locals kernel\r
threads ;\r
+FROM: sequences => 3append ;\r
\r
:: exchanger-test ( -- string )\r
[let |\r
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup concurrency.messaging.private
-threads kernel arrays quotations threads strings ;
+threads kernel arrays quotations strings ;
IN: concurrency.messaging
HELP: send
{ $subsection reply-synchronous }
"An example:"
{ $example
- "USING: concurrency.messaging kernel prettyprint threads ;"
+ "USING: concurrency.messaging threads ;"
"IN: scratchpad"
": pong-server ( -- )"
" receive [ \"pong\" ] dip reply-synchronous ;"
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax core-foundation.numbers kernel math
-sequences core-foundation.numbers ;
+USING: alien.c-types alien.syntax kernel math sequences ;
IN: core-foundation.data
TYPEDEF: void* CFDataRef
IN: cpu.ppc.assembler.tests
USING: cpu.ppc.assembler tools.test arrays kernel namespaces
make vocabs sequences ;
+FROM: cpu.ppc.assembler => B ;
: test-assembler ( expected quot -- )
[ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
system cpu.ppc.assembler compiler.codegen.fixup compiler.units\r
compiler.constants math math.private layouts words\r
vocabs slots.private locals.backend ;\r
+FROM: cpu.ppc.assembler => B ;\r
IN: bootstrap.ppc\r
\r
4 \ cell set\r
compiler.cfg.instructions compiler.constants compiler.codegen
compiler.codegen.fixup compiler.cfg.intrinsics
compiler.cfg.stack-frame compiler.units ;
+FROM: cpu.ppc.assembler => B ;
IN: cpu.ppc
! PowerPC register assignments:
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel db.errors peg.ebnf strings sequences math
-combinators.short-circuit accessors math.parser quoting ;
+combinators.short-circuit accessors math.parser quoting
+locals ;
IN: db.errors.postgresql
EBNF: parse-postgresql-sql-error
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.combinators db.pools db.sqlite db.tuples
db.types kernel math random threads tools.test db sequences
-io prettyprint db.postgresql db.sqlite accessors io.files.temp
+io prettyprint db.postgresql accessors io.files.temp
namespaces fry system math.parser ;
IN: db.tester
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.files.temp kernel tools.test db db.tuples classes
-db.types continuations namespaces math math.ranges
+db.types continuations namespaces math
prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitwise system
math.ranges strings urls fry db.tuples.private db.private
db.tester ;
+FROM: math.ranges => [a,b] ;
IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes db kernel namespaces
classes.tuple words sequences slots math accessors
-math.parser io prettyprint db.types continuations
+math.parser io prettyprint continuations
destructors mirrors sets db.types db.private fry
combinators.short-circuit db.errors ;
IN: db.tuples
M: no-current-vocab summary
drop "Not in a vocabulary; IN: form required" ;
-M: no-word-error error.
- "No word named ``" write name>> write "'' found in current vocabulary search path" print ;
+M: no-word-error summary
+ name>> "No word named ``" "'' found in current vocabulary search path" surround ;
+
+M: no-word-error error. summary print ;
+
+M: ambiguous-use-error summary
+ words>> first name>> "More than one vocabulary defines a word named ``" "''" surround ;
+
+M: ambiguous-use-error error. summary print ;
M: staging-violation summary
drop
USING: accessors arrays io kernel math models namespaces make
sequences strings splitting combinators unicode.categories
math.order math.ranges fry locals ;
+FROM: models => change-model ;
IN: documents
: +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
io.files io.backend io.pathnames io summary continuations
tools.crossref vocabs.hierarchy prettyprint source-files
source-files.errors assocs vocabs vocabs.loader splitting
-accessors debugger prettyprint help.topics ;
+accessors debugger help.topics ;
IN: editors
TUPLE: no-edit-hook ;
HOOK: gvim-path io-backend ( -- path )
M: gvim vim-command ( file line -- string )
- [ gvim-path , "+" swap number>string append , , ] { } make ;
+ [
+ gvim-path ,
+ number>string "+" prepend , ,
+ ] { } make ;
gvim vim-editor set-global
IN: editors.macvim
-: macvim-location ( file line -- )
+: macvim ( file line -- )
drop
[ "open" , "-a" , "MacVim", , ] { } make
- try-process ;
-
-[ macvim-location ] edit-hook set-global
-
+ run-detached drop ;
+[ macvim ] edit-hook set-global
number>string "-goto:" prepend ,
] { } make ;
-: scite-location ( file line -- )
+: scite ( file line -- )
scite-command run-detached drop ;
-[ scite-location ] edit-hook set-global
+[ scite ] edit-hook set-global
namespaces prettyprint editors make ;
IN: editors.textedit
-: textedit-location ( file line -- )
+: textedit ( file line -- )
drop
[ "open" , "-a" , "TextEdit", , ] { } make
- try-process ;
+ run-detached drop ;
-[ textedit-location ] edit-hook set-global
+[ textedit ] edit-hook set-global
USING: definitions io.launcher kernel math math.parser parser
namespaces prettyprint editors make ;
-
IN: editors.textmate
-: textmate-location ( file line -- )
+: textmate ( file line -- )
[ "mate" , "-a" , "-l" , number>string , , ] { } make
- try-process ;
+ run-detached drop ;
-[ textmate-location ] edit-hook set-global
+[ textmate ] edit-hook set-global
IN: editors.vim
ARTICLE: { "vim" "vim" } "Vim support"
-"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim-location } ". The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "."
+"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim } ". The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "."
$nl
"If you intend to use this module regularly, it helps to have it load during stage 2 bootstrap. On Windows, place the following example " { $snippet ".factor-boot-rc" } " in the directory returned by " { $link home } ":"
{ $code
IN: editors.vim
SYMBOL: vim-path
-
SYMBOL: vim-editor
HOOK: vim-command vim-editor ( file line -- array )
M: vim vim-command
[
- vim-path get , swap , "+" swap number>string append ,
+ vim-path get ,
+ [ , ] [ number>string "+" prepend , ] bi*
] { } make ;
-: vim-location ( file line -- )
- vim-command try-process ;
+: vim ( file line -- )
+ vim-command run-detached drop ;
"vim" vim-path set-global
-[ vim-location ] edit-hook set-global
-vim vim-editor set-global
+[ vim ] edit-hook set-global
+\ vim vim-editor set-global
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax kernel
layouts sequences system unix environment io.encodings.utf8
-unix.utilities vocabs.loader combinators alien.accessors
-alien.syntax ;
+unix.utilities vocabs.loader combinators alien.accessors ;
IN: environment.unix
HOOK: environ os ( -- void* )
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: splitting parser compiler.units kernel namespaces
+USING: splitting parser parser.notes compiler.units kernel namespaces
debugger io.streams.string fry combinators effects.parser ;
IN: eval
[ "<pre><span class=\"KEYWORD3\">int</span> <span class=\"FUNCTION\">main</span><span class=\"OPERATOR\">(</span><span class=\"OPERATOR\">)</span></pre>" ]
[ "[c{int main()}]" convert-farkup ] unit-test
-[ "<p><img src=\"lol.jpg\" alt=\"image:lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
+[ "<p><img src=\"lol.jpg\" alt=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
[ "<p><a href=\"http://lol.com\">http://lol.com</a></p>" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
[ "<p><a href=\"http://lol.com\">haha</a></p>" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
[ convert-farkup drop t ] [ drop print f ] recover
] all?
] unit-test
+
+[ "<p><a href=\"http://foo.com/~foo\">http://foo.com/~foo</a></p>" ] [ "[[http://foo.com/~foo]]" convert-farkup ] unit-test
{ CHAR: % inline-code }
} at ;
+: or-simple-title ( url title/f quot: ( title -- title' ) -- url title' )
+ [ "" like dup simple-link-title ] if* ; inline
+
: parse-link ( string -- paragraph-list )
rest-slice "]]" split1-slice [
"|" split1
- [ "" like dup simple-link-title ] unless*
- [ "image:" ?head ] dip swap [ image boa ] [ parse-paragraph link boa ] if
+ [ "image:" ?head ] dip swap
+ [ [ ] or-simple-title image boa ]
+ [ [ parse-paragraph ] or-simple-title link boa ] if
] dip [ (parse-paragraph) cons ] [ 1list ] if* ;
: ?first ( seq -- elt ) 0 swap ?nth ;
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-USING: accessors arrays ascii assocs calendar combinators fry kernel
-generalizations io io.encodings.ascii io.files io.streams.string
-macros math math.functions math.parser peg.ebnf quotations
-sequences splitting strings unicode.case vectors combinators.smart ;
+USING: accessors arrays assocs calendar combinators fry kernel
+generalizations io io.streams.string macros math math.functions
+math.parser peg.ebnf quotations sequences splitting strings
+unicode.categories unicode.case vectors combinators.smart ;
IN: formatting
io.files.unique namespaces threads tools.test kernel
io.servers.connection ftp.client accessors urls
io.pathnames io.directories sequences fry ;
+FROM: ftp.client => ftp-get ;
IN: ftp.server.tests
: test-file-contents ( -- string )
} ;
: push-functor-words ( -- )
- functor-words use get push ;
+ functor-words use-words ;
: pop-functor-words ( -- )
- functor-words use get delq ;
+ functor-words unuse-words ;
: parse-functor-body ( -- form )
push-functor-words
USING: help.markup help.syntax io.streams.string quotations
-strings calendar serialize kernel furnace.db words words.symbol
+strings calendar serialize furnace.db words words.symbol
kernel ;
IN: furnace.sessions
USING: cocoa cocoa.plists core-foundation iokit iokit.hid
kernel cocoa.enumeration destructors math.parser cocoa.application
sequences locals combinators.short-circuit threads
-namespaces assocs vectors arrays combinators hints alien
+namespaces assocs arrays combinators hints alien
core-foundation.run-loop accessors sequences.private
alien.c-types math parser game-input vectors bit-arrays ;
IN: game-input.iokit
iokit-game-input-backend game-input-backend set-global
-: hid-manager-matching ( matching-seq -- alien )
- f 0 IOHIDManagerCreate
- [ swap >plist IOHIDManagerSetDeviceMatchingMultiple ]
- keep ;
+: make-hid-manager ( -- alien )
+ f 0 IOHIDManagerCreate ;
+
+: set-hid-manager-matching ( alien matching-seq -- )
+ >plist IOHIDManagerSetDeviceMatchingMultiple ;
: devices-from-hid-manager ( manager -- vector )
[
: ?hat-switch ( device -- ? )
hat-switch-matching-hash ?axis ;
-: hid-manager-matching-game-devices ( -- alien )
- game-devices-matching-seq hid-manager-matching ;
-
: device-property ( device key -- value )
<NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
: element-property ( element key -- value )
256 <bit-array> +keyboard-state+ set-global ;
M: iokit-game-input-backend (open-game-input)
- hid-manager-matching-game-devices {
+ make-hid-manager {
[ initialize-variables ]
[ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
[ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
[ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
[ 0 IOHIDManagerOpen mach-error ]
+ [ game-devices-matching-seq set-hid-manager-matching ]
[
CFRunLoopGetMain CFRunLoopDefaultMode
IOHIDManagerScheduleWithRunLoop
-USING: help.markup help.syntax io kernel math namespaces parser
+USING: help.markup help.syntax io kernel math parser
prettyprint sequences vocabs.loader namespaces stack-checker
help command-line multiline see ;
IN: help.cookbook
} ;
ARTICLE: "cookbook-vocabs" "Vocabularies cookbook"
-"Rather than being in one flat list, words belong to vocabularies; every word is contained in exactly one. When parsing a word name, the parser searches the " { $emphasis "vocabulary search path" } ". When working at the listener, a useful set of vocabularies is already available. In a source file, all used vocabularies must be imported."
+"Rather than being in one flat list, words belong to vocabularies; every word is contained in exactly one. When parsing a word name, the parser searches through vocabularies. When working at the listener, a useful set of vocabularies is already available. In a source file, all used vocabularies must be imported."
$nl
"For example, a source file containing the following code will print a parse error if you try loading it:"
{ $code "\"Hello world\" print" }
"You would have to place the first definition after the two others for the parser to accept the file."
{ $references
{ }
- "vocabulary-search"
+ "word-search"
"words"
"parser"
} ;
{ $list
"Factor only makes use of one native thread, and Factor threads are scheduled co-operatively. C library calls block the entire VM."
"Factor does not hide anything from the programmer, all internals are exposed. It is your responsibility to avoid writing fragile code which depends too much on implementation detail."
- { "When a source file uses two vocabularies which define words with the same name, the order of the vocabularies in the " { $link POSTPONE: USE: } " or " { $link POSTPONE: USING: } " forms is important. The " { $link POSTPONE: QUALIFIED: } " word implements qualified naming, which can be used to resolve ambiguities." }
{ "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." }
{ "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." }
{ "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by “multiple inheritance” in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." }
{ $subsection "namespaces-global" }
{ $subsection "values" }
{ $heading "Abstractions" }
-{ $subsection "errors" }
+{ $subsection "fry" }
{ $subsection "objects" }
+{ $subsection "errors" }
{ $subsection "destructors" }
-{ $subsection "continuations" }
{ $subsection "memoize" }
{ $subsection "parsing-words" }
{ $subsection "macros" }
-{ $subsection "fry" }
+{ $subsection "continuations" }
{ $heading "Program organization" }
{ $subsection "vocabs.loader" }
"Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ;
USING: help.html tools.test help.topics kernel ;
[ ] [ "xml" >link help>html drop ] unit-test
+
+[ "article-foobar.html" ] [ "foobar" >link topic>filename ] unit-test
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
+USING: io.encodings.utf8 io.encodings.binary
io.files io.files.temp io.directories html.streams help kernel
assocs sequences make words accessors arrays help.topics vocabs
vocabs.hierarchy help.vocabs namespaces prettyprint io
-vocabs.loader serialize fry memoize ascii unicode.case math.order
+vocabs.loader serialize fry memoize unicode.case math.order
sorting debugger html xml.syntax xml.writer math.parser ;
+FROM: io.encodings.ascii => ascii ;
+FROM: ascii => ascii? ;
IN: help.html
: escape-char ( ch -- )
] check-something ;
: check-about ( vocab -- )
- dup '[ _ vocab-help [ article drop ] when* ] check-something ;
+ vocab-link boa dup
+ '[ _ vocab-help [ article drop ] when* ] check-something ;
: check-vocab ( vocab -- )
"Checking " write dup write "..." print
- [ vocab check-about ]
+ [ check-about ]
[ words [ check-word ] each ]
[ vocab-articles get at [ check-article ] each ]
tri ;
io.styles vectors words math sorting splitting classes slots fry
sets vocabs help.stylesheet help.topics vocabs.loader quotations
combinators see present ;
+FROM: prettyprint.sections => with-pprint ;
IN: help.markup
PREDICATE: simple-element < array
drop
"Throws an error if the I/O operation fails." $errors ;
-FROM: prettyprint.private => with-pprint ;
-
: $prettyprinting-note ( children -- )
drop {
"This word should only be called from inside the "
] dip remember-definition ;
SYNTAX: ABOUT:
- in get vocab scan-object >>help changed-definition ;
+ current-vocab scan-object >>help changed-definition ;
$nl
"Now we have changed the source file, we must reload it into Factor so that we can test the new definition. To do this, simply go to the Factor listener and press " { $command tool "common" refresh-all } ". This will find any previously-loaded source files which have changed on disk, and reload them."
$nl
-"When you do this, you will get an error about the " { $link dup } " word not being found. This is because this word is part of the " { $vocab-link "kernel" } " vocabulary, but this vocabulary is not part of the source file's " { $link "vocabulary-search" } ". You must explicitly list dependencies in source files. This allows Factor to automatically load required vocabularies and makes larger programs easier to maintain."
+"When you do this, you will get an error about the " { $link dup } " word not being found. This is because this word is part of the " { $vocab-link "kernel" } " vocabulary, but this vocabulary is not part of the source file's " { $link "word-search" } ". You must explicitly list dependencies in source files. This allows Factor to automatically load required vocabularies and makes larger programs easier to maintain."
$nl
"To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary. Enter " { $snippet "dup" } " in the listener's input area, and press " { $operation com-browse } ". This will open the documentation browser tool, viewing the help for the " { $link dup } " word. One of the subheadings in the help article will mention the word's vocabulary."
$nl
io.streams.null accessors inspector html.streams
html.components html.forms namespaces
xml.writer ;
+FROM: html.components => inspector ;
[ ] [ begin-form ] unit-test
IN: html.forms.tests
USING: kernel sequences tools.test assocs html.forms validators accessors
namespaces ;
+FROM: html.forms => values ;
: with-validation ( quot -- messages )
[
USING: html.streams html.streams.private accessors io
io.streams.string io.styles kernel namespaces tools.test
-xml.writer sbufs sequences inspector colors xml.writer
+sbufs sequences inspector colors xml.writer
classes.predicate prettyprint ;
IN: html.streams.tests
IN: html.templates.chloe
-USING: xml.data help.markup help.syntax html.components html.forms
+USING: help.markup help.syntax html.components html.forms
html.templates html.templates.chloe.syntax
html.templates.chloe.compiler html.templates.chloe.components
math strings quotations namespaces ;
+FROM: xml.data => tag ;
HELP: <chloe>
{ $values { "path" "a pathname string without the trailing " { $snippet ".xml" } " extension" } { "chloe" chloe } }
USING: html.templates html.templates.chloe
tools.test io.streams.string kernel sequences ascii boxes
namespaces xml html.components html.forms
-splitting unicode.categories furnace accessors
+splitting furnace accessors
html.templates.chloe.compiler ;
IN: html.templates.chloe.tests
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences combinators kernel fry
+USING: accessors kernel sequences combinators fry
namespaces make classes.tuple assocs splitting words arrays io
io.files io.files.info io.encodings.utf8 io.streams.string
unicode.case mirrors math urls present multiline quotations xml
logging
-xml.data xml.writer xml.syntax strings
+xml.writer xml.syntax strings
html.forms
html
html.components
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: html.templates.chloe.syntax
-USING: accessors kernel sequences combinators kernel namespaces
-classes.tuple assocs splitting words arrays memoize parser lexer
-io io.files io.encodings.utf8 io.streams.string
-unicode.case mirrors fry math urls
-multiline xml xml.data xml.writer xml.syntax
-html.components
+USING: accessors sequences combinators kernel namespaces classes.tuple
+assocs splitting words arrays memoize parser lexer io io.files
+io.encodings.utf8 io.streams.string unicode.case mirrors fry math urls
+multiline xml xml.data xml.writer xml.syntax html.components
html.templates ;
+IN: html.templates.chloe.syntax
SYMBOL: tags
! See http://factorcode.org/license.txt for BSD license.
USING: continuations sequences kernel namespaces debugger
combinators math quotations generic strings splitting accessors
-assocs fry vocabs.parser parser lexer io io.files
+assocs fry vocabs.parser parser parser.notes lexer io io.files
io.streams.string io.encodings.utf8 html.templates ;
IN: html.templates.fhtml
[
"quiet" on
parser-notes off
- "html.templates.fhtml" use+
+ "html.templates.fhtml" use-vocab
string-lines parse-template-lines
] with-file-vocabs ;
USING: http help.markup help.syntax io.pathnames io.streams.string
-io.encodings.8-bit io.encodings.binary kernel strings urls
+io.encodings.8-bit io.encodings.binary kernel urls
urls.encoding byte-arrays strings assocs sequences destructors
http.client.post-data.private ;
IN: http.client
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel math math.parser namespaces make
+USING: assocs kernel math math.parser namespaces make
sequences strings splitting calendar continuations accessors vectors
math.order hashtables byte-arrays destructors
io io.sockets io.streams.string io.files io.timeouts
] unit-test
! Live-fire exercise
-USING: http.server http.server.static furnace.sessions furnace.alloy
-furnace.actions furnace.auth furnace.auth.login furnace.db http.client
-io.servers.connection io.files io.files.temp io.directories io io.encodings.ascii
-accessors namespaces threads
+USING: http.server.static furnace.sessions furnace.alloy
+furnace.actions furnace.auth furnace.auth.login furnace.db
+io.servers.connection io.files io.files.temp io.directories io
+threads
http.server.responses http.server.redirection furnace.redirection
http.server.dispatchers db.tuples ;
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit math math.order math.parser
kernel sequences sequences.deep peg peg.parsers assocs arrays
-hashtables strings unicode.case namespaces make ascii ;
+hashtables strings namespaces make ascii ;
IN: http.parsers
: except ( quot -- parser )
io.timeouts
io.crlf
fry logging logging.insomniac calendar urls urls.encoding
-mime.multipart
unicode.categories
http
http.parsers
html.streams
html
xml.writer ;
+FROM: mime.multipart => parse-multipart ;
IN: http.server
: check-absolute ( url -- url )
: http-insomniac ( -- )
"http.server" { "httpd-hit" } schedule-insomniac ;
-USE: vocabs.loader
-
"http.server.filters" require
"http.server.dispatchers" require
"http.server.redirection" require
! See http://factorcode.org/license.txt for BSD license.
USING: constructors kernel splitting unicode.case combinators
accessors images.bitmap images.tiff images io.pathnames
-images.jpeg images.png ;
+images.png ;
IN: images.loader
ERROR: unknown-image-extension extension ;
{ "bmp" [ bitmap-image ] }
{ "tif" [ tiff-image ] }
{ "tiff" [ tiff-image ] }
- { "jpg" [ jpeg-image ] }
- { "jpeg" [ jpeg-image ] }
+ ! { "jpg" [ jpeg-image ] }
+ ! { "jpeg" [ jpeg-image ] }
{ "png" [ png-image ] }
[ unknown-image-extension ]
} case ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel math grouping fry columns locals accessors
-images math math.vectors arrays ;
+images math.vectors arrays ;
IN: images.tesselation
: group-rows ( bitmap bitmap-dim -- rows )
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io kernel macros make multiline namespaces parser
+USING: io kernel macros make multiline namespaces vocabs.parser
present sequences strings splitting fry accessors ;
IN: interpolate
! Copyright (C) 2007, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel words summary slots quotations
-sequences assocs math arrays stack-checker effects generalizations
+sequences assocs math arrays stack-checker effects
continuations debugger classes.tuple namespaces make vectors
bit-arrays byte-arrays strings sbufs math.functions macros
sequences.private combinators mirrors splitting combinators.smart
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.accessors alien.c-types
alien.syntax kernel libc math sequences byte-arrays strings
-hints accessors math.order destructors combinators ;
+hints math.order destructors combinators ;
IN: io.buffers
TUPLE: buffer
! See http://factorcode.org/license.txt for BSD license.
USING: xml xml.data kernel io io.encodings interval-maps splitting fry
math.parser sequences combinators assocs locals accessors math arrays
-byte-arrays values io.encodings.ascii ascii io.files biassocs
-math.order combinators.short-circuit io.binary io.encodings.iana ;
+byte-arrays values ascii io.files biassocs math.order
+combinators.short-circuit io.binary io.encodings.iana ;
+FROM: io.encodings.ascii => ascii ;
IN: io.encodings.gb18030
SINGLETON: gb18030
-USING: io.files.info io.pathnames io.encodings.utf8 io.files
+USING: io.files.info io.encodings.utf8 io.files
io.directories kernel io.pathnames accessors tools.test
sequences io.files.temp ;
IN: io.files.info.tests
system unix unix.statfs.linux unix.statvfs.linux io.files.links
specialized-arrays.direct.uint arrays io.files.info.unix assocs
io.pathnames unix.types ;
+FROM: csv => delimiter ;
IN: io.files.info.unix.linux
TUPLE: linux-file-system-info < unix-file-system-info
continuations environment io io.backend io.backend.unix
io.files io.files.private io.files.unix io.launcher
io.launcher.unix.parser io.pathnames io.ports kernel math
-namespaces sequences strings system threads unix unix
+namespaces sequences strings system threads unix
unix.process ;
IN: io.launcher.unix
-! Search unix first
-USE: unix
-
: get-arguments ( process -- seq )
command>> dup string? [ tokenize-command ] when ;
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors io.files io.files.info
io.backend kernel quotations system alien alien.accessors
-accessors system vocabs.loader combinators alien.c-types
+accessors vocabs.loader combinators alien.c-types
math ;
IN: io.mmap
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.backend io.monitors io.monitors.recursive
-io.files io.pathnames io.buffers io.monitors io.ports io.timeouts
+io.files io.pathnames io.buffers io.ports io.timeouts
io.backend.unix io.encodings.utf8 unix.linux.inotify assocs
namespaces make threads continuations init math math.bitwise
sets alien alien.strings alien.c-types vocabs.loader accessors
io.backend.unix io.sockets.unix io.encodings.ascii io.buffers
io.sockets io.sockets.secure io.sockets.secure.openssl
io.timeouts system summary fry ;
+FROM: io.ports => shutdown ;
IN: io.sockets.secure.unix
M: ssl-handle handle-fd file>> handle-fd ;
! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman,
! Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-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 byte-arrays system combinators parser
-alien.c-types math.parser splitting grouping math assocs summary
-system vocabs.loader combinators present fry vocabs.parser ;
+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 byte-arrays
+parser alien.c-types math.parser splitting grouping math assocs
+summary system vocabs.loader combinators present fry vocabs.parser ;
IN: io.sockets
<< {
{ [ os windows? ] [ "windows.winsock" ] }
{ [ os unix? ] [ "unix" ] }
-} cond use+ >>
+} cond use-vocab >>
! Addressing
GENERIC: protocol-family ( addrspec -- af )
! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings generic kernel math
-namespaces threads sequences byte-arrays io.ports
-io.binary io.backend.unix io.streams.duplex
-io.backend io.ports io.pathnames io.files.private
-io.encodings.utf8 math.parser continuations libc combinators
-system accessors destructors unix locals init ;
-
-EXCLUDE: io => read write close ;
+USING: alien alien.c-types alien.strings generic kernel math threads
+sequences byte-arrays io.binary io.backend.unix io.streams.duplex
+io.backend io.pathnames io.files.private io.encodings.utf8 math.parser
+continuations libc combinators system accessors destructors unix
+locals init ;
+
+EXCLUDE: namespaces => bind ;
+EXCLUDE: io => read write ;
EXCLUDE: io.sockets => accept ;
IN: io.sockets.unix
USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.ports io.timeouts io.sockets
-io.sockets io namespaces io.streams.duplex io.backend.windows
+io namespaces io.streams.duplex io.backend.windows
io.sockets.windows io.backend.windows.nt windows.winsock kernel
libc math sequences threads system combinators accessors ;
IN: io.sockets.windows.nt
] with-file-vocabs
[
- "debugger" use+
-
[ [ \ + 1 2 3 4 ] ]
[
[
GENERIC: stream-read-quot ( stream -- quot/f )
: parse-lines-interactive ( lines -- quot/f )
- [ parse-lines in get ] with-compilation-unit in set ;
+ [ parse-lines ] with-compilation-unit ;
: read-quot-step ( lines -- quot/f )
[ parse-lines-interactive ] [
] [ drop ] if ;
: prompt. ( -- )
- in get auto-use? get [ " - auto" append ] when "( " " )" surround
+ current-vocab name>> auto-use? get [ " - auto" append ] when "( " " )" surround
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
:: (listener) ( datastack -- )
-USING: lists.lazy.examples lists.lazy tools.test ;
+USING: lists.lazy.examples lists.lazy lists tools.test ;
IN: lists.lazy.examples.tests
[ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test
! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: lists.lazy math kernel sequences quotations ;
+USING: lists lists.lazy math kernel sequences quotations ;
IN: lists.lazy.examples
: naturals ( -- list ) 0 lfrom ;
ARTICLE: { "lists.lazy" "combinators" } "Combinators for manipulating lazy lists"
"The following combinators create lazy lists from other lazy lists:"
-{ $subsection lmap }
+{ $subsection lazy-map }
{ $subsection lfilter }
{ $subsection luntil }
{ $subsection lwhile }
{ $values { "list" "a cons object" } { "quot" { $quotation "( X -- ? )" } } { "result" "resulting cons object" } }
{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-HELP: list>vector
-{ $values { "list" "a cons object" } { "vector" "the list converted to a vector" } }
-{ $description "Convert a list to a vector. If the list is a lazy infinite list then this will enter an infinite loop." }
-{ $see-also list>array } ;
-
-HELP: list>array
-{ $values { "list" "a cons object" } { "array" "the list converted to an array" } }
-{ $description "Convert a list to an array. If the list is a lazy infinite list then this will enter an infinite loop." }
-{ $see-also list>vector } ;
-
HELP: lappend
{ $values { "list1" "a cons object" } { "list2" "a cons object" } { "result" "a lazy list of list2 appended to list1" } }
{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
HELP: lfrom-by
-{ $values { "n" "an integer" } { "quot" { $quotation "( -- int )" } } { "lazy-from-by" "a lazy list of integers" } }
+{ $values { "n" "an integer" } { "quot" { $quotation "( -- n )" } } { "lazy-from-by" "a lazy list of integers" } }
{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;
HELP: lfrom
HELP: seq>list
{ $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } }
-{ $description "Convert the sequence into a list, starting from the 'index' offset into the sequence." }
+{ $description "Convert the sequence into a list, starting from " { $snippet "index" } "." }
{ $see-also >list } ;
HELP: >list
{ $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } }
{ $description "Return the result of merging the two lists in a lazy manner." }
{ $examples
- { $example "USING: lists.lazy prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
+ { $example "USING: lists lists.lazy prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
} ;
HELP: lcontents
] if
] if ;
-: list>vector ( list -- vector )
- [ [ , ] leach ] V{ } make ;
-
-: list>array ( list -- array )
- [ [ , ] leach ] { } make ;
-
TUPLE: lazy-append list1 list2 ;
C: <lazy-append> lazy-append
{ $vocab-subsection "Lazy lists" "lists.lazy" } ;
ARTICLE: { "lists" "protocol" } "The list protocol"
-"Lists are instances of a mixin class"
+"Lists are instances of a mixin class:"
{ $subsection list }
"Instances of the mixin must implement the following words:"
{ $subsection car }
"Strict lists are simply cons cells where the car and cdr have already been evaluated. These are the lists of Lisp. To construct a strict list, the following words are provided:"
{ $subsection cons }
{ $subsection swons }
-{ $subsection sequence>cons }
-{ $subsection deep-sequence>cons }
+{ $subsection sequence>list }
{ $subsection 1list }
{ $subsection 2list }
{ $subsection 3list } ;
{ $subsection foldl }
{ $subsection foldr }
{ $subsection lmap>array }
-{ $subsection lmap-as }
{ $subsection traverse } ;
ARTICLE: { "lists" "manipulation" } "Manipulating lists"
{ $subsection lcut } ;
HELP: cons
-{ $values { "car" "the head of the list cell" } { "cdr" "the tail of the list cell" } { "cons" "a cons object" } }
+{ $values { "car" "the head of the list cell" } { "cdr" "the tail of the list cell" } { "cons" list } }
{ $description "Constructs a cons cell." } ;
HELP: swons
-{ $values { "cdr" "the tail of the list cell" } { "car" "the head of the list cell" } { "cons" "a cons object" } }
+{ $values { "cdr" "the tail of the list cell" } { "car" "the head of the list cell" } { "cons" list } }
{ $description "Constructs a cons cell." } ;
{ cons swons uncons unswons } related-words
HELP: car
-{ $values { "cons" "a cons object" } { "car" "the first item in the list" } }
+{ $values { "cons" list } { "car" "the first item in the list" } }
{ $description "Returns the first item in the list." } ;
HELP: cdr
-{ $values { "cons" "a cons object" } { "cdr" "a cons object" } }
+{ $values { "cons" list } { "cdr" list } }
{ $description "Returns the tail of the list." } ;
{ car cdr } related-words
{ 1list 2list 3list } related-words
HELP: 1list
-{ $values { "obj" "an object" } { "cons" "a cons object" } }
+{ $values { "obj" "an object" } { "cons" list } }
{ $description "Create a list with 1 element." } ;
HELP: 2list
-{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
+{ $values { "a" "an object" } { "b" "an object" } { "cons" list } }
{ $description "Create a list with 2 elements." } ;
HELP: 3list
-{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } }
+{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" list } }
{ $description "Create a list with 3 elements." } ;
HELP: lnth
-{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } }
+{ $values { "n" "an integer index" } { "list" list } { "elt" "the element at the nth index" } }
{ $description "Outputs the nth element of the list." }
{ $see-also llength cons car cdr } ;
HELP: llength
-{ $values { "list" "a cons object" } { "n" "a non-negative integer" } }
+{ $values { "list" list } { "n" "a non-negative integer" } }
{ $description "Outputs the length of the list. This should not be called on an infinite list." }
{ $see-also lnth cons car cdr } ;
HELP: uncons
-{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
+{ $values { "cons" list } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
{ $description "Put the head and tail of the list on the stack." } ;
HELP: unswons
-{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
+{ $values { "cons" list } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
{ $description "Put the head and tail of the list on the stack." } ;
{ leach foldl lmap>array } related-words
HELP: leach
-{ $values { "list" "a cons object" } { "quot" { $quotation "( obj -- )" } } }
+{ $values { "list" list } { "quot" { $quotation "( obj -- )" } } }
{ $description "Call the quotation for each item in the list." } ;
HELP: foldl
-{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
+{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
{ $description "Combines successive elements of the list (in a left-assocative order) using a binary operation and outputs the final result." } ;
HELP: foldr
-{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
+{ $values { "list" list } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
{ $description "Combines successive elements of the list (in a right-assocative order) using a binary operation, and outputs the final result." } ;
HELP: lmap
-{ $values { "list" "a cons object" } { "quot" { $quotation "( old -- new )" } } { "result" "the final result" } }
+{ $values { "list" list } { "quot" { $quotation "( old -- new )" } } { "result" "the final result" } }
{ $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ;
HELP: lreverse
{ $description "Reverses the input list, outputing a new, reversed list. The output is a strict cons list." } ;
HELP: list>array
-{ $values { "list" "a cons object" } { "array" array } }
-{ $description "Turns the given cons object into an array, maintaing order." } ;
-
-HELP: sequence>cons
-{ $values { "sequence" sequence } { "list" cons } }
-{ $description "Turns the given array into a cons object, maintaing order." } ;
-
-HELP: deep-list>array
{ $values { "list" list } { "array" array } }
-{ $description "Recursively turns the given cons object into an array, maintaing order and also converting nested lists." } ;
-
-HELP: deep-sequence>cons
-{ $values { "sequence" sequence } { "cons" cons } }
-{ $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ;
+{ $description "Convert a list into an array." } ;
HELP: traverse
-{ $values { "list" "a cons object" } { "pred" { $quotation "( list/elt -- ? )" } }
+{ $values { "list" list } { "pred" { $quotation "( list/elt -- ? )" } }
{ "quot" { $quotation "( list/elt -- result)" } } { "result" "a new cons object" } }
{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred"
" returns true for with the result of applying quot to." } ;
{ $values { "list" list } { "quot" quotation } { "array" array } }
{ $description "Executes the quotation on each element of the list, collecting the results in an array." } ;
-HELP: lmap-as
-{ $values { "list" list } { "quot" quotation } { "exemplar" sequence } { "sequence" sequence } }
-{ $description "Executes the quotation on each element of the list, collecting the results in a sequence of the type given by the exemplar." } ;
IN: lists.tests
{ { 3 4 5 6 7 } } [
- { 1 2 3 4 5 } sequence>cons [ 2 + ] lmap list>array
+ { 1 2 3 4 5 } sequence>list [ 2 + ] lmap list>array
] unit-test
{ { 3 4 5 6 } } [
+nil+ } } } } 0 [ + ] foldl
] unit-test
-{ T{ cons f
- 1
- T{ cons f
- 2
- T{ cons f
- T{ cons f
- 3
- T{ cons f
- 4
- T{ cons f
- T{ cons f 5 +nil+ }
- +nil+ } } }
- +nil+ } } }
-} [
- { 1 2 { 3 4 { 5 } } } deep-sequence>cons
-] unit-test
-
-{ { 1 2 { 3 4 { 5 } } } } [
- { 1 2 { 3 4 { 5 } } } deep-sequence>cons deep-list>array
-] unit-test
-
{ T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [
- { 1 2 3 4 } sequence>cons [ 1+ ] lmap
+ { 1 2 3 4 } sequence>list [ 1+ ] lmap
] unit-test
{ 15 } [
- { 1 2 3 4 5 } sequence>cons 0 [ + ] foldr
+ { 1 2 3 4 5 } sequence>list 0 [ + ] foldr
] unit-test
{ { 5 4 3 2 1 } } [
- { 1 2 3 4 5 } sequence>cons lreverse list>array
+ { 1 2 3 4 5 } sequence>list lreverse list>array
] unit-test
{ 5 } [
- { 1 2 3 4 5 } sequence>cons llength
-] unit-test
-
-{ { 3 4 { 5 6 { 7 } } } } [
- { 1 2 { 3 4 { 5 } } } deep-sequence>cons [ atom? ] [ 2 + ] traverse deep-list>array
+ { 1 2 3 4 5 } sequence>list llength
] unit-test
{ { 1 2 3 4 5 6 } } [
- { 1 2 3 } sequence>cons { 4 5 6 } sequence>cons lappend list>array
+ { 1 2 3 } sequence>list { 4 5 6 } sequence>list lappend list>array
] unit-test
-[ { 1 } { 2 } ] [ { 1 2 } sequence>cons 1 lcut [ list>array ] bi@ ] unit-test
+[ { 1 } { 2 } ] [ { 1 2 } sequence>list 1 lcut [ list>array ] bi@ ] unit-test
-! Copyright (C) 2008 James Cash
+! Copyright (C) 2008 James Cash, Daniel Ehrenberg, Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors math arrays vectors classes words
combinators.short-circuit combinators locals ;
C: cons cons
-M: cons car ( cons -- car )
- car>> ;
+M: cons car ( cons -- car ) car>> ;
-M: cons cdr ( cons -- cdr )
- cdr>> ;
+M: cons cdr ( cons -- cdr ) cdr>> ;
SINGLETON: +nil+
M: +nil+ nil? drop t ;
M: object nil? drop f ;
-: atom? ( obj -- ? )
- list? not ;
+: atom? ( obj -- ? ) list? not ; inline
-: nil ( -- symbol ) +nil+ ;
+: nil ( -- symbol ) +nil+ ; inline
-: uncons ( cons -- car cdr )
- [ car ] [ cdr ] bi ;
+: uncons ( cons -- car cdr ) [ car ] [ cdr ] bi ; inline
-: swons ( cdr car -- cons )
- swap cons ;
+: swons ( cdr car -- cons ) swap cons ; inline
-: unswons ( cons -- cdr car )
- uncons swap ;
+: unswons ( cons -- cdr car ) uncons swap ; inline
-: 1list ( obj -- cons )
- nil cons ;
+: 1list ( obj -- cons ) nil cons ; inline
-: 1list? ( list -- ? )
- { [ nil? not ] [ cdr nil? ] } 1&& ;
+: 1list? ( list -- ? ) { [ nil? not ] [ cdr nil? ] } 1&& ; inline
-: 2list ( a b -- cons )
- nil cons cons ;
+: 2list ( a b -- cons ) nil cons cons ; inline
-: 3list ( a b c -- cons )
- nil cons cons cons ;
+: 3list ( a b c -- cons ) nil cons cons cons ; inline
-: cadr ( list -- elt )
- cdr car ;
+: cadr ( list -- elt ) cdr car ; inline
-: 2car ( list -- car caar )
- [ car ] [ cdr car ] bi ;
+: 2car ( list -- car caar ) [ car ] [ cdr car ] bi ; inline
-: 3car ( list -- car cadr caddr )
- [ car ] [ cdr car ] [ cdr cdr car ] tri ;
+: 3car ( list -- car cadr caddr ) [ car ] [ cdr car ] [ cdr cdr car ] tri ; inline
-: lnth ( n list -- elt )
- swap [ cdr ] times car ;
+: lnth ( n list -- elt ) swap [ cdr ] times car ; inline
<PRIVATE
+
: (leach) ( list quot -- cdr quot )
[ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline
+
PRIVATE>
: leach ( list quot: ( elt -- ) -- )
: lcut ( list index -- before after )
[ nil ] dip
- [ [ [ cdr ] [ car ] bi ] dip cons ] times
+ [ [ unswons ] dip cons ] times
lreverse swap ;
-: sequence>cons ( sequence -- list )
- <reversed> nil [ swap cons ] reduce ;
-
-<PRIVATE
-: same? ( obj1 obj2 -- ? )
- [ class ] bi@ = ;
-PRIVATE>
-
-: deep-sequence>cons ( sequence -- cons )
- [ <reversed> ] keep nil
- [ [ nip ] [ same? ] 2bi [ deep-sequence>cons ] when swons ]
- with reduce ;
-
-<PRIVATE
-:: (lmap>vector) ( acc list quot: ( elt -- elt' ) -- acc )
- list nil? [ acc ] [
- list car quot call acc push
- acc list cdr quot (lmap>vector)
- ] if ; inline recursive
-
-: lmap>vector ( list quot -- array )
- [ V{ } clone ] 2dip (lmap>vector) ; inline
-PRIVATE>
-
-: lmap-as ( list quot exemplar -- sequence )
- [ lmap>vector ] dip like ; inline
+: sequence>list ( sequence -- list )
+ <reversed> nil [ swons ] reduce ;
: lmap>array ( list quot -- array )
- { } lmap-as ; inline
-
-: deep-list>array ( list -- array )
- [
- {
- { [ dup nil? ] [ drop { } ] }
- { [ dup list? ] [ deep-list>array ] }
- [ ]
- } cond
- ] lmap>array ;
-
-: list>array ( list -- array )
+ accumulator [ leach ] dip { } like ; inline
+
+: list>array ( list -- array )
[ ] lmap>array ;
:: traverse ( list pred quot: ( list/elt -- result ) -- result )
ARTICLE: "literals" "Interpolating code results into literal values"
"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
{ $example <"
-USING: kernel literals math prettyprint ;
+USE: literals
IN: scratchpad
CONSTANT: five 5
[ 9 ] [ 4 write-test-5 ] unit-test
-SYMBOL: a
-
-:: use-test ( a b c -- a b c )
- USE: kernel
- a b c ;
-
-[ t ] [ a symbol? ] unit-test
-
:: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ;
[ 13 ] [ 10 let-let-test ] unit-test
[ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
"local-word-def" set-word-prop ;
-: push-locals ( assoc -- )
- use get push ;
-
-: pop-locals ( assoc -- )
- use get delq ;
-
SINGLETON: lambda-parser
SYMBOL: locals
'[
in-lambda? on
lambda-parser quotation-parser set
- [ locals set ] [ push-locals @ ] [ pop-locals ] tri
+ [ locals set ]
+ [ use-words @ ]
+ [ unuse-words ] tri
] with-scope ; inline
: (parse-lambda) ( assoc -- quot )
: parse-bindings* ( end -- words assoc )
[
- namespace push-locals
+ namespace use-words
(parse-bindings)
- namespace pop-locals
+ namespace unuse-words
] with-bindings ;
: parse-let* ( -- form )
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: namespaces kernel io io.files io.pathnames io.directories\r
-io.sockets io.encodings.utf8\r
-calendar calendar.format sequences continuations destructors\r
-prettyprint assocs math.parser words debugger math combinators\r
-concurrency.messaging threads arrays init math.ranges strings ;\r
+io.encodings.utf8 calendar calendar.format sequences continuations\r
+destructors prettyprint assocs math.parser words debugger math\r
+combinators concurrency.messaging threads arrays init math.ranges\r
+strings ;\r
IN: logging.server\r
\r
: log-root ( -- string )\r
ARTICLE: "complex-numbers-zero" "Embedding of real numbers in complex numbers"
"Constructing a complex number with an imaginary component equal to an integer zero simply returns the real number corresponding to the real component:"
-{ $example "USING: math prettyprint ;" "C{ 1 2 } C{ 3 -2 } + ." "4" }
+{ $example "C{ 1 2 } C{ 3 -2 } + ." "4" }
"Constructing a complex number with an imaginary component equal to floating point zero will still output a new complex number, however:"
-{ $example "USING: math prettyprint ;" "C{ 0.0 2.0 } C{ 0.0 1.0 } * ." "C{ -2.0 0.0 }" }
+{ $example "C{ 0.0 2.0 } C{ 0.0 1.0 } * ." "C{ -2.0 0.0 }" }
"Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero." ;
ARTICLE: "complex-numbers" "Complex numbers"
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors kernel models arrays sequences math math.order\r
models.product ;\r
+FROM: models.product => product ;\r
IN: models.range\r
\r
TUPLE: range < product ;\r
{ [ os macosx? ] [ "opengl.gl.macosx" ] }
{ [ os unix? ] [ "opengl.gl.unix" ] }
[ unknown-gl-platform ]
-} cond use+ >>
+} cond use-vocab >>
SYMBOL: +gl-function-number-counter+
SYMBOL: +gl-function-pointers+
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test opengl.textures opengl.textures.private
-opengl.textures.private images kernel namespaces accessors
-sequences ;
+images kernel namespaces accessors sequences ;
IN: opengl.textures.tests
[
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs cache colors.constants destructors fry kernel
+USING: accessors assocs cache colors.constants destructors kernel
opengl opengl.gl opengl.capabilities combinators images
images.tesselation grouping specialized-arrays.float sequences math
math.vectors math.matrices generalizations fry arrays namespaces
! Copyright (C) 2007 Chris Double.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel compiler.units words arrays strings math.parser\r
+USING: kernel words arrays strings math.parser\r
sequences quotations vectors namespaces make math assocs\r
continuations peg peg.parsers unicode.categories multiline\r
splitting accessors effects sequences.deep peg.search\r
combinators.short-circuit lexer io.streams.string stack-checker\r
io combinators parser summary ;\r
+FROM: compiler.units => with-compilation-unit ;\r
+FROM: vocabs.parser => search ;\r
IN: peg.ebnf\r
\r
: rule ( name word -- parser )\r
drop \r
] [ \r
[\r
- "USING: locals sequences ; [let* | " %\r
+ "FROM: locals => [let* ; FROM: sequences => nth ; [let* | " %\r
dup length swap [\r
dup ebnf-var? [\r
name>> % \r
\r
M: ebnf-var build-locals ( code ast -- )\r
[\r
- "USING: locals kernel ; [let* | " %\r
+ "FROM: locals => [let* ; FROM: kernel => dup nip ; [let* | " %\r
name>> % " [ dup ] " %\r
" | " %\r
% \r
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test strings namespaces make arrays sequences
- peg peg.private peg.parsers accessors words math accessors ;
+ peg peg.private peg.parsers words math accessors ;
IN: peg.tests
[ ] [ reset-pegs ] unit-test
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces make math assocs
-io vectors arrays math.parser math.order vectors combinators
+io vectors arrays math.parser math.order combinators
classes sets unicode.categories compiler.units parser words
-quotations effects memoize accessors locals effects splitting
+quotations memoize accessors locals splitting
combinators.short-circuit generalizations ;
IN: peg
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays byte-vectors generic hashtables io
+USING: accessors arrays byte-arrays byte-vectors generic hashtables
assocs kernel math namespaces make sequences strings sbufs vectors
words prettyprint.config prettyprint.custom prettyprint.sections
quotations io io.pathnames io.styles math.parser effects classes.tuple
[ 1array ] [ [ f 2array ] dip append ] if-empty ;
M: object pprint-narrow? drop f ;
+M: byte-vector pprint-narrow? drop f ;
M: array pprint-narrow? drop t ;
M: vector pprint-narrow? drop t ;
M: hashtable pprint-narrow? drop t ;
USING: prettyprint.backend prettyprint.config prettyprint.custom
-prettyprint.sections prettyprint.private help.markup help.syntax
+prettyprint.sections help.markup help.syntax
io kernel words definitions quotations strings generic classes
prettyprint.private ;
IN: prettyprint
ABOUT: "prettyprint"
-HELP: with-pprint
-{ $values { "obj" object } { "quot" quotation } }
-{ $description "Sets up the prettyprinter and calls the quotation in a new scope. The quotation should add sections to the top-level block. When the quotation returns, the top-level block is printed to " { $link output-stream } "." } ;
-
HELP: pprint
{ $values { "obj" object } }
{ $description "Prettyprints an object to " { $link output-stream } ". Output is influenced by many variables; see " { $link "prettyprint-variables" } "." }
HELP: .s
{ $description "Displays the contents of the data stack, with the top of the stack printed first." } ;
-
-HELP: in.
-{ $values { "vocab" "a vocabulary specifier" } }
-{ $description "Prettyprints a " { $snippet "IN:" } " declaration." }
-$prettyprinting-note ;
\ No newline at end of file
: check-see ( expect name -- ? )
[
- use [ clone ] change
-
[
[ parse-fresh drop ] with-compilation-unit
[
"prettyprint.tests" lookup see
] with-string-writer "\n" split but-last
] keep =
- ] with-scope ;
+ ] with-interactive-vocabs ;
GENERIC: method-layout ( a -- b )
io.streams.string io.styles kernel make math math.parser namespaces
parser prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections quotations sequences sorting strings vocabs
-vocabs.parser words sets ;
+vocabs.prettyprint words sets ;
IN: prettyprint
-<PRIVATE
-
-: make-pprint ( obj quot -- block in use )
- [
- 0 position set
- H{ } clone pprinter-use set
- V{ } clone recursion-check set
- V{ } clone pprinter-stack set
- over <object
- call
- pprinter-block
- pprinter-in get
- pprinter-use get keys
- ] with-scope ; inline
-
-: with-pprint ( obj quot -- )
- make-pprint 2drop do-pprint ; inline
-
-: pprint-vocab ( vocab -- )
- dup vocab present-text ;
-
-: write-in ( vocab -- )
- [ \ IN: pprint-word pprint-vocab ] with-pprint ;
-
-: in. ( vocab -- )
- [ write-in ] when* ;
-
-: use. ( seq -- )
- [
- natural-sort [
- \ USING: pprint-word
- [ pprint-vocab ] each
- \ ; pprint-word
- ] with-pprint
- ] unless-empty ;
-
-: use/in. ( in use -- )
- over "syntax" 2array diff
- [ nip use. ]
- [ empty? not and [ nl ] when ]
- [ drop in. ]
- 2tri ;
-
-: vocab-names ( words -- vocabs )
- dictionary get
- [ [ words>> eq? nip ] with assoc-find 2drop ] curry map sift ;
-
-: prelude. ( -- )
- in get use get vocab-names prune in get ".private" append swap remove use/in. ;
-
-[
- nl
- { { font-style bold } { font-name "sans-serif" } } [
- "Restarts were invoked adding vocabularies to the search path." print
- "To avoid doing this in the future, add the following USING:" print
- "and IN: forms at the top of the source file:" print nl
- ] with-style
- { { page-color T{ rgba f 0.8 0.8 0.8 1.0 } } } [ prelude. ] with-nesting
- nl nl
-] print-use-hook set-global
-
-PRIVATE>
-
: with-use ( obj quot -- )
- make-pprint [ use/in. ] [ empty? not or [ nl ] when ] 2bi
+ make-pprint (pprint-manifest
+ [ pprint-manifest) ] [ [ drop nl ] unless-empty ] bi
do-pprint ; inline
: with-in ( obj quot -- )
- make-pprint drop [ write-in bl ] when* do-pprint ; inline
+ make-pprint current-vocab>> [ pprint-in bl ] when* do-pprint ; inline
: pprint ( obj -- ) [ pprint* ] with-pprint ;
USING: prettyprint io kernel help.markup help.syntax
prettyprint.config words hashtables math
-strings definitions ;
+strings definitions quotations ;
IN: prettyprint.sections
HELP: position
{ $values { "?" "a boolean" } }
{ $description "Tests if the line number limit has been reached, and thus if prettyprinting should stop." } ;
-
HELP: do-indent
{ $description "Outputs the current indent nesting to " { $link output-stream } "." } ;
HELP: do-pprint
{ $values { "block" block } }
{ $description "Recursively output all children of the given block. The continuation is restored and output terminates if the line length is exceeded; this test is performed in " { $link fresh-line } "." } ;
+
+HELP: with-pprint
+{ $values { "obj" object } { "quot" quotation } }
+{ $description "Sets up the prettyprinter and calls the quotation in a new scope. The quotation should add sections to the top-level block. When the quotation returns, the top-level block is printed to " { $link output-stream } "." } ;
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables io kernel math assocs
namespaces make sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
-accessors sets ;
+accessors sets vocabs.parser combinators vocabs ;
IN: prettyprint.sections
! State
: <pprinter> ( -- pprinter ) 0 1 0 pprinter boa ;
+: (record-vocab) ( vocab -- )
+ dup pprinter-in get dup [ vocab-name ] when =
+ [ drop ] [ pprinter-use get conjoin ] if ;
+
: record-vocab ( word -- )
- vocabulary>> [ pprinter-use get conjoin ] when* ;
+ vocabulary>> {
+ { f [ ] }
+ { "syntax" [ ] }
+ [ (record-vocab) ]
+ } case ;
! Utility words
: line-limit? ( -- ? )
] each
] each
] if-nonempty ;
+
+: pprinter-manifest ( -- manifest )
+ <manifest>
+ [ [ pprinter-use get keys >vector ] dip (>>search-vocabs) ]
+ [ [ pprinter-in get ] dip (>>current-vocab) ]
+ [ ]
+ tri ;
+
+: make-pprint ( obj quot -- block manifest )
+ [
+ 0 position set
+ H{ } clone pprinter-use set
+ V{ } clone recursion-check set
+ V{ } clone pprinter-stack set
+ over <object
+ call
+ pprinter-block
+ pprinter-manifest
+ ] with-scope ; inline
+
+: with-pprint ( obj quot -- )
+ make-pprint drop do-pprint ; inline
\ No newline at end of file
-USING: kernel random math accessors random ;
+USING: kernel math accessors random ;
IN: random.dummy
TUPLE: random-dummy i ;
[ seq>> nth-unsafe mt-temper ]
[ [ 1+ ] change-i drop ] tri ;
-USE: init
-
[
[ 32 random-bits ] with-system-random
<mersenne-twister> random-generator set-global
[ 1.0 swap - log -2.0 * sqrt ]
bi* * * + ;
-USE: vocabs.loader
-
{
{ [ os windows? ] [ "random.windows" require ] }
{ [ os unix? ] [ "random.unix" require ] }
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math math.order words combinators locals
-ascii unicode.categories combinators.short-circuit sequences
+unicode.categories combinators.short-circuit sequences
fry macros arrays assocs sets classes mirrors unicode.script
unicode.data ;
+FROM: ascii => ascii? ;
IN: regexp.classes
SINGLETONS: dot letter-class LETTER-class Letter-class digit-class
"To search a file for all lines that match a given regular expression, you could use code like this:"
{ $code <" "file.txt" ascii file-lines [ R/ (f|b)oo+/ re-contains? ] filter "> }
"To test if a string in its entirety matches a regular expression, the following can be used:"
-{ $example <" USING: regexp prettyprint ; "fooo" R/ (b|f)oo+/ matches? . "> "t" }
+{ $example <" USE: regexp "fooo" R/ (b|f)oo+/ matches? . "> "t" }
"Regular expressions can't be used for all parsing tasks. For example, they are not powerful enough to match balancing parentheses." ;
ARTICLE: { "regexp" "construction" } "Constructing regular expressions"
+USING: help.markup help.syntax strings definitions generic words classes ;
+FROM: prettyprint.sections => with-pprint ;
IN: see
-USING: help.markup help.syntax strings prettyprint.private
-definitions generic words classes ;
HELP: synopsis
{ $values { "defspec" "a definition specifier" } { "str" string } }
{ $contract "Prettyprints the methods defined on a generic word or class." } ;
HELP: definer
-{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } }
+{ $values { "defspec" "a definition specifier" } { "start" word } { "end" { $maybe word } } }
{ $contract "Outputs the parsing words which delimit the definition." }
{ $examples
{ $example "USING: definitions prettyprint ;"
IN: see.tests
-USING: see tools.test io.streams.string math ;
+USING: see tools.test io.streams.string math words ;
CONSTANT: test-const 10
[ "IN: see.tests\nCONSTANT: test-const 10 inline\n" ]
[ "USING: math ;\nIN: see.tests\nALIAS: test-alias + inline\n" ]
[ [ \ test-alias see ] with-string-writer ] unit-test
+
+[ ] [ gensym see ] unit-test
\ No newline at end of file
io.streams.string io.styles kernel make namespaces prettyprint
prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections sequences sets sorting strings summary words
-words.symbol words.constant words.alias ;
+words.symbol words.constant words.alias vocabs ;
IN: see
GENERIC: synopsis* ( defspec -- )
<PRIVATE
: seeing-word ( word -- )
- vocabulary>> pprinter-in set ;
+ vocabulary>> dup [ vocab ] when pprinter-in set ;
: word-synopsis ( word -- )
{
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: tools.test kernel serialize io io.streams.byte-array math
+USING: tools.test kernel serialize io io.streams.byte-array
alien arrays byte-arrays bit-arrays specialized-arrays.double
sequences math prettyprint parser classes math.constants
io.encodings.binary random assocs serialize.private ;
CHAR: F write1
double>bits serialize-cell ;
-M: complex (serialize) ( obj -- )
- CHAR: c write1
- [ real-part (serialize) ]
- [ imaginary-part (serialize) ] bi ;
-
-M: ratio (serialize) ( obj -- )
- CHAR: r write1
- [ numerator (serialize) ]
- [ denominator (serialize) ] bi ;
-
: serialize-seq ( obj code -- )
[
write1
: deserialize-float ( -- float )
deserialize-cell bits>double ;
-: deserialize-ratio ( -- ratio )
- (deserialize) (deserialize) / ;
-
-: deserialize-complex ( -- complex )
- (deserialize) (deserialize) rect> ;
-
: (deserialize-string) ( -- string )
deserialize-cell read utf8 decode ;
{ CHAR: T [ deserialize-tuple ] }
{ CHAR: W [ deserialize-wrapper ] }
{ CHAR: a [ deserialize-array ] }
- { CHAR: c [ deserialize-complex ] }
{ CHAR: h [ deserialize-hashtable ] }
{ CHAR: m [ deserialize-negative-integer ] }
{ CHAR: n [ deserialize-false ] }
{ CHAR: o [ deserialize-unknown ] }
{ CHAR: p [ deserialize-positive-integer ] }
{ CHAR: q [ deserialize-quotation ] }
- { CHAR: r [ deserialize-ratio ] }
{ CHAR: s [ deserialize-string ] }
{ CHAR: w [ deserialize-word ] }
{ CHAR: G [ deserialize-word ] }
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences grouping assocs kernel ascii ascii tr ;
+USING: sequences grouping assocs kernel ascii tr ;
IN: soundex
TR: soundex-tr
-USING: stack-checker.call-effect tools.test math kernel math effects ;
+USING: stack-checker.call-effect tools.test kernel math effects ;
IN: stack-checker.call-effect.tests
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces assocs kernel sequences words accessors
definitions math math.order effects classes arrays combinators
-vectors arrays hints
+vectors hints
stack-checker.state
stack-checker.errors
stack-checker.values
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors alien alien.accessors arrays byte-arrays classes
-sequences.private continuations.private effects generic hashtables
+continuations.private effects generic hashtables
hashtables.private io io.backend io.files io.files.private
io.streams.c kernel kernel.private math math.private
math.parser.private memory memory.private namespaces
classes.tuple.private vectors vectors.private words definitions assocs
summary compiler.units system.private combinators
combinators.short-circuit locals locals.backend locals.types
-quotations.private combinators.private stack-checker.values
+combinators.private stack-checker.values
generic.single generic.single.private
alien.libraries
stack-checker.alien
USING: fry accessors arrays kernel kernel.private combinators.private
words sequences generic math math.order namespaces quotations
assocs combinators combinators.short-circuit classes.tuple
-classes.tuple.private effects summary hashtables classes generic sets
+classes.tuple.private effects summary hashtables classes sets
definitions generic.standard slots.private continuations locals
sequences.private generalizations stack-checker.backend
stack-checker.state stack-checker.visitor stack-checker.errors
IN: struct-arrays.tests
USING: struct-arrays tools.test kernel math sequences
-alien.syntax alien.c-types destructors libc accessors
-destructors ;
+alien.syntax alien.c-types destructors libc accessors ;
C-STRUCT: test-struct
{ "int" "x" }
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors io.backend io.streams.c init fry namespaces
-math make assocs kernel parser lexer strings.parser vocabs sequences
-sequences.private words memory kernel.private continuations io
-vocabs.loader system strings sets vectors quotations byte-arrays
-sorting compiler.units definitions generic generic.standard
-generic.single tools.deploy.config combinators classes
-slots.private ;
+math make assocs kernel parser parser.notes lexer strings.parser
+vocabs sequences sequences.private words memory kernel.private
+continuations io vocabs.loader system strings sets vectors quotations
+byte-arrays sorting compiler.units definitions generic
+generic.standard generic.single tools.deploy.config combinators
+classes slots.private ;
QUALIFIED: bootstrap.stage2
QUALIFIED: command-line
QUALIFIED: compiler.errors
: list-files-slow ( listing-tool -- array )
[ path>> ] [ sort>> ] [ specs>> ] tri '[
- [ dup name>> file-info file-listing boa ] map
- _ [ sort-by ] when*
- [ _ [ file-spec>string ] with map ] map
+ [ dup name>> link-info file-listing boa ] map
+ _ [ sort-by ] when*
+ [ _ [ file-spec>string ] with map ] map
] with-directory-entries ; inline
: list-files ( listing-tool -- array )
[ file-systems-info ]
[ [ unparse ] map ] bi prefix simple-table. ;
-: file-systems. ( -- )
+CONSTANT: default-file-systems-spec
{
+device-name+ +available-space+ +free-space+ +used-space+
+total-space+ +percent-used+ +mount-point+
- } print-file-systems ;
+ }
+
+: file-systems. ( -- )
+ default-file-systems-spec print-file-systems ;
{
{ [ os unix? ] [ "tools.files.unix" ] }
io.files.info io.files.info.unix generalizations
strings arrays sequences math.parser unix.groups unix.users
tools.files.private unix.stat math fry macros combinators.smart
-io.files.info.unix io tools.files math.order prettyprint ;
+io tools.files math.order prettyprint ;
IN: tools.files.unix
<PRIVATE
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences vectors arrays generic assocs io math
-namespaces parser prettyprint strings io.styles vectors words
+USING: kernel sequences arrays generic assocs io math
+namespaces parser prettyprint strings io.styles words
system sorting splitting grouping math.parser classes memory
combinators fry ;
IN: tools.memory
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators compiler.units
continuations debugger effects fry generalizations io io.files
-io.styles kernel lexer locals macros math.parser namespaces
-parser prettyprint quotations sequences source-files splitting
+io.styles kernel lexer locals macros math.parser namespaces parser
+vocabs.parser prettyprint quotations sequences source-files splitting
stack-checker summary unicode.case vectors vocabs vocabs.loader
-vocabs.files words tools.errors source-files.errors
-io.streams.string make compiler.errors ;
+vocabs.files words tools.errors source-files.errors io.streams.string
+make compiler.errors ;
IN: tools.test
TUPLE: test-failure < source-file-error continuation ;
windows.kernel32 windows.gdi32 windows.user32 windows.opengl32
windows.messages windows.types windows.offscreen windows.nt
threads libc combinators fry combinators.short-circuit continuations
-command-line shuffle opengl ui.render ascii math.bitwise locals
-accessors math.rectangles math.order ascii calendar
+command-line shuffle opengl ui.render math.bitwise locals
+accessors math.rectangles math.order calendar ascii
io.encodings.utf16n windows.errors literals ui.pixel-formats
ui.pixel-formats.private memoize classes struct-arrays ;
IN: ui.backend.windows
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel sequences strings
-math assocs words generic namespaces make assocs quotations
+math assocs words generic namespaces make quotations
splitting ui.gestures unicode.case unicode.categories tr fry ;
IN: ui.commands
ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.pens ui.pens.solid
ui.pens.image ui.pens.tile math.rectangles locals fry
combinators.smart ;
+FROM: models => change-model ;
IN: ui.gadgets.buttons
TUPLE: button < border pressed? selected? quot ;
USING: accessors arrays documents documents.elements kernel math
math.ranges models models.arrow namespaces locals fry make opengl
opengl.gl sequences strings math.vectors math.functions sorting colors
-colors.constants combinators assocs math.order fry calendar alarms
+colors.constants combinators assocs math.order calendar alarms
continuations ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
ui.gadgets.menus ui.gadgets.wrappers ui.render ui.pens.solid
-USING: accessors ui.gadgets ui.gadgets.private ui.gadgets.packs
-ui.gadgets.worlds tools.test namespaces models kernel dlists deques
-math sets math.parser ui sequences hashtables assocs io arrays
-prettyprint io.streams.string math.rectangles ui.gadgets.private
-sets generic ;
+USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds
+tools.test namespaces models kernel dlists deques math
+math.parser ui sequences hashtables assocs io arrays prettyprint
+io.streams.string math.rectangles ui.gadgets.private sets generic ;
IN: ui.gadgets.tests
[ { 300 300 } ]
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables kernel models math namespaces
+USING: accessors arrays hashtables kernel math namespaces
make sequences quotations math.vectors combinators sorting
binary-search vectors dlists deques models threads
concurrency.flags math.order math.rectangles fry locals ;
USING: accessors kernel namespaces ui.gadgets ui.gadgets.worlds
ui.gadgets.wrappers ui.gestures math.rectangles
math.rectangles.positioning combinators vectors ;
+FROM: ui.gadgets.wrappers => wrapper ;
IN: ui.gadgets.glass
GENERIC: hide-glass-hook ( gadget -- )
USING: colors.constants kernel locals math.rectangles namespaces
sequences ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.glass ui.gadgets.packs ui.gadgets.frames ui.gadgets.worlds
-ui.gadgets.frames ui.gadgets.corners ui.gestures ui.operations
+ui.gadgets.corners ui.gestures ui.operations
ui.render ui.pens ui.pens.solid opengl math.vectors words accessors
math math.order sorting ;
IN: ui.gadgets.menus
ui.text ui.gadgets.presentations ui.gadgets.grids ui.gadgets.tracks
ui.gadgets.icons ui.gadgets.grid-lines ui.baseline-alignment
colors io.styles ;
+FROM: io.styles => foreground background ;
IN: ui.gadgets.panes
TUPLE: pane < track
opengl sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
ui.gadgets.worlds ui.gestures ui.render ui.pens.solid ui.text
ui.commands ui.images ui.gadgets.menus ui.gadgets.line-support
-math.rectangles models math.ranges sequences combinators
+models math.ranges combinators
combinators.short-circuit fonts locals strings ;
IN: ui.gadgets.tables
USING: destructors help.markup help.syntax kernel math multiline sequences
-vocabs vocabs.parser words ;
+vocabs vocabs.parser words namespaces ;
IN: ui.pixel-formats
! break circular dependency
<<
"ui.gadgets.worlds" create-vocab drop
"world" "ui.gadgets.worlds" create drop
- "ui.gadgets.worlds" (use+)
+ "ui.gadgets.worlds" vocab-words use-words
>>
ARTICLE: "ui.pixel-formats-attributes" "Pixel format attributes"
] with each
] do-matrix ;
-USING: vocabs.loader namespaces system combinators ;
+USING: vocabs.loader system combinators ;
{
{ [ os macosx? ] [ "core-text" ] }
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: debugger classes help help.topics help.crossref help.home kernel models
-compiler.units assocs words vocabs accessors fry arrays
-combinators.short-circuit namespaces sequences models help.apropos
+USING: debugger classes help help.topics help.crossref help.home
+kernel models compiler.units assocs words vocabs accessors fry arrays
+combinators.short-circuit namespaces sequences help.apropos
combinators ui ui.commands ui.gadgets ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons
ui.gadgets.packs ui.gadgets.editors ui.gadgets.labels
-ui.gadgets.status-bar ui.gadgets.glass ui.gadgets.borders ui.gadgets.viewports
-ui.tools.common ui.tools.browser.popups ui.tools.browser.history ;
+ui.gadgets.status-bar ui.gadgets.glass ui.gadgets.borders
+ui.gadgets.viewports ui.tools.common ui.tools.browser.popups
+ui.tools.browser.history ;
IN: ui.tools.browser
TUPLE: browser-gadget < tool history pane scroller search-field popup ;
ui.gadgets.labeled ui.gadgets.scrollers ui.gadgets.tables
ui.gadgets.search-tables ui.gadgets.wrappers ui.gestures ui.operations
ui.pens.solid ui.images ;
+FROM: ui.gadgets.wrappers => wrapper ;
IN: ui.tools.browser.popups
SINGLETON: link-renderer
USING: ui.gadgets help.markup help.syntax kernel quotations
-continuations debugger ui continuations ;
+continuations debugger ui ;
IN: ui.tools.debugger
HELP: <debugger>
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables io kernel math models
-colors.constants namespaces sequences sequences words continuations
-debugger prettyprint help editors fonts ui ui.commands ui.gestures
-ui.gadgets ui.pens.solid ui.gadgets.worlds ui.gadgets.packs
-ui.gadgets.buttons ui.gadgets.labels ui.gadgets.panes
-ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables
-ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes
+colors.constants namespaces sequences words continuations debugger
+prettyprint help editors fonts ui ui.commands ui.gestures ui.gadgets
+ui.pens.solid ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
+ui.gadgets.labels ui.gadgets.presentations ui.gadgets.viewports
+ui.gadgets.tables ui.gadgets.tracks ui.gadgets.scrollers
ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback
ui.tools.inspector ui.tools.browser ui.debugger ;
IN: ui.tools.debugger
GENERIC: error-in-debugger? ( error -- ? )
-M: world-error error-in-debugger? world>> children>> [ f ] [ first debugger? ] if-empty ;
+M: world-error error-in-debugger?
+ world>> children>> [ f ] [ first debugger? ] if-empty ;
M: object error-in-debugger? drop f ;
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: colors kernel namespaces models tools.deploy.config
-tools.deploy.config.editor tools.deploy vocabs
-namespaces models.mapping sequences system accessors fry
-ui.gadgets ui.render ui.gadgets.buttons ui.gadgets.packs
-ui.gadgets.labels ui.gadgets.editors ui.gadgets.borders ui.gestures
-ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
-ui.tools.browser ;
+USING: colors kernel models tools.deploy.config
+tools.deploy.config.editor tools.deploy vocabs namespaces
+models.mapping sequences system accessors fry ui.gadgets ui.render
+ui.gadgets.buttons ui.gadgets.packs ui.gadgets.labels
+ui.gadgets.editors ui.gadgets.borders ui.gestures ui.commands assocs
+ui.gadgets.tracks ui ui.tools.listener ui.tools.browser ;
IN: ui.tools.deploy
TUPLE: deploy-gadget < pack vocab settings ;
namespaces summary locals ui ui.commands ui.gadgets ui.gadgets.panes
ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures
ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers
-ui.tools.inspector ui.gadgets.status-bar ui.operations
+ui.tools.inspector ui.gadgets.status-bar
ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs
ui.gadgets.labels ui.baseline-alignment ui.images
compiler.errors tools.errors tools.errors.model ;
[ dup string>> { { CHAR: \n CHAR: \s } } substitute ] { } map>assoc
<reversed> ;
-TUPLE: word-completion vocabs ;
+TUPLE: word-completion manifest ;
C: <word-completion> word-completion
SINGLETONS: vocab-completion char-completion history-completion ;
2array ;
M: word-completion row-color
- [ vocabulary>> ] [ vocabs>> ] bi* {
- { [ 2dup [ vocab-words ] dip memq? ] [ COLOR: black ] }
+ [ vocabulary>> ] [ manifest>> ] bi* {
+ { [ 2dup search-vocabs>> memq? ] [ COLOR: black ] }
{ [ over ".private" tail? ] [ COLOR: dark-red ] }
[ COLOR: dark-gray ]
} cond 2nip ;
[ { 0 0 } ] 2dip doc-range ;
: completion-mode ( interactor -- symbol )
- [ vocabs>> ] [ editor-caret ] [ model>> ] tri up-to-caret " \r\n" split
+ [ manifest>> ] [ editor-caret ] [ model>> ] tri up-to-caret " \r\n" split
{
{ [ dup { [ complete-IN:/USE:? ] [ complete-USING:? ] } 1|| ] [ 2drop vocab-completion ] }
{ [ dup complete-CHAR:? ] [ 2drop char-completion ] }
ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words ui.gadgets.debug slots.private
-threads arrays generic threads accessors listener math
+arrays generic threads accessors listener math
calendar concurrency.promises io ui.tools.common ;
IN: ui.tools.listener.tests
[ ] [ "listener" get com-end ] unit-test
] with-grafted-gadget
-[ ] [ \ + <interactor> vocabs>> use-if-necessary ] unit-test
+[ ] [ \ + <interactor> manifest>> use-if-necessary ] unit-test
[ ] [ <listener-gadget> "l" set ] unit-test
[ ] [ "l" get com-scroll-up ] unit-test
[ thread>> dup [ thread-registered? ] when ]
} 1&& not ;
-SLOT: vocabs
+SLOT: manifest
-M: interactor vocabs>>
+M: interactor manifest>>
dup interactor-busy? [ drop f ] [
- use swap
interactor-continuation name>>
- assoc-stack
+ manifest swap assoc-stack
] if ;
: vocab-exists? ( name -- ? )
drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ;
M: word-completion (word-at-caret)
- vocabs>> assoc-stack ;
+ manifest>> dup [
+ '[ _ _ search-manifest ] [ drop f ] recover
+ ] [ 2drop f ] if ;
M: char-completion (word-at-caret)
2drop f ;
: clear-stack ( listener -- )
[ [ clear ] \ clear ] dip (call-listener) ;
-: use-if-necessary ( word seq -- )
+: use-if-necessary ( word manifest -- )
2dup [ vocabulary>> ] dip and [
- 2dup [ assoc-stack ] keep = [ 2drop ] [
- [ vocabulary>> vocab-words ] dip push
- ] if
+ manifest [
+ vocabulary>> use-vocab
+ ] with-variable
] [ 2drop ] if ;
M: word accept-completion-hook
- interactor>> vocabs>> use-if-necessary ;
+ interactor>> manifest>> use-if-necessary ;
M: object accept-completion-hook 2drop ;
M: word com-stack-effect 1quotation com-stack-effect ;
-: com-enter-in ( vocab -- ) vocab-name set-in ;
+: com-enter-in ( vocab -- ) vocab-name set-current-vocab ;
[ vocab? ] \ com-enter-in H{
{ +listener+ t }
} define-operation
-: com-use-vocab ( vocab -- ) vocab-name use+ ;
+: com-use-vocab ( vocab -- ) vocab-name use-vocab ;
[ vocab-spec? ] \ com-use-vocab H{
{ +secondary+ t }
definitions.icons see ui ui.commands ui.gadgets ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons
ui.gadgets.tables ui.gadgets.search-tables ui.gadgets.labeled
-ui.gadgets.buttons ui.gadgets.packs ui.gadgets.labels
-ui.gadgets.tabbed ui.gadgets.status-bar ui.gadgets.borders
-ui.tools.browser ui.tools.common ui.baseline-alignment
-ui.operations ui.images ;
+ui.gadgets.packs ui.gadgets.labels ui.gadgets.tabbed
+ui.gadgets.status-bar ui.gadgets.borders ui.tools.browser
+ui.tools.common ui.baseline-alignment ui.operations ui.images ;
FROM: models.arrow => <arrow> ;
FROM: models.arrow.smart => <smart-arrow> ;
FROM: models.product => <product> ;
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces make dlists
-deques sequences threads sequences words continuations init
+deques sequences threads words continuations init
combinators combinators.short-circuit hashtables concurrency.flags
sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render
! Copyright (C) 2008 Daniel Ehrenberg.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: combinators.short-circuit sequences io.files\r
-io.encodings.ascii kernel values splitting accessors math.parser\r
-ascii io assocs strings math namespaces make sorting combinators\r
-math.order arrays unicode.normalize unicode.data locals\r
-macros sequences.deep words unicode.breaks\r
-quotations combinators.short-circuit simple-flat-file ;\r
+USING: sequences io.files io.encodings.ascii kernel values splitting\r
+accessors math.parser ascii io assocs strings math namespaces make\r
+sorting combinators math.order arrays unicode.normalize unicode.data\r
+locals macros sequences.deep words unicode.breaks quotations\r
+combinators.short-circuit simple-flat-file ;\r
IN: unicode.collation\r
\r
<PRIVATE\r
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit assocs math kernel sequences
io.files hashtables quotations splitting grouping arrays io
-math.parser hash2 math.order byte-arrays words namespaces words
+math.parser hash2 math.order byte-arrays namespaces
compiler.units parser io.encodings.ascii values interval-maps
ascii sets combinators locals math.ranges sorting make
strings.parser io.encodings.utf8 memoize simple-flat-file ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: debugger prettyprint accessors unix io kernel ;
+USING: debugger prettyprint accessors unix kernel ;
+FROM: io => write print nl ;
IN: unix.debugger
M: unix-error error.
-USING: kernel alien.c-types alien.strings sequences math alien.syntax unix
-vectors kernel namespaces continuations threads assocs vectors
-io.backend.unix io.encodings.utf8 unix.utilities fry ;
+USING: kernel alien.c-types alien.strings sequences math alien.syntax
+unix namespaces continuations threads assocs io.backend.unix
+io.encodings.utf8 unix.utilities fry ;
IN: unix.process
! Low-level Unix process launching utilities. These are used
{ 64 [ "unix.stat.netbsd.64" require ] }
} case
-CONSTANT: _VFS_NAMELEN 32
-CONSTANT: _VFS_MNAMELEN 1024
-
-C-STRUCT: statvfs
- { "ulong" "f_flag" }
- { "ulong" "f_bsize" }
- { "ulong" "f_frsize" }
- { "ulong" "f_iosize" }
- { "fsblkcnt_t" "f_blocks" }
- { "fsblkcnt_t" "f_bfree" }
- { "fsblkcnt_t" "f_bavail" }
- { "fsblkcnt_t" "f_bresvd" }
- { "fsfilcnt_t" "f_files" }
- { "fsfilcnt_t" "f_ffree" }
- { "fsfilcnt_t" "f_favail" }
- { "fsfilcnt_t" "f_fresvd" }
- { "uint64_t" "f_syncreads" }
- { "uint64_t" "f_syncwrites" }
- { "uint64_t" "f_asyncreads" }
- { "uint64_t" "f_asyncwrites" }
- { "fsid_t" "f_fsidx" }
- { "ulong" "f_fsid" }
- { "ulong" "f_namemax" }
- { "uid_t" "f_owner" }
- { { "uint32_t" 4 } "f_spare" }
- { { "char" _VFS_NAMELEN } "f_fstypename" }
- { { "char" _VFS_NAMELEN } "f_mntonname" }
- { { "char" _VFS_NAMELEN } "f_mntfromname" } ;
-
-FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
CONSTANT: S_IFSOCK OCT: 140000 ! Socket.
CONSTANT: S_IFWHT OCT: 160000 ! Whiteout.
-FUNCTION: int chmod ( char* path, mode_t mode ) ;
-FUNCTION: int fchmod ( int fd, mode_t mode ) ;
-FUNCTION: int mkdir ( char* path, mode_t mode ) ;
-
C-STRUCT: fsid
{ { "int" 2 } "__val" } ;
-USING: kernel system alien.syntax combinators vocabs.loader
-system ;
+USING: kernel system alien.syntax combinators vocabs.loader ;
IN: unix.types
TYPEDEF: char int8_t
sequences continuations byte-arrays strings math namespaces
system combinators vocabs.loader accessors
stack-checker macros locals generalizations unix.types
-io vocabs vocabs.loader ;
+io vocabs ;
IN: unix
CONSTANT: PROT_NONE 0
FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ;
FUNCTION: int listen ( int s, int backlog ) ;
FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ;
+FUNCTION: int mkdir ( char* path, mode_t mode ) ;
FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_t offset ) ;
FUNCTION: int munmap ( void* addr, size_t len ) ;
FUNCTION: uint ntohl ( uint n ) ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: vocabs.prettyprint.tests
+USING: vocabs.prettyprint tools.test io.streams.string multiline eval ;
+
+: manifest-test-1 ( -- string )
+ <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+
+ << manifest get pprint-manifest >> "> ;
+
+[
+<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;">
+]
+[ [ manifest-test-1 eval( -- ) ] with-string-writer ] unit-test
+
+: manifest-test-2 ( -- string )
+ <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+ IN: vocabs.prettyprint.tests
+
+ << manifest get pprint-manifest >> "> ;
+
+[
+<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+IN: vocabs.prettyprint.tests">
+]
+[ [ manifest-test-2 eval( -- ) ] with-string-writer ] unit-test
+
+: manifest-test-3 ( -- string )
+ <" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+ FROM: math => + - ;
+ QUALIFIED: system
+ QUALIFIED-WITH: assocs a
+ EXCLUDE: parser => run-file ;
+ IN: vocabs.prettyprint.tests
+
+ << manifest get pprint-manifest >> "> ;
+
+[
+<" USING: kernel namespaces vocabs.parser vocabs.prettyprint ;
+FROM: math => + - ;
+QUALIFIED: system
+QUALIFIED-WITH: assocs a
+EXCLUDE: parser => run-file ;
+IN: vocabs.prettyprint.tests">
+]
+[ [ manifest-test-3 eval( -- ) ] with-string-writer ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sorting sequences vocabs io io.styles arrays assocs
+namespaces sets parser colors prettyprint.backend prettyprint.sections
+vocabs.parser make fry math.order ;
+IN: vocabs.prettyprint
+
+: pprint-vocab ( vocab -- )
+ [ vocab-name ] [ vocab ] bi present-text ;
+
+: pprint-in ( vocab -- )
+ [ \ IN: pprint-word pprint-vocab ] with-pprint ;
+
+<PRIVATE
+
+: sort-vocabs ( seq -- seq' )
+ [ [ vocab-name ] compare ] sort ;
+
+: pprint-using ( seq -- )
+ [ "syntax" vocab = not ] filter
+ sort-vocabs [
+ \ USING: pprint-word
+ [ pprint-vocab ] each
+ \ ; pprint-word
+ ] with-pprint ;
+
+GENERIC: pprint-qualified ( qualified -- )
+
+M: qualified pprint-qualified ( qualified -- )
+ [
+ dup [ vocab>> vocab-name ] [ prefix>> ] bi = [
+ \ QUALIFIED: pprint-word
+ vocab>> pprint-vocab
+ ] [
+ \ QUALIFIED-WITH: pprint-word
+ [ vocab>> pprint-vocab ] [ prefix>> text ] bi
+ ] if
+ ] with-pprint ;
+
+M: from pprint-qualified ( from -- )
+ [
+ \ FROM: pprint-word
+ [ vocab>> pprint-vocab "=>" text ]
+ [ names>> [ text ] each ] bi
+ \ ; pprint-word
+ ] with-pprint ;
+
+M: exclude pprint-qualified ( exclude -- )
+ [
+ \ EXCLUDE: pprint-word
+ [ vocab>> pprint-vocab "=>" text ]
+ [ names>> [ text ] each ] bi
+ \ ; pprint-word
+ ] with-pprint ;
+
+M: rename pprint-qualified ( rename -- )
+ [
+ \ RENAME: pprint-word
+ [ word>> text ]
+ [ vocab>> text "=>" text ]
+ [ words>> >alist first first text ]
+ tri
+ ] with-pprint ;
+
+PRIVATE>
+
+: (pprint-manifest ( manifest -- quots )
+ [
+ [ search-vocabs>> [ '[ _ pprint-using ] , ] unless-empty ]
+ [ qualified-vocabs>> [ extra-words? not ] filter [ '[ _ pprint-qualified ] , ] each ]
+ [ current-vocab>> [ '[ _ pprint-in ] , ] when* ]
+ tri
+ ] { } make ;
+
+: pprint-manifest) ( quots -- )
+ [ nl ] [ call( -- ) ] interleave ;
+
+: pprint-manifest ( manifest -- )
+ (pprint-manifest pprint-manifest) ;
+
+[
+ nl
+ { { font-style bold } { font-name "sans-serif" } } [
+ "Restarts were invoked adding vocabularies to the search path." print
+ "To avoid doing this in the future, add the following forms" print
+ "at the top of the source file:" print nl
+ ] with-style
+ { { page-color T{ rgba f 0.8 0.8 0.8 1.0 } } }
+ [ manifest get pprint-manifest ] with-nesting
+ nl nl
+] print-use-hook set-global
\ No newline at end of file
CONSTANT: PFD_DRAW_TO_BITMAP 8
CONSTANT: PFD_SUPPORT_GDI 16
CONSTANT: PFD_SUPPORT_OPENGL 32
+CONSTANT: PFD_SUPPORT_DIRECTDRAW 8192
CONSTANT: PFD_GENERIC_FORMAT 64
CONSTANT: PFD_NEED_PALETTE 128
CONSTANT: PFD_NEED_SYSTEM_PALETTE HEX: 00000100
CONSTANT: SEC_NOCACHE HEX: 10000000
ALIAS: MEM_IMAGE SEC_IMAGE
-CONSTANT: ERROR_ALREADY_EXISTS 183
-
CONSTANT: FILE_MAP_ALL_ACCESS HEX: f001f
CONSTANT: FILE_MAP_READ 4
CONSTANT: FILE_MAP_WRITE 2
sequences libc opengl.gl opengl.gl.extensions opengl.gl.windows ;
IN: windows.opengl32
-! PIXELFORMATDESCRIPTOR flags
-CONSTANT: PFD_DOUBLEBUFFER HEX: 00000001
-CONSTANT: PFD_STEREO HEX: 00000002
-CONSTANT: PFD_DRAW_TO_WINDOW HEX: 00000004
-CONSTANT: PFD_DRAW_TO_BITMAP HEX: 00000008
-CONSTANT: PFD_SUPPORT_GDI HEX: 00000010
-CONSTANT: PFD_SUPPORT_OPENGL HEX: 00000020
-CONSTANT: PFD_GENERIC_FORMAT HEX: 00000040
-CONSTANT: PFD_NEED_PALETTE HEX: 00000080
-CONSTANT: PFD_NEED_SYSTEM_PALETTE HEX: 00000100
-CONSTANT: PFD_SWAP_EXCHANGE HEX: 00000200
-CONSTANT: PFD_SWAP_COPY HEX: 00000400
-CONSTANT: PFD_SWAP_LAYER_BUFFERS HEX: 00000800
-CONSTANT: PFD_GENERIC_ACCELERATED HEX: 00001000
-CONSTANT: PFD_SUPPORT_DIRECTDRAW HEX: 00002000
-
-! PIXELFORMATDESCRIPTOR flags for use in ChoosePixelFormat only
-CONSTANT: PFD_DEPTH_DONTCARE HEX: 20000000
-CONSTANT: PFD_DOUBLEBUFFER_DONTCARE HEX: 40000000
-CONSTANT: PFD_STEREO_DONTCARE HEX: 80000000
-
-! pixel types
-CONSTANT: PFD_TYPE_RGBA 0
-CONSTANT: PFD_TYPE_COLORINDEX 1
-
-! layer types
-CONSTANT: PFD_MAIN_PLANE 0
-CONSTANT: PFD_OVERLAY_PLANE 1
-CONSTANT: PFD_UNDERLAY_PLANE -1
-
CONSTANT: LPD_TYPE_RGBA 0
CONSTANT: LPD_TYPE_COLORINDEX 1
0 <paragraph> ;
: post-process ( paragraph -- array )
- lines>> deep-list>array
- [ [ contents>> ] map ] map ;
+ lines>> [ [ contents>> ] lmap>array ] lmap>array ;
: initialize ( elements -- elements paragraph )
<reversed> unclip-slice 1paragraph 1array ;
! 8.7 - Transferring Images between Client and Server
-CONSTANT: XYBitmap 0
-CONSTANT: XYPixmap 1
-CONSTANT: ZPixmap 2
CONSTANT: AllPlanes -1
C-STRUCT: XImage-funcs
$nl
"These forms can be used where a tag might go, as in " { $snippet "[XML <foo><-></foo> XML]" } " or where an attribute might go, as in " { $snippet "[XML <foo bar=<->/> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:"
{ $example
-{" USING: splitting sequences xml.writer xml.syntax ;
+{" USING: splitting xml.writer xml.syntax ;
"one two three" " " split
[ [XML <item><-></item> XML] ] map
<XML <doc><-></doc> XML> pprint-xml"}
{" <?xml version="1.0" encoding="UTF-8"?>
<x number="3" url="http://factorcode.org/" string="hello" word="drop"/>"} }
"XML interpolation can also be used, in conjunction with " { $vocab-link "inverse" } " in pattern matching. For example:"
-{ $example {" USING: sequences xml.syntax inverse ;
+{ $example {" USING: xml.syntax inverse ;
: dispatch ( xml -- string )
{
{ [ [XML <a><-></a> XML] ] [ "a" prepend ] }
[ "" ] [ [XML XML] concat ] unit-test
-USE: inverse
-
[ "foo" ] [ [XML <a>foo</a> XML] [ [XML <a><-></a> XML] ] undo ] unit-test
[ "foo" ] [ [XML <a bar='foo'/> XML] [ [XML <a bar=<-> /> XML] ] undo ] unit-test
[ "foo" "baz" ] [ [XML <a bar='foo'>baz</a> XML] [ [XML <a bar=<->><-></a> XML] ] undo ] unit-test
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: words assocs kernel accessors parser effects.parser
-sequences summary lexer splitting combinators locals xml.data
+USING: words assocs kernel accessors parser vocabs.parser effects.parser
+sequences summary lexer splitting combinators locals
memoize sequences.deep xml.data xml.state xml namespaces present
arrays generalizations strings make math macros multiline
inverse combinators.short-circuit sorting fry unicode.categories
-USING: xmode.tokens xmode.marker xmode.catalog kernel locals
-io io.files sequences words io.encodings.utf8
-namespaces xml.entities accessors xml.syntax locals xml.writer ;
+USING: xmode.tokens xmode.marker xmode.catalog kernel io io.files
+sequences words io.encodings.utf8 namespaces xml.entities accessors
+xml.syntax locals xml.writer ;
IN: xmode.code2html
: htmlize-tokens ( tokens -- xml )
USING: kernel namespaces make xmode.rules xmode.tokens
xmode.marker.state xmode.marker.context xmode.utilities
xmode.catalog sequences math assocs combinators strings
-regexp splitting unicode.case ascii
-combinators.short-circuit accessors ;
+regexp splitting ascii combinators.short-circuit accessors ;
IN: xmode.marker
! Next two words copied from parser-combinators
{ $subsection enum }
{ $subsection <enum> }
"Inverting a permutation using enumerations:"
-{ $example "USING: assocs sorting prettyprint ;" "IN: scratchpad" ": invert ( perm -- perm' )" " <enum> >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ;
+{ $example "IN: scratchpad" ": invert ( perm -- perm' )" " <enum> >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ;
HELP: enum
{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays debugger generic hashtables io assocs
-kernel.private kernel math memory namespaces make parser
-prettyprint sequences vectors words system splitting
-init io.files bootstrap.image bootstrap.image.private vocabs
-vocabs.loader system debugger continuations ;
+USING: arrays debugger generic hashtables io assocs kernel.private
+kernel math memory namespaces make parser prettyprint sequences
+vectors words system splitting init io.files vocabs vocabs.loader
+debugger continuations ;
+QUALIFIED: bootstrap.image.private
IN: bootstrap.stage1
"Bootstrap stage 1..." print flush
] if
] %
] [ ] make
-bootstrap-boot-quot set
+bootstrap.image.private:bootstrap-boot-quot set
"UNION:"
"INTERSECTION:"
"USE:"
+ "UNUSE:"
"USING:"
"QUALIFIED:"
"QUALIFIED-WITH:"
USING: alien arrays definitions generic assocs hashtables io\r
kernel math namespaces parser prettyprint sequences strings\r
-tools.test vectors words quotations classes classes.algebra\r
+tools.test words quotations classes classes.algebra\r
classes.private classes.union classes.mixin classes.predicate\r
vectors definitions source-files compiler.units growable\r
random stack-checker effects kernel.private sbufs math.order\r
USING: help.markup help.syntax kernel kernel.private
-namespaces sequences words arrays layouts effects math
-layouts classes.private classes.union classes.mixin
+namespaces sequences words arrays effects math
+classes.private classes.union classes.mixin
classes.predicate quotations ;
IN: classes
-USING: alien arrays definitions generic assocs hashtables io
+USING: alien arrays generic assocs hashtables io
io.streams.string kernel math namespaces parser prettyprint
sequences strings tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
USING: generic help.markup help.syntax kernel kernel.private
-namespaces sequences words arrays layouts help effects math
+namespaces sequences words arrays help effects math
layouts classes.private classes compiler.units ;
IN: classes.intersection
-USING: alien arrays definitions generic assocs hashtables io
-kernel math namespaces parser prettyprint sequences strings
-tools.test vectors words quotations classes
-classes.private classes.union classes.mixin classes.predicate
-classes.algebra vectors definitions source-files
-compiler.units kernel.private sorting vocabs eval ;
+USING: alien arrays definitions generic assocs hashtables io kernel
+math namespaces parser prettyprint sequences strings tools.test words
+quotations classes classes.private classes.union classes.mixin
+classes.predicate classes.algebra vectors source-files compiler.units
+kernel.private sorting vocabs eval ;
IN: classes.mixin.tests
! Test mixins
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser words kernel classes compiler.units lexer ;
+USING: parser vocabs.parser words kernel classes compiler.units lexer ;
IN: classes.parser
: save-class-location ( class -- )
GENERIC: ptest ( tuple -- )
M: tuple-a ptest drop ;
-IN: classes.predicate.tests USING: kernel ; M: tuple-c ptest drop ;
+M: tuple-c ptest drop ;
[ ] [ tuple-b new ptest ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sets namespaces make sequences parser
lexer combinators words classes.parser classes.tuple arrays
-slots math assocs ;
+slots math assocs parser.notes ;
IN: classes.tuple.parser
: slot-names ( slots -- seq )
vectors strings compiler.units accessors classes.algebra calendar
prettyprint io.streams.string splitting summary columns math.order
classes.private slots slots.private eval see words.symbol
-compiler.errors ;
+compiler.errors parser.notes ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
USING: generic help.markup help.syntax kernel kernel.private
-namespaces sequences words arrays layouts help effects math
-layouts classes.private classes compiler.units ;
+namespaces sequences words arrays help effects math
+classes.private classes compiler.units ;
IN: classes.union
ARTICLE: "unions" "Union classes"
{ $code ": subtract-n ( seq n -- seq' ) swap [ over - ] map nip ;" }
"Three shuffle words are required to pass the value around. Instead, the loop-invariant value can be partially applied to a quotation using " { $link curry } ", yielding a new quotation that is passed to " { $link map } ":"
{ $example
- "USING: kernel math prettyprint sequences ;"
": subtract-n ( seq n -- seq' ) [ - ] curry map ;"
"{ 10 20 30 } 5 subtract-n ."
"{ 5 15 25 }"
{ $code ": n-subtract ( n seq -- seq' ) swap [ swap - ] curry map ;" }
"Since this pattern comes up often, " { $link with } " encapsulates it:"
{ $example
- "USING: kernel math prettyprint sequences ;"
": n-subtract ( n seq -- seq' ) [ - ] with map ;"
"30 { 10 20 30 } n-subtract ."
"{ 20 10 0 }"
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations continuations.private kernel
-kernel.private sequences assocs namespaces namespaces.private
-continuations continuations.private ;
+kernel.private sequences assocs namespaces namespaces.private ;
IN: init
SYMBOL: init-hooks
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init kernel system namespaces io io.encodings
-io.encodings.utf8 init assocs splitting alien ;
+io.encodings.utf8 assocs splitting alien ;
IN: io.backend
SYMBOL: io-backend
USING: generic help.markup help.syntax math memory
namespaces sequences kernel.private layouts classes
-kernel.private vectors combinators quotations strings words
+vectors combinators quotations strings words
assocs arrays math.order ;
IN: kernel
"The accumulator sequence can be accessed directly from inside a " { $link make } ":"
{ $subsection building }
{ $example
- "USING: make math.parser io ;"
+ "USING: make math.parser ;"
"[ \"Language #\" % CHAR: \\s , 5 # ] \"\" make print"
"Language # 5"
}
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: help.markup help.syntax io ;
+IN: parser.notes
+
+HELP: parser-notes
+{ $var-description "A boolean controlling whether the parser will print various notes. Switched on by default. If a source file is being run for its effect on " { $link output-stream } ", this variable should be switched off, to prevent parser notes from polluting the output." } ;
+
+HELP: parser-notes?
+{ $values { "?" "a boolean" } }
+{ $description "Tests if the parser will print various notes and warnings. To disable parser notes, either set " { $link parser-notes } " to " { $link f } ", or pass the " { $snippet "-quiet" } " command line switch." } ;
+
--- /dev/null
+USING: lexer namespaces parser.notes source-files tools.test ;
+IN: parser.notes.tests
+
+[ ] [ f lexer set f file set "Hello world" note. ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces kernel source-files lexer accessors io math.parser ;
+IN: parser.notes
+
+SYMBOL: parser-notes
+
+t parser-notes set-global
+
+: parser-notes? ( -- ? )
+ parser-notes get "quiet" get not and ;
+
+: note. ( str -- )
+ parser-notes? [
+ file get [ path>> write ":" write ] when*
+ lexer get [ line>> number>string write ": " write ] when*
+ "Note:" print dup print
+ ] when drop ;
\ No newline at end of file
USING: help.markup help.syntax kernel sequences words
math strings vectors quotations generic effects classes
vocabs.loader definitions io vocabs source-files
-quotations namespaces compiler.units assocs lexer
+namespaces compiler.units assocs lexer
words.symbol words.alias words.constant vocabs.parser ;
IN: parser
{ $subsection "reading-ahead" }
{ $subsection "parsing-word-nest" }
{ $subsection "defining-words" }
-{ $subsection "parsing-tokens" } ;
+{ $subsection "parsing-tokens" }
+{ $subsection "word-search-parsing" } ;
ARTICLE: "parser-files" "Parsing source files"
"The parser can run source files:"
ARTICLE: "top-level-forms" "Top level forms"
"Any code outside of a definition is known as a " { $emphasis "top-level form" } "; top-level forms are run after the entire source file has been parsed, regardless of their position in the file."
$nl
-"Top-level forms do not have access to the " { $link in } " and " { $link use } " variables that were set at parse time, nor do they run inside " { $link with-compilation-unit } "; so meta-programming might require extra work in a top-level form compared with a parsing word."
+"Top-level forms cannot access the parse-time manifest (" { $link "word-search-parsing" } "), nor do they run inside " { $link with-compilation-unit } "; as a result, meta-programming might require extra work in a top-level form compared with a parsing word."
$nl
"Also, top-level forms run in a new dynamic scope, so using " { $link set } " to store values is almost always wrong, since the values will be lost after the top-level form completes. To save values computed by a top-level form, either use " { $link set-global } " or define a new word with the value." ;
{ $values { "definition" "a definition specifier" } }
{ $description "Saves the location of a definition and associates this definition with the current source file." } ;
-HELP: parser-notes
-{ $var-description "A boolean controlling whether the parser will print various notes. Switched on by default. If a source file is being run for its effect on " { $link output-stream } ", this variable should be switched off, to prevent parser notes from polluting the output." } ;
-
-HELP: parser-notes?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if the parser will print various notes and warnings. To disable parser notes, either set " { $link parser-notes } " to " { $link f } ", or pass the " { $snippet "-quiet" } " command line switch." } ;
-
HELP: bad-number
{ $error-description "Indicates the parser encountered an invalid numeric literal." } ;
-HELP: use
-{ $var-description "A variable holding the current vocabulary search path as a sequence of assocs." } ;
-
-{ use in use+ (use+) set-use set-in POSTPONE: USING: POSTPONE: USE: with-file-vocabs with-interactive-vocabs } related-words
-
-HELP: in
-{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ;
-
-HELP: current-vocab
-{ $values { "str" "a vocabulary" } }
-{ $description "Returns the vocabulary stored in the " { $link in } " symbol. Throws an error if the current vocabulary is " { $link f } "." } ;
-
-HELP: (use+)
-{ $values { "vocab" "an assoc mapping strings to words" } }
-{ $description "Adds an assoc at the front of the search path." }
-$parsing-note ;
-
-HELP: use+
-{ $values { "vocab" string } }
-{ $description "Adds a new vocabulary at the front of the search path after loading it if necessary. Subsequent word lookups by the parser will search this vocabulary first." }
-$parsing-note
-{ $errors "Throws an error if the vocabulary does not exist." } ;
-
-HELP: set-use
-{ $values { "seq" "a sequence of strings" } }
-{ $description "Sets the vocabulary search path. Later vocabularies take precedence." }
-{ $errors "Throws an error if one of the vocabularies does not exist." }
-$parsing-note ;
-
-HELP: add-use
-{ $values { "seq" "a sequence of strings" } }
-{ $description "Adds multiple vocabularies to the search path, with later vocabularies taking precedence." }
-{ $errors "Throws an error if one of the vocabularies does not exist." }
-$parsing-note ;
-
-HELP: set-in
-{ $values { "name" string } }
-{ $description "Sets the current vocabulary where new words will be defined, creating the vocabulary first if it does not exist." }
-$parsing-note ;
-
HELP: create-in
{ $values { "str" "a word name" } { "word" "a new word" } }
{ $description "Creates a word in the current vocabulary. Until re-defined, the word throws an error when invoked." }
{ $values { "name" string } { "newword" word } }
{ $description "Throws a " { $link no-word-error } "." } ;
-HELP: search
-{ $values { "str" string } { "word/f" "a word or " { $link f } } }
-{ $description "Searches for a word by name in the current vocabulary search path. If no such word could be found, outputs " { $link f } "." }
-$parsing-note ;
-
HELP: scan-word
{ $values { "word/number/f" "a word, number or " { $link f } } }
{ $description "Reads the next token from parser input. If the token is a valid number literal, it is converted to a number, otherwise the dictionary is searched for a word named by the token. Outputs " { $link f } " if the end of the input has been reached." }
HELP: auto-use?
{ $var-description "If set to a true value, the behavior of the parser when encountering an unknown word name is changed. If only one loaded vocabulary has a word with this name, instead of throwing an error, the parser adds the vocabulary to the search path and prints a parse note. Off by default." }
-{ $notes "This feature is intended to help during development. To generate a " { $link POSTPONE: USING: } " form automatically, enable " { $link auto-use? } ", load the source file, and copy and paste the " { $link POSTPONE: USING: } " form printed by the parser back into the file, then disable " { $link auto-use? } ". See " { $link "vocabulary-search-errors" } "." } ;
+{ $notes "This feature is intended to help during development. To generate a " { $link POSTPONE: USING: } " form automatically, enable " { $link auto-use? } ", load the source file, and copy and paste the " { $link POSTPONE: USING: } " form printed by the parser back into the file, then disable " { $link auto-use? } ". See " { $link "word-search-errors" } "." } ;
continuations sorting classes.tuple compiler.units debugger
vocabs vocabs.loader accessors eval combinators lexer
vocabs.parser words.symbol multiline source-files.errors
-tools.crossref ;
+tools.crossref grouping ;
IN: parser.tests
[
[ "OCT: 999" eval( -- obj ) ] must-fail
[ "BIN: --0" eval( -- obj ) ] must-fail
- ! Another funny bug
- [ t ] [
- [
- "scratchpad" in set
- { "scratchpad" "arrays" } set-use
- [
- ! This shouldn't modify in/use in the outer scope!
- ] with-file-vocabs
-
- use get { "scratchpad" "arrays" } set-use use get =
- ] with-scope
- ] unit-test
DEFER: foo
"IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval( -- )
[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval( -- ) ]
[ error>> error>> def>> \ blahy eq? ] must-fail-with
-[ ] [ f lexer set f file set "Hello world" note. ] unit-test
-
[ "CHAR: \\u9999999999999" eval( -- n ) ] must-fail
SYMBOLS: a b c ;
[ t ] [ "is-not-deferred" "parser.tests" lookup >boolean ] unit-test
[ t ] [ "is-not-deferred" "parser.tests" lookup deferred? ] unit-test
+
+! Forward-reference resolution case iterated using list in the wrong direction
+[ [ ] ] [
+ "IN: parser.tests.forward-ref-1 DEFER: x DEFER: y"
+ <string-reader> "forward-ref-1" parse-stream
+] unit-test
+
+[ [ ] ] [
+ "IN: parser.tests.forward-ref-2 DEFER: x DEFER: y"
+ <string-reader> "forward-ref-2" parse-stream
+] unit-test
+
+[ [ ] ] [
+ "IN: parser.tests.forward-ref-3 FROM: parser.tests.forward-ref-1 => x y ; FROM: parser.tests.forward-ref-2 => x y ; : z ( -- ) x y ;"
+ <string-reader> "forward-ref-3" parse-stream
+] unit-test
+
+[ t ] [
+ "z" "parser.tests.forward-ref-3" lookup def>> [ vocabulary>> ] map all-equal?
+] unit-test
+
+[ [ ] ] [
+ "FROM: parser.tests.forward-ref-1 => x y ; FROM: parser.tests.forward-ref-2 => x y ; IN: parser.tests.forward-ref-3 : x ( -- ) ; : z ( -- ) x y ;"
+ <string-reader> "forward-ref-3" parse-stream
+] unit-test
+
+[ f ] [
+ "z" "parser.tests.forward-ref-3" lookup def>> [ vocabulary>> ] map all-equal?
+] unit-test
+
+[ [ ] ] [
+ "IN: parser.tests.forward-ref-3 FROM: parser.tests.forward-ref-1 => x y ; FROM: parser.tests.forward-ref-2 => x y ; : z ( -- ) x y ;"
+ <string-reader> "forward-ref-3" parse-stream
+] unit-test
+
+[ t ] [
+ "z" "parser.tests.forward-ref-3" lookup def>> [ vocabulary>> ] map all-equal?
+] unit-test
+
+[ [ dup ] ] [
+ "USE: kernel dup" <string-reader> "unuse-test" parse-stream
+] unit-test
+
+[
+ "dup" <string-reader> "unuse-test" parse-stream
+] [ error>> error>> error>> no-word-error? ] must-fail-with
+
+[
+ "USE: kernel UNUSE: kernel dup" <string-reader> "unuse-test" parse-stream
+] [ error>> error>> error>> no-word-error? ] must-fail-with
\ No newline at end of file
combinators sorting splitting math.parser effects continuations
io.files vocabs io.encodings.utf8 source-files classes
hashtables compiler.units accessors sets lexer vocabs.parser
-effects.parser slots ;
+effects.parser slots parser.notes ;
IN: parser
: location ( -- loc )
: save-location ( definition -- )
location remember-definition ;
-SYMBOL: parser-notes
-
-t parser-notes set-global
-
-: parser-notes? ( -- ? )
- parser-notes get "quiet" get not and ;
-
-: note. ( str -- )
- parser-notes? [
- file get [ path>> write ":" write ] when*
- lexer get [ line>> number>string write ": " write ] when*
- "Note:" print dup print
- ] when drop ;
-
M: parsing-word stack-effect drop (( parsed -- parsed )) ;
-TUPLE: no-current-vocab ;
-
-: no-current-vocab ( -- vocab )
- \ no-current-vocab boa
- { { "Define words in scratchpad vocabulary" "scratchpad" } }
- throw-restarts dup set-in ;
-
-: current-vocab ( -- str )
- in get [ no-current-vocab ] unless* ;
-
: create-in ( str -- word )
current-vocab create dup set-word dup save-location ;
: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
-SYMBOL: amended-use
-
SYMBOL: auto-use?
: no-word-restarted ( restart-value -- word )
dup word? [
dup vocabulary>>
- [ (use+) ]
- [ amended-use get dup [ push ] [ 2drop ] if ]
- [ "Added \"" "\" vocabulary to search path" surround note. ]
- tri
+ [ auto-use-vocab ]
+ [ "Added \"" "\" vocabulary to search path" surround note. ] bi
] [ create-in ] if ;
: no-word ( name -- newword )
[ <no-word-error> throw-restarts no-word-restarted ]
if ;
-: check-forward ( str word -- word/f )
- dup forward-reference? [
- drop
- use get
- [ at ] with map sift
- [ forward-reference? not ] find nip
- ] [
- nip
- ] if ;
-
-: search ( str -- word/f )
- dup use get assoc-stack check-forward ;
-
: scan-word ( -- word/number/f )
scan dup [
dup search [ ] [
: with-file-vocabs ( quot -- )
[
- f in set { "syntax" } set-use
- bootstrap-syntax get [ use get push ] when*
+ <manifest> manifest set
+ "syntax" use-vocab
+ bootstrap-syntax get [ use-words ] when*
call
] with-scope ; inline
: with-interactive-vocabs ( quot -- )
[
- "scratchpad" in set
- interactive-vocabs get set-use
+ <manifest> manifest set
+ "scratchpad" set-current-vocab
+ interactive-vocabs get only-use-vocabs
call
] with-scope ; inline
: parse-fresh ( lines -- quot )
[
- V{ } clone amended-use set
parse-lines
- amended-use get empty? [ print-use-hook get call( -- ) ] unless
+ auto-used? [ print-use-hook get call( -- ) ] when
] with-file-vocabs ;
: parsing-file ( file -- )
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math strings sequences.private sequences
+USING: accessors kernel math sequences.private sequences
strings growable strings.private ;
IN: sbufs
[ [ 2unclip-slice ] dip [ call ] keep ] dip
compose 2reduce ; inline
-: map-find ( seq quot -- result elt )
- [ f ] 2dip
- [ [ nip ] dip call dup ] curry find
+<PRIVATE
+
+: (map-find) ( seq quot find-quot -- result elt )
+ [ [ f ] 2dip [ [ nip ] dip call dup ] curry ] dip call
[ [ drop f ] unless ] dip ; inline
+PRIVATE>
+
+: map-find ( seq quot -- result elt )
+ [ find ] (map-find) ; inline
+
+: map-find-last ( seq quot -- result elt )
+ [ find-last ] (map-find) ; inline
+
: unclip-last-slice ( seq -- butlast-slice last )
[ but-last-slice ] [ peek ] bi ; inline
USING: help.markup help.syntax generic kernel.private parser
-words kernel quotations namespaces sequences words arrays
-effects generic.standard classes.builtin
-slots.private classes strings math assocs byte-arrays alien
-math classes.tuple ;
+kernel quotations namespaces sequences arrays effects
+generic.standard classes.builtin slots.private classes strings math
+assocs byte-arrays alien classes.tuple ;
IN: slots
ARTICLE: "accessors" "Slot accessors"
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays kernel kernel.private math namespaces
-make sequences strings words effects generic generic.standard
+make sequences strings effects generic generic.standard
classes classes.algebra slots.private combinators accessors
words sequences.private assocs alien quotations hashtables ;
IN: slots
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel math sequences vectors math.order
-sequences sequences.private math.order ;
+USING: accessors arrays kernel math vectors math.order
+sequences sequences.private ;
IN: sorting
! Optimized merge-sort:
USING: generic help.syntax help.markup kernel math parser words
-effects classes generic.standard classes.tuple generic.math
-generic.standard generic.single arrays io.pathnames vocabs.loader io
-sequences assocs words.symbol words.alias words.constant combinators ;
+effects classes classes.tuple generic.math generic.single arrays
+io.pathnames vocabs.loader io sequences assocs words.symbol
+words.alias words.constant combinators vocabs.parser ;
IN: syntax
ARTICLE: "parser-algorithm" "Parser algorithm"
ARTICLE: "syntax" "Syntax"
"Factor has two main forms of syntax: " { $emphasis "definition" } " syntax and " { $emphasis "literal" } " syntax. Code is data, so the syntax for code is a special case of object literal syntax. This section documents literal syntax. Definition syntax is covered in " { $link "words" } ". Extending the parser is the main topic of " { $link "parser" } "."
{ $subsection "parser-algorithm" }
-{ $subsection "vocabulary-search" }
+{ $subsection "word-search" }
{ $subsection "top-level-forms" }
{ $subsection "syntax-comments" }
{ $subsection "syntax-literals" }
HELP: USE:
{ $syntax "USE: vocabulary" }
{ $values { "vocabulary" "a vocabulary name" } }
-{ $description "Adds a new vocabulary at the front of the search path. Subsequent word lookups by the parser will search this vocabulary first." }
+{ $description "Adds a new vocabulary to the search path, loading it first if necessary." }
+{ $notes "If adding the vocabulary introduces ambiguity, referencing the ambiguous names will throw a " { $link ambiguous-use-error } "." }
+{ $errors "Throws an error if the vocabulary does not exist or could not be loaded." } ;
+
+HELP: UNUSE:
+{ $syntax "UNUSE: vocabulary" }
+{ $values { "vocabulary" "a vocabulary name" } }
+{ $description "Removes a vocabulary from the search path." }
{ $errors "Throws an error if the vocabulary does not exist." } ;
HELP: USING:
{ $syntax "USING: vocabularies... ;" }
{ $values { "vocabularies" "a list of vocabulary names" } }
-{ $description "Adds a list of vocabularies to the front of the search path, with later vocabularies taking precedence." }
+{ $description "Adds a list of vocabularies to the search path." }
+{ $notes "If adding the vocabularies introduces ambiguity, referencing the ambiguous names will throw a " { $link ambiguous-use-error } "." }
{ $errors "Throws an error if one of the vocabularies does not exist." } ;
HELP: QUALIFIED:
{ $syntax "QUALIFIED: vocab" }
-{ $description "Similar to " { $link POSTPONE: USE: } " but loads vocabulary with prefix." }
+{ $description "Adds the vocabulary's words, prefixed with the vocabulary name, to the search path." }
+{ $notes "If adding the vocabulary introduces ambiguity, the vocabulary will take precedence when resolving any ambiguous names. This is a rare case; for example, suppose a vocabulary " { $snippet "fish" } " defines a word named " { $snippet "go:fishing" } ", and a vocabulary named " { $snippet "go" } " defines a word named " { $snippet "finishing" } ". Then, the following will call the latter word:"
+ { $code
+ "USE: fish"
+ "QUALIFIED: go"
+ "go:fishing"
+ }
+}
{ $examples { $example
"USING: prettyprint ;"
"QUALIFIED: math"
HELP: QUALIFIED-WITH:
{ $syntax "QUALIFIED-WITH: vocab word-prefix" }
-{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." }
+{ $description "Like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." }
{ $examples { $code
"USING: prettyprint ;"
"QUALIFIED-WITH: math m"
HELP: FROM:
{ $syntax "FROM: vocab => words ... ;" }
-{ $description "Imports " { $snippet "words" } " from " { $snippet "vocab" } "." }
-{ $examples { $code
- "FROM: math.parser => bin> hex> ; ! imports only bin> and hex>" } } ;
+{ $description "Adds " { $snippet "words" } " from " { $snippet "vocab" } " to the search path." }
+{ $notes "If adding the words introduces ambiguity, the words will take precedence when resolving any ambiguous names." }
+{ $examples
+ "Both the " { $vocab-link "vocabs.parser" } " and " { $vocab-link "binary-search" } " vocabularies define a word named " { $snippet "search" } ". The following will throw an " { $link ambiguous-use-error } ":"
+ { $code "USING: vocabs.parser binary-search ;" "... search ..." }
+ "Because " { $link POSTPONE: FROM: } " takes precedence over a " { $link POSTPONE: USING: } ", the ambiguity can be resolved explicitly. Suppose you wanted the " { $vocab-link "binary-search" } " vocabulary's " { $snippet "search" } " word:"
+ { $code "USING: vocabs.parser binary-search ;" "FROM: binary-search => search ;" "... search ..." }
+ } ;
HELP: EXCLUDE:
{ $syntax "EXCLUDE: vocab => words ... ;" }
-{ $description "Imports everything from " { $snippet "vocab" } " excluding " { $snippet "words" } "." }
+{ $description "Adds all words except for " { $snippet "words" } " from " { $snippet "vocab" } " to the search path." }
{ $examples { $code
- "EXCLUDE: math.parser => bin> hex> ; ! imports everything but bin> and hex>" } } ;
+ "EXCLUDE: math.parser => bin> hex> ;" "! imports everything but bin> and hex>" } } ;
HELP: RENAME:
-{ $syntax "RENAME: word vocab => newname" }
-{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "newname" } "." }
+{ $syntax "RENAME: word vocab => new-name" }
+{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "new-name" } "." }
+{ $notes "If adding the words introduces ambiguity, the words will take precedence when resolving any ambiguous names." }
{ $examples { $example
"USING: prettyprint ;"
"RENAME: + math => -"
HELP: <PRIVATE
{ $syntax "<PRIVATE ... PRIVATE>" }
-{ $description "Marks the start of a block of private word definitions. Private word definitions are placed in a vocabulary named by suffixing the current vocabulary with " { $snippet ".private" } "." }
+{ $description "Begins a block of private word definitions. Private word definitions are placed in the current vocabulary name, suffixed with " { $snippet ".private" } "." }
{ $notes
"The following is an example of usage:"
{ $code
HELP: PRIVATE>
{ $syntax "<PRIVATE ... PRIVATE>" }
-{ $description "Marks the end of a block of private word definitions." } ;
+{ $description "Ends a block of private word definitions." } ;
{ POSTPONE: <PRIVATE POSTPONE: PRIVATE> } related-words
"#!" [ POSTPONE: ! ] define-core-syntax
- "IN:" [ scan set-in ] define-core-syntax
+ "IN:" [ scan set-current-vocab ] define-core-syntax
- "PRIVATE>" [ in get ".private" ?tail drop set-in ] define-core-syntax
+ "<PRIVATE" [ begin-private ] define-core-syntax
- "<PRIVATE" [
- POSTPONE: PRIVATE> in get ".private" append set-in
- ] define-core-syntax
+ "PRIVATE>" [ end-private ] define-core-syntax
+
+ "USE:" [ scan use-vocab ] define-core-syntax
- "USE:" [ scan use+ ] define-core-syntax
+ "UNUSE:" [ scan unuse-vocab ] define-core-syntax
- "USING:" [ ";" parse-tokens add-use ] define-core-syntax
+ "USING:" [ ";" parse-tokens [ use-vocab ] each ] define-core-syntax
"QUALIFIED:" [ scan dup add-qualified ] define-core-syntax
"QUALIFIED-WITH:" [ scan scan add-qualified ] define-core-syntax
"FROM:" [
- scan "=>" expect ";" parse-tokens swap add-words-from
+ scan "=>" expect ";" parse-tokens add-words-from
] define-core-syntax
"EXCLUDE:" [
- scan "=>" expect ";" parse-tokens swap add-words-excluding
+ scan "=>" expect ";" parse-tokens add-words-excluding
] define-core-syntax
"RENAME:" [
"))" parse-effect parsed
] define-core-syntax
- "MAIN:" [ scan-word in get vocab (>>main) ] define-core-syntax
+ "MAIN:" [ scan-word current-vocab (>>main) ] define-core-syntax
"<<" [
[
-USING: help.markup help.syntax parser ;
+USING: help.markup help.syntax parser strings words assocs vocabs ;
IN: vocabs.parser
-ARTICLE: "vocabulary-search-shadow" "Shadowing word names"
-"If adding a vocabulary to the search path results in a word in another vocabulary becoming inaccessible due to the new vocabulary defining a word with the same name, we say that the old word has been " { $emphasis "shadowed" } "."
-$nl
-"Here is an example where shadowing occurs:"
-{ $code
- "IN: foe"
- "USING: sequences io ;"
- ""
- ": append"
- " \"foe::append calls sequences:append\" print append ;"
- ""
- "IN: fee"
- ""
- ": append"
- " \"fee::append calls fee:append\" print append ;"
- ""
- "IN: fox"
- "USE: foe"
- ""
- ": append"
- " \"fox::append calls foe:append\" print append ;"
- ""
- "\"1234\" \"5678\" append print"
- ""
- "USE: fox"
- "\"1234\" \"5678\" append print"
-}
-"When placed in a source file and run, the above code produces the following output:"
-{ $code
- "foe:append calls sequences:append"
- "12345678"
- "fee:append calls foe:append"
- "foe:append calls sequences:append"
- "12345678"
-} ;
-
-ARTICLE: "vocabulary-search-errors" "Word lookup errors"
+ARTICLE: "word-search-errors" "Word lookup errors"
"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies."
$nl
"If " { $link auto-use? } " mode is off, a restartable error is thrown with a restart for each vocabulary in question, together with a restart which defers the word in the current vocabulary, as if " { $link POSTPONE: DEFER: } " was used."
"If any restarts were invoked, or if " { $link auto-use? } " is on, the parser will print the correct " { $link POSTPONE: USING: } " after parsing completes. This form can be copy and pasted back into the source file."
{ $subsection auto-use? } ;
-ARTICLE: "vocabulary-search" "Vocabulary search path"
-"When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order."
-$nl
-"For a source file the vocabulary search path starts off with one vocabulary:"
-{ $code "syntax" }
-"The " { $vocab-link "syntax" } " vocabulary consists of a set of parsing words for reading Factor data and defining new words."
-$nl
-"In the listener, the " { $vocab-link "scratchpad" } " is the default vocabulary for new word definitions. However, when loading source files, there is no default vocabulary. Defining words before declaring a vocabulary with " { $link POSTPONE: IN: } " results in an error."
-$nl
-"At the interactive listener, the default search path contains many more vocabularies. Details on the default search path and parser invocation are found in " { $link "parser" } "."
-$nl
-"Three parsing words deal with the vocabulary search path:"
-{ $subsection POSTPONE: IN: }
+ARTICLE: "word-search-syntax" "Syntax to control word lookup"
+"Parsing words which make all words in a vocabulary available:"
{ $subsection POSTPONE: USE: }
{ $subsection POSTPONE: USING: }
-"There are some additional parsing words give more control over word lookup than is offered by " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } ":"
{ $subsection POSTPONE: QUALIFIED: }
{ $subsection POSTPONE: QUALIFIED-WITH: }
+"Parsing words which make a subset of all words in a vocabulary available:"
{ $subsection POSTPONE: FROM: }
{ $subsection POSTPONE: EXCLUDE: }
{ $subsection POSTPONE: RENAME: }
-"These words are useful when there is no way to avoid using two vocabularies with identical word names in the same source file."
+"Removing vocabularies from the search path:"
+{ $subsection POSTPONE: UNUSE: }
+"In the listener, the " { $vocab-link "scratchpad" } " is the default vocabulary for new word definitions. In source files, there is no default vocabulary. Defining words before declaring a vocabulary with " { $link POSTPONE: IN: } " results in an error."
+{ $subsection POSTPONE: IN: } ;
+
+ARTICLE: "word-search-semantics" "Resolution of ambiguous word names"
+"There is a distinction between parsing words which perform “open” imports versus “closed” imports. An open import introduces all words from a vocabulary as identifiers, except possibly a finite set of exclusions. The " { $link POSTPONE: USE: } ", " { $link POSTPONE: USING: } " and " { $link POSTPONE: EXCLUDE: } " words perform open imports. A closed import only adds a fixed set of identifiers. The " { $link POSTPONE: FROM: } ", " { $link POSTPONE: RENAME: } ", " { $link POSTPONE: QUALIFIED: } " and " { $link POSTPONE: QUALIFIED-WITH: } " words perform closed imports. Note that the latter two are considered as closed imports, due to the fact that all identifiers they introduce are unambiguously qualified with a prefix. The " { $link POSTPONE: IN: } " parsing word also performs a closed import of the newly-created vocabulary."
+$nl
+"When the parser encounters a reference to a word, it first searches the closed imports, in order. Closed imports are searched from the most recent to least recent. If the word could not be found this way, it searches open imports. Unlike closed imports, with open imports, the order does not matter -- instead, if more than one vocabulary defines a word with this name, an error is thrown."
+{ $subsection ambiguous-use-error }
+"To resolve the error, add a closed import, using " { $link POSTPONE: FROM: } ", " { $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: QUALIFIED-WITH: } ". The closed import will then take precedence over the open imports, and the ambiguity will be resolved."
$nl
-"Private words can be defined; note that this is just a convention and they can be called from other vocabularies anyway:"
+"The rationale for this behavior is as follows. Open imports are named such because they are open to future extension; if a future version of a vocabulary that you use adds new words, those new words will now be in scope in your source file, too. To avoid problems, any references to the new word have to be resolved since the parser cannot safely determine which vocabulary was meant. This problem can be avoided entirely by using only closed imports, but this leads to additional verbosity."
+$nl
+"In practice, a small set of guidelines helps avoid name clashes:"
+{ $list
+ "Keep vocabularies small"
+ { "Hide internal words using " { $link POSTPONE: <PRIVATE } }
+ { "Make good use of " { $link POSTPONE: FROM: } ", " { $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: QUALIFIED-WITH: } }
+} ;
+
+ARTICLE: "word-search-private" "Private words"
+"Words which only serve as implementation detail should be defined in a private code block. Words in a private code blocks get defined in a vocabulary whose name is the name of the current vocabulary suffixed with " { $snippet ".private" } ". Privacy is not enforced by the system; private words can be called from other vocabularies, and from the listener. However, this should be avoided where possible."
{ $subsection POSTPONE: <PRIVATE }
-{ $subsection POSTPONE: PRIVATE> }
-{ $subsection "vocabulary-search-errors" }
-{ $subsection "vocabulary-search-shadow" }
+{ $subsection POSTPONE: PRIVATE> } ;
+
+ARTICLE: "word-search" "Parse-time word lookup"
+"When the parser reads a word name, it resolves the word at parse-time, looking up the " { $link word } " instance in the right vocabulary and adding it to the parse tree."
+$nl
+"Initially, only words from the " { $vocab-link "syntax" } " vocabulary are available in source files. Since most files will use words in other vocabularies, they will need to make those words available using a set of parsing words."
+{ $subsection "word-search-syntax" }
+{ $subsection "word-search-private" }
+{ $subsection "word-search-semantics" }
+{ $subsection "word-search-errors" }
{ $see-also "words" } ;
-ABOUT: "vocabulary-search"
+ARTICLE: "word-search-parsing" "Word lookup in parsing words"
+"The parsing words described in " { $link "word-search-syntax" } " are implemented using the below words, which you can also call from your own parsing words."
+$nl
+"The current state used for word search is stored in a " { $emphasis "manifest" } ":"
+{ $subsection manifest }
+"Words for working with the current manifest:"
+{ $subsection use-vocab }
+{ $subsection unuse-vocab }
+{ $subsection only-use-vocabs }
+{ $subsection add-qualified }
+{ $subsection add-words-from }
+{ $subsection add-words-excluding }
+"Words used to implement " { $link POSTPONE: IN: } ":"
+{ $subsection current-vocab }
+{ $subsection set-current-vocab }
+"Words used to implement " { $link "word-search-private" } ":"
+{ $subsection begin-private }
+{ $subsection end-private } ;
+
+ABOUT: "word-search"
+
+HELP: manifest
+{ $var-description "The current manifest. Only set at parse time." }
+{ $class-description "Encapsulates the current vocabulary, as well as the vocabulary search path." } ;
+
+HELP: <manifest>
+{ $values { "manifest" manifest } }
+{ $description "Creates a new manifest." } ;
+
+HELP: set-current-vocab
+{ $values { "name" string } }
+{ $description "Sets the current vocabulary where new words will be defined, creating the vocabulary first if it does not exist." }
+{ $notes "This word is used to implement " { $link POSTPONE: IN: } "." } ;
+
+HELP: no-current-vocab
+{ $error-description "Thrown when a new word is defined in a source file that does not have an " { $link POSTPONE: IN: } " form." } ;
+
+HELP: current-vocab
+{ $values { "vocab" vocab } }
+{ $description "Returns the current vocabulary, where new words will be defined." }
+{ $errors "Throws an error if the current vocabulary has not been set." } ;
+
+HELP: begin-private
+{ $description "Begins a block of private word definitions. Private word definitions are placed in the current vocabulary name, suffixed with " { $snippet ".private" } "." }
+{ $notes "This word is used to implement " { $link POSTPONE: <PRIVATE } "." } ;
+
+HELP: end-private
+{ $description "Ends a block of private word definitions." }
+{ $notes "This word is used to implement " { $link POSTPONE: PRIVATE> } "." } ;
+
+HELP: use-vocab
+{ $values { "vocab" "a vocabulary specifier" } }
+{ $description "Adds a vocabulary to the current manifest." }
+{ $notes "This word is used to implement " { $link POSTPONE: USE: } "." } ;
+
+HELP: unuse-vocab
+{ $values { "vocab" "a vocabulary specifier" } }
+{ $description "Removes a vocabulary from the current manifest." }
+{ $notes "This word is used to implement " { $link POSTPONE: UNUSE: } "." } ;
+
+HELP: only-use-vocabs
+{ $values { "vocabs" "a sequence of vocabulary specifiers" } }
+{ $description "Replaces the current manifest's vocabulary search path with the given set of vocabularies." } ;
+
+HELP: add-qualified
+{ $values { "vocab" "a vocabulary specifier" } { "prefix" string } }
+{ $description "Adds the vocabulary's words, prefixed with the given string, to the current manifest." }
+{ $notes "If adding the vocabulary introduces ambiguity, the vocabulary will take precedence when resolving any ambiguous names. See the example in " { $link POSTPONE: QUALIFIED: } " for further explanation." } ;
+
+HELP: add-words-from
+{ $values { "vocab" "a vocabulary specifier" } { "words" "a sequence of word names" } }
+{ $description "Adds " { $snippet "words" } " from " { $snippet "vocab" } " to the current manifest." }
+{ $notes "This word is used to implement " { $link POSTPONE: FROM: } "." } ;
+
+HELP: add-words-excluding
+{ $values { "vocab" "a vocabulary specifier" } { "words" "a sequence of word names" } }
+{ $description "Adds all words except for " { $snippet "words" } " from " { $snippet "vocab" } " to the manifest." }
+{ $notes "This word is used to implement " { $link POSTPONE: EXCLUDE: } "." } ;
+
+HELP: add-renamed-word
+{ $values { "word" string } { "vocab" "a vocabulary specifier" } { "new-name" string } }
+{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "new-name" } "." }
+{ $notes "This word is used to implement " { $link POSTPONE: RENAME: } "." } ;
+
+HELP: use-words
+{ $values { "assoc" assoc } }
+{ $description "Adds an assoc mapping word names to words to the current manifest." }
+{ $notes "This word is used by " { $link "locals" } " to implement lexically-scoped names." } ;
+
+HELP: unuse-words
+{ $values { "assoc" assoc } }
+{ $description "Removes an assoc mapping word names to words from the current manifest." }
+{ $notes "This word is used by " { $link "locals" } " to implement lexically-scoped names." } ;
+
+HELP: ambiguous-use-error
+{ $error-description "Thrown when a word name referenced in source file is available in more than one vocabulary in the manifest. Such cases must be explicitly disambiguated using " { $link POSTPONE: FROM: } ", " { $link POSTPONE: EXCLUDE: } ", " { $link POSTPONE: QUALIFIED: } ", or " { $link POSTPONE: QUALIFIED-WITH: } "." } ;
+
+HELP: search-manifest
+{ $values { "name" string } { "manifest" manifest } { "word/f" { $maybe word } } }
+{ $description "Searches for a word by name in the given manifest. If no such word could be found, outputs " { $link f } "." } ;
+
+HELP: search
+{ $values { "name" string } { "word/f" { $maybe word } } }
+{ $description "Searches for a word by name in the current manifest. If no such word could be found, outputs " { $link f } "." }
+$parsing-note ;
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel namespaces sequences
-sets strings vocabs sorting accessors arrays ;
+sets strings vocabs sorting accessors arrays compiler.units
+combinators vectors splitting continuations math
+parser.notes ;
IN: vocabs.parser
ERROR: no-word-error name ;
-: word-restarts ( name possibilities -- restarts )
+: word-restarts ( possibilities -- restarts )
natural-sort
- [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc
+ [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc ;
+
+: word-restarts-with-defer ( name possibilities -- restarts )
+ word-restarts
swap "Defer word in current vocabulary" swap 2array
suffix ;
: <no-word-error> ( name possibilities -- error restarts )
- [ drop \ no-word-error boa ] [ word-restarts ] 2bi ;
+ [ drop \ no-word-error boa ] [ word-restarts-with-defer ] 2bi ;
-SYMBOL: use
-SYMBOL: in
+TUPLE: manifest
+current-vocab
+{ search-vocab-names hashtable }
+{ search-vocabs vector }
+{ qualified-vocabs vector }
+{ extra-words vector }
+{ auto-used vector } ;
-: (use+) ( vocab -- )
- vocab-words use get push ;
+: <manifest> ( -- manifest )
+ manifest new
+ H{ } clone >>search-vocab-names
+ V{ } clone >>search-vocabs
+ V{ } clone >>qualified-vocabs
+ V{ } clone >>extra-words
+ V{ } clone >>auto-used ;
-: use+ ( vocab -- )
- load-vocab (use+) ;
+M: manifest clone
+ call-next-method
+ [ clone ] change-search-vocab-names
+ [ clone ] change-search-vocabs
+ [ clone ] change-qualified-vocabs
+ [ clone ] change-extra-words
+ [ clone ] change-auto-used ;
-: add-use ( seq -- ) [ use+ ] each ;
+TUPLE: extra-words words ;
-: set-use ( seq -- )
- [ vocab-words ] V{ } map-as sift use set ;
+M: extra-words equal?
+ over extra-words? [ [ words>> ] bi@ eq? ] [ 2drop f ] if ;
-: add-qualified ( vocab prefix -- )
- [ load-vocab vocab-words ] [ CHAR: : suffix ] bi*
+C: <extra-words> extra-words
+
+<PRIVATE
+
+: clear-manifest ( -- )
+ manifest get
+ [ search-vocab-names>> clear-assoc ]
+ [ search-vocabs>> delete-all ]
+ [ qualified-vocabs>> delete-all ]
+ tri ;
+
+: (add-qualified) ( qualified -- )
+ manifest get qualified-vocabs>> push ;
+
+: (from) ( vocab words -- vocab words words' assoc )
+ 2dup swap load-vocab words>> ;
+
+: extract-words ( seq assoc -- assoc' )
+ extract-keys dup [ [ drop ] [ no-word-error ] if ] assoc-each ;
+
+: (lookup) ( name assoc -- word/f )
+ at dup forward-reference? [ drop f ] when ;
+
+: (use-words) ( assoc -- extra-words seq )
+ <extra-words> manifest get qualified-vocabs>> ;
+
+PRIVATE>
+
+: set-current-vocab ( name -- )
+ create-vocab
+ [ manifest get (>>current-vocab) ]
+ [ words>> <extra-words> (add-qualified) ] bi ;
+
+TUPLE: no-current-vocab ;
+
+: no-current-vocab ( -- vocab )
+ \ no-current-vocab boa
+ { { "Define words in scratchpad vocabulary" "scratchpad" } }
+ throw-restarts dup set-current-vocab ;
+
+: current-vocab ( -- vocab )
+ manifest get current-vocab>> [ no-current-vocab ] unless* ;
+
+: begin-private ( -- )
+ manifest get current-vocab>> vocab-name ".private" ?tail
+ [ drop ] [ ".private" append set-current-vocab ] if ;
+
+: end-private ( -- )
+ manifest get current-vocab>> vocab-name ".private" ?tail
+ [ set-current-vocab ] [ drop ] if ;
+
+: using-vocab? ( vocab -- ? )
+ vocab-name manifest get search-vocab-names>> key? ;
+
+: use-vocab ( vocab -- )
+ dup using-vocab?
+ [ vocab-name "Already using ``" "'' vocabulary" surround note. ] [
+ manifest get
+ [ [ vocab-name ] dip search-vocab-names>> conjoin ]
+ [ [ load-vocab ] dip search-vocabs>> push ]
+ 2bi
+ ] if ;
+
+: auto-use-vocab ( vocab -- )
+ [ use-vocab ] [ manifest get auto-used>> push ] bi ;
+
+: auto-used? ( -- ? ) manifest get auto-used>> length 0 > ;
+
+: unuse-vocab ( vocab -- )
+ dup using-vocab? [
+ manifest get
+ [ [ vocab-name ] dip search-vocab-names>> delete-at ]
+ [ [ load-vocab ] dip search-vocabs>> delq ]
+ 2bi
+ ] [ drop ] if ;
+
+: only-use-vocabs ( vocabs -- )
+ clear-manifest [ vocab ] filter [ use-vocab ] each ;
+
+TUPLE: qualified vocab prefix words ;
+
+: <qualified> ( vocab prefix -- qualified )
+ 2dup
+ [ load-vocab words>> ] [ CHAR: : suffix ] bi*
[ swap [ prepend ] dip ] curry assoc-map
- use get push ;
+ qualified boa ;
+
+: add-qualified ( vocab prefix -- )
+ <qualified> (add-qualified) ;
+
+TUPLE: from vocab names words ;
+
+: <from> ( vocab words -- from )
+ (from) extract-words from boa ;
+
+: add-words-from ( vocab words -- )
+ <from> (add-qualified) ;
+
+TUPLE: exclude vocab names words ;
-: partial-vocab ( words vocab -- assoc )
- load-vocab vocab-words
- [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
+: <exclude> ( vocab words -- from )
+ (from) [ nip ] [ extract-words ] 2bi assoc-diff exclude boa ;
-: add-words-from ( words vocab -- )
- partial-vocab use get push ;
+: add-words-excluding ( vocab words -- )
+ <exclude> (add-qualified) ;
-: partial-vocab-excluding ( words vocab -- assoc )
- load-vocab [ vocab-words keys swap diff ] keep partial-vocab ;
+TUPLE: rename word vocab words ;
-: add-words-excluding ( words vocab -- )
- partial-vocab-excluding use get push ;
+: <rename> ( word vocab new-name -- rename )
+ [ 2dup load-vocab words>> dupd at [ ] [ no-word-error ] ?if ] dip
+ associate rename boa ;
: add-renamed-word ( word vocab new-name -- )
- [ load-vocab vocab-words dupd at [ ] [ no-word-error ] ?if ] dip
- associate use get push ;
+ <rename> (add-qualified) ;
+
+: use-words ( assoc -- ) (use-words) push ;
+
+: unuse-words ( assoc -- ) (use-words) delete ;
+
+TUPLE: ambiguous-use-error words ;
+
+: <ambiguous-use-error> ( words -- error restarts )
+ [ \ ambiguous-use-error boa ] [ word-restarts ] bi ;
+
+<PRIVATE
+
+: (vocab-search) ( name assocs -- words n )
+ [ words>> (lookup) ] with map
+ sift dup length ;
+
+: vocab-search ( name manifest -- word/f )
+ search-vocabs>>
+ (vocab-search) {
+ { 0 [ drop f ] }
+ { 1 [ first ] }
+ [
+ drop <ambiguous-use-error> throw-restarts
+ dup [ vocabulary>> ] [ name>> 1array ] bi add-words-from
+ ]
+ } case ;
+
+: qualified-search ( name manifest -- word/f )
+ qualified-vocabs>>
+ (vocab-search) 0 = [ drop f ] [ peek ] if ;
+
+PRIVATE>
-: check-vocab-string ( name -- name )
- dup string? [ "Vocabulary name must be a string" throw ] unless ;
+: search-manifest ( name manifest -- word/f )
+ 2dup qualified-search dup [ 2nip ] [ drop vocab-search ] if ;
-: set-in ( name -- )
- check-vocab-string dup in set create-vocab (use+) ;
\ No newline at end of file
+: search ( name -- word/f )
+ manifest get search-manifest ;
: notify-vocab-observers ( -- )
vocab-observers get [ vocabs-changed ] each ;
+ERROR: bad-vocab-name name ;
+
+: check-vocab-name ( name -- name )
+ dup string? [ bad-vocab-name ] unless ;
+
: create-vocab ( name -- vocab )
+ check-vocab-name
dictionary get [ <vocab> ] cache
notify-vocab-observers ;
$nl
"Words whose names are known at parse time -- that is, most words making up your program -- can be referenced in source code by stating their name. However, the parser itself, and sometimes code you write, will need to create look up words dynamically."
$nl
-"Parsing words add definitions to the current vocabulary. When a source file is being parsed, the current vocabulary is initially set to " { $vocab-link "scratchpad" } ". The current vocabulary may be changed with the " { $link POSTPONE: IN: } " parsing word (see " { $link "vocabulary-search" } ")."
+"Parsing words add definitions to the current vocabulary. When a source file is being parsed, the current vocabulary is initially set to " { $vocab-link "scratchpad" } ". The current vocabulary may be changed with the " { $link POSTPONE: IN: } " parsing word (see " { $link "word-search" } ")."
{ $subsection create }
{ $subsection create-in }
{ $subsection lookup } ;
{ $description "Sets the recently defined word." } ;
HELP: lookup
-{ $values { "name" string } { "vocab" string } { "word" "a word or " { $link f } } }
+{ $values { "name" string } { "vocab" string } { "word" { $maybe word } } }
{ $description "Looks up a word in the dictionary. If the vocabulary or the word is not defined, outputs " { $link f } "." } ;
HELP: reveal
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays definitions graphs assocs kernel
-kernel.private kernel.private slots.private math namespaces sequences
+USING: accessors arrays definitions graphs kernel
+kernel.private slots.private math namespaces sequences
strings vectors sbufs quotations assocs hashtables sorting vocabs
math.order sets ;
IN: words
ERROR: bad-create name vocab ;
: check-create ( name vocab -- name vocab )
- 2dup [ string? ] both?
+ 2dup [ string? ] [ [ string? ] [ vocab? ] bi or ] bi* and
[ bad-create ] unless ;
: create ( name vocab -- word )
check-create 2dup lookup
- dup [ 2nip ] [ drop <word> dup reveal ] if ;
+ dup [ 2nip ] [ drop vocab-name <word> dup reveal ] if ;
: constructor-word ( name vocab -- word )
[ "<" ">" surround ] dip create ;
-USING: kernel math arrays math.vectors math.matrices
-namespaces make
-math.constants math.functions
-math.vectors
-splitting grouping math.trig
- sequences accessors 4DNav.deep models vars ;
+USING: kernel math arrays math.vectors math.matrices namespaces make
+math.constants math.functions splitting grouping math.trig sequences
+accessors 4DNav.deep models vars ;
IN: 4DNav.turtle
! replacement of self
namespaces\r
adsoda \r
models\r
-accessors\r
prettyprint\r
;\r
\r
USING: accessors arrays bank calendar kernel math math.functions
namespaces make tools.test tools.walker ;
+FROM: bank => balance>> ;
IN: bank.tests
SYMBOL: my-account
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: backtrack shuffle math math.ranges quotations locals fry
-kernel words io memoize macros io prettyprint sequences assocs
+kernel words io memoize macros prettyprint sequences assocs
combinators namespaces ;
IN: benchmark.backtrack
[ 4 32 ] [ 0.05 5 size-bloom-filter ] unit-test
! This is a lot of bits.
-: oversized-filter-params ( -- error-rate n-objects )
- 0.00000001 400000000000000 ;
-! [ oversized-filter-params size-bloom-filter ] [ capacity-error? ] must-fail-with
-! [ oversized-filter-params <bloom-filter> ] [ capacity-error? ] must-fail-with
+[ 0.00000001 max-array-capacity size-bloom-filter ] [ capacity-error? ] must-fail-with
! Other error conditions.
[ 1.0 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
opengl.framebuffers opengl.gl opengl.textures opengl.demo-support fry
opengl.capabilities sequences ui.gadgets combinators accessors
macros locals ;
+FROM: opengl.demo-support => rect-vertices ;
IN: bunny.outlined
STRING: outlined-pass1-fragment-shader-main-source
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel peg strings sequences math math.parser
namespaces make words quotations arrays hashtables io
-io.streams.string assocs ascii peg.parsers accessors
-words.symbol ;
+io.streams.string assocs ascii peg.parsers words.symbol ;
IN: fjsc
TUPLE: ast-number value ;
IN: fuel.eval
-TUPLE: fuel-status in use restarts ;
+TUPLE: fuel-status manifest restarts ;
SYMBOL: fuel-status-stack
V{ } clone fuel-status-stack set-global
fuel-eval-res-flag get-global ;
: fuel-push-status ( -- )
- in get use get clone restarts get-global clone
+ manifest get clone restarts get-global clone
fuel-status boa
fuel-status-stack get push ;
: fuel-pop-status ( -- )
fuel-status-stack get empty? [
fuel-status-stack get pop
- [ in>> in set ]
- [ use>> clone use set ]
- [ restarts>> fuel-pop-restarts ] tri
+ [ manifest>> clone manifest set ]
+ [ restarts>> fuel-pop-restarts ]
+ bi
] unless ;
: fuel-forget-error ( -- ) f error set-global ;
[ print-error ] recover ;
: (fuel-eval-usings) ( usings -- )
- [ [ use+ ] curry [ drop ] recover ] each
+ [ [ use-vocab ] curry [ drop ] recover ] each
fuel-forget-error fuel-forget-output ;
: (fuel-eval-in) ( in -- )
- [ in set ] when* ;
+ [ set-current-vocab ] when* ;
: (fuel-eval-in-context) ( lines in usings -- )
(fuel-begin-eval)
USING: accessors assocs compiler.units continuations fuel.eval fuel.help
fuel.remote fuel.xref help.topics io.pathnames kernel namespaces parser
-sequences tools.scaffold vocabs.loader words ;
+sequences tools.scaffold vocabs.loader vocabs.parser words ;
IN: fuel
dup length 1 = [ first restart ] [ drop ] if ;
: fuel-set-use-hook ( -- )
- [ amended-use get clone :uses prefix fuel-eval-set-result ]
+ [ manifest get auto-used>> clone :uses prefix fuel-eval-set-result ]
print-use-hook set ;
: (fuel-get-uses) ( lines -- )
>vocab-link words [ name>> ] map ;
: current-words ( -- seq )
- use get [ keys ] map concat ; inline
+ manifest get
+ [ search-vocabs>> ] [ qualified-vocabs>> ] bi [ words>> ] bi@
+ assoc-union keys ; inline
: vocabs-words ( names -- seq )
prune [ (vocab-words) ] map concat ; inline
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: slides help.markup math arrays hashtables namespaces
-sequences kernel sequences parser memoize io.encodings.binary
+kernel sequences parser memoize io.encodings.binary
locals kernel.private help.vocabs assocs quotations
urls peg.ebnf tools.annotations tools.crossref
help.topics math.functions compiler.tree.optimizer
! Copyright (C) 2009 Diego Martinelli.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors byte-arrays calendar calendar.format
-checksums checksums.openssl classes.tuple
-fry kernel make math math.functions math.parser math.ranges
-present random sequences splitting strings syntax ;
+USING: accessors byte-arrays calendar calendar.format checksums
+checksums.openssl classes.tuple fry kernel make math math.functions
+math.parser math.ranges present random sequences splitting strings ;
IN: hashcash
! Hashcash implementation
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs html.parser kernel math sequences strings ascii
-arrays generalizations shuffle unicode.case namespaces make
+arrays generalizations shuffle namespaces make
splitting http accessors io combinators http.client urls
urls.encoding fry prettyprint sets ;
IN: html.parser.analyzer
! Copyright (C) 2009 Tim Wawrzynczak, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences io io.encodings.binary io.files io.pathnames
-strings kernel math io.mmap io.mmap.uchar accessors syntax
+strings kernel math io.mmap io.mmap.uchar accessors
combinators math.ranges unicode.categories byte-arrays
io.encodings.string io.encodings.utf16 assocs math.parser
combinators.short-circuit fry namespaces combinators.smart
}
"The standard precedence rules apply: Grouping with parentheses before " { $snippet "*" } ", " { $snippet "/" } "and " { $snippet "%" } " before " { $snippet "+" } " and " { $snippet "-" } "."
{ $example
- "USING: infix prettyprint ;"
+ "USE: infix"
"[infix 5-40/10*2 infix] ."
"-3"
}
"The word name must consist of the letters a-z, A-Z, _ or 0-9, and the first character can't be a number."
}
{ $example
- "USING: infix locals math math.functions prettyprint ;"
+ "USING: infix locals math.functions ;"
":: binary_entropy ( p -- h )"
" [infix -(p*log(p) + (1-p)*log(1-p)) / log(2) infix] ;"
"[infix binary_entropy( sqrt(0.25) ) infix] ."
$nl
"You can access " { $vocab-link "sequences" } " inside infix expressions with the familiar " { $snippet "arr[index]" } " notation."
{ $example
- "USING: arrays infix prettyprint ;"
+ "USING: arrays infix ;"
"[infix| myarr [ { 1 2 3 4 } ] | myarr[4/2]*3 infix] ."
"9"
}
"Please note: in Factor " { $emphasis "fixnums are sequences too." } " If you are not careful with sequence accesses you may introduce subtle bugs:"
{ $example
- "USING: arrays infix locals prettyprint ;"
+ "USING: arrays infix locals ;"
":: add-2nd-element ( x y -- res )"
" [infix x[1] + y[1] infix] ;"
"{ 1 2 3 } 5 add-2nd-element ."
USING: accessors assocs combinators combinators.short-circuit
effects fry infix.parser infix.ast kernel locals.parser
locals.types math multiline namespaces parser quotations
-sequences summary words ;
+sequences summary words vocabs.parser ;
IN: infix
<PRIVATE
"infix]" [infix-parse parsed \ call parsed ;
<PRIVATE
+
: parse-infix-locals ( assoc end -- quot )
- [
- in-lambda? on
- [ dup [ locals set ] [ push-locals ] bi ] dip
- [infix-parse prepare-operand swap pop-locals
- ] with-scope ;
+ '[ _ [infix-parse prepare-operand ] ((parse-lambda)) ;
+
PRIVATE>
SYNTAX: [infix|
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays colors combinators kernel literals locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ;
+FROM: jamshred.oint => distance ;
IN: jamshred.tunnel
CONSTANT: n-segments 5000
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs hashtables assocs io kernel math
+USING: accessors arrays hashtables assocs io kernel math
math.vectors math.matrices math.matrices.elimination namespaces
parser prettyprint sequences words combinators math.parser
splitting sorting shuffle sets math.order ;
math.functions make io io.files io.pathnames io.directories
io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
combinators.short-circuit parser combinators calendar
-calendar.format arrays mason.config locals system debugger fry
+calendar.format arrays mason.config locals debugger fry
continuations strings ;
IN: mason.common
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors calendar continuations debugger debugger io
-io.directories io.files kernel mason.build mason.common
+USING: accessors calendar continuations debugger io
+io.directories io.files kernel mason.common
mason.email mason.updates namespaces threads ;
+FROM: mason.build => build ;
IN: mason
: build-loop-error ( error -- )
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel debugger namespaces sequences splitting combinators
+USING: kernel debugger namespaces sequences splitting
combinators io io.files io.launcher prettyprint bootstrap.image
mason.common mason.release.branch mason.release.tidy
mason.release.archive mason.release.upload mason.notify ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test math.floating-point math.constants kernel
-math.constants fry sequences kernel math ;
+USING: tools.test math.floating-point kernel
+math.constants fry sequences math ;
IN: math.floating-point.tests
[ t ] [ pi >double< >double pi = ] unit-test
-USING: lists.lazy math.primes.lists tools.test ;
+USING: lists lists.lazy math.primes.lists tools.test ;
{ { 2 3 5 7 11 13 17 19 23 29 } } [ 10 lprimes ltake list>array ] unit-test
{ { 101 103 107 109 113 } } [ 5 100 lprimes-from ltake list>array ] unit-test
USING: tools.test math kernel sequences lists promises monads ;
+FROM: monads => do ;
IN: monads.tests
[ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test
USING: calendar math fry kernel assocs math.ranges bson.reader io.streams.byte-array
sequences formatting combinators namespaces io tools.time prettyprint io.encodings.binary
-accessors words mongodb.driver strings math.parser tools.walker bson.writer
-tools.continuations ;
+accessors words mongodb.driver strings math.parser bson.writer ;
+FROM: mongodb.driver => find ;
IN: mongodb.benchmark
classes.tuple.parser compiler.units fry kernel sequences mongodb.driver
mongodb.msg mongodb.tuple.collection
mongodb.tuple.persistent mongodb.tuple.state strings ;
+FROM: mongodb.driver => update delete find count ;
+FROM: mongodb.tuple.persistent => assoc>tuple ;
IN: mongodb.tuple
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: slides help.markup math arrays hashtables namespaces
-sequences kernel sequences parser memoize io.encodings.binary
+kernel sequences parser memoize io.encodings.binary
locals kernel.private help.vocabs assocs quotations
tools.annotations tools.crossref help.topics math.functions
compiler.tree.optimizer compiler.cfg.optimizer fry
! Copyright (C) 2005 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel lists.lazy tools.test strings math
+USING: kernel lists lists.lazy tools.test strings math
sequences parser-combinators arrays math.parser unicode.categories ;
IN: parser-combinators.tests
! Copyright (C) 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors peg peg.ebnf peg.javascript.ast peg.javascript.tokenizer ;
+USING: kernel accessors sequences
+peg peg.ebnf peg.javascript.ast peg.javascript.tokenizer ;
IN: peg.javascript.parser
#! Grammar for JavaScript. Based on OMeta-JS example from:
SYNTAX: SOLUTION:
scan-word
[ name>> "-main" append create-in ] keep
- [ drop in get vocab (>>main) ]
+ [ drop current-vocab (>>main) ]
[ [ . ] swap prefix (( -- )) define-declared ]
2bi ;
! (c)2009 Joe Groff bsd license
USING: accessors classes.tuple compiler.units kernel qw roles sequences
tools.test ;
+FROM: roles => TUPLE: ;
IN: roles.tests
ROLE: fork tines ;
+++ /dev/null
-Maxim Savchenko
+++ /dev/null
-! Copyright (C) 2009 Maxim Savchenko
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel accessors continuations lexer vocabs vocabs.parser
- combinators.short-circuit sandbox tools.test ;
-
-IN: sandbox.tests
-
-<< "sandbox.syntax" load-vocab drop >>
-USE: sandbox.syntax.private
-
-: run-script ( x lines -- y )
- H{ { "kernel" "kernel" } { "math" "math" } { "sequences" "sequences" } }
- parse-sandbox call( x -- x! ) ;
-
-[ 120 ]
-[
- 5
- {
- "! Simple factorial example"
- "APPLYING: kernel math sequences ;"
- "1 swap [ 1+ * ] each"
- } run-script
-] unit-test
-
-[
- 5
- {
- "! Jailbreak attempt with USE:"
- "USE: io"
- "\"Hello world!\" print"
- } run-script
-]
-[
- {
- [ lexer-error? ]
- [ error>> condition? ]
- [ error>> error>> no-word-error? ]
- [ error>> error>> name>> "USE:" = ]
- } 1&&
-] must-fail-with
-
-[
- 5
- {
- "! Jailbreak attempt with unauthorized APPLY:"
- "APPLY: io"
- "\"Hello world!\" print"
- } run-script
-]
-[
- {
- [ lexer-error? ]
- [ error>> sandbox-error? ]
- [ error>> vocab>> "io" = ]
- } 1&&
-] must-fail-with
+++ /dev/null
-! Copyright (C) 2009 Maxim Savchenko.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel sequences vectors assocs namespaces parser lexer vocabs
- combinators.short-circuit vocabs.parser ;
-
-IN: sandbox
-
-SYMBOL: whitelist
-
-: with-sandbox-vocabs ( quot -- )
- "sandbox.syntax" load-vocab vocab-words 1vector
- use [ auto-use? off call ] with-variable ; inline
-
-: parse-sandbox ( lines assoc -- quot )
- whitelist [ [ parse-lines ] with-sandbox-vocabs ] with-variable ;
-
-: reveal-in ( name -- )
- [ { [ search ] [ no-word ] } 1|| ] keep current-vocab vocab-words set-at ;
-
-SYNTAX: REVEAL: scan reveal-in ;
-
-SYNTAX: REVEALING: ";" parse-tokens [ reveal-in ] each ;
+++ /dev/null
-Basic sandboxing
+++ /dev/null
-! Copyright (C) 2009 Maxim Savchenko.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel sequences assocs namespaces lexer vocabs.parser sandbox ;
-IN: sandbox.syntax
-
-<PRIVATE
-
-ERROR: sandbox-error vocab ;
-
-: sandbox-use+ ( alias -- )
- dup whitelist get at [ use+ ] [ sandbox-error ] ?if ;
-
-PRIVATE>
-
-SYNTAX: APPLY: scan sandbox-use+ ;
-
-SYNTAX: APPLYING: ";" parse-tokens [ sandbox-use+ ] each ;
-
-REVEALING:
- ! #!
- HEX: OCT: BIN: f t CHAR: "
- [ { T{
- ] } ;
-
-REVEAL: ;
ui.gadgets accessors sequences ui.render ui math locals arrays
generalizations combinators ui.gadgets.worlds
literals ui.pixel-formats ;
+FROM: opengl.demo-support => rect-vertices ;
IN: spheres
STRING: plane-vertex-shader
sequences sequences.product specialized-arrays.float
terrain.generation terrain.shaders ui ui.gadgets
ui.gadgets.worlds ui.pixel-formats game-worlds method-chains
-math.affine-transforms noise ui.gestures ;
+math.affine-transforms noise ui.gestures combinators.short-circuit ;
IN: terrain
CONSTANT: FOV $[ 2.0 sqrt 1+ ]
CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
CONSTANT: FAR-PLANE 2.0
CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 }
+CONSTANT: VELOCITY-MODIFIER-NORMAL { 1.0 1.0 1.0 }
+CONSTANT: VELOCITY-MODIFIER-FAST { 2.0 1.0 2.0 }
CONSTANT: PLAYER-HEIGHT $[ 1.0 256.0 / ]
CONSTANT: GRAVITY $[ 1.0 4096.0 / ]
CONSTANT: JUMP $[ 1.0 1024.0 / ]
CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ]
TUPLE: player
- location yaw pitch velocity velocity-modifier ;
+ location yaw pitch velocity velocity-modifier
+ reverse-time ;
TUPLE: terrain-world < game-world
player
sky-image sky-texture sky-program
terrain terrain-segment terrain-texture terrain-program
- terrain-vertex-buffer ;
+ terrain-vertex-buffer
+ history ;
+
+: <player> ( -- player )
+ player new
+ PLAYER-START-LOCATION >>location
+ 0.0 >>yaw
+ 0.0 >>pitch
+ { 0.0 0.0 0.0 } >>velocity
+ VELOCITY-MODIFIER-NORMAL >>velocity-modifier ;
M: terrain-world tick-length
drop 1000 30 /i ;
:: handle-input ( world -- )
world player>> :> player
read-keyboard keys>> :> keys
- key-left-shift keys nth [
- { 2.0 1.0 2.0 } player (>>velocity-modifier)
- ] when
- key-left-shift keys nth [
- { 1.0 1.0 1.0 } player (>>velocity-modifier)
- ] unless
+
+ key-left-shift keys nth
+ VELOCITY-MODIFIER-FAST VELOCITY-MODIFIER-NORMAL ? player (>>velocity-modifier)
+
+ {
+ [ key-1 keys nth 1 f ? ]
+ [ key-2 keys nth 2 f ? ]
+ [ key-3 keys nth 3 f ? ]
+ [ key-4 keys nth 4 f ? ]
+ [ key-5 keys nth 10000 f ? ]
+ } 0|| player (>>reverse-time)
key-w keys nth [ player walk-forward ] when
key-s keys nth [ player walk-backward ] when
: scaled-velocity ( player -- velocity )
[ velocity>> ] [ velocity-modifier>> ] bi v* ;
-: tick-player ( world player -- )
+: save-history ( world player -- )
+ clone swap history>> push ;
+
+:: tick-player-reverse ( world player -- )
+ player reverse-time>> :> reverse-time
+ world history>> :> history
+ history length 0 > [
+ history length reverse-time 1 - - 1 max history set-length
+ history pop world (>>player)
+ ] when ;
+
+: tick-player-forward ( world player -- )
+ 2dup save-history
[ apply-friction apply-gravity ] change-velocity
dup scaled-velocity [ v+ [ terrain-segment>> ] dip collide ] curry with change-location
drop ;
+: tick-player ( world player -- )
+ dup reverse-time>> [
+ tick-player-reverse
+ ] [
+ tick-player-forward
+ ] if ;
+
M: terrain-world tick*
[ dup focused?>> [ handle-input ] [ drop ] if ]
[ dup player>> tick-player ] bi ;
GL_DEPTH_TEST glEnable
GL_TEXTURE_2D glEnable
GL_VERTEX_ARRAY glEnableClientState
- PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } { 1.0 1.0 1.0 } player boa >>player
+ <player> >>player
+ V{ } clone >>history
<perlin-noise-table> 0.01 0.01 <scale> { 512 512 } perlin-noise-image
[ >>sky-image ] keep
make-texture [ set-texture-parameters ] keep >>sky-texture
USING: accessors kernel tetris.game tetris.board tetris.piece tools.test
sequences ;
+FROM: tetris.game => level>> ;
[ t ] [ <default-tetris> [ current-piece ] [ next-piece ] bi and t f ? ] unit-test
[ t ] [ <default-tetris> { 1 1 } can-move? ] unit-test
! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alarms arrays calendar kernel make math math.rectangles math.parser namespaces sequences system tetris.game tetris.gl ui.gadgets ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui ;
+FROM: tetris.game => level>> ;
IN: tetris
TUPLE: tetris-gadget < gadget { tetris tetris } { alarm } ;
USING: accessors kernel fry math models ui.gadgets ui.gadgets.books ui.gadgets.buttons ;
+FROM: models => change-model ;
IN: ui.gadgets.book-extras
: <book*> ( pages -- book ) 0 <model> <book> ;
: |<< ( book -- ) 0 swap set-control-value ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: slides help.markup math arrays hashtables namespaces
-sequences kernel sequences parser memoize io.encodings.binary
+kernel sequences parser memoize io.encodings.binary
locals kernel.private help.vocabs assocs quotations urls
peg.ebnf tools.annotations tools.crossref help.topics
math.functions compiler.tree.optimizer compiler.cfg.optimizer
"twitter" value >>twitter
"sms" value >>sms
update-tuple
- site-list-url <redirect>
+ f <redirect>
] >>submit
<protected>
"update notification details" >>description ;
furnace.boilerplate
furnace.syndication
validators
-db.types db.tuples lcs farkup urls ;
+db.types db.tuples lcs urls ;
IN: webapps.wiki
: wiki-url ( rest path -- url )
--- /dev/null
+Maxim Savchenko
--- /dev/null
+! Copyright (C) 2009 Maxim Savchenko
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel accessors continuations lexer vocabs vocabs.parser
+ combinators.short-circuit sandbox tools.test ;
+
+IN: sandbox.tests
+
+<< "sandbox.syntax" load-vocab drop >>
+USE: sandbox.syntax.private
+
+: run-script ( x lines -- y )
+ H{ { "kernel" "kernel" } { "math" "math" } { "sequences" "sequences" } }
+ parse-sandbox call( x -- x! ) ;
+
+[ 120 ]
+[
+ 5
+ {
+ "! Simple factorial example"
+ "APPLYING: kernel math sequences ;"
+ "1 swap [ 1+ * ] each"
+ } run-script
+] unit-test
+
+[
+ 5
+ {
+ "! Jailbreak attempt with USE:"
+ "USE: io"
+ "\"Hello world!\" print"
+ } run-script
+]
+[
+ {
+ [ lexer-error? ]
+ [ error>> condition? ]
+ [ error>> error>> no-word-error? ]
+ [ error>> error>> name>> "USE:" = ]
+ } 1&&
+] must-fail-with
+
+[
+ 5
+ {
+ "! Jailbreak attempt with unauthorized APPLY:"
+ "APPLY: io"
+ "\"Hello world!\" print"
+ } run-script
+]
+[
+ {
+ [ lexer-error? ]
+ [ error>> sandbox-error? ]
+ [ error>> vocab>> "io" = ]
+ } 1&&
+] must-fail-with
--- /dev/null
+! Copyright (C) 2009 Maxim Savchenko.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel sequences vectors assocs namespaces parser lexer vocabs
+ combinators.short-circuit vocabs.parser ;
+
+IN: sandbox
+
+SYMBOL: whitelist
+
+: with-sandbox-vocabs ( quot -- )
+ "sandbox.syntax" load-vocab vocab-words 1vector
+ use [ auto-use? off call ] with-variable ; inline
+
+: parse-sandbox ( lines assoc -- quot )
+ whitelist [ [ parse-lines ] with-sandbox-vocabs ] with-variable ;
+
+: reveal-in ( name -- )
+ [ { [ search ] [ no-word ] } 1|| ] keep current-vocab vocab-words set-at ;
+
+SYNTAX: REVEAL: scan reveal-in ;
+
+SYNTAX: REVEALING: ";" parse-tokens [ reveal-in ] each ;
--- /dev/null
+Basic sandboxing
--- /dev/null
+! Copyright (C) 2009 Maxim Savchenko.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel sequences assocs namespaces lexer vocabs.parser sandbox ;
+IN: sandbox.syntax
+
+<PRIVATE
+
+ERROR: sandbox-error vocab ;
+
+: sandbox-use+ ( alias -- )
+ dup whitelist get at [ add-use ] [ sandbox-error ] ?if ;
+
+PRIVATE>
+
+SYNTAX: APPLY: scan sandbox-use+ ;
+
+SYNTAX: APPLYING: ";" parse-tokens [ sandbox-use+ ] each ;
+
+REVEALING:
+ ! #!
+ HEX: OCT: BIN: f t CHAR: "
+ [ { T{
+ ] } ;
+
+REVEAL: ;
projects / factor.git / commitdiff