! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar combinators generic init
-kernel math namespaces sequences heaps boxes threads debugger
+kernel math namespaces sequences heaps boxes threads
quotations assocs math.order ;
IN: alarms
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel combinators alien alien.strings alien.syntax
+prettyprint.backend prettyprint.custom prettyprint.sections ;
+IN: alien.prettyprint
+
+M: alien pprint*
+ {
+ { [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
+ { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
+ [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
+ } cond ;
+
+M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
$nl
"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
-HELP: utf16n
-{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
-{ $see-also "encodings-introduction" } ;
-
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl
USING: alien.strings tools.test kernel libc
io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
-io.encodings.ascii alien io.encodings.string ;
+io.encodings.utf16n io.encodings.ascii alien io.encodings.string ;
IN: alien.strings.tests
[ "\u0000ff" ]
! See http://factorcode.org/license.txt for BSD license.
USING: arrays sequences kernel accessors math alien.accessors
alien.c-types byte-arrays words io io.encodings
-io.streams.byte-array io.streams.memory io.encodings.utf8
-io.encodings.utf16 system alien strings cpu.architecture fry ;
+io.encodings.utf8 io.streams.byte-array io.streams.memory system
+alien strings cpu.architecture fry vocabs.loader combinators ;
IN: alien.strings
GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
M: string-type c-type-setter
drop [ set-alien-cell ] ;
-! Native-order UTF-16
+HOOK: alien>native-string os ( alien -- string )
-SINGLETON: utf16n
-
-: utf16n ( -- descriptor )
- little-endian? utf16le utf16be ? ; foldable
-
-M: utf16n <decoder> drop utf16n <decoder> ;
-
-M: utf16n <encoder> drop utf16n <encoder> ;
-
-: alien>native-string ( alien -- string )
- os windows? [ utf16n ] [ utf8 ] if alien>string ;
+HOOK: native-string>alien os ( string -- alien )
: dll-path ( dll -- string )
path>> alien>native-string ;
: string>symbol ( str -- alien )
- [ os wince? [ utf16n ] [ utf8 ] if string>alien ]
- over string? [ call ] [ map ] if ;
+ dup string?
+ [ native-string>alien ]
+ [ [ native-string>alien ] map ] if ;
{ "char*" utf8 } "char*" typedef
-{ "char*" utf16n } "wchar_t*" typedef
"char*" "uchar*" typedef
+
+{
+ { [ os windows? ] [ "alien.strings.windows" require ] }
+ { [ os unix? ] [ "alien.strings.unix" require ] }
+} cond
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.strings io.encodings.utf8 system ;
+IN: alien.strings.unix
+
+M: unix alien>native-string utf8 alien>string ;
+
+M: unix native-string>alien utf8 string>alien ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.strings alien.c-types io.encodings.utf8
+io.encodings.utf16n system ;
+IN: alien.strings.windows
+
+M: windows alien>native-string utf16n alien>string ;
+
+M: wince native-string>alien utf16n string>alien ;
+
+M: winnt native-string>alien utf8 string>alien ;
+
+{ "char*" utf16n } "wchar_t*" typedef
USING: accessors arrays alien alien.c-types alien.structs
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
-effects prettyprint prettyprint.sections prettyprint.backend
-assocs combinators lexer strings.parser alien.parser ;
+effects assocs combinators lexer strings.parser alien.parser ;
IN: alien.syntax
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
dup length
[ [ create-in ] dip 1quotation define ] 2each ;
parsing
-
-M: alien pprint*
- {
- { [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
- { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
- [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
- } cond ;
-
-M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types accessors math alien.accessors kernel
kernel.private locals sequences sequences.private byte-arrays
-parser prettyprint.backend fry ;
+parser prettyprint.custom fry ;
IN: bit-arrays
TUPLE: bit-array
:: integer>bit-array ( n -- bit-array )
n zero? [ 0 <bit-array> ] [
[let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
- [ n' zero? not ] [
+ [ n' zero? ] [
n' out underlying>> i set-alien-unsigned-1
n' -8 shift n'!
i 1+ i!
- ] [ ] while
+ ] [ ] until
out
]
] if ;
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: arrays kernel kernel.private math sequences\r
-sequences.private growable bit-arrays prettyprint.backend\r
+sequences.private growable bit-arrays prettyprint.custom\r
parser accessors ;\r
IN: bit-vectors\r
\r
--- /dev/null
+USING: continuations kernel io debugger vocabs words system namespaces ;
+
+:c
+:error
+"listener" vocab
+[ restarts. vocab-main execute ]
+[ die ] if*
+1 exit
classes.private arrays hashtables vectors classes.tuple sbufs
hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words command-line vocabs io
-io.encodings.string prettyprint libc splitting math.parser
+io.encodings.string libc splitting math.parser
compiler.units math.order compiler.tree.builder
compiler.tree.optimizer compiler.cfg.optimizer ;
IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a
! reference to 'eval' in a global variable
-"deploy-vocab" get [
+"deploy-vocab" get "staging" get or [
"alien.remote-control" require
] unless
+"prettyprint" vocab [
+ "stack-checker.errors.prettyprint" require
+ "alien.prettyprint" require
+] when
+
"cpu." cpu name>> append require
enable-compiler
"." write flush
{
- new-sequence nth push pop peek
+ new-sequence nth push pop peek flip
} compile-uncompiled
"." write flush
"." write flush
{
- . malloc calloc free memcpy
+ malloc calloc free memcpy
} compile-uncompiled
"." write flush
--- /dev/null
+USING: init command-line debugger system continuations
+namespaces eval kernel vocabs.loader io ;
+
+[
+ boot
+ do-init-hooks
+ [
+ (command-line) parse-command-line
+ load-vocab-roots
+ run-user-init
+ "e" get [ eval ] when*
+ ignore-cli-args? not script get and
+ [ run-script ] [ "run" get run ] if*
+ output-stream get [ stream-flush ] when*
+ ] [ print-error 1 exit ] recover
+] set-boot-quot
--- /dev/null
+USING: init command-line system namespaces kernel vocabs.loader
+io ;
+
+[
+ boot
+ do-init-hooks
+ (command-line) parse-command-line
+ "run" get run
+ output-stream get [ stream-flush ] when*
+] set-boot-quot
os name>> cpu name>> arch ;
: boot-image-name ( arch -- string )
- "boot." swap ".image" 3append ;
+ "boot." ".image" surround ;
: my-boot-image-name ( -- string )
my-arch boot-image-name ;
-USE: vocabs.loader
+USING: vocabs vocabs.loader kernel ;
"math.ratios" require
"math.floats" require
"math.complex" require
+
+"prettyprint" vocab [ "math.complex.prettyprint" require ] when
! See http://factorcode.org/license.txt for BSD license.
USING: accessors init namespaces words io
kernel.private math memory continuations kernel io.files
-io.backend system parser vocabs sequences prettyprint
+io.backend system parser vocabs sequences
vocabs.loader combinators splitting source-files strings
definitions assocs compiler.errors compiler.units
-math.parser generic sets debugger command-line ;
+math.parser generic sets command-line ;
IN: bootstrap.stage2
SYMBOL: core-bootstrap-time
f error set-global
f error-continuation set-global
+ millis swap - bootstrap-time set-global
+ print-report
+
"deploy-vocab" get [
"tools.deploy.shaker" run
] [
- [
- boot
- do-init-hooks
- handle-command-line
- ] set-boot-quot
-
- millis swap - bootstrap-time set-global
- print-report
+ "staging" get [
+ "resource:basis/bootstrap/finish-staging.factor" run-file
+ ] [
+ "resource:basis/bootstrap/finish-bootstrap.factor" run-file
+ ] if
"output-image" get save-image-and-exit
] if
-] [
- :c
- dup print-error flush
- "listener" vocab
- [ restarts. vocab-main execute ]
- [ die ] if*
- 1 exit
-] recover
+] [ drop "resource:basis/bootstrap/bootstrap-error.factor" run-file ] recover
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: vocabs vocabs.loader kernel ;
IN: bootstrap.threads
USE: io.thread
USE: threads
-USE: debugger.threads
+
+"debugger" vocab [
+ "debugger.threads" require
+] when
--- /dev/null
+USING: arrays byte-arrays help.markup help.syntax kernel\r
+byte-vectors.private combinators ;\r
+IN: byte-vectors\r
+\r
+ARTICLE: "byte-vectors" "Byte vectors"\r
+"A byte vector is a resizable mutable sequence of unsigned bytes. Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary."\r
+$nl\r
+"Byte vectors form a class:"\r
+{ $subsection byte-vector }\r
+{ $subsection byte-vector? }\r
+"Creating byte vectors:"\r
+{ $subsection >byte-vector }\r
+{ $subsection <byte-vector> }\r
+"Literal syntax:"\r
+{ $subsection POSTPONE: BV{ }\r
+"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"\r
+{ $code "BV{ } clone" } ;\r
+\r
+ABOUT: "byte-vectors"\r
+\r
+HELP: byte-vector\r
+{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ;\r
+\r
+HELP: <byte-vector>\r
+{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }\r
+{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;\r
+\r
+HELP: >byte-vector\r
+{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }\r
+{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }\r
+{ $errors "Throws an error if the sequence contains elements other than integers." } ;\r
+\r
+HELP: BV{\r
+{ $syntax "BV{ elements... }" }\r
+{ $values { "elements" "a list of bytes" } }\r
+{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } \r
+{ $examples { $code "BV{ 1 2 3 12 }" } } ;\r
--- /dev/null
+IN: byte-vectors.tests\r
+USING: tools.test byte-vectors vectors sequences kernel\r
+prettyprint ;\r
+\r
+[ 0 ] [ 123 <byte-vector> length ] unit-test\r
+\r
+: do-it\r
+ 123 [ over push ] each ;\r
+\r
+[ t ] [\r
+ 3 <byte-vector> do-it\r
+ 3 <vector> do-it sequence=\r
+] unit-test\r
+\r
+[ t ] [ BV{ } byte-vector? ] unit-test\r
+\r
+[ "BV{ }" ] [ BV{ } unparse ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: arrays kernel kernel.private math sequences\r
+sequences.private growable byte-arrays accessors parser\r
+prettyprint.custom ;\r
+IN: byte-vectors\r
+\r
+TUPLE: byte-vector\r
+{ underlying byte-array }\r
+{ length array-capacity } ;\r
+\r
+: <byte-vector> ( n -- byte-vector )\r
+ (byte-array) 0 byte-vector boa ; inline\r
+\r
+: >byte-vector ( seq -- byte-vector )\r
+ T{ byte-vector f B{ } 0 } clone-like ;\r
+\r
+M: byte-vector like\r
+ drop dup byte-vector? [\r
+ dup byte-array?\r
+ [ dup length byte-vector boa ] [ >byte-vector ] if\r
+ ] unless ;\r
+\r
+M: byte-vector new-sequence\r
+ drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;\r
+\r
+M: byte-vector equal?\r
+ over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
+\r
+M: byte-array like\r
+ #! If we have an byte-array, we're done.\r
+ #! If we have a byte-vector, and it's at full capacity,\r
+ #! we're done. Otherwise, call resize-byte-array, which is a\r
+ #! relatively fast primitive.\r
+ drop dup byte-array? [\r
+ dup byte-vector? [\r
+ [ length ] [ underlying>> ] bi\r
+ 2dup length eq?\r
+ [ nip ] [ resize-byte-array ] if\r
+ ] [ >byte-array ] if\r
+ ] unless ;\r
+\r
+M: byte-array new-resizable drop <byte-vector> ;\r
+\r
+: BV{ \ } [ >byte-vector ] parse-literal ; parsing\r
+\r
+M: byte-vector pprint* pprint-object ;\r
+M: byte-vector pprint-delims drop \ BV{ \ } ;\r
+M: byte-vector >pprint-sequence ;\r
+\r
+INSTANCE: byte-vector growable\r
--- /dev/null
+Growable byte arrays
--- /dev/null
+collections
{ $values { "integer" integer } }
{ $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
-HELP: biweekly
-{ $values
- { "x" number }
- { "y" number }
-}
-{ $description "Divides a number by the number of two week periods in a year." } ;
-
-HELP: daily-360
-{ $values
- { "x" number }
- { "y" number }
-}
-{ $description "Divides a number by the number of days in a 360-day year." } ;
-
-HELP: daily-365
-{ $values
- { "x" number }
- { "y" number }
-}
-{ $description "Divides a number by the number of days in a 365-day year." } ;
-
-HELP: monthly
-{ $values
- { "x" number }
- { "y" number }
-}
-{ $description "Divides a number by the number of months in a year." } ;
-
-HELP: semimonthly
-{ $values
- { "x" number }
- { "y" number }
-}
-{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ;
-
-HELP: weekly
-{ $values
- { "x" number }
- { "y" number }
-}
-{ $description "Divides a number by the number of weeks in a year." } ;
-
HELP: julian-day-number
{ $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } }
{ $description "Calculates the Julian day number from a year, month, and day. The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." }
{ $subsection "years" }
{ $subsection "months" }
{ $subsection "days" }
-"Calculating amounts per period of time:"
-{ $subsection "time-period-calculations" }
"Meta-data about the calendar:"
{ $subsection "calendar-facts" }
;
{ $subsection day-of-week }
;
-ARTICLE: "time-period-calculations" "Calculations over periods of time"
-{ $subsection monthly }
-{ $subsection semimonthly }
-{ $subsection biweekly }
-{ $subsection weekly }
-{ $subsection daily-360 }
-{ $subsection daily-365 }
-{ $subsection biweekly }
-{ $subsection biweekly }
-{ $subsection biweekly }
-;
-
ARTICLE: "years" "Year operations"
"Leap year predicate:"
{ $subsection leap-year? }
[ t ] [ now 50 milliseconds sleep now before? ] unit-test
[ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
-
-[ 4+1/6 ] [ 100 semimonthly ] unit-test
: minutes-per-year ( -- ratio ) 5259492/10 ; inline
: seconds-per-year ( -- integer ) 31556952 ; inline
-: monthly ( x -- y ) 12 / ; inline
-: semimonthly ( x -- y ) 24 / ; inline
-: biweekly ( x -- y ) 26 / ; inline
-: weekly ( x -- y ) 52 / ; inline
-: daily-360 ( x -- y ) 360 / ; inline
-: daily-365 ( x -- y ) 365 / ; inline
-
:: julian-day-number ( year month day -- n )
#! Returns a composite date number
#! Not valid before year -4800
-USING: math math.order math.parser math.functions kernel sequences io\r
-accessors arrays io.streams.string splitting\r
-combinators accessors debugger\r
-calendar calendar.format.macros ;\r
+! Copyright (C) 2008 Slava Pestov.\r
+! 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
IN: calendar.format\r
\r
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ;\r
]\r
} formatted\r
] with-string-writer ;\r
+\r
+M: timestamp present timestamp>string ;\r
math.functions math.parser namespaces splitting grouping strings
sequences byte-arrays locals sequences.private
io.encodings.binary symbols math.bitwise checksums
-checksums.common ;
+checksums.common checksums.stream ;
IN: checksums.md5
! See http://www.faqs.org/rfcs/rfc1321.html
SINGLETON: md5
-INSTANCE: md5 checksum
+INSTANCE: md5 stream-checksum
M: md5 checksum-stream ( stream -- byte-array )
drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ;
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays alien.c-types kernel continuations
-destructors sequences io openssl openssl.libcrypto checksums ;
+destructors sequences io openssl openssl.libcrypto checksums
+checksums.stream ;
IN: checksums.openssl
ERROR: unknown-digest name ;
: openssl-sha1 T{ openssl-checksum f "sha1" } ;
-INSTANCE: openssl-checksum checksum
+INSTANCE: openssl-checksum stream-checksum
C: <openssl-checksum> openssl-checksum
USING: arrays combinators kernel io io.encodings.binary io.files
io.streams.byte-array math.vectors strings sequences namespaces
make math parser sequences assocs grouping vectors io.binary
-hashtables symbols math.bitwise checksums checksums.common ;
+hashtables symbols math.bitwise checksums checksums.common
+checksums.stream ;
IN: checksums.sha1
! Implemented according to RFC 3174.
SINGLETON: sha1
-INSTANCE: sha1 checksum
+INSTANCE: sha1 stream-checksum
M: sha1 checksum-stream ( stream -- sha1 )
drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.binary io.streams.byte-array kernel
+checksums ;
+IN: checksums.stream
+
+MIXIN: stream-checksum
+
+M: stream-checksum checksum-bytes
+ [ binary <byte-reader> ] dip checksum-stream ;
+
+INSTANCE: stream-checksum checksum
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
core-foundation.run-loop cocoa.messages cocoa cocoa.classes
-cocoa.runtime sequences threads debugger init summary
-kernel.private assocs ;
+cocoa.runtime sequences threads init summary kernel.private
+assocs ;
IN: cocoa.application
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
-combinators compiler compiler.alien kernel math namespaces make
-parser prettyprint prettyprint.sections quotations sequences
-strings words cocoa.runtime io macros memoize debugger
-io.encodings.ascii effects libc libc.private parser lexer init
-core-foundation fry generalizations
-specialized-arrays.direct.alien ;
+continuations combinators compiler compiler.alien kernel math
+namespaces make parser quotations sequences strings words
+cocoa.runtime io macros memoize io.encodings.utf8
+effects libc libc.private parser lexer init core-foundation fry
+generalizations specialized-arrays.direct.alien ;
IN: cocoa.messages
: make-sender ( method function -- quot )
[ over first , f , , second , \ alien-invoke , ] [ ] make ;
-: sender-stub-name ( method function -- string )
- [ % "_" % unparse % ] "" make ;
-
: sender-stub ( method function -- word )
- [ sender-stub-name f <word> dup ] 2keep
+ [ "( sender-stub )" f <word> dup ] 2dip
over first large-struct? [ "_stret" append ] when
make-sender define ;
: send ( receiver args... selector -- return... ) f (send) ; inline
-\ send soft "break-after" set-word-prop
-
: super-send ( receiver args... selector -- return... ) t (send) ; inline
-\ super-send soft "break-after" set-word-prop
-
! Runtime introspection
SYMBOL: class-init-hooks
: (objc-class) ( name word -- class )
2dup execute dup [ 2nip ] [
- drop over class-init-hooks get at [ call ] when*
+ drop over class-init-hooks get at [ assert-depth ] when*
2dup execute dup [ 2nip ] [
2drop "No such class: " prepend throw
] if
: method-arg-type ( method i -- type )
method_copyArgumentType
- [ ascii alien>string parse-objc-type ] keep
+ [ utf8 alien>string parse-objc-type ] keep
(free) ;
: method-arg-types ( method -- args )
: method-return-type ( method -- ctype )
method_copyReturnType
- [ ascii alien>string parse-objc-type ] keep
+ [ utf8 alien>string parse-objc-type ] keep
(free) ;
: register-objc-method ( method -- )
: register-objc-methods ( class -- )
[ register-objc-method ] each-method-in-class ;
-: method. ( method -- )
- {
- [ method_getName sel_getName ]
- [ method-return-type ]
- [ method-arg-types ]
- [ method_getImplementation ]
- } cleave 4array . ;
-
-: methods. ( class -- )
- [ method. ] each-method-in-class ;
-
: class-exists? ( string -- class ) objc_getClass >boolean ;
: define-objc-class-word ( quot name -- )
: import-objc-class ( name quot -- )
over define-objc-class-word
- '[
- _
- [ objc-class register-objc-methods ]
- [ objc-meta-class register-objc-methods ] bi
- ] try ;
+ [ objc-class register-objc-methods ]
+ [ objc-meta-class register-objc-methods ] bi ;
: root-class ( class -- root )
dup class_getSuperclass [ root-class ] [ ] ?if ;
USING: alien alien.c-types alien.strings arrays assocs
combinators compiler hashtables kernel libc math namespaces
parser sequences words cocoa.messages cocoa.runtime locals
-compiler.units io.encodings.ascii continuations make fry ;
+compiler.units io.encodings.utf8 continuations make fry ;
IN: cocoa.subclassing
: init-method ( method -- sel imp types )
first3 swap
- [ sel_registerName ] [ execute ] [ ascii string>alien ]
+ [ sel_registerName ] [ execute ] [ utf8 string>alien ]
tri* ;
: throw-if-false ( obj what -- )
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: init continuations debugger hashtables io
-io.encodings.utf8 io.files kernel kernel.private namespaces
-parser sequences strings system splitting eval vocabs.loader ;
+USING: init continuations hashtables io io.encodings.utf8
+io.files kernel kernel.private namespaces parser sequences
+strings system splitting vocabs.loader ;
IN: command-line
SYMBOL: script
] [ drop ] if
] when ;
-<PRIVATE
-
: var-param ( name value -- ) swap set-global ;
: bool-param ( name -- ) "no-" ?head not var-param ;
: run-script ( file -- )
t "quiet" set-global run-file ;
-PRIVATE>
-
: parse-command-line ( args -- )
[ command-line off script off ] [
unclip "-" ?head
: script-mode ( -- ) ;
-: handle-command-line ( -- )
- [
- (command-line) parse-command-line
- load-vocab-roots
- run-user-init
- "e" get [ eval ] when*
- ignore-cli-args? not script get and
- [ run-script ] [ "run" get run ] if*
- output-stream get [ stream-flush ] when*
- ] [ print-error 1 exit ] recover ;
-
[ default-cli-args ] "command-line" add-init-hook
USING: compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.alias-analysis cpu.architecture tools.test
-kernel ;
+compiler.cfg.alias-analysis compiler.cfg.debugger
+cpu.architecture tools.test kernel ;
IN: compiler.cfg.alias-analysis.tests
[ ] [
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces assocs hashtables sequences
+USING: kernel math namespaces assocs hashtables sequences arrays
accessors vectors combinators sets classes compiler.cfg
compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.copy-prop ;
M: ##slot-imm insn-slot# slot>> ;
M: ##set-slot insn-slot# slot>> constant ;
M: ##set-slot-imm insn-slot# slot>> ;
+M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
M: ##peek insn-object loc>> class ;
M: ##replace insn-object loc>> class ;
M: ##slot-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ;
+M: ##alien-global insn-object drop \ ##alien-global ;
: init-alias-analysis ( -- )
H{ } clone histories set
M: ##load-indirect analyze-aliases*
dup dst>> set-heap-ac ;
+M: ##alien-global analyze-aliases*
+ dup dst>> set-heap-ac ;
+
M: ##allot analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
USING: compiler.cfg.dead-code compiler.cfg.instructions
-compiler.cfg.registers cpu.architecture tools.test ;
+compiler.cfg.registers compiler.cfg.debugger
+cpu.architecture tools.test ;
IN: compiler.cfg.dead-code.tests
[ { } ] [
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io
classes.tuple accessors prettyprint prettyprint.config
-compiler.tree.builder compiler.tree.optimizer
+prettyprint.backend prettyprint.custom prettyprint.sections
+parser compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.linearization
-compiler.cfg.stack-frame compiler.cfg.linear-scan
-compiler.cfg.two-operand compiler.cfg.optimizer ;
+compiler.cfg.registers compiler.cfg.stack-frame
+compiler.cfg.linear-scan compiler.cfg.two-operand
+compiler.cfg.optimizer ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
instructions>> [ insn. ] each
nl
] each ;
+
+! Prettyprinting
+M: vreg pprint*
+ <block
+ \ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
+ block> ;
+
+: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
+
+M: ds-loc pprint* \ D pprint-loc ;
+
+M: rs-loc pprint* \ R pprint-loc ;
: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
: ^^not ( src -- dst ) ^^i1 ##not ; inline
+: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline
: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
+: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; inline
: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
INSN: ##shr-imm < ##binary-imm ;
INSN: ##sar-imm < ##binary-imm ;
INSN: ##not < ##unary ;
+INSN: ##log2 < ##unary ;
! Overflowing arithmetic
TUPLE: ##fixnum-overflow < insn src1 src2 ;
INSN: ##allot < ##flushable size class { temp vreg } ;
INSN: ##write-barrier < ##effect card# table ;
+INSN: ##alien-global < ##read symbol library ;
+
! FFI
INSN: ##alien-invoke params ;
INSN: ##alien-indirect params ;
IN: compiler.cfg.intrinsics.fixnum
: emit-both-fixnums? ( -- )
- D 0 ^^peek
- D 1 ^^peek
+ 2inputs
^^or
tag-mask get ^^and-imm
0 cc= ^^compare-imm
: emit-fixnum-bitnot ( -- )
ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
+: emit-fixnum-log2 ( -- )
+ ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
+
: (emit-fixnum*fast) ( -- dst )
2inputs ^^untag-fixnum ^^mul ;
compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float
compiler.cfg.intrinsics.slots
+compiler.cfg.intrinsics.misc
compiler.cfg.iterator ;
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: strings.private
QUALIFIED: classes.tuple.private
QUALIFIED: math.private
+QUALIFIED: math.integers.private
QUALIFIED: alien.accessors
IN: compiler.cfg.intrinsics
{
kernel.private:tag
+ kernel.private:getenv
math.private:both-fixnums?
math.private:fixnum+
math.private:fixnum-
alien.accessors:set-alien-double
} [ t "intrinsic" set-word-prop ] each ;
+: enable-fixnum-log2 ( -- )
+ \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
+
: emit-intrinsic ( node word -- node/f )
{
{ \ kernel.private:tag [ drop emit-tag iterate-next ] }
+ { \ kernel.private:getenv [ emit-getenv iterate-next ] }
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
+ { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
{ \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces layouts sequences kernel
+accessors compiler.tree.propagation.info
+compiler.cfg.stacks compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.utilities ;
+IN: compiler.cfg.intrinsics.misc
+
+: emit-tag ( -- )
+ ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
+
+: emit-getenv ( node -- )
+ "userenv" f ^^alien-global
+ swap node-input-infos first literal>>
+ [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
+ ds-push ;
compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.slots
-: emit-tag ( -- )
- ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
-
: value-tag ( info -- n ) class>> class-tag ; inline
: (emit-slot) ( infos -- dst )
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel arrays
-parser prettyprint.backend prettyprint.sections ;
+USING: accessors namespaces kernel arrays parser ;
IN: compiler.cfg.registers
! Virtual registers, used by CFG and machine IRs
TUPLE: rs-loc < loc ;
C: <rs-loc> rs-loc
-! Prettyprinting
: V scan-word scan-word vreg boa parsed ; parsing
-
-M: vreg pprint*
- <block
- \ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
- block> ;
-
-: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
-
: D scan-word <ds-loc> parsed ; parsing
-
-M: ds-loc pprint* \ D pprint-loc ;
-
: R scan-word <rs-loc> parsed ; parsing
-
-M: rs-loc pprint* \ R pprint-loc ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel sequences sequences.deep
+USING: accessors arrays kernel sequences compiler.utilities
compiler.cfg.instructions cpu.architecture ;
IN: compiler.cfg.two-operand
: convert-two-operand ( mr -- mr' )
[
two-operand? [
- [ convert-two-operand* ] map flatten
+ [ convert-two-operand* ] map-flat
] when
] change-instructions ;
IN: compiler.cfg.value-numbering.tests
USING: compiler.cfg.value-numbering compiler.cfg.instructions
-compiler.cfg.registers cpu.architecture tools.test kernel math
-combinators.short-circuit accessors sequences ;
+compiler.cfg.registers compiler.cfg.debugger cpu.architecture
+tools.test kernel math combinators.short-circuit accessors
+sequences ;
: trim-temps ( insns -- insns )
[
USING: compiler.cfg.write-barrier compiler.cfg.instructions
-compiler.cfg.registers cpu.architecture arrays tools.test ;
+compiler.cfg.registers compiler.cfg.debugger cpu.architecture
+arrays tools.test ;
IN: compiler.cfg.write-barrier.tests
[
M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
M: ##not generate-insn dst/src %not ;
+M: ##log2 generate-insn dst/src %log2 ;
: src1/src2 ( insn -- src1 src2 )
[ src1>> register ] [ src2>> register ] bi ; inline
M: ##loop-entry generate-insn drop %loop-entry ;
+M: ##alien-global generate-insn
+ [ dst>> register ] [ symbol>> ] [ library>> ] tri
+ %alien-global ;
+
! ##alien-invoke
GENERIC: reg-size ( register-class -- n )
TUPLE: callback-context ;
-: current-callback 2 getenv ;
+: current-callback ( -- id ) 2 getenv ;
: wait-to-return ( token -- )
dup current-callback eq? [
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays generic assocs hashtables io.binary
-kernel kernel.private math namespaces make sequences words
-quotations strings alien.accessors alien.strings layouts system
-combinators math.bitwise words.private math.order accessors
-growable cpu.architecture compiler.constants ;
+USING: arrays byte-arrays byte-vectors generic assocs hashtables
+io.binary kernel kernel.private math namespaces make sequences
+words quotations strings alien.accessors alien.strings layouts
+system combinators math.bitwise words.private math.order
+accessors growable cpu.architecture compiler.constants ;
IN: compiler.codegen.fixup
GENERIC: fixup* ( obj -- )
-: code-format 22 getenv ;
+: code-format ( -- n ) 22 getenv ;
: compiled-offset ( -- n ) building get length code-format * ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces arrays sequences io debugger
-words fry continuations vocabs assocs dlists definitions
-math threads graphs generic combinators deques search-deques
-prettyprint io stack-checker stack-checker.state
-stack-checker.inlining compiler.errors compiler.units
-compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.builder compiler.cfg.optimizer
-compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.linear-scan compiler.cfg.stack-frame
-compiler.codegen ;
+USING: accessors kernel namespaces arrays sequences io
+words fry continuations vocabs assocs dlists definitions math
+threads graphs generic combinators deques search-deques io
+stack-checker stack-checker.state stack-checker.inlining
+compiler.errors compiler.units compiler.tree.builder
+compiler.tree.optimizer compiler.cfg.builder
+compiler.cfg.optimizer compiler.cfg.linearization
+compiler.cfg.two-operand compiler.cfg.linear-scan
+compiler.cfg.stack-frame compiler.codegen ;
IN: compiler
SYMBOL: compile-queue
2bi ;
: start ( word -- )
- "trace-compilation" get [ dup . flush ] when
+ "trace-compilation" get [ dup name>> print flush ] when
H{ } clone dependencies set
H{ } clone generic-dependencies set
f swap compiler-error ;
: loop-ccc ( -- ) loop-bbb ;
[ 0 ] [ 0 counter set loop-ccc counter get ] unit-test
+
+! Type inference issue
+[ 4 3 ] [
+ 1 >bignum 2 >bignum
+ [ { bignum integer } declare [ shift ] keep 1+ ] compile-call
+] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences sequences.deep combinators fry
+USING: kernel accessors sequences combinators fry
classes.algebra namespaces assocs words math math.private
math.partial-dispatch math.intervals classes classes.tuple
classes.tuple.private layouts definitions stack-checker.state
stack-checker.branches
+compiler.utilities
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
: cleanup ( nodes -- nodes' )
#! We don't recurse into children here, instead the methods
#! do it since the logic is a bit more involved
- [ cleanup* ] map flatten ;
+ [ cleanup* ] map-flat ;
: cleanup-folding? ( #call -- ? )
node-output-infos
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs fry kernel accessors sequences sequences.deep arrays
-stack-checker.inlining namespaces compiler.tree ;
+USING: assocs fry kernel accessors sequences compiler.utilities
+arrays stack-checker.inlining namespaces compiler.tree
+math.order ;
IN: compiler.tree.combinators
: each-node ( nodes quot: ( node -- ) -- )
[ _ map-nodes ] change-child
] when
] if
- ] map flatten ; inline recursive
+ ] map-flat ; inline recursive
: contains-node? ( nodes quot: ( node -- ? ) -- ? )
dup dup '[
: sift-children ( seq flags -- seq' )
zip [ nip ] assoc-filter keys ;
-: (3each) [ 3array flip ] dip '[ first3 @ ] ; inline
-
-: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
-
-: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline
-
: until-fixed-point ( #recursive quot: ( node -- ) -- )
over label>> t >>fixed-point drop
[ with-scope ] 2keep
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors namespaces assocs deques search-deques
-dlists kernel sequences sequences.deep words sets
+dlists kernel sequences compiler.utilities words sets
stack-checker.branches compiler.tree compiler.tree.def-use
compiler.tree.combinators ;
IN: compiler.tree.dead-code.liveness
M: node remove-dead-code* ;
: (remove-dead-code) ( nodes -- nodes' )
- [ remove-dead-code* ] map flatten ;
+ [ remove-dead-code* ] map-flat ;
[ out-d>> ] [ label>> return>> in-d>> ] bi look-at-mapping ;
:: drop-dead-inputs ( inputs outputs -- #shuffle )
- [let* | live-inputs [ inputs filter-live ]
- new-live-inputs [ outputs inputs filter-corresponding make-values ] |
- live-inputs
- new-live-inputs
- outputs
- inputs
- drop-values
- ] ;
+ inputs filter-live
+ outputs inputs filter-corresponding make-values
+ outputs
+ inputs
+ drop-values ;
M: #enter-recursive remove-dead-code*
[ filter-live ] change-out-d ;
bi
] ;
-M:: #recursive remove-dead-code* ( node -- nodes )
- [let* | drop-inputs [ node drop-recursive-inputs ]
- drop-outputs [ node drop-recursive-outputs ] |
- node [ (remove-dead-code) ] change-child drop
- node label>> [ filter-live ] change-enter-out drop
- { drop-inputs node drop-outputs }
- ] ;
+M: #recursive remove-dead-code* ( node -- nodes )
+ [ drop-recursive-inputs ]
+ [
+ [ (remove-dead-code) ] change-child
+ dup label>> [ filter-live ] change-enter-out drop
+ ]
+ [ drop-recursive-outputs ] tri 3array ;
M: #return-recursive remove-dead-code* ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
-prettyprint prettyprint.backend prettyprint.sections math words
-combinators combinators.short-circuit io sorting hints qualified
+prettyprint prettyprint.backend prettyprint.custom
+prettyprint.sections math words combinators
+combinators.short-circuit io sorting hints qualified
compiler.tree
compiler.tree.recursive
compiler.tree.normalization
H{ } clone intrinsics-called set
0 swap [
- >r 1+ r>
+ [ 1+ ] dip
dup #call? [
word>> {
{ [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
{ [ dup generic? ] [ generics-called ] }
{ [ dup method-body? ] [ methods-called ] }
[ words-called ]
- } cond 1 -rot get at+
+ } cond inc-at
] [ drop ] if
] each-node
node-count set
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences sequences.deep kernel
+USING: sequences kernel fry vectors
compiler.tree compiler.tree.def-use ;
IN: compiler.tree.def-use.simplified
! A 'real' usage is a usage of a value that is not a #renaming.
TUPLE: real-usage value node ;
-GENERIC: actually-used-by* ( value node -- real-usages )
-
! Def
GENERIC: actually-defined-by* ( value node -- real-usage )
M: node actually-defined-by* real-usage boa ;
! Use
-: (actually-used-by) ( value -- real-usages )
- dup used-by [ actually-used-by* ] with map ;
+GENERIC# actually-used-by* 1 ( value node accum -- )
+
+: (actually-used-by) ( value accum -- )
+ [ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ;
M: #renaming actually-used-by*
- inputs/outputs [ indices ] dip nths
- [ (actually-used-by) ] map ;
+ [ inputs/outputs [ indices ] dip nths ] dip
+ '[ _ (actually-used-by) ] each ;
-M: #return-recursive actually-used-by* real-usage boa ;
+M: #return-recursive actually-used-by* [ real-usage boa ] dip push ;
-M: node actually-used-by* real-usage boa ;
+M: node actually-used-by* [ real-usage boa ] dip push ;
: actually-used-by ( value -- real-usages )
- (actually-used-by) flatten ;
+ 10 <vector> [ (actually-used-by) ] keep ;
2bi ;
M: #phi escape-analysis*
- [ phi-in-d>> <flipped> ] [ out-d>> ] bi merge-allocations ;
+ [ phi-in-d>> flip ] [ out-d>> ] bi merge-allocations ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes classes.tuple math math.private accessors
+combinators kernel compiler.tree compiler.tree.combinators
+compiler.tree.propagation.info ;
+IN: compiler.tree.escape-analysis.check
+
+GENERIC: run-escape-analysis* ( node -- ? )
+
+M: #push run-escape-analysis*
+ literal>> [ class immutable-tuple-class? ] [ complex? ] bi or ;
+
+M: #call run-escape-analysis*
+ {
+ { [ dup word>> \ <complex> eq? ] [ t ] }
+ { [ dup immutable-tuple-boa? ] [ t ] }
+ [ f ]
+ } cond nip ;
+
+M: node run-escape-analysis* drop f ;
+
+: run-escape-analysis? ( nodes -- ? )
+ [ run-escape-analysis* ] contains-node? ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences words memoize classes.builtin
+USING: kernel accessors sequences words memoize combinators
+classes classes.builtin classes.tuple math.partial-dispatch
fry assocs
compiler.tree
compiler.tree.combinators
! See the comment in compiler.tree.late-optimizations.
! This pass runs after propagation, so that it can expand
-! built-in type predicates; these cannot be expanded before
+! type predicates; these cannot be expanded before
! propagation since we need to see 'fixnum?' instead of
! 'tag 0 eq?' and so on, for semantic reasoning.
[ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
bi and [ drop f ] when ;
-: builtin-predicate? ( #call -- ? )
- word>> "predicating" word-prop builtin-class? ;
-
-MEMO: builtin-predicate-expansion ( word -- nodes )
+MEMO: cached-expansion ( word -- nodes )
def>> splice-final ;
-: expand-builtin-predicate ( #call -- nodes )
- word>> builtin-predicate-expansion ;
+GENERIC: finalize-word ( #call word -- nodes )
+
+M: predicate finalize-word
+ "predicating" word-prop {
+ { [ dup builtin-class? ] [ drop word>> cached-expansion ] }
+ { [ dup tuple-class? ] [ drop word>> def>> splice-final ] }
+ [ drop ]
+ } cond ;
+
+! M: math-partial finalize-word
+! dup primitive? [ drop ] [ nip cached-expansion ] if ;
+
+M: word finalize-word drop ;
M: #call finalize*
- dup builtin-predicate? [ expand-builtin-predicate ] when ;
+ dup word>> finalize-word ;
M: node finalize* ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces sequences math accessors kernel arrays
-combinators sequences.deep assocs
+combinators compiler.utilities assocs
stack-checker.backend
stack-checker.branches
stack-checker.inlining
+compiler.utilities
compiler.tree
compiler.tree.combinators
compiler.tree.normalization.introductions
[
[
[
- [ normalize* ] map flatten
+ [ normalize* ] map-flat
introduction-stack get
2array
] with-scope
: (normalize) ( nodes introductions -- nodes )
introduction-stack [
- [ normalize* ] map flatten
+ [ normalize* ] map-flat
] with-variable ;
M: #recursive normalize*
compiler.tree.propagation
compiler.tree.cleanup
compiler.tree.escape-analysis
+compiler.tree.escape-analysis.check
compiler.tree.tuple-unboxing
compiler.tree.identities
compiler.tree.def-use
normalize
propagate
cleanup
- escape-analysis
- unbox-tuples
+ dup run-escape-analysis? [
+ escape-analysis
+ unbox-tuples
+ ] when
apply-identities
compute-def-use
remove-dead-code
USING: fry kernel sequences assocs accessors namespaces
math.intervals arrays classes.algebra combinators columns
stack-checker.branches
+compiler.utilities
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
M: #phi propagate-before ( #phi -- )
[ annotate-phi-inputs ]
- [ [ phi-info-d>> <flipped> ] [ out-d>> ] bi merge-value-infos ]
+ [ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ]
bi ;
: branch-phi-constraints ( output values booleans -- )
M: #phi propagate-after ( #phi -- )
condition-value get [
[ out-d>> ]
- [ phi-in-d>> <flipped> ]
- [ phi-info-d>> <flipped> ] tri
+ [ phi-in-d>> flip ]
+ [ phi-info-d>> flip ] tri
[
[ possible-boolean-values ] map
branch-phi-constraints
] 2each ;
M: #phi compute-copy-equiv*
- [ phi-in-d>> <flipped> ] [ out-d>> ] bi compute-phi-equiv ;
+ [ phi-in-d>> flip ] [ out-d>> ] bi compute-phi-equiv ;
M: node compute-copy-equiv* drop ;
] [ 2drop f >>method f >>body f >>class drop f ] if ;
: inlining-standard-method ( #call word -- class/f method/f )
- [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
- [ swap nth value-info class>> dup ] dip
- specific-method ;
+ dup "methods" word-prop assoc-empty? [ 2drop f f ] [
+ [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
+ [ swap nth value-info class>> dup ] dip
+ specific-method
+ ] if ;
: inline-standard-method ( #call word -- ? )
dupd inlining-standard-method eliminate-dispatch ;
SYMBOL: history
: remember-inlining ( word -- )
- [ [ 1 ] dip inlining-count get at+ ]
+ [ inlining-count get inc-at ]
[ history [ swap suffix ] change ]
bi ;
over in-d>> second value-info literal>> dup class?
[ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
-: do-inlining ( #call word -- ? )
+: (do-inlining) ( #call word -- ? )
#! If the generic was defined in an outer compilation unit,
#! then it doesn't have a definition yet; the definition
#! is built at the end of the compilation unit. We do not
#! discouraged, but it should still work.)
{
{ [ dup deferred? ] [ 2drop f ] }
- { [ dup custom-inlining? ] [ inline-custom ] }
{ [ dup \ instance? eq? ] [ inline-instance-check ] }
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup method-body? ] [ inline-method-body ] }
[ 2drop f ]
} cond ;
+
+: do-inlining ( #call word -- ? )
+ #! Note the logic here: if there's a custom inlining hook,
+ #! it is permitted to return f, which means that we try the
+ #! normal inlining heuristic.
+ dup custom-inlining? [ 2dup inline-custom ] [ f ] if
+ [ 2drop t ] [ (do-inlining) ] if ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel effects accessors math math.private math.libm
-math.partial-dispatch math.intervals math.parser math.order
-layouts words sequences sequences.private arrays assocs classes
-classes.algebra combinators generic.math splitting fry locals
-classes.tuple alien.accessors classes.tuple.private slots.private
-definitions
+USING: kernel effects accessors math math.private
+math.integers.private math.partial-dispatch math.intervals
+math.parser math.order layouts words sequences sequences.private
+arrays assocs classes classes.algebra combinators generic.math
+splitting fry locals classes.tuple alien.accessors
+classes.tuple.private slots.private definitions strings.private
+vectors hashtables
stack-checker.state
compiler.tree.comparisons
compiler.tree.propagation.info
[ rational math-class-max ] dip
] unless ;
+: ensure-math-class ( class must-be -- class' )
+ [ class<= ] 2keep ? ;
+
: number-valued ( class interval -- class' interval' )
- [ number math-class-min ] dip ;
+ [ number ensure-math-class ] dip ;
: integer-valued ( class interval -- class' interval' )
- [ integer math-class-min ] dip ;
+ [ integer ensure-math-class ] dip ;
: real-valued ( class interval -- class' interval' )
- [ real math-class-min ] dip ;
+ [ real ensure-math-class ] dip ;
: float-valued ( class interval -- class' interval' )
over null-class? [
comparison-ops
[ dup '[ _ define-comparison-constraints ] each-derived-op ] each
-generic-comparison-ops [
- dup specific-comparison
- '[ _ _ define-comparison-constraints ] each-derived-op
-] each
+! generic-comparison-ops [
+! dup specific-comparison define-comparison-constraints
+! ] each
! Remove redundant comparisons
: fold-comparison ( info1 info2 word -- info )
2bi and maybe-or-never
] "outputs" set-word-prop
+\ both-fixnums? [
+ [ class>> fixnum classes-intersect? not ] either?
+ f <literal-info> object-info ?
+] "outputs" set-word-prop
+
{
{ >fixnum fixnum }
{ bignum>fixnum fixnum }
} [
[
in-d>> second value-info >literal<
- [ power-of-2? [ 1- bitand ] f ? ] when
+ [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
] "custom-inlining" set-word-prop
] each
] "custom-inlining" set-word-prop
] each
+{ numerator denominator }
+[ [ drop integer <class-info> ] "outputs" set-word-prop ] each
+
+{ (log2) fixnum-log2 bignum-log2 } [
+ [
+ [ class>> ] [ interval>> interval-log2 ] bi <class/interval-info>
+ ] "outputs" set-word-prop
+] each
+
+\ string-nth [
+ 2drop fixnum 0 23 2^ [a,b] <class/interval-info>
+] "outputs" set-word-prop
+
{
alien-signed-1
alien-unsigned-1
"outputs" set-word-prop
] each
+! Generate more efficient code for common idiom
+\ clone [
+ in-d>> first value-info literal>> {
+ { V{ } [ [ drop { } 0 vector boa ] ] }
+ { H{ } [ [ drop hashtable new ] ] }
+ [ drop f ]
+ } case
+] "custom-inlining" set-word-prop
+
\ slot [
dup literal?>>
[ literal>> swap value-info-slot ] [ 2drop object-info ] if
compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
-specialized-arrays.double system sorting math.libm ;
+specialized-arrays.double system sorting math.libm
+math.intervals ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
[ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
-[ V{ number } ] [ [ + ] final-classes ] unit-test
+! Test type propagation for math ops
+: cleanup-math-class ( obj -- class )
+ { null fixnum bignum integer ratio rational float real complex number }
+ [ class= ] with find nip ;
-[ V{ float } ] [ [ { float integer } declare + ] final-classes ] unit-test
+: final-math-class ( quot -- class )
+ final-classes first cleanup-math-class ;
-[ V{ float } ] [ [ /f ] final-classes ] unit-test
+[ number ] [ [ + ] final-math-class ] unit-test
-[ V{ integer } ] [ [ /i ] final-classes ] unit-test
+[ bignum ] [ [ { fixnum bignum } declare + ] final-math-class ] unit-test
-[ V{ integer } ] [
- [ { integer } declare bitnot ] final-classes
-] unit-test
+[ integer ] [ [ { fixnum integer } declare + ] final-math-class ] unit-test
+
+[ bignum ] [ [ { integer bignum } declare + ] final-math-class ] unit-test
+
+[ integer ] [ [ { fixnum fixnum } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ { float integer } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ { real float } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ { float real } declare + ] final-math-class ] unit-test
+
+[ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test
+
+[ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test
+
+[ number ] [ [ { complex complex } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ /f ] final-math-class ] unit-test
+
+[ float ] [ [ { real real } declare /f ] final-math-class ] unit-test
+
+[ integer ] [ [ /i ] final-math-class ] unit-test
+
+[ integer ] [ [ { integer float } declare /i ] final-math-class ] unit-test
+
+[ integer ] [ [ { float float } declare /i ] final-math-class ] unit-test
+
+[ integer ] [ [ { integer } declare bitnot ] final-math-class ] unit-test
+
+[ null ] [ [ { null null } declare + ] final-math-class ] unit-test
+
+[ null ] [ [ { null fixnum } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ { float fixnum } declare + ] final-math-class ] unit-test
+
+[ bignum ] [ [ { bignum bignum } declare bitxor ] final-math-class ] unit-test
+
+[ float ] [ [ { float float } declare mod ] final-math-class ] unit-test
[ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
[ { fixnum } declare 615949 * ] final-classes
] unit-test
-[ V{ null } ] [
- [ { null null } declare + ] final-classes
-] unit-test
-
-[ V{ null } ] [
- [ { null fixnum } declare + ] final-classes
-] unit-test
-
-[ V{ float } ] [
- [ { float fixnum } declare + ] final-classes
-] unit-test
-
[ V{ fixnum } ] [
[ 255 bitand >fixnum 3 bitor ] final-classes
] unit-test
] final-classes
] unit-test
-[ V{ float } ] [
- [ { real float } declare + ] final-classes
-] unit-test
-
-[ V{ float } ] [
- [ { float real } declare + ] final-classes
-] unit-test
-
[ V{ fixnum } ] [
[ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
] unit-test
[ V{ t } ] [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test
+[ T{ interval f { 0 t } { 127 t } } ] [
+ [ { integer } declare 127 bitand ] final-info first interval>>
+] unit-test
+
+[ V{ bignum } ] [
+ [ { bignum } declare dup 1- bitxor ] final-classes
+] unit-test
+
+[ V{ bignum integer } ] [
+ [ { bignum integer } declare [ shift ] keep ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+ [ { fixnum } declare log2 ] final-classes
+] unit-test
+
+[ V{ word } ] [
+ [ { fixnum } declare log2 0 >= ] final-classes
+] unit-test
+
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs accessors kernel combinators
-classes.algebra sequences sequences.deep slots.private
+classes.algebra sequences slots.private fry vectors
classes.tuple.private math math.private arrays
stack-checker.branches
+compiler.utilities
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
: (expand-#push) ( object value -- nodes )
dup unboxed-allocation dup [
[ object-slots ] [ drop ] [ ] tri*
- [ (expand-#push) ] 2map
+ [ (expand-#push) ] 2map-flat
] [
drop #push
] if ;
: unbox-<complex> ( #call -- nodes )
dup unbox-output? [ drop { } ] when ;
-: (flatten-values) ( values -- values' )
- [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
+: (flatten-values) ( values accum -- )
+ dup '[
+ dup unboxed-allocation
+ [ _ (flatten-values) ] [ _ push ] ?if
+ ] each ;
: flatten-values ( values -- values' )
- dup empty? [ (flatten-values) flatten ] unless ;
+ dup empty? [
+ 10 <vector> [ (flatten-values) ] keep
+ ] unless ;
: prepare-slot-access ( #call -- tuple-values outputs slot-values )
[ in-d>> flatten-values ]
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences sequences.private arrays vectors fry
+math.order ;
+IN: compiler.utilities
+
+: flattener ( seq quot -- seq vector quot' )
+ over length <vector> [
+ dup
+ '[
+ @ [
+ dup array?
+ [ _ push-all ] [ _ push ] if
+ ] when*
+ ]
+ ] keep ; inline
+
+: flattening ( seq quot combinator -- seq' )
+ [ flattener ] dip dip { } like ; inline
+
+: map-flat ( seq quot -- seq' ) [ each ] flattening ; inline
+
+: 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline
+
+: (3each) ( seq1 seq2 seq3 quot -- n quot' )
+ [ [ [ length ] tri@ min min ] 3keep ] dip
+ '[ [ _ nth-unsafe ] [ _ nth-unsafe ] [ _ nth-unsafe ] tri @ ] ; inline
+
+: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
+
+: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline
] (parallel-each) ; inline\r
\r
: parallel-filter ( seq quot -- newseq )\r
- over [ pusher [ each ] dip ] dip like ; inline\r
+ over [ pusher [ parallel-each ] dip ] dip like ; inline\r
\r
<PRIVATE\r
\r
{ $values { "message" object }
{ "thread" thread }
}
-{ $description "Send the message to the thread by placing it in the threades mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." }
+{ $description "Send the message to the thread by placing it in the threads mailbox. This is an asynchronous operation and will return immediately. The receving thread will act on the message the next time it retrieves that item from its mailbox (usually using the " { $link receive } " word. The message can be any Factor object. For destinations that are instances of remote-thread the message must be a serializable Factor type." }
{ $see-also receive receive-if } ;
HELP: receive
{ $values { "message" object }
}
-{ $description "Return a message from the current threades mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." }
+{ $description "Return a message from the current threads mailbox. If the box is empty, suspend the thread until another thread places an item in the mailbox (usually via the " { $link send } " word." }
{ $see-also send receive-if } ;
HELP: receive-if
{ $values { "pred" "a predicate with stack effect " { $snippet "( obj -- ? )" } }
{ "message" object }
}
-{ $description "Return the first message from the current threades mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." }
+{ $description "Return the first message from the current threads mailbox that satisfies the predicate. To satisfy the predicate, " { $snippet "pred" } " is called with the item on the stack and the predicate should leave a boolean indicating whether it was satisfied or not. If nothing in the mailbox satisfies the predicate then the thread will block until something does." }
{ $see-also send receive } ;
HELP: spawn-linked
{ "name" string }
{ "thread" thread }
}
-{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" }
+{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threads that restart child threads that crash due to uncaught errors.\n" }
{ $see-also spawn } ;
ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages"
ARTICLE: { "concurrency" "exceptions" } "Linked exceptions"
"A thread can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the thread will terminate. For example:"
{ $code "[ 1 0 / \"This will not print\" print ] \"division-by-zero\" spawn" }
-"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threades can be created that are notified when child threades terminate and possibly restart them."
+"Processes can be linked so that a parent thread can receive the exception that caused the child thread to terminate. In this way 'supervisor' threads can be created that are notified when child threads terminate and possibly restart them."
{ $subsection spawn-linked }
"This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent thread can catch it:"
{ $code "["
"Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ;
ARTICLE: "concurrency.messaging" "Message-passing concurrency"
-"The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of the standard Factor lightweight thread system."
+"The " { $vocab-link "concurrency.messaging" } " vocabulary is based upon the style of concurrency used in systems like Erlang and Termite. It is built on top of " { $link "threads" } "."
$nl
-"A concurrency oriented program is one in which multiple threades run simultaneously in a single Factor image or across multiple running Factor instances. The threades can communicate with each other by asynchronous message sends."
+"A concurrency-oriented program is one in which multiple threads run simultaneously in a single Factor image or across multiple running Factor instances. The threads can communicate with each other by asynchronous message sends."
$nl
-"Although threades can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code."
+"Although threads can share data via Factor's mutable data structures it is not recommended to mix shared state with message passing as it can lead to confusing code."
{ $subsection { "concurrency" "messaging" } }
{ $subsection { "concurrency" "synchronous-sends" } }
{ $subsection { "concurrency" "exceptions" } } ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: core-foundation tools.test kernel ;
+IN: core-foundation
+
+[ ] [ "Hello" <CFString> CFRelease ] unit-test
+[ "Hello" ] [ "Hello" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
+[ "Hello\u003456" ] [ "Hello\u003456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
+[ "Hello\u013456" ] [ "Hello\u013456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax kernel
-math sequences io.encodings.utf16 destructors accessors combinators ;
+math sequences io.encodings.utf8 destructors accessors
+combinators byte-arrays ;
IN: core-foundation
TYPEDEF: void* CFAllocatorRef
TYPEDEF: void* CFURLRef
TYPEDEF: void* CFUUIDRef
TYPEDEF: void* CFTypeRef
+TYPEDEF: void* CFFileDescriptorRef
TYPEDEF: bool Boolean
TYPEDEF: long CFIndex
TYPEDEF: int SInt32
TYPEDEF: uint UInt32
TYPEDEF: ulong CFTypeID
+TYPEDEF: UInt32 CFOptionFlags
TYPEDEF: double CFTimeInterval
TYPEDEF: double CFAbsoluteTime
+TYPEDEF: int CFFileDescriptorNativeDescriptor
+TYPEDEF: void* CFFileDescriptorCallBack
TYPEDEF: int CFNumberType
: kCFNumberSInt8Type 1 ; inline
FUNCTION: CFURLRef CFURLCopyFileSystemPath ( CFURLRef url, int pathStyle ) ;
-FUNCTION: CFStringRef CFStringCreateWithCharacters ( CFAllocatorRef allocator, wchar_t* cStr, CFIndex numChars ) ;
+TYPEDEF: int CFStringEncoding
+: kCFStringEncodingMacRoman HEX: 0 ;
+: kCFStringEncodingWindowsLatin1 HEX: 0500 ;
+: kCFStringEncodingISOLatin1 HEX: 0201 ;
+: kCFStringEncodingNextStepLatin HEX: 0B01 ;
+: kCFStringEncodingASCII HEX: 0600 ;
+: kCFStringEncodingUnicode HEX: 0100 ;
+: kCFStringEncodingUTF8 HEX: 08000100 ;
+: kCFStringEncodingNonLossyASCII HEX: 0BFF ;
+: kCFStringEncodingUTF16 HEX: 0100 ;
+: kCFStringEncodingUTF16BE HEX: 10000100 ;
+: kCFStringEncodingUTF16LE HEX: 14000100 ;
+: kCFStringEncodingUTF32 HEX: 0c000100 ;
+: kCFStringEncodingUTF32BE HEX: 18000100 ;
+: kCFStringEncodingUTF32LE HEX: 1c000100 ;
+
+FUNCTION: CFStringRef CFStringCreateFromExternalRepresentation (
+ CFAllocatorRef alloc,
+ CFDataRef data,
+ CFStringEncoding encoding
+) ;
+
+FUNCTION: CFStringRef CFStringCreateWithBytes (
+ CFAllocatorRef alloc,
+ UInt8* bytes,
+ CFIndex numBytes,
+ CFStringEncoding encoding,
+ Boolean isExternalRepresentation
+) ;
FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ;
+FUNCTION: Boolean CFStringGetCString (
+ CFStringRef theString,
+ char* buffer,
+ CFIndex bufferSize,
+ CFStringEncoding encoding
+) ;
+
+FUNCTION: CFStringRef CFStringCreateWithCString (
+ CFAllocatorRef alloc,
+ char* cStr,
+ CFStringEncoding encoding
+) ;
+
FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFIndex length ) ;
[ [ dupd ] dip CFArraySetValueAtIndex ] 2each ;
: <CFString> ( string -- alien )
- f swap dup length CFStringCreateWithCharacters ;
+ f swap utf8 string>alien kCFStringEncodingUTF8 CFStringCreateWithCString
+ [ "CFStringCreateWithCString failed" throw ] unless* ;
: CF>string ( alien -- string )
- dup CFStringGetLength 1+ "ushort" <c-array> [
- [ 0 over CFStringGetLength ] dip CFStringGetCharacters
- ] keep utf16n alien>string ;
+ dup CFStringGetLength 4 * 1 + <byte-array> [
+ dup length
+ kCFStringEncodingUTF8
+ CFStringGetCString
+ [ "CFStringGetCString failed" throw ] unless
+ ] keep utf8 alien>string ;
: CF>string-array ( alien -- seq )
CF>array [ CF>string ] map ;
] keep CFRelease ;
GENERIC: <CFNumber> ( number -- alien )
+
M: integer <CFNumber>
[ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
+
M: float <CFNumber>
[ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
+
M: t <CFNumber>
drop f kCFNumberIntType 1 <int> CFNumberCreate ;
+
M: f <CFNumber>
drop f kCFNumberIntType 0 <int> CFNumberCreate ;
: <CFData> ( byte-array -- alien )
[ f ] dip dup length CFDataCreate ;
+FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
+ CFAllocatorRef allocator,
+ CFFileDescriptorNativeDescriptor fd,
+ Boolean closeOnInvalidate,
+ CFFileDescriptorCallBack callout,
+ CFFileDescriptorContext* context
+) ;
+
+FUNCTION: void CFFileDescriptorEnableCallBacks (
+ CFFileDescriptorRef f,
+ CFOptionFlags callBackTypes
+) ;
+
: load-framework ( name -- )
dup <CFBundle> [
CFBundleLoadExecutable drop
] ?if ;
TUPLE: CFRelease-destructor alien disposed ;
+
M: CFRelease-destructor dispose* alien>> CFRelease ;
+
: &CFRelease ( alien -- alien )
dup f CFRelease-destructor boa &dispose drop ; inline
+
: |CFRelease ( alien -- alien )
dup f CFRelease-destructor boa |dispose drop ; inline
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel threads init namespaces alien
-core-foundation calendar ;
+USING: alien alien.syntax core-foundation kernel namespaces ;
IN: core-foundation.run-loop
: kCFRunLoopRunFinished 1 ; inline
: kCFRunLoopRunHandledSource 4 ; inline
TYPEDEF: void* CFRunLoopRef
+TYPEDEF: void* CFRunLoopSourceRef
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ;
Boolean returnAfterSourceHandled
) ;
+FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
+ CFAllocatorRef allocator,
+ CFFileDescriptorRef f,
+ CFIndex order
+) ;
+
+FUNCTION: void CFRunLoopAddSource (
+ CFRunLoopRef rl,
+ CFRunLoopSourceRef source,
+ CFStringRef mode
+) ;
+
: CFRunLoopDefaultMode ( -- alien )
#! Ugly, but we don't have static NSStrings
\ CFRunLoopDefaultMode get-global dup expired? [
"kCFRunLoopDefaultMode" <CFString>
dup \ CFRunLoopDefaultMode set-global
] when ;
-
-: run-loop-thread ( -- )
- CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
- kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless
- run-loop-thread ;
-
-: start-run-loop-thread ( -- )
- [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: init core-foundation.run-loop ;
+USING: calendar core-foundation.run-loop init kernel threads ;
IN: core-foundation.run-loop.thread
! Load this vocabulary if you need a run loop running.
+: run-loop-thread ( -- )
+ CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
+ kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless
+ run-loop-thread ;
+
+: start-run-loop-thread ( -- )
+ [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
+
[ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook
HOOK: %shr-imm cpu ( dst src1 src2 -- )
HOOK: %sar-imm cpu ( dst src1 src2 -- )
HOOK: %not cpu ( dst src -- )
+HOOK: %log2 cpu ( dst src -- )
HOOK: %fixnum-add cpu ( src1 src2 -- )
HOOK: %fixnum-add-tail cpu ( src1 src2 -- )
HOOK: %set-alien-float cpu ( ptr value -- )
HOOK: %set-alien-double cpu ( ptr value -- )
+HOOK: %alien-global cpu ( dst symbol library -- )
+
HOOK: %allot cpu ( dst size class temp -- )
HOOK: %write-barrier cpu ( src card# table -- )
HOOK: %gc cpu ( -- )
! Math\r
[\r
3 ds-reg 0 LWZ\r
- 4 ds-reg -4 LWZ\r
+ ds-reg ds-reg 4 SUBI\r
+ 4 ds-reg 0 LWZ\r
3 3 4 OR\r
3 3 tag-mask get ANDI\r
\ f tag-number 4 LI\r
0 3 0 CMPI\r
2 BNE\r
1 tag-fixnum 4 LI\r
- 4 ds-reg 4 STWU\r
+ 4 ds-reg 0 STW\r
] f f f \ both-fixnums? define-sub-primitive\r
\r
: jit-math ( insn -- )\r
M: ppc %load-indirect ( reg obj -- )
[ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
-: %load-dlsym ( symbol dll register -- )
- 0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
+M: ppc %alien-global ( register symbol dll -- )
+ [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
: ds-reg 29 ; inline
: rs-reg 30 ; inline
"end" define-label
temp src index ADD
dst temp string-offset LBZ
+ 0 dst HEX: 80 CMPI
+ "end" get BLT
temp src string-aux-offset LWZ
- 0 temp \ f tag-number CMPI
- "end" get BEQ
temp temp index ADD
temp temp index ADD
temp temp byte-array-offset LHZ
- temp temp 8 SLWI
- dst dst temp OR
+ temp temp 7 SLWI
+ dst dst temp XOR
"end" resolve-label
] with-scope ;
+M:: ppc %set-string-nth-fast ( ch obj index temp -- )
+ temp obj index ADD
+ ch temp string-offset STB ;
+
M: ppc %add ADD ;
M: ppc %add-imm ADDI ;
M: ppc %sub swap SUBF ;
M: ppc %not NOT ;
: %alien-invoke-tail ( func dll -- )
- scratch-reg %load-dlsym scratch-reg MTCTR BCTR ;
+ [ scratch-reg ] 2dip %alien-global scratch-reg MTCTR BCTR ;
:: exchange-regs ( r1 r2 -- )
scratch-reg r1 MR
M: ppc %set-alien-double swap 0 STFD ;
: load-zone-ptr ( reg -- )
- [ "nursery" f ] dip %load-dlsym ;
+ "nursery" f %alien-global ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
dst class store-header
dst class store-tagged ;
-: %alien-global ( dst name -- )
- [ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
-
: load-cards-offset ( dst -- )
- "cards_offset" %alien-global ;
+ [ "cards_offset" f %alien-global ] [ dup 0 LWZ ] bi ;
: load-decks-offset ( dst -- )
- "decks_offset" %alien-global ;
+ [ "decks_offset" f %alien-global ] [ dup 0 LWZ ] bi ;
M:: ppc %write-barrier ( src card# table -- )
card-mark scratch-reg LI
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
- "stack_chain" f scratch-reg %load-dlsym
+ scratch-reg "stack_chain" f %alien-global
scratch-reg scratch-reg 0 LWZ
1 scratch-reg 0 STW
ds-reg scratch-reg 8 STW
rs-reg scratch-reg 12 STW ;
M: ppc %alien-invoke ( symbol dll -- )
- 11 %load-dlsym 11 MTLR BLRL ;
+ [ 11 ] 2dip %alien-global 11 MTLR BLRL ;
M: ppc %alien-callback ( quot -- )
3 swap %load-indirect "c_to_factor" f %alien-invoke ;
M: x86.32 reserved-area-size 0 ;
-M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
-
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
: shift-arg ( -- reg ) ECX ;
: div-arg ( -- reg ) EAX ;
: mod-arg ( -- reg ) EDX ;
-: arg0 ( -- reg ) EAX ;
-: arg1 ( -- reg ) EDX ;
-: arg2 ( -- reg ) ECX ;
-: temp-reg ( -- reg ) EBX ;
+: temp0 ( -- reg ) EAX ;
+: temp1 ( -- reg ) EDX ;
+: temp2 ( -- reg ) ECX ;
+: temp3 ( -- reg ) EBX ;
: stack-reg ( -- reg ) ESP ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
-: fixnum>slot@ ( -- ) arg0 1 SAR ;
+: fixnum>slot@ ( -- ) temp0 1 SAR ;
: rex-length ( -- n ) 0 ;
[
- arg0 0 [] MOV ! load stack_chain
- arg0 [] stack-reg MOV ! save stack pointer
+ temp0 0 [] MOV ! load stack_chain
+ temp0 [] stack-reg MOV ! save stack pointer
] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define
[
M: x86.64 %prepare-var-args RAX RAX XOR ;
-M: x86.64 %alien-global
- [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
-
M: x86.64 %alien-invoke
R11 0 MOV
rc-absolute-cell rel-dlsym
: shift-arg ( -- reg ) RCX ;
: div-arg ( -- reg ) RAX ;
: mod-arg ( -- reg ) RDX ;
-: temp-reg ( -- reg ) RBX ;
+: temp0 ( -- reg ) RDI ;
+: temp1 ( -- reg ) RSI ;
+: temp2 ( -- reg ) RDX ;
+: temp3 ( -- reg ) RBX ;
: stack-reg ( -- reg ) RSP ;
: ds-reg ( -- reg ) R14 ;
: rs-reg ( -- reg ) R15 ;
: rex-length ( -- n ) 1 ;
[
- arg0 0 MOV ! load stack_chain
- arg0 arg0 [] MOV
- arg0 [] stack-reg MOV ! save stack pointer
+ temp0 0 MOV ! load stack_chain
+ temp0 temp0 [] MOV
+ temp0 [] stack-reg MOV ! save stack pointer
] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define
[
- arg1 0 MOV ! load XT
- arg1 JMP ! go
+ temp1 0 MOV ! load XT
+ temp1 JMP ! go
] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
<< "resource:basis/cpu/x86/bootstrap.factor" parse-file parsed >>
IN: bootstrap.x86
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
-: arg0 ( -- reg ) RDI ;
-: arg1 ( -- reg ) RSI ;
-: arg2 ( -- reg ) RDX ;
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
call
IN: bootstrap.x86
: stack-frame-size ( -- n ) 8 bootstrap-cells ;
-: arg0 ( -- reg ) RCX ;
-: arg1 ( -- reg ) RDX ;
-: arg2 ( -- reg ) R8 ;
<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
call
: LEAVE ( -- ) HEX: c9 , ;
: RET ( n -- )
- dup zero? [ drop HEX: c3 , ] [ HEX: C2 , 2, ] if ;
+ dup zero? [ drop HEX: c3 , ] [ HEX: c2 , 2, ] if ;
! Arithmetic
: XCHG ( dst src -- ) OCT: 207 2-operand ;
+: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;
+
: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
: MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
[
! Load word
- temp-reg 0 MOV
+ temp0 0 MOV
! Bump profiling counter
- temp-reg profile-count-offset [+] 1 tag-fixnum ADD
+ temp0 profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code
- temp-reg temp-reg word-code-offset [+] MOV
+ temp0 temp0 word-code-offset [+] MOV
! Compute word XT
- temp-reg compiled-header-size ADD
+ temp0 compiled-header-size ADD
! Jump to XT
- temp-reg JMP
+ temp0 JMP
] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define
[
- temp-reg 0 MOV ! load XT
- stack-frame-size PUSH ! save stack frame size
- temp-reg PUSH ! push XT
- stack-reg stack-frame-size 3 bootstrap-cells - SUB ! alignment
+ ! load XT
+ temp0 0 MOV
+ ! save stack frame size
+ stack-frame-size PUSH
+ ! push XT
+ temp0 PUSH
+ ! alignment
+ stack-reg stack-frame-size 3 bootstrap-cells - SUB
] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
[
- arg0 0 MOV ! load literal
- ds-reg bootstrap-cell ADD ! increment datastack pointer
- ds-reg [] arg0 MOV ! store literal on datastack
+ ! load literal
+ temp0 0 MOV
+ ! increment datastack pointer
+ ds-reg bootstrap-cell ADD
+ ! store literal on datastack
+ ds-reg [] temp0 MOV
] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
[
] rc-relative rt-xt 1 jit-word-call jit-define
[
- arg0 ds-reg [] MOV ! load boolean
- ds-reg bootstrap-cell SUB ! pop boolean
- arg0 \ f tag-number CMP ! compare boolean with f
- f JNE ! jump to true branch if not equal
+ ! load boolean
+ temp0 ds-reg [] MOV
+ ! pop boolean
+ ds-reg bootstrap-cell SUB
+ ! compare boolean with f
+ temp0 \ f tag-number CMP
+ ! jump to true branch if not equal
+ f JNE
] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define
[
- f JMP ! jump to false branch if equal
+ ! jump to false branch if equal
+ f JMP
] rc-relative rt-xt 1 jit-if-2 jit-define
[
- arg1 0 MOV ! load dispatch table
- arg0 ds-reg [] MOV ! load index
- fixnum>slot@ ! turn it into an array offset
- ds-reg bootstrap-cell SUB ! pop index
- arg0 arg1 ADD ! compute quotation location
- arg0 arg0 array-start-offset [+] MOV ! load quotation
- arg0 quot-xt-offset [+] JMP ! execute branch
+ ! load dispatch table
+ temp1 0 MOV
+ ! load index
+ temp0 ds-reg [] MOV
+ ! turn it into an array offset
+ fixnum>slot@
+ ! pop index
+ ds-reg bootstrap-cell SUB
+ ! compute quotation location
+ temp0 temp1 ADD
+ ! load quotation
+ temp0 temp0 array-start-offset [+] MOV
+ ! execute branch
+ temp0 quot-xt-offset [+] JMP
] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define
: jit->r ( -- )
rs-reg bootstrap-cell ADD
- arg0 ds-reg [] MOV
+ temp0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
- rs-reg [] arg0 MOV ;
+ rs-reg [] temp0 MOV ;
: jit-2>r ( -- )
rs-reg 2 bootstrap-cells ADD
- arg0 ds-reg [] MOV
- arg1 ds-reg -1 bootstrap-cells [+] MOV
+ temp0 ds-reg [] MOV
+ temp1 ds-reg -1 bootstrap-cells [+] MOV
ds-reg 2 bootstrap-cells SUB
- rs-reg [] arg0 MOV
- rs-reg -1 bootstrap-cells [+] arg1 MOV ;
+ rs-reg [] temp0 MOV
+ rs-reg -1 bootstrap-cells [+] temp1 MOV ;
: jit-3>r ( -- )
rs-reg 3 bootstrap-cells ADD
- arg0 ds-reg [] MOV
- arg1 ds-reg -1 bootstrap-cells [+] MOV
- arg2 ds-reg -2 bootstrap-cells [+] MOV
+ temp0 ds-reg [] MOV
+ temp1 ds-reg -1 bootstrap-cells [+] MOV
+ temp2 ds-reg -2 bootstrap-cells [+] MOV
ds-reg 3 bootstrap-cells SUB
- rs-reg [] arg0 MOV
- rs-reg -1 bootstrap-cells [+] arg1 MOV
- rs-reg -2 bootstrap-cells [+] arg2 MOV ;
+ rs-reg [] temp0 MOV
+ rs-reg -1 bootstrap-cells [+] temp1 MOV
+ rs-reg -2 bootstrap-cells [+] temp2 MOV ;
: jit-r> ( -- )
ds-reg bootstrap-cell ADD
- arg0 rs-reg [] MOV
+ temp0 rs-reg [] MOV
rs-reg bootstrap-cell SUB
- ds-reg [] arg0 MOV ;
+ ds-reg [] temp0 MOV ;
: jit-2r> ( -- )
ds-reg 2 bootstrap-cells ADD
- arg0 rs-reg [] MOV
- arg1 rs-reg -1 bootstrap-cells [+] MOV
+ temp0 rs-reg [] MOV
+ temp1 rs-reg -1 bootstrap-cells [+] MOV
rs-reg 2 bootstrap-cells SUB
- ds-reg [] arg0 MOV
- ds-reg -1 bootstrap-cells [+] arg1 MOV ;
+ ds-reg [] temp0 MOV
+ ds-reg -1 bootstrap-cells [+] temp1 MOV ;
: jit-3r> ( -- )
ds-reg 3 bootstrap-cells ADD
- arg0 rs-reg [] MOV
- arg1 rs-reg -1 bootstrap-cells [+] MOV
- arg2 rs-reg -2 bootstrap-cells [+] MOV
+ temp0 rs-reg [] MOV
+ temp1 rs-reg -1 bootstrap-cells [+] MOV
+ temp2 rs-reg -2 bootstrap-cells [+] MOV
rs-reg 3 bootstrap-cells SUB
- ds-reg [] arg0 MOV
- ds-reg -1 bootstrap-cells [+] arg1 MOV
- ds-reg -2 bootstrap-cells [+] arg2 MOV ;
+ ds-reg [] temp0 MOV
+ ds-reg -1 bootstrap-cells [+] temp1 MOV
+ ds-reg -2 bootstrap-cells [+] temp2 MOV ;
[
jit->r
] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define
[
- jit-3>r
+ jit-3>r
f CALL
jit-3r>
] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define
[
- stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
+ ! unwind stack frame
+ stack-reg stack-frame-size bootstrap-cell - ADD
] f f f jit-epilog jit-define
[ 0 RET ] f f f jit-return jit-define
! Quotations and words
[
- arg0 ds-reg [] MOV ! load from stack
- ds-reg bootstrap-cell SUB ! pop stack
- arg0 quot-xt-offset [+] JMP ! call quotation
+ ! load from stack
+ temp0 ds-reg [] MOV
+ ! pop stack
+ ds-reg bootstrap-cell SUB
+ ! call quotation
+ temp0 quot-xt-offset [+] JMP
] f f f \ (call) define-sub-primitive
[
- arg0 ds-reg [] MOV ! load from stack
- ds-reg bootstrap-cell SUB ! pop stack
- arg0 word-xt-offset [+] JMP ! execute word
+ ! load from stack
+ temp0 ds-reg [] MOV
+ ! pop stack
+ ds-reg bootstrap-cell SUB
+ ! execute word
+ temp0 word-xt-offset [+] JMP
] f f f \ (execute) define-sub-primitive
! Objects
[
- arg1 ds-reg [] MOV ! load from stack
- arg1 tag-mask get AND ! compute tag
- arg1 tag-bits get SHL ! tag the tag
- ds-reg [] arg1 MOV ! push to stack
+ ! load from stack
+ temp0 ds-reg [] MOV
+ ! compute tag
+ temp0 tag-mask get AND
+ ! tag the tag
+ temp0 tag-bits get SHL
+ ! push to stack
+ ds-reg [] temp0 MOV
] f f f \ tag define-sub-primitive
[
- arg0 ds-reg [] MOV ! load slot number
- ds-reg bootstrap-cell SUB ! adjust stack pointer
- arg1 ds-reg [] MOV ! load object
- fixnum>slot@ ! turn slot number into offset
- arg1 tag-bits get SHR ! mask off tag
- arg1 tag-bits get SHL
- arg0 arg1 arg0 [+] MOV ! load slot value
- ds-reg [] arg0 MOV ! push to stack
+ ! load slot number
+ temp0 ds-reg [] MOV
+ ! adjust stack pointer
+ ds-reg bootstrap-cell SUB
+ ! load object
+ temp1 ds-reg [] MOV
+ ! turn slot number into offset
+ fixnum>slot@
+ ! mask off tag
+ temp1 tag-bits get SHR
+ temp1 tag-bits get SHL
+ ! load slot value
+ temp0 temp1 temp0 [+] MOV
+ ! push to stack
+ ds-reg [] temp0 MOV
] f f f \ slot define-sub-primitive
! Shufflers
] f f f \ 3drop define-sub-primitive
[
- arg0 ds-reg [] MOV
+ temp0 ds-reg [] MOV
ds-reg bootstrap-cell ADD
- ds-reg [] arg0 MOV
+ ds-reg [] temp0 MOV
] f f f \ dup define-sub-primitive
[
- arg0 ds-reg [] MOV
- arg1 ds-reg bootstrap-cell neg [+] MOV
+ temp0 ds-reg [] MOV
+ temp1 ds-reg bootstrap-cell neg [+] MOV
ds-reg 2 bootstrap-cells ADD
- ds-reg [] arg0 MOV
- ds-reg bootstrap-cell neg [+] arg1 MOV
+ ds-reg [] temp0 MOV
+ ds-reg bootstrap-cell neg [+] temp1 MOV
] f f f \ 2dup define-sub-primitive
[
- arg0 ds-reg [] MOV
- arg1 ds-reg -1 bootstrap-cells [+] MOV
- temp-reg ds-reg -2 bootstrap-cells [+] MOV
+ temp0 ds-reg [] MOV
+ temp1 ds-reg -1 bootstrap-cells [+] MOV
+ temp3 ds-reg -2 bootstrap-cells [+] MOV
ds-reg 3 bootstrap-cells ADD
- ds-reg [] arg0 MOV
- ds-reg -1 bootstrap-cells [+] arg1 MOV
- ds-reg -2 bootstrap-cells [+] temp-reg MOV
+ ds-reg [] temp0 MOV
+ ds-reg -1 bootstrap-cells [+] temp1 MOV
+ ds-reg -2 bootstrap-cells [+] temp3 MOV
] f f f \ 3dup define-sub-primitive
[
- arg0 ds-reg [] MOV
+ temp0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
- ds-reg [] arg0 MOV
+ ds-reg [] temp0 MOV
] f f f \ nip define-sub-primitive
[
- arg0 ds-reg [] MOV
+ temp0 ds-reg [] MOV
ds-reg 2 bootstrap-cells SUB
- ds-reg [] arg0 MOV
+ ds-reg [] temp0 MOV
] f f f \ 2nip define-sub-primitive
[
- arg0 ds-reg -1 bootstrap-cells [+] MOV
+ temp0 ds-reg -1 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
- ds-reg [] arg0 MOV
+ ds-reg [] temp0 MOV
] f f f \ over define-sub-primitive
[
- arg0 ds-reg -2 bootstrap-cells [+] MOV
+ temp0 ds-reg -2 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
- ds-reg [] arg0 MOV
+ ds-reg [] temp0 MOV
] f f f \ pick define-sub-primitive
[
- arg0 ds-reg [] MOV
- arg1 ds-reg -1 bootstrap-cells [+] MOV
- ds-reg [] arg1 MOV
+ temp0 ds-reg [] MOV
+ temp1 ds-reg -1 bootstrap-cells [+] MOV
+ ds-reg [] temp1 MOV
ds-reg bootstrap-cell ADD
- ds-reg [] arg0 MOV
+ ds-reg [] temp0 MOV
] f f f \ dupd define-sub-primitive
[
- arg0 ds-reg [] MOV
- arg1 ds-reg -1 bootstrap-cells [+] MOV
+ temp0 ds-reg [] MOV
+ temp1 ds-reg -1 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
- ds-reg [] arg0 MOV
- ds-reg -1 bootstrap-cells [+] arg1 MOV
- ds-reg -2 bootstrap-cells [+] arg0 MOV
+ ds-reg [] temp0 MOV
+ ds-reg -1 bootstrap-cells [+] temp1 MOV
+ ds-reg -2 bootstrap-cells [+] temp0 MOV
] f f f \ tuck define-sub-primitive
[
- arg0 ds-reg [] MOV
- arg1 ds-reg bootstrap-cell neg [+] MOV
- ds-reg bootstrap-cell neg [+] arg0 MOV
- ds-reg [] arg1 MOV
+ temp0 ds-reg [] MOV
+ temp1 ds-reg bootstrap-cell neg [+] MOV
+ ds-reg bootstrap-cell neg [+] temp0 MOV
+ ds-reg [] temp1 MOV
] f f f \ swap define-sub-primitive
[
- arg0 ds-reg -1 bootstrap-cells [+] MOV
- arg1 ds-reg -2 bootstrap-cells [+] MOV
- ds-reg -2 bootstrap-cells [+] arg0 MOV
- ds-reg -1 bootstrap-cells [+] arg1 MOV
+ temp0 ds-reg -1 bootstrap-cells [+] MOV
+ temp1 ds-reg -2 bootstrap-cells [+] MOV
+ ds-reg -2 bootstrap-cells [+] temp0 MOV
+ ds-reg -1 bootstrap-cells [+] temp1 MOV
] f f f \ swapd define-sub-primitive
[
- arg0 ds-reg [] MOV
- arg1 ds-reg -1 bootstrap-cells [+] MOV
- temp-reg ds-reg -2 bootstrap-cells [+] MOV
- ds-reg -2 bootstrap-cells [+] arg1 MOV
- ds-reg -1 bootstrap-cells [+] arg0 MOV
- ds-reg [] temp-reg MOV
+ temp0 ds-reg [] MOV
+ temp1 ds-reg -1 bootstrap-cells [+] MOV
+ temp3 ds-reg -2 bootstrap-cells [+] MOV
+ ds-reg -2 bootstrap-cells [+] temp1 MOV
+ ds-reg -1 bootstrap-cells [+] temp0 MOV
+ ds-reg [] temp3 MOV
] f f f \ rot define-sub-primitive
[
- arg0 ds-reg [] MOV
- arg1 ds-reg -1 bootstrap-cells [+] MOV
- temp-reg ds-reg -2 bootstrap-cells [+] MOV
- ds-reg -2 bootstrap-cells [+] arg0 MOV
- ds-reg -1 bootstrap-cells [+] temp-reg MOV
- ds-reg [] arg1 MOV
+ temp0 ds-reg [] MOV
+ temp1 ds-reg -1 bootstrap-cells [+] MOV
+ temp3 ds-reg -2 bootstrap-cells [+] MOV
+ ds-reg -2 bootstrap-cells [+] temp0 MOV
+ ds-reg -1 bootstrap-cells [+] temp3 MOV
+ ds-reg [] temp1 MOV
] f f f \ -rot define-sub-primitive
[ jit->r ] f f f \ >r define-sub-primitive
! Comparisons
: jit-compare ( insn -- )
- temp-reg 0 MOV ! load t
- arg1 \ f tag-number MOV ! load f
- arg0 ds-reg [] MOV ! load first value
- ds-reg bootstrap-cell SUB ! adjust stack pointer
- ds-reg [] arg0 CMP ! compare with second value
- [ arg1 temp-reg ] dip execute ! move t if true
- ds-reg [] arg1 MOV ! store
- ;
+ ! load t
+ temp3 0 MOV
+ ! load f
+ temp1 \ f tag-number MOV
+ ! load first value
+ temp0 ds-reg [] MOV
+ ! adjust stack pointer
+ ds-reg bootstrap-cell SUB
+ ! compare with second value
+ ds-reg [] temp0 CMP
+ ! move t if true
+ [ temp1 temp3 ] dip execute
+ ! store
+ ds-reg [] temp1 MOV ;
: define-jit-compare ( insn word -- )
[ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip
! Math
: jit-math ( insn -- )
- arg0 ds-reg [] MOV ! load second input
- ds-reg bootstrap-cell SUB ! pop stack
- [ ds-reg [] arg0 ] dip execute ! compute result
- ;
+ ! load second input
+ temp0 ds-reg [] MOV
+ ! pop stack
+ ds-reg bootstrap-cell SUB
+ ! compute result
+ [ ds-reg [] temp0 ] dip execute ;
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
[ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive
[
- arg0 ds-reg [] MOV ! load second input
- ds-reg bootstrap-cell SUB ! pop stack
- arg1 ds-reg [] MOV ! load first input
- arg0 tag-bits get SAR ! untag second input
- arg0 arg1 IMUL2 ! multiply
- ds-reg [] arg1 MOV ! push result
+ ! load second input
+ temp0 ds-reg [] MOV
+ ! pop stack
+ ds-reg bootstrap-cell SUB
+ ! load first input
+ temp1 ds-reg [] MOV
+ ! untag second input
+ temp0 tag-bits get SAR
+ ! multiply
+ temp0 temp1 IMUL2
+ ! push result
+ ds-reg [] temp1 MOV
] f f f \ fixnum*fast define-sub-primitive
[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
[
- ds-reg [] NOT ! complement
- ds-reg [] tag-mask get XOR ! clear tag bits
+ ! complement
+ ds-reg [] NOT
+ ! clear tag bits
+ ds-reg [] tag-mask get XOR
] f f f \ fixnum-bitnot define-sub-primitive
[
- shift-arg ds-reg [] MOV ! load shift count
- shift-arg tag-bits get SAR ! untag shift count
- ds-reg bootstrap-cell SUB ! adjust stack pointer
- temp-reg ds-reg [] MOV ! load value
- arg1 temp-reg MOV ! make a copy
- arg1 CL SHL ! compute positive shift value in arg1
- shift-arg NEG ! compute negative shift value in arg0
- temp-reg CL SAR
- temp-reg tag-mask get bitnot AND
- shift-arg 0 CMP ! if shift count was negative, move arg0 to arg1
- arg1 temp-reg CMOVGE
- ds-reg [] arg1 MOV ! push to stack
+ ! load shift count
+ shift-arg ds-reg [] MOV
+ ! untag shift count
+ shift-arg tag-bits get SAR
+ ! adjust stack pointer
+ ds-reg bootstrap-cell SUB
+ ! load value
+ temp3 ds-reg [] MOV
+ ! make a copy
+ temp1 temp3 MOV
+ ! compute positive shift value in temp1
+ temp1 CL SHL
+ shift-arg NEG
+ ! compute negative shift value in temp3
+ temp3 CL SAR
+ temp3 tag-mask get bitnot AND
+ shift-arg 0 CMP
+ ! if shift count was negative, move temp0 to temp1
+ temp1 temp3 CMOVGE
+ ! push to stack
+ ds-reg [] temp1 MOV
] f f f \ fixnum-shift-fast define-sub-primitive
: jit-fixnum-/mod ( -- )
- temp-reg ds-reg [] MOV ! load second parameter
- div-arg ds-reg bootstrap-cell neg [+] MOV ! load first parameter
- mod-arg div-arg MOV ! make a copy
- mod-arg bootstrap-cell-bits 1- SAR ! sign-extend
- temp-reg IDIV ; ! divide
+ ! load second parameter
+ temp3 ds-reg [] MOV
+ ! load first parameter
+ div-arg ds-reg bootstrap-cell neg [+] MOV
+ ! make a copy
+ mod-arg div-arg MOV
+ ! sign-extend
+ mod-arg bootstrap-cell-bits 1- SAR
+ ! divide
+ temp3 IDIV ;
[
jit-fixnum-/mod
- ds-reg bootstrap-cell SUB ! adjust stack pointer
- ds-reg [] mod-arg MOV ! push to stack
+ ! adjust stack pointer
+ ds-reg bootstrap-cell SUB
+ ! push to stack
+ ds-reg [] mod-arg MOV
] f f f \ fixnum-mod define-sub-primitive
[
jit-fixnum-/mod
- ds-reg bootstrap-cell SUB ! adjust stack pointer
- div-arg tag-bits get SHL ! tag it
- ds-reg [] div-arg MOV ! push to stack
+ ! adjust stack pointer
+ ds-reg bootstrap-cell SUB
+ ! tag it
+ div-arg tag-bits get SHL
+ ! push to stack
+ ds-reg [] div-arg MOV
] f f f \ fixnum/i-fast define-sub-primitive
[
jit-fixnum-/mod
- div-arg tag-bits get SHL ! tag it
- ds-reg [] mod-arg MOV ! push to stack
+ ! tag it
+ div-arg tag-bits get SHL
+ ! push to stack
+ ds-reg [] mod-arg MOV
ds-reg bootstrap-cell neg [+] div-arg MOV
] f f f \ fixnum/mod-fast define-sub-primitive
[
- arg0 ds-reg [] MOV
- arg0 ds-reg bootstrap-cell neg [+] OR
- ds-reg bootstrap-cell ADD
- arg0 tag-mask get AND
- arg0 \ f tag-number MOV
- arg1 1 tag-fixnum MOV
- arg0 arg1 CMOVE
- ds-reg [] arg0 MOV
+ temp0 ds-reg [] MOV
+ ds-reg bootstrap-cell SUB
+ temp0 ds-reg [] OR
+ temp0 tag-mask get AND
+ temp0 \ f tag-number MOV
+ temp1 1 tag-fixnum MOV
+ temp0 temp1 CMOVE
+ ds-reg [] temp0 MOV
] f f f \ both-fixnums? define-sub-primitive
[
- arg0 ds-reg [] MOV ! load local number
- fixnum>slot@ ! turn local number into offset
- arg0 rs-reg arg0 [+] MOV ! load local value
- ds-reg [] arg0 MOV ! push to stack
+ ! load local number
+ temp0 ds-reg [] MOV
+ ! turn local number into offset
+ fixnum>slot@
+ ! load local value
+ temp0 rs-reg temp0 [+] MOV
+ ! push to stack
+ ds-reg [] temp0 MOV
] f f f \ get-local define-sub-primitive
[
- arg0 ds-reg [] MOV ! load local count
- ds-reg bootstrap-cell SUB ! adjust stack pointer
- fixnum>slot@ ! turn local number into offset
- rs-reg arg0 SUB ! decrement retain stack pointer
+ ! load local count
+ temp0 ds-reg [] MOV
+ ! adjust stack pointer
+ ds-reg bootstrap-cell SUB
+ ! turn local number into offset
+ fixnum>slot@
+ ! decrement retain stack pointer
+ rs-reg temp0 SUB
] f f f \ drop-locals define-sub-primitive
[ "bootstrap.x86" forget-vocab ] with-compilation-unit
kernel kernel.private math memory namespaces make sequences
words system layouts combinators math.order fry locals
compiler.constants compiler.cfg.registers
-compiler.cfg.instructions compiler.codegen
-compiler.codegen.fixup ;
+compiler.cfg.instructions compiler.cfg.intrinsics
+compiler.codegen compiler.codegen.fixup ;
IN: cpu.x86
+<< enable-fixnum-log2 >>
+
M: x86 two-operand? t ;
HOOK: temp-reg-1 cpu ( -- reg )
M: x86 %shr-imm nip SHR ;
M: x86 %sar-imm nip SAR ;
M: x86 %not drop NOT ;
+M: x86 %log2 BSR ;
: ?MOV ( dst src -- )
2dup = [ 2drop ] [ MOV ] if ; inline
] with-small-register ;
M:: x86 %set-string-nth-fast ( ch str index temp -- )
- ch { index str } [| new-ch |
+ ch { index str temp } [| new-ch |
new-ch ch ?MOV
temp str index [+] LEA
temp string-offset [+] new-ch 1 small-reg MOV
dst class store-tagged
nursery-ptr size inc-allot-ptr ;
-HOOK: %alien-global cpu ( symbol dll register -- )
-
M:: x86 %write-barrier ( src card# table -- )
#! Mark the card pointed to by vreg.
! Mark the card
card# src MOV
card# card-bits SHR
- "cards_offset" f table %alien-global
+ table "cards_offset" f %alien-global
+ table table [] MOV
table card# [+] card-mark <byte> MOV
! Mark the card deck
card# deck-bits card-bits - SHR
- "decks_offset" f table %alien-global
+ table "decks_offset" f %alien-global
+ table table [] MOV
table card# [+] card-mark <byte> MOV ;
M: x86 %gc ( -- )
"minor_gc" f %alien-invoke
"end" resolve-label ;
+M: x86 %alien-global
+ [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
+
HOOK: stack-reg cpu ( -- reg )
: decr-stack-reg ( n -- )
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
- "stack_chain" f temp-reg-1 %alien-global
+ temp-reg-1 "stack_chain" f %alien-global
+ temp-reg-1 temp-reg-1 [] MOV
temp-reg-1 [] stack-reg MOV
temp-reg-1 [] cell SUB
temp-reg-1 2 cells [+] ds-reg MOV
{ $subsection db-open }
"Closing a database:"
{ $subsection db-close }
-"Creating tatements:"
+"Creating statements:"
{ $subsection <simple-statement> }
{ $subsection <prepared-statement> }
"Using statements with the database:"
M: sqlite-db bind# ( spec obj -- )
[
- [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
+ [ column-name>> ":" next-sql-counter surround dup 0% ]
[ type>> ] bi
] dip <literal-bind> 1, ;
M: string error. print ;
-: :error ( -- )
- error get error. ;
-
: :s ( -- )
error-continuation get data>> stack. ;
[ global [ "Error in print-error!" print drop ] bind ]
recover ;
+: :error ( -- )
+ error get print-error ;
+
: print-error-and-restarts ( error -- )
print-error
restarts.
: try ( quot -- )
[ print-error-and-restarts ] recover ;
-M: relative-underflow summary
- drop "Too many items removed from data stack" ;
-
-M: relative-overflow summary
- drop "Superfluous items pushed to data stack" ;
-
: expired-error. ( obj -- )
"Object did not survive image save/load: " write third . ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors parser generic kernel classes classes.tuple
words slots assocs sequences arrays vectors definitions
-prettyprint math hashtables sets generalizations namespaces make ;
+math hashtables sets generalizations namespaces make ;
IN: delegate
: protocol-words ( protocol -- words )
M: protocol definer drop \ PROTOCOL: \ ; ;
-M: protocol synopsis* word-synopsis ; ! Necessary?
-
M: protocol group-words protocol-words ;
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: delegate sequences.private sequences assocs
-prettyprint.sections io definitions kernel continuations
-listener ;
+io definitions kernel continuations ;
IN: delegate.protocols
PROTOCOL: sequence-protocol
PROTOCOL: input-stream-protocol
stream-read1 stream-read stream-read-partial stream-readln
- stream-read-until stream-read-quot ;
+ stream-read-until ;
PROTOCOL: output-stream-protocol
stream-flush stream-write1 stream-write stream-format
--- /dev/null
+Ryan Murphy
+Doug Coleman
--- /dev/null
+USING: help.syntax help.markup ;
+IN: editors.editpadpro
+
+ARTICLE: "editors.editpadpro" "EditPad Pro support"
+"EditPadPro text editor integration on Windows. Be sure to put EditPadPro in your system path so that it will be found. Windows only." ;
+
+ABOUT: "editors.editpadpro"
--- /dev/null
+USING: definitions kernel parser words sequences math.parser
+namespaces editors io.launcher windows.shell32 io.files
+io.paths.windows strings unicode.case make ;
+IN: editors.editpadlite
+
+: editpadlite-path ( -- path )
+ \ editpadlite-path get-global [
+ "JGsoft" t [ >lower "editpadlite.exe" tail? ] find-in-program-files
+ ] unless* ;
+
+: editpadlite ( file line -- )
+ [
+ editpadlite-path , drop ,
+ ] { } make run-detached drop ;
+
+[ editpadlite ] edit-hook set-global
--- /dev/null
+EditPadLite editor integration
--- /dev/null
+unportable
USING: help.syntax help.markup ;
+IN: editors.editpadpro
-ARTICLE: "editpadpro" "EditPad Pro support"
-"Just load this module and you will be able to edit documentation with EditPadPro. Be sure to put EditPadPro in your system path so that it will be found. Windows only." ;
+ARTICLE: "editors.editpadpro" "EditPad Pro support"
+"EditPadPro text editor integration on Windows. Be sure to put EditPadPro in your system path so that it will be found. Windows only." ;
-ABOUT: "editpadpro"
\ No newline at end of file
+ABOUT: "editors.editpadpro"
USING: definitions kernel parser words sequences math.parser
namespaces editors io.launcher windows.shell32 io.files
-io.paths strings unicode.case make ;
+io.paths.windows strings unicode.case make ;
IN: editors.editpadpro
-: editpadpro-path
+: editpadpro-path ( -- path )
\ editpadpro-path get-global [
- program-files "JGsoft" append-path
- t [ >lower "editpadpro.exe" tail? ] find-file
+ "JGsoft" t [ >lower "editpadpro.exe" tail? ] find-in-program-files
] unless* ;
: editpadpro ( file line -- )
[
- editpadpro-path , "/l" swap number>string append , ,
+ editpadpro-path , number>string "/l" prepend , ,
] { } make run-detached drop ;
[ editpadpro ] edit-hook set-global
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make ;
+namespaces sequences windows.shell32 make io.paths.windows ;
IN: editors.editplus
: editplus-path ( -- path )
\ editplus-path get-global [
- program-files "\\EditPlus 2\\editplus.exe" append-path
+ "EditPlus 2" t [ "editplus.exe" tail? ] find-in-program-files
] unless* ;
: editplus ( file line -- )
-USING: editors hardware-info.windows io.files io.launcher
-kernel math.parser namespaces sequences windows.shell32
-make ;
+USING: editors io.files io.launcher kernel math.parser
+namespaces sequences windows.shell32 make io.paths.windows ;
IN: editors.emeditor
: emeditor-path ( -- path )
\ emeditor-path get-global [
- program-files "\\EmEditor\\EmEditor.exe" append-path
+ "EmEditor" t [ "EmEditor.exe" tail? ] find-in-program-files
] unless* ;
: emeditor ( file line -- )
! Copyright (C) 2008 Kibleur Christophe.
! See http://factorcode.org/license.txt for BSD license.
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make ;
+namespaces sequences windows.shell32 io.paths.windows make ;
IN: editors.etexteditor
: etexteditor-path ( -- str )
\ etexteditor-path get-global [
- program-files "e\\e.exe" append-path
+ "e" t [ "e.exe" tail? ] find-in-program-files
] unless* ;
: etexteditor ( file line -- )
USING: editors.gvim io.files io.windows kernel namespaces
-sequences windows.shell32 io.paths system ;
+sequences windows.shell32 io.paths.windows system ;
IN: editors.gvim.windows
M: windows gvim-path
\ gvim-path get-global [
- program-files "vim" append-path
- t [ "gvim.exe" tail? ] find-file
+ "vim" t [ "gvim.exe" tail? ] find-in-program-files
] unless* ;
namespaces sequences windows.shell32 make ;
IN: editors.notepad2
-: notepad2-path ( -- str )
+: notepad2-path ( -- path )
\ notepad2-path get-global [
- program-files "C:\\Windows\\system32\\notepad.exe" append-path
- ] unless* ;
+ "C:\\Windows\\system32\\notepad.exe"
+ ] unless* ;
: notepad2 ( file line -- )
[
"/g" , number>string , ,
] { } make run-detached drop ;
-[ notepad2 ] edit-hook set-global
\ No newline at end of file
+[ notepad2 ] edit-hook set-global
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make ;
+namespaces sequences io.paths.windows make ;
IN: editors.notepadpp
-: notepadpp-path
+: notepadpp-path ( -- path )
\ notepadpp-path get-global [
- program-files "notepad++\\notepad++.exe" append-path
+ "notepad++" t [ "notepad++.exe" tail? ] find-in-program-files
] unless* ;
: notepadpp ( file line -- )
-! Basic SciTE integration for Factor.
-!
-! By Clemens F. Hofreither, 2007.
+! Copyright (C) 2007 Clemens F. Hofreither.
+! See http://factorcode.org/license.txt for BSD license.
! clemens.hofreither@gmx.net
-!
-! In your .factor-rc or .factor-boot-rc,
-! require this module and set the scite-path
-! variable to point to your executable,
-! if not on the path.
-!
-USING: io.files io.launcher kernel namespaces math
-math.parser editors sequences windows.shell32 make ;
+USING: io.files io.launcher kernel namespaces io.paths.windows
+math math.parser editors sequences make unicode.case ;
IN: editors.scite
: scite-path ( -- path )
\ scite-path get-global [
- program-files "ScITE Source Code Editor\\SciTE.exe" append-path
- dup exists? [
- drop program-files "wscite\\SciTE.exe" append-path
- ] unless
+ "Scintilla Text Editor" t
+ [ >lower "scite.exe" tail? ] find-in-program-files
] unless* ;
: scite-command ( file line -- cmd )
- swap
- [
- scite-path ,
- ,
- "-goto:" swap number>string append ,
- ] { } make ;
+ swap
+ [
+ scite-path ,
+ ,
+ number>string "-goto:" prepend ,
+ ] { } make ;
: scite-location ( file line -- )
- scite-command run-detached drop ;
+ scite-command run-detached drop ;
[ scite-location ] edit-hook set-global
-SciTE editor integration
+Scintilla text editor (SciTE) integration
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make ;
+namespaces sequences io.paths.windows make ;
IN: editors.ted-notepad
-: ted-notepad-path
+: ted-notepad-path ( -- path )
\ ted-notepad-path get-global [
- program-files "\\TED Notepad\\TedNPad.exe" append-path
+ "TED Notepad" t [ "TedNPad.exe" tail? ] find-in-program-files
] unless* ;
: ted-notepad ( file line -- )
[
- ted-notepad-path , "/l" swap number>string append , ,
+ ted-notepad-path ,
+ number>string "/l" prepend , ,
] { } make run-detached drop ;
[ ted-notepad ] edit-hook set-global
USING: definitions io.launcher kernel math math.parser parser
namespaces prettyprint editors make ;
-
IN: editors.textedit
: textedit-location ( file line -- )
try-process ;
[ textedit-location ] edit-hook set-global
-
-
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 wne ;
+namespaces sequences io.paths.windows make ;
IN: editors.ultraedit
: ultraedit-path ( -- path )
\ ultraedit-path get-global [
- program-files
- "IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" append-path
+ "IDM Computer Solutions" t [ "uedit32.exe" tail? ] find-in-program-files
] unless* ;
: ultraedit ( file line -- )
-USING: editors hardware-info.windows io.launcher kernel
-math.parser namespaces sequences windows.shell32 io.files
-arrays ;
+USING: editors io.launcher kernel io.paths.windows
+math.parser namespaces sequences io.files arrays ;
IN: editors.wordpad
: wordpad-path ( -- path )
\ wordpad-path get [
- program-files "Windows NT\\Accessories\\wordpad.exe" append-path
+ "Windows NT\\Accessories" t
+ [ "wordpad.exe" tail? ] find-in-program-files
] unless* ;
: wordpad ( file line -- )
- drop wordpad-path swap 2array dup . run-detached drop ;
+ drop wordpad-path swap 2array run-detached drop ;
[ wordpad ] edit-hook set-global
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.strings fry io.encodings.utf16 kernel
+USING: alien.strings fry io.encodings.utf16n kernel
splitting windows windows.kernel32 system environment
alien.c-types sequences windows.errors io.streams.memory
io.encodings io ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel locals.private quotations classes.tuple make
-combinators generic words interpolate namespaces sequences
-io.streams.string fry classes.mixin effects lexer parser
-classes.tuple.parser effects.parser ;
+USING: kernel quotations classes.tuple make combinators generic
+words interpolate namespaces sequences io.streams.string fry
+classes.mixin effects lexer parser classes.tuple.parser
+effects.parser locals.types locals.parser locals.rewrite.closures ;
IN: functors
: scan-param ( -- obj )
: (FUNCTOR:) ( -- word def )
CREATE
- parse-locals
+ parse-locals dup push-locals
parse-functor-body swap pop-locals <lambda>
- lambda-rewrite first ;
+ rewrite-closures first ;
: FUNCTOR: (FUNCTOR:) define ; parsing
USING: help.syntax help.markup kernel sequences quotations\r
-math arrays ;\r
+math arrays combinators ;\r
IN: generalizations\r
\r
HELP: nsequence\r
}\r
} ;\r
\r
+HELP: ncleave\r
+{ $values { "quots" "a sequence of quotations" } { "n" integer } }\r
+{ $description "A generalization of " { $link cleave } " and " { $link 2cleave } " that can work for any quotation arity."\r
+} \r
+{ $examples\r
+ "Some core words expressed in terms of " { $link ncleave } ":"\r
+ { $table\r
+ { { $link cleave } { $snippet "1 ncleave" } }\r
+ { { $link 2cleave } { $snippet "2 ncleave" } }\r
+ }\r
+} ;\r
+\r
HELP: mnswap\r
{ $values { "m" integer } { "n" integer } }\r
{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }\r
{ $subsection nslip }\r
{ $subsection nkeep }\r
{ $subsection napply }\r
+{ $subsection ncleave }\r
"Generalized quotation construction:"\r
{ $subsection ncurry } \r
{ $subsection nwith } ;\r
MACRO: nwith ( n -- )
[ with ] n*quot ;
+MACRO: ncleave ( quots n -- )
+ [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
+ compose ;
+
MACRO: napply ( n -- )
2 [a,b]
[ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ]
[ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
-[ { V{ "a" "b" } V{ f f } } ] [
+[ { V{ "a" "b" } V{ 0 0 } } ] [
V{ "a" "b" } clone 2 <groups>
2 over set-length
>array
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors definitions help help.topics help.syntax
-prettyprint.backend prettyprint words kernel effects ;
+prettyprint.backend prettyprint.custom prettyprint words kernel
+effects ;
IN: help.definitions
! Definition protocol implementation
USING: help help.markup help.syntax help.definitions help.topics
namespaces words sequences classes assocs vocabs kernel arrays
-prettyprint.backend kernel.private io generic math system
-strings sbufs vectors byte-arrays quotations
+prettyprint.backend prettyprint.custom kernel.private io generic
+math system strings sbufs vectors byte-arrays quotations
io.streams.byte-array classes.builtin parser lexer
classes.predicate classes.union classes.intersection
classes.singleton classes.tuple tools.vocabs.browser math.parser
vocab-exists? [ "$vocab-link to non-existent vocabulary" throw ] unless
] each ;
-: check-rendering ( word element -- )
+: check-rendering ( element -- )
[ print-topic ] with-string-writer drop ;
: all-word-help ( words -- seq )
: check-word ( word -- )
dup word-help [
[
- dup word-help [
- 2dup check-examples
- 2dup check-values
- 2dup check-see-also
- 2dup nip check-modules
- 2dup drop check-rendering
- ] assert-depth 2drop
+ dup word-help '[
+ _ _ {
+ [ check-examples ]
+ [ check-values ]
+ [ check-see-also ]
+ [ [ check-rendering ] [ check-modules ] bi* ]
+ } 2cleave
+ ] assert-depth
] check-something
] [ drop ] if ;
: check-article ( article -- )
[
- dup article-content [
- 2dup check-modules check-rendering
- ] assert-depth 2drop
+ dup article-content
+ '[ _ check-rendering _ check-modules ]
+ assert-depth
] check-something ;
: files>vocabs ( -- assoc )
] [
[
swap vocab-heading.
- [ error. nl ] each
+ [ print-error nl ] each
] assoc-each
] if-empty ;
#! dynamically creating words.
[ elements-vocab create ] 2dip define-declared ;
-: <foo> ( str -- <str> ) "<" swap ">" 3append ;
+: <foo> ( str -- <str> ) "<" ">" surround ;
: def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned
#! word.
foo> [ ">" write-html ] (( -- )) html-word ;
-: </foo> ( str -- </str> ) "</" swap ">" 3append ;
+: </foo> ( str -- </str> ) "</" ">" surround ;
: def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned
#! word.
</foo> dup '[ _ write-html ] (( -- )) html-word ;
-: <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
+: <foo/> ( str -- <str/> ) "<" "/>" surround ;
: def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned
namespaces make classes.tuple assocs splitting words arrays io
io.files io.encodings.utf8 io.streams.string unicode.case
mirrors math urls present multiline quotations xml logging
+continuations
xml.data
html.forms
html.elements
USING: assocs namespaces make kernel sequences accessors
combinators strings splitting io io.streams.string present
xml.writer xml.data xml.entities html.forms
-html.templates html.templates.chloe.syntax ;
+html.templates html.templates.chloe.syntax continuations ;
IN: html.templates.chloe.compiler
: chloe-attrs-only ( assoc -- assoc' )
USING: accessors assocs kernel math math.parser namespaces make
sequences io io.sockets io.streams.string io.files io.timeouts
strings splitting calendar continuations accessors vectors
-math.order hashtables byte-arrays prettyprint destructors
+math.order hashtables byte-arrays destructors
io.encodings
io.encodings.string
io.encodings.ascii
io.encodings.8-bit
io.encodings.binary
io.streams.duplex
-fry debugger summary ascii urls urls.encoding present
+fry ascii urls urls.encoding present
http http.parsers ;
IN: http.client
ERROR: too-many-redirects ;
-M: too-many-redirects summary
- drop
- [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
-
<PRIVATE
DEFER: (with-http-request)
ERROR: download-failed response ;
-M: download-failed error.
- "HTTP request failed:" print nl
- response>> . ;
-
: check-response ( response -- response )
dup code>> success? [ download-failed ] unless ;
: http-post ( post-data url -- response data )
<post-request> http-request ;
+
+USING: vocabs vocabs.loader ;
+
+"debugger" vocab [ "http.client.debugger" require ] when
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel summary debugger io make math.parser
+prettyprint http.client accessors ;
+IN: http.client.debugger
+
+M: too-many-redirects summary
+ drop
+ [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
+
+M: download-failed error.
+ "HTTP request failed:" print nl
+ response>> . ;
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel combinators math namespaces make
-assocs sequences splitting sorting sets debugger
-strings vectors hashtables quotations arrays byte-arrays
-math.parser calendar calendar.format present urls
+USING: accessors kernel combinators math namespaces make assocs
+sequences splitting sorting sets strings vectors hashtables
+quotations arrays byte-arrays math.parser calendar
+calendar.format present urls
io io.encodings io.encodings.iana io.encodings.binary
io.encodings.8-bit
[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test
[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test
-
-: correct-endian
- code>> little-endian? [ utf16le = ] [ utf16be = ] if ;
-
-[ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test
-[ t ] [ utf16n <byte-writer> correct-endian ] unit-test
--- /dev/null
+USING: help.markup help.syntax ;
+IN: io.encodings.utf16n
+
+HELP: utf16n
+{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
+{ $see-also "encodings-introduction" } ;
--- /dev/null
+USING: accessors alien.c-types kernel
+io.encodings.utf16 io.streams.byte-array tools.test ;
+IN: io.encodings.utf16n
+
+: correct-endian
+ code>> little-endian? [ utf16le = ] [ utf16be = ] if ;
+
+[ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test
+[ t ] [ utf16n <byte-writer> correct-endian ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types io.encodings io.encodings.utf16 kernel ;
+IN: io.encodings.utf16n
+
+! Native-order UTF-16
+
+SINGLETON: utf16n
+
+: utf16n ( -- descriptor )
+ little-endian? utf16le utf16be ? ; foldable
+
+M: utf16n <decoder> drop utf16n <decoder> ;
+
+M: utf16n <encoder> drop utf16n <encoder> ;
+++ /dev/null
-USING: io.backend ;
-IN: io.files.unique.backend
-
-HOOK: (make-unique-file) io-backend ( path -- )
-HOOK: temporary-path io-backend ( -- path )
io.files.unique.private math.parser io.files ;
IN: io.files.unique
+HELP: temporary-path
+{ $values
+ { "path" "a pathname string" }
+}
+{ $description "A hook that returns the path of the temporary directory in a platform-specific way. Does not guarantee that path is writable by your user." } ;
+
+HELP: touch-unique-file
+{ $values
+ { "path" "a pathname string" }
+}
+{ $description "Creates a unique file in a platform-specific way. The file is guaranteed not to exist and is openable by your user." } ;
+
+HELP: unique-length
+{ $description "A symbol storing the number of random characters inserted between the prefix and suffix of a random file name." } ;
+
+HELP: unique-retries
+{ $description "The number of times to try creating a unique file in case of a name collision. The odds of a name collision are extremely low with a sufficient " { $link unique-length } "." } ;
+
+{ unique-length unique-retries } related-words
+
HELP: make-unique-file ( prefix suffix -- path )
{ $values { "prefix" "a string" } { "suffix" "a string" }
{ "path" "a pathname string" } }
{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." }
-{ $errors "Throws an error if a new unique file cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." }
-{ $see-also with-unique-file } ;
+{ $errors "Throws an error if a new unique file cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ;
+
+HELP: make-unique-file*
+{ $values
+ { "prefix" null } { "suffix" null }
+ { "path" "a pathname string" }
+}
+{ $description "Creates a file that is guaranteed not to exist in the directory in the " { $link current-directory } " variable. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." } ;
+
+{ make-unique-file make-unique-file* with-unique-file } related-words
HELP: with-unique-file ( prefix suffix quot: ( path -- ) -- )
{ $values { "prefix" "a string" } { "suffix" "a string" }
HELP: make-unique-directory ( -- path )
{ $values { "path" "a pathname string" } }
{ $description "Creates a directory that is guaranteed not to exist in a platform-specific temporary directory and returns the full pathname." }
-{ $errors "Throws an error if the directory cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." }
-{ $see-also with-unique-directory } ;
+{ $errors "Throws an error if the directory cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ;
HELP: with-unique-directory ( quot -- )
{ $values { "quot" "a quotation" } }
"The " { $vocab-link "io.files.unique" } " vocabulary implements cross-platform temporary file creation in a high-level and secure way." $nl
"Files:"
{ $subsection make-unique-file }
+{ $subsection make-unique-file* }
{ $subsection with-unique-file }
"Directories:"
{ $subsection make-unique-directory }
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.bitwise math.parser
-random sequences continuations namespaces
-io.files io arrays io.files.unique.backend system
-combinators vocabs.loader fry ;
+USING: kernel math math.bitwise math.parser random sequences
+continuations namespaces io.files io arrays system
+combinators vocabs.loader fry io.backend ;
IN: io.files.unique
+HOOK: touch-unique-file io-backend ( path -- )
+HOOK: temporary-path io-backend ( -- path )
+
SYMBOL: unique-length
SYMBOL: unique-retries
PRIVATE>
+: (make-unique-file) ( path prefix suffix -- path )
+ '[
+ _ _ _ unique-length get random-name glue append-path
+ dup touch-unique-file
+ ] unique-retries get retry ;
+
: make-unique-file ( prefix suffix -- path )
- temporary-path -rot
- [
- unique-length get random-name glue append-path
- dup (make-unique-file)
- ] 3curry unique-retries get retry ;
+ [ temporary-path ] 2dip (make-unique-file) ;
+
+: make-unique-file* ( prefix suffix -- path )
+ [ current-directory get ] 2dip (make-unique-file) ;
: with-unique-file ( prefix suffix quot: ( path -- ) -- )
[ make-unique-file ] dip [ delete-file ] bi ; inline
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: io.paths kernel tools.test io.files.unique sequences
+io.files namespaces sorting ;
+IN: io.paths.tests
+
+[ t ] [
+ [
+ 10 [ "io.paths.test" "gogogo" make-unique-file* ] replicate
+ current-directory get t [ ] find-all-files
+ ] with-unique-directory
+ [ natural-sort ] bi@ =
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays deques dlists io.files
+kernel sequences system vocabs.loader fry continuations ;
+IN: io.paths
+
+TUPLE: directory-iterator path bfs queue ;
+
+<PRIVATE
+
+: qualified-directory ( path -- seq )
+ dup directory-files [ append-path ] with map ;
+
+: push-directory ( path iter -- )
+ [ qualified-directory ] dip [
+ dup queue>> swap bfs>>
+ [ push-front ] [ push-back ] if
+ ] curry each ;
+
+: <directory-iterator> ( path bfs? -- iterator )
+ <dlist> directory-iterator boa
+ dup path>> over push-directory ;
+
+: next-file ( iter -- file/f )
+ dup queue>> deque-empty? [ drop f ] [
+ dup queue>> pop-back dup link-info directory?
+ [ over push-directory next-file ] [ nip ] if
+ ] if ;
+
+: iterate-directory ( iter quot: ( obj -- ? ) -- obj )
+ over next-file [
+ over call
+ [ 2nip ] [ iterate-directory ] if*
+ ] [
+ 2drop f
+ ] if* ; inline recursive
+
+PRIVATE>
+
+: find-file ( path bfs? quot: ( obj -- ? ) -- path/f )
+ [ <directory-iterator> ] dip
+ [ keep and ] curry iterate-directory ; inline
+
+: each-file ( path bfs? quot: ( obj -- ? ) -- )
+ [ <directory-iterator> ] dip
+ [ f ] compose iterate-directory drop ; inline
+
+: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths )
+ [ <directory-iterator> ] dip
+ pusher [ [ f ] compose iterate-directory drop ] dip ; inline
+
+: recursive-directory ( path bfs? -- paths )
+ [ ] accumulator [ each-file ] dip ;
+
+: find-in-directories ( directories bfs? quot -- path' )
+ '[ _ _ find-file ] attempt-all ; inline
+
+os windows? [ "io.paths.windows" require ] when
--- /dev/null
+Doug Coleman
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays continuations fry io.files io.paths
+kernel windows.shell32 sequences ;
+IN: io.paths.windows
+
+: program-files-directories ( -- array )
+ program-files program-files-x86 2array ; inline
+
+: find-in-program-files ( base-directory bfs? quot -- path )
+ [
+ [ program-files-directories ] dip '[ _ append-path ] map
+ ] 2dip find-in-directories ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel io sequences io.buffers io.timeouts generic
byte-vectors system io.encodings math.order io.backend
-continuations debugger classes byte-arrays namespaces splitting
+continuations classes byte-arrays namespaces splitting
grouping dlists assocs io.encodings.binary summary accessors
destructors combinators ;
IN: io.ports
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors kernel math math.parser
-namespaces parser sequences strings prettyprint debugger
+namespaces parser sequences strings prettyprint
quotations combinators logging calendar assocs present
fry accessors arrays io io.sockets io.encodings.ascii
io.sockets.secure io.files io.streams.duplex io.timeouts
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors byte-arrays kernel debugger sequences
+USING: accessors byte-arrays kernel sequences
namespaces math math.order combinators init alien alien.c-types
-alien.strings libc continuations destructors debugger summary
+alien.strings libc continuations destructors summary
splitting assocs random math.parser locals unicode.case openssl
openssl.libcrypto openssl.libssl io.backend io.ports io.files
io.encodings.8-bit io.timeouts io.sockets.secure ;
USING: generic kernel io.backend namespaces continuations
sequences arrays io.encodings io.ports io.streams.duplex
io.encodings.ascii alien.strings io.binary accessors destructors
-classes debugger byte-arrays system combinators parser
+classes byte-arrays system combinators parser
alien.c-types math.parser splitting grouping math assocs summary
system vocabs.loader combinators present fry ;
IN: io.sockets
--- /dev/null
+USING: help.syntax help.markup io byte-arrays quotations ;
+IN: io.streams.byte-array
+
+ABOUT: "io.streams.byte-array"
+
+ARTICLE: "io.streams.byte-array" "Byte-array streams"
+"Byte array streams:"
+{ $subsection <byte-reader> }
+{ $subsection <byte-writer> }
+"Utility combinators:"
+{ $subsection with-byte-reader }
+{ $subsection with-byte-writer } ;
+
+HELP: <byte-reader>
+{ $values { "byte-array" byte-array }
+ { "encoding" "an encoding descriptor" }
+ { "stream" "a new byte reader" } }
+{ $description "Creates an input stream reading from a byte array using an encoding." } ;
+
+HELP: <byte-writer>
+{ $values { "encoding" "an encoding descriptor" }
+ { "stream" "a new byte writer" } }
+{ $description "Creates an output stream writing data to a byte array using an encoding." } ;
+
+HELP: with-byte-reader
+{ $values { "encoding" "an encoding descriptor" }
+ { "quot" quotation } { "byte-array" byte-array } }
+{ $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream for reading from a byte array using an encoding." } ;
+
+HELP: with-byte-writer
+{ $values { "encoding" "an encoding descriptor" }
+ { "quot" quotation }
+ { "byte-array" byte-array } }
+{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an output stream writing data to a byte array using an encoding." } ;
--- /dev/null
+USING: tools.test io.streams.byte-array io.encodings.binary
+io.encodings.utf8 io kernel arrays strings ;
+
+[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test
+[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
+
+[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
+[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test
+[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
--- /dev/null
+USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
+sequences io namespaces io.encodings.private accessors ;
+IN: io.streams.byte-array
+
+: <byte-writer> ( encoding -- stream )
+ 512 <byte-vector> swap <encoder> ;
+
+: with-byte-writer ( encoding quot -- byte-array )
+ [ <byte-writer> ] dip [ output-stream get ] compose with-output-stream*
+ dup encoder? [ stream>> ] when >byte-array ; inline
+
+: <byte-reader> ( byte-array encoding -- stream )
+ [ >byte-vector dup reverse-here ] dip <decoder> ;
+
+: with-byte-reader ( byte-array encoding quot -- )
+ [ <byte-reader> ] dip with-input-stream* ; inline
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations destructors io io.encodings
-io.encodings.private io.timeouts io.ports debugger summary
-listener accessors delegate delegate.protocols ;
+io.encodings.private io.timeouts io.ports summary
+accessors delegate delegate.protocols ;
IN: io.streams.duplex
TUPLE: duplex-stream in out ;
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math io io.encodings destructors accessors
-sequences namespaces ;
+sequences namespaces byte-vectors ;
IN: io.streams.limited
TUPLE: limited-stream stream count limit ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables io colors ;
+USING: hashtables io colors summary make accessors splitting
+kernel ;
IN: io.styles
SYMBOL: plain
C: <input> input
+M: input summary
+ [
+ "Input: " %
+ string>> "\n" split1 swap %
+ "..." "" ? %
+ ] "" make ;
+
: write-object ( str obj -- ) presented associate format ;
GENERIC: wait-for-events ( ms mx -- )
: input-available ( fd mx -- )
- remove-input-callbacks [ resume ] each ;
+ reads>> delete-at* drop [ resume ] each ;
: output-available ( fd mx -- )
- remove-output-callbacks [ resume ] each ;
+ writes>> delete-at* drop [ resume ] each ;
M: fd cancel-operation ( fd -- )
dup disposed>> [ drop ] [
f <void*> dup 0 getmntinfo64 dup io-error
[ *void* ] dip
"statfs64" heap-size [ * memory>byte-array ] keep group
- [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
+ [ statfs64-f_mntonname utf8 alien>string file-system-info ] map ;
+ ! [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
M: macosx new-file-system-info macosx-file-system-info new ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.ports io.unix.backend math.bitwise
-unix io.files.unique.backend system ;
+unix system io.files.unique ;
IN: io.unix.files.unique
: open-unique-flags ( -- flags )
{ O_RDWR O_CREAT O_EXCL } flags ;
-M: unix (make-unique-file) ( path -- )
+M: unix touch-unique-file ( path -- )
open-unique-flags file-mode open-file close-file ;
M: unix temporary-path ( -- path ) "/tmp" ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel math math.bitwise namespaces
-locals accessors combinators threads vectors hashtables
-sequences assocs continuations sets
-unix unix.time unix.kqueue unix.process
-io.ports io.unix.backend io.launcher io.unix.launcher
-io.monitors ;
+USING: accessors alien.c-types combinators io.unix.backend
+kernel math.bitwise sequences struct-arrays unix unix.kqueue
+unix.time assocs ;
IN: io.unix.kqueue
-TUPLE: kqueue-mx < mx events monitors ;
+TUPLE: kqueue-mx < mx events ;
: max-events ( -- n )
#! We read up to 256 events at a time. This is an arbitrary
: <kqueue-mx> ( -- mx )
kqueue-mx new-mx
- H{ } clone >>monitors
kqueue dup io-error >>fd
- max-events "kevent" <c-array> >>events ;
+ max-events "kevent" <struct-array> >>events ;
-GENERIC: io-task-filter ( task -- n )
-
-M: input-task io-task-filter drop EVFILT_READ ;
-
-M: output-task io-task-filter drop EVFILT_WRITE ;
-
-GENERIC: io-task-fflags ( task -- n )
-
-M: io-task io-task-fflags drop 0 ;
-
-: make-kevent ( task flags -- event )
+: make-kevent ( fd filter flags -- event )
"kevent" <c-object>
- tuck set-kevent-flags
- over io-task-fd over set-kevent-ident
- over io-task-fflags over set-kevent-fflags
- swap io-task-filter over set-kevent-filter ;
+ [ set-kevent-flags ] keep
+ [ set-kevent-filter ] keep
+ [ set-kevent-ident ] keep ;
: register-kevent ( kevent mx -- )
- fd>> swap 1 f 0 f kevent
- 0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
-
-M: kqueue-mx register-io-task ( task mx -- )
- [ >r EV_ADD make-kevent r> register-kevent ]
- [ call-next-method ]
- 2bi ;
-
-M: kqueue-mx unregister-io-task ( task mx -- )
- [ call-next-method ]
- [ >r EV_DELETE make-kevent r> register-kevent ]
- 2bi ;
+ fd>> swap 1 f 0 f kevent io-error ;
+
+M: kqueue-mx add-input-callback ( thread fd mx -- )
+ [ call-next-method ] [
+ [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+ register-kevent
+ ] 2bi ;
+
+M: kqueue-mx add-output-callback ( thread fd mx -- )
+ [ call-next-method ] [
+ [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+ register-kevent
+ ] 2bi ;
+
+M: kqueue-mx remove-input-callbacks ( fd mx -- seq )
+ 2dup reads>> key? [
+ [ call-next-method ] [
+ [ EVFILT_READ EV_DELETE make-kevent ] dip
+ register-kevent
+ ] 2bi
+ ] [ 2drop f ] if ;
+
+M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
+ 2dup writes>> key? [
+ [
+ [ EVFILT_WRITE EV_DELETE make-kevent ] dip
+ register-kevent
+ ] [ call-next-method ] 2bi
+ ] [ 2drop f ] if ;
: wait-kevent ( mx timespec -- n )
- >r [ fd>> f 0 ] keep events>> max-events r> kevent
- dup multiplexer-error ;
-
-:: kevent-read-task ( mx fd kevent -- )
- mx fd mx reads>> at perform-io-task ;
-
-:: kevent-write-task ( mx fd kevent -- )
- mx fd mx writes>> at perform-io-task ;
-
-:: kevent-proc-task ( mx pid kevent -- )
- pid wait-for-pid
- pid find-process
- dup [ swap notify-exit ] [ 2drop ] if ;
-
-: parse-action ( mask -- changed )
[
- NOTE_DELETE +remove-file+ ?flag
- NOTE_WRITE +modify-file+ ?flag
- NOTE_EXTEND +modify-file+ ?flag
- NOTE_ATTRIB +modify-file+ ?flag
- NOTE_RENAME +rename-file+ ?flag
- NOTE_REVOKE +remove-file+ ?flag
- drop
- ] { } make prune ;
-
-:: kevent-vnode-task ( mx kevent fd -- )
- ""
- kevent kevent-fflags parse-action
- fd mx monitors>> at queue-change ;
+ [ fd>> f 0 ]
+ [ events>> [ underlying>> ] [ length ] bi ] bi
+ ] dip kevent
+ dup multiplexer-error ;
: handle-kevent ( mx kevent -- )
- [ ] [ kevent-ident ] [ kevent-filter ] tri {
- { [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
- { [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
- { [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] }
- { [ dup EVFILT_VNODE = ] [ drop kevent-vnode-task ] }
- } cond ;
+ [ kevent-ident swap ] [ kevent-filter ] bi {
+ { EVFILT_READ [ input-available ] }
+ { EVFILT_WRITE [ output-available ] }
+ } case ;
: handle-kevents ( mx n -- )
- [ over events>> kevent-nth handle-kevent ] with each ;
+ [ dup events>> ] dip head-slice [ handle-kevent ] with each ;
M: kqueue-mx wait-for-events ( us mx -- )
swap dup [ make-timespec ] when
dupd wait-kevent handle-kevents ;
-
-! Procs
-: make-proc-kevent ( pid -- kevent )
- "kevent" <c-object>
- tuck set-kevent-ident
- EV_ADD over set-kevent-flags
- EVFILT_PROC over set-kevent-filter
- NOTE_EXIT over set-kevent-fflags ;
-
-: register-pid-task ( pid mx -- )
- swap make-proc-kevent swap register-kevent ;
-
-! VNodes
-TUPLE: vnode-monitor < monitor fd ;
-
-: vnode-fflags ( -- n )
- {
- NOTE_DELETE
- NOTE_WRITE
- NOTE_EXTEND
- NOTE_ATTRIB
- NOTE_LINK
- NOTE_RENAME
- NOTE_REVOKE
- } flags ;
-
-: make-vnode-kevent ( fd flags -- kevent )
- "kevent" <c-object>
- tuck set-kevent-flags
- tuck set-kevent-ident
- EVFILT_VNODE over set-kevent-filter
- vnode-fflags over set-kevent-fflags ;
-
-: register-monitor ( monitor mx -- )
- >r dup fd>> r>
- [ >r EV_ADD EV_CLEAR bitor make-vnode-kevent r> register-kevent drop ]
- [ monitors>> set-at ] 3bi ;
-
-: unregister-monitor ( monitor mx -- )
- >r fd>> r>
- [ monitors>> delete-at ]
- [ >r EV_DELETE make-vnode-kevent r> register-kevent ] 2bi ;
-
-: <vnode-monitor> ( path mailbox -- monitor )
- >r [ O_RDONLY 0 open dup io-error ] keep r>
- vnode-monitor new-monitor swap >>fd
- [ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ;
-
-M: vnode-monitor dispose
- [ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ;
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces math system sequences debugger
+USING: kernel namespaces math system sequences
continuations arrays assocs combinators alien.c-types strings
threads accessors environment
io io.backend io.launcher io.ports io.files
: redirect-fd ( oldfd fd -- )
2dup = [ 2drop ] [ dup2 io-error ] if ;
-: redirect-inherit ( obj mode fd -- )
- 3drop ;
-
: redirect-file ( obj mode fd -- )
[ [ normalize-path ] dip file-mode open-file ] dip redirect-fd ;
: redirect ( obj mode fd -- )
{
- { [ pick not ] [ redirect-inherit ] }
+ { [ pick not ] [ 3drop ] }
{ [ pick string? ] [ redirect-file ] }
{ [ pick appender? ] [ redirect-file-append ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.unix.macosx
-USING: io.unix.bsd io.backend system ;
+USING: io.unix.backend io.unix.bsd io.unix.kqueue io.backend
+namespaces system ;
+
+M: macosx init-io ( -- )
+ <kqueue-mx> mx set-global ;
macosx set-io-backend
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors unix byte-arrays kernel debugger sequences
+USING: accessors unix byte-arrays kernel sequences
namespaces math math.order combinators init alien alien.c-types
alien.strings libc continuations destructors openssl
openssl.libcrypto openssl.libssl io io.files io.ports
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.binary io.backend io.files io.buffers
-io.windows kernel math splitting fry alien.strings
-windows windows.kernel32 windows.time calendar combinators
-math.functions sequences namespaces make words symbols system
-io.ports destructors accessors math.bitwise continuations
+io.encodings.utf16n io.ports io.windows kernel math splitting
+fry alien.strings windows windows.kernel32 windows.time calendar
+combinators math.functions sequences namespaces make words
+symbols system destructors accessors math.bitwise continuations
windows.errors arrays byte-arrays ;
IN: io.windows.files
-USING: kernel system io.files.unique.backend
-windows.kernel32 io.windows io.windows.files io.ports windows
-destructors environment ;
+USING: kernel system windows.kernel32 io.windows
+io.windows.files io.ports windows destructors environment
+io.files.unique ;
IN: io.windows.files.unique
-M: windows (make-unique-file) ( path -- )
+M: windows touch-unique-file ( path -- )
GENERIC_WRITE CREATE_NEW 0 open-file dispose ;
M: windows temporary-path ( -- path )
: escape-argument ( str -- newstr )
CHAR: \s over member? [
- "\"" swap fix-trailing-backslashes "\"" 3append
+ fix-trailing-backslashes "\"" dup surround
] when ;
: join-arguments ( args -- cmd-line )
USING: continuations destructors io.buffers io.files io.backend
-io.timeouts io.ports io.windows io.windows.files
-io.windows.nt.backend windows windows.kernel32
-kernel libc math threads system environment
-alien.c-types alien.arrays alien.strings sequences combinators
-combinators.short-circuit ascii splitting alien strings
-assocs namespaces make io.files.private accessors tr ;
+io.timeouts io.ports io.files.private io.windows
+io.windows.files io.windows.nt.backend io.encodings.utf16n
+windows windows.kernel32 kernel libc math threads system
+environment alien.c-types alien.arrays alien.strings sequences
+combinators combinators.short-circuit ascii splitting alien
+strings assocs namespaces make accessors tr ;
IN: io.windows.nt.files
M: winnt cwd
hashtables sorting arrays combinators math.bitwise strings
system accessors threads splitting io.backend io.windows
io.windows.nt.backend io.windows.nt.files io.monitors io.ports
-io.buffers io.files io.timeouts io.encodings.string io
-windows windows.kernel32 windows.types ;
+io.buffers io.files io.timeouts io.encodings.string
+io.encodings.utf16n io windows windows.kernel32 windows.types ;
IN: io.windows.nt.monitors
: open-directory ( path -- handle )
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors definitions effects generic kernel locals
+macros memoize prettyprint prettyprint.backend words ;
+IN: locals.definitions
+
+PREDICATE: lambda-word < word "lambda" word-prop >boolean ;
+
+M: lambda-word definer drop \ :: \ ; ;
+
+M: lambda-word definition
+ "lambda" word-prop body>> ;
+
+M: lambda-word reset-word
+ [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
+
+INTERSECTION: lambda-macro macro lambda-word ;
+
+M: lambda-macro definer drop \ MACRO:: \ ; ;
+
+M: lambda-macro definition
+ "lambda" word-prop body>> ;
+
+M: lambda-macro reset-word
+ [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
+
+INTERSECTION: lambda-method method-body lambda-word ;
+
+M: lambda-method definer drop \ M:: \ ; ;
+
+M: lambda-method definition
+ "lambda" word-prop body>> ;
+
+M: lambda-method reset-word
+ [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
+
+INTERSECTION: lambda-memoized memoized lambda-word ;
+
+M: lambda-memoized definer drop \ MEMO:: \ ; ;
+
+M: lambda-memoized definition
+ "lambda" word-prop body>> ;
+
+M: lambda-memoized reset-word
+ [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
+
+: method-stack-effect ( method -- effect )
+ dup "lambda" word-prop vars>>
+ swap "method-generic" word-prop stack-effect
+ dup [ out>> ] when
+ <effect> ;
+
+M: lambda-method synopsis*
+ dup dup dup definer.
+ "method-class" word-prop pprint-word
+ "method-generic" word-prop pprint-word
+ method-stack-effect effect>string comment. ;
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel summary ;
+IN: locals.errors
+
+ERROR: >r/r>-in-lambda-error ;
+
+M: >r/r>-in-lambda-error summary
+ drop
+ "Explicit retain stack manipulation is not permitted in lambda bodies" ;
+
+ERROR: binding-form-in-literal-error ;
+
+M: binding-form-in-literal-error summary
+ drop "[let, [let* and [wlet not permitted inside literals" ;
+
+ERROR: local-writer-in-literal-error ;
+
+M: local-writer-in-literal-error summary
+ drop "Local writer words not permitted inside literals" ;
+
+ERROR: local-word-in-literal-error ;
+
+M: local-word-in-literal-error summary
+ drop "Local words not permitted inside literals" ;
+
+ERROR: :>-outside-lambda-error ;
+
+M: :>-outside-lambda-error summary
+ drop ":> cannot be used outside of lambda expressions" ;
+
+ERROR: bad-lambda-rewrite output ;
+
+M: bad-lambda-rewrite summary
+ drop "You have found a bug in locals. Please report." ;
+
+ERROR: bad-local args obj ;
+
+M: bad-local summary
+ drop "You have bound a bug in locals. Please report." ;
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors fry fry.private generalizations kernel
+locals.types make sequences ;
+IN: locals.fry
+
+! Support for mixing locals with fry
+
+M: binding-form count-inputs body>> count-inputs ;
+
+M: lambda count-inputs body>> count-inputs ;
+
+M: lambda deep-fry
+ clone [ shallow-fry swap ] change-body
+ [ [ vars>> length ] keep '[ _ _ mnswap @ ] , ] [ drop [ncurry] % ] 2bi ;
+
+M: binding-form deep-fry
+ clone [ fry '[ @ call ] ] change-body , ;
}
} ;
+HELP: :>
+{ $syntax ":> binding" }
+{ $description "Introduces a new binding, lexically scoped to the enclosing quotation or definition." }
+{ $notes
+ "This word can only be used inside a lambda word, lambda quotation or let binding form."
+ $nl
+ "Lambda and let forms are really just syntax sugar for " { $link POSTPONE: :> } "."
+ $nl
+ "Lambdas desugar as follows:"
+ { $code
+ "[| a b | a b + b / ]"
+ "[ :> b :> a a b + b / ]"
+ }
+ "Let forms desugar as follows:"
+ { $code
+ "[|let | x [ 10 random ] | { x x } ]"
+ "10 random :> x { x x }"
+ }
+}
+{ $examples
+ { $code
+ "USING: locals math kernel ;"
+ "IN: scratchpad"
+ ":: quadratic ( a b c -- x y )"
+ " b sq 4 a c * * - sqrt :> disc"
+ " b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@ ;"
+ }
+} ;
+
HELP: ::
{ $syntax ":: word ( bindings... -- outputs... ) body... ;" }
{ $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." }
{ $subsection POSTPONE: [wlet }
"Lambda abstractions:"
{ $subsection POSTPONE: [| }
+"Lightweight binding form:"
+{ $subsection POSTPONE: :> }
"Additional topics:"
{ $subsection "locals-literals" }
{ $subsection "locals-mutable" }
[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval ] must-fail
+[ "USE: locals [| | { :> a } ]" eval ] must-fail
+
+[ "USE: locals 3 :> a" eval ] must-fail
+
+[ 3 ] [ 3 [| | :> a a ] call ] unit-test
+
+[ 3 ] [ 3 [| | :> a! a ] call ] unit-test
+
+[ 3 ] [ 2 [| | :> a! a 1+ a! a ] call ] unit-test
+
:: wlet-&&-test ( a -- ? )
[wlet | is-integer? [ a integer? ]
is-even? [ a even? ]
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces make sequences sequences.private assocs
-math vectors strings classes.tuple generalizations parser words
-quotations debugger macros arrays macros splitting combinators
-prettyprint.backend definitions prettyprint hashtables
-prettyprint.sections sets sequences.private effects
-effects.parser generic generic.parser compiler.units accessors
-locals.backend memoize macros.expander lexer classes summary fry
-fry.private ;
+USING: lexer macros memoize parser sequences vocabs
+vocabs.loader words kernel namespaces locals.parser locals.types
+locals.errors ;
IN: locals
-ERROR: >r/r>-in-lambda-error ;
-
-M: >r/r>-in-lambda-error summary
- drop
- "Explicit retain stack manipulation is not permitted in lambda bodies" ;
-
-ERROR: binding-form-in-literal-error ;
-
-M: binding-form-in-literal-error summary
- drop "[let, [let* and [wlet not permitted inside literals" ;
-
-ERROR: local-writer-in-literal-error ;
-
-M: local-writer-in-literal-error summary
- drop "Local writer words not permitted inside literals" ;
-
-ERROR: local-word-in-literal-error ;
-
-M: local-word-in-literal-error summary
- drop "Local words not permitted inside literals" ;
-
-ERROR: bad-lambda-rewrite output ;
-
-M: bad-lambda-rewrite summary
- drop "You have found a bug in locals. Please report." ;
-
-<PRIVATE
-
-TUPLE: lambda vars body ;
-
-C: <lambda> lambda
-
-TUPLE: binding-form bindings body ;
-
-TUPLE: let < binding-form ;
-
-C: <let> let
-
-TUPLE: let* < binding-form ;
-
-C: <let*> let*
-
-TUPLE: wlet < binding-form ;
-
-C: <wlet> wlet
-
-M: lambda expand-macros clone [ expand-macros ] change-body ;
-
-M: lambda expand-macros* expand-macros literal ;
-
-M: binding-form expand-macros
- clone
- [ [ expand-macros ] assoc-map ] change-bindings
- [ expand-macros ] change-body ;
-
-M: binding-form expand-macros* expand-macros literal ;
-
-PREDICATE: local < word "local?" word-prop ;
-
-: <local> ( name -- word )
- #! Create a local variable identifier
- f <word>
- dup t "local?" set-word-prop ;
-
-PREDICATE: local-word < word "local-word?" word-prop ;
-
-: <local-word> ( name -- word )
- f <word> dup t "local-word?" set-word-prop ;
-
-PREDICATE: local-reader < word "local-reader?" word-prop ;
-
-: <local-reader> ( name -- word )
- f <word>
- dup t "local-reader?" set-word-prop ;
-
-PREDICATE: local-writer < word "local-writer?" word-prop ;
-
-: <local-writer> ( reader -- word )
- dup name>> "!" append f <word> {
- [ nip t "local-writer?" set-word-prop ]
- [ swap "local-reader" set-word-prop ]
- [ "local-writer" set-word-prop ]
- [ nip ]
- } 2cleave ;
-
-TUPLE: quote local ;
-
-C: <quote> quote
-
-: local-index ( obj args -- n )
- [ dup quote? [ local>> ] when eq? ] with find drop ;
-
-: read-local-quot ( obj args -- quot )
- local-index neg [ get-local ] curry ;
-
-GENERIC# localize 1 ( obj args -- quot )
-
-M: local localize read-local-quot ;
-
-M: quote localize [ local>> ] dip read-local-quot ;
-
-M: local-word localize read-local-quot [ call ] append ;
-
-M: local-reader localize read-local-quot [ local-value ] append ;
-
-M: local-writer localize
- [ "local-reader" word-prop ] dip
- read-local-quot [ set-local-value ] append ;
-
-M: object localize drop 1quotation ;
-
-UNION: special local quote local-word local-reader local-writer ;
-
-: load-locals-quot ( args -- quot )
- [ [ ] ] [
- dup [ local-reader? ] contains? [
- dup [ local-reader? [ 1array ] [ ] ? ] map spread>quot
- ] [ [ ] ] if swap length [ load-locals ] curry append
- ] if-empty ;
-
-: drop-locals-quot ( args -- quot )
- [ [ ] ] [ length [ drop-locals ] curry ] if-empty ;
-
-: point-free-body ( quot args -- newquot )
- [ but-last-slice ] dip '[ _ localize ] map concat ;
-
-: point-free-end ( quot args -- newquot )
- over peek special?
- [ dup drop-locals-quot [ [ peek ] dip localize ] dip append ]
- [ drop-locals-quot swap peek suffix ]
- if ;
-
-: (point-free) ( quot args -- newquot )
- [ nip load-locals-quot ]
- [ reverse point-free-body ]
- [ reverse point-free-end ]
- 2tri [ ] 3append-as ;
-
-: point-free ( quot args -- newquot )
- over empty? [ nip length '[ _ ndrop ] ] [ (point-free) ] if ;
-
-UNION: lexical local local-reader local-writer local-word ;
-
-GENERIC: free-vars* ( form -- )
-
-: free-vars ( form -- vars )
- [ free-vars* ] { } make prune ;
-
-M: local-writer free-vars* "local-reader" word-prop , ;
-
-M: lexical free-vars* , ;
-
-M: quote free-vars* , ;
-
-M: object free-vars* drop ;
-
-M: quotation free-vars* [ free-vars* ] each ;
-
-M: lambda free-vars* [ vars>> ] [ body>> ] bi free-vars swap diff % ;
-
-GENERIC: lambda-rewrite* ( obj -- )
-
-GENERIC: local-rewrite* ( obj -- )
-
-: lambda-rewrite ( form -- form' )
- expand-macros
- [ local-rewrite* ] [ ] make
- [ [ lambda-rewrite* ] each ] [ ] make ;
-
-UNION: block callable lambda ;
-
-GENERIC: block-vars ( block -- seq )
-
-GENERIC: block-body ( block -- quot )
-
-M: callable block-vars drop { } ;
-
-M: callable block-body ;
-
-M: callable local-rewrite*
- [ [ local-rewrite* ] each ] [ ] make , ;
-
-M: lambda block-vars vars>> ;
-
-M: lambda block-body body>> ;
-
-M: lambda local-rewrite*
- [ vars>> ] [ body>> ] bi
- [ [ local-rewrite* ] each ] [ ] make <lambda> , ;
-
-M: block lambda-rewrite*
- #! Turn free variables into bound variables, curry them
- #! onto the body
- dup free-vars [ <quote> ] map dup % [
- over block-vars prepend
- swap block-body [ [ lambda-rewrite* ] each ] [ ] make
- swap point-free ,
- ] keep length \ curry <repetition> % ;
-
-GENERIC: rewrite-literal? ( obj -- ? )
-
-M: special rewrite-literal? drop t ;
-
-M: array rewrite-literal? [ rewrite-literal? ] contains? ;
-
-M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
-
-M: wrapper rewrite-literal? drop t ;
-
-M: hashtable rewrite-literal? drop t ;
-
-M: vector rewrite-literal? drop t ;
-
-M: tuple rewrite-literal? drop t ;
-
-M: object rewrite-literal? drop f ;
-
-GENERIC: rewrite-element ( obj -- )
-
-: rewrite-elements ( seq -- )
- [ rewrite-element ] each ;
-
-: rewrite-sequence ( seq -- )
- [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ;
-
-M: array rewrite-element
- dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
-
-M: vector rewrite-element rewrite-sequence ;
-
-M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
-
-M: tuple rewrite-element
- [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
-
-M: quotation rewrite-element local-rewrite* ;
-
-M: lambda rewrite-element local-rewrite* ;
-
-M: binding-form rewrite-element binding-form-in-literal-error ;
-
-M: local rewrite-element , ;
-
-M: local-reader rewrite-element , ;
-
-M: local-writer rewrite-element
- local-writer-in-literal-error ;
-
-M: local-word rewrite-element
- local-word-in-literal-error ;
-
-M: word rewrite-element literalize , ;
-
-M: wrapper rewrite-element
- dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ;
-
-M: object rewrite-element , ;
-
-M: array local-rewrite* rewrite-element ;
-
-M: vector local-rewrite* rewrite-element ;
-
-M: tuple local-rewrite* rewrite-element ;
-
-M: hashtable local-rewrite* rewrite-element ;
-
-M: wrapper local-rewrite* rewrite-element ;
-
-M: word local-rewrite*
- dup { >r r> load-locals get-local drop-locals } memq?
- [ >r/r>-in-lambda-error ] [ call-next-method ] if ;
-
-M: object lambda-rewrite* , ;
-
-M: object local-rewrite* , ;
-
-: make-local ( name -- word )
- "!" ?tail [
- <local-reader>
- dup <local-writer> dup name>> set
- ] [ <local> ] if
- dup dup name>> set ;
-
-: make-locals ( seq -- words assoc )
- [ [ make-local ] map ] H{ } make-assoc ;
-
-: make-local-word ( name def -- word )
- [ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
- "local-word-def" set-word-prop ;
-
-: push-locals ( assoc -- )
- use get push ;
-
-: pop-locals ( assoc -- )
- use get delete ;
-
-SYMBOL: in-lambda?
-
-: (parse-lambda) ( assoc end -- quot )
- t in-lambda? [ parse-until ] with-variable
- >quotation swap pop-locals ;
-
-: parse-lambda ( -- lambda )
- "|" parse-tokens make-locals dup push-locals
- \ ] (parse-lambda) <lambda> ;
-
-: parse-binding ( end -- pair/f )
- scan {
- { [ dup not ] [ unexpected-eof ] }
- { [ 2dup = ] [ 2drop f ] }
- [ nip scan-object 2array ]
- } cond ;
-
-: (parse-bindings) ( end -- )
- dup parse-binding dup [
- first2 [ make-local ] dip 2array ,
- (parse-bindings)
- ] [ 2drop ] if ;
-
-: parse-bindings ( end -- bindings vars )
- [
- [ (parse-bindings) ] H{ } make-assoc
- dup push-locals
- ] { } make swap ;
-
-: parse-bindings* ( end -- words assoc )
- [
- [
- namespace push-locals
-
- (parse-bindings)
- ] { } make-assoc
- ] { } make swap ;
-
-: (parse-wbindings) ( end -- )
- dup parse-binding dup [
- first2 [ make-local-word ] keep 2array ,
- (parse-wbindings)
- ] [ 2drop ] if ;
-
-: parse-wbindings ( end -- bindings vars )
- [
- [ (parse-wbindings) ] H{ } make-assoc
- dup push-locals
- ] { } make swap ;
-
-: let-rewrite ( body bindings -- )
- <reversed> [
- [ 1array ] dip spin <lambda> '[ @ @ ]
- ] assoc-each local-rewrite* \ call , ;
-
-M: let local-rewrite*
- [ body>> ] [ bindings>> ] bi let-rewrite ;
-
-M: let* local-rewrite*
- [ body>> ] [ bindings>> ] bi let-rewrite ;
-
-M: wlet local-rewrite*
- [ body>> ] [ bindings>> ] bi
- [ '[ _ ] ] assoc-map
- let-rewrite ;
-
-: parse-locals ( -- vars assoc )
- "(" expect ")" parse-effect
- word [ over "declared-effect" set-word-prop ] when*
- in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
-
-: parse-locals-definition ( word -- word quot )
- parse-locals \ ; (parse-lambda) <lambda>
- 2dup "lambda" set-word-prop
- lambda-rewrite dup length 1 = [ first ] [ bad-lambda-rewrite ] if ;
-
-: (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
-
-: (M::) ( -- word def )
- CREATE-METHOD
- [ parse-locals-definition ] with-method-definition ;
-
-: parsed-lambda ( accum form -- accum )
- in-lambda? get [ parsed ] [ lambda-rewrite over push-all ] if ;
-
-PRIVATE>
+: :>
+ scan locals get [ :>-outside-lambda-error ] unless*
+ [ make-local ] bind <def> parsed ; parsing
: [| parse-lambda parsed-lambda ; parsing
: MEMO:: (::) define-memoized ; parsing
-<PRIVATE
-
-! Pretty-printing locals
-SYMBOL: |
-
-: pprint-var ( var -- )
- #! Prettyprint a read/write local as its writer, just like
- #! in the input syntax: [| x! | ... x 3 + x! ]
- dup local-reader? [
- "local-writer" word-prop
- ] when pprint-word ;
-
-: pprint-vars ( vars -- ) [ pprint-var ] each ;
-
-M: lambda pprint*
- <flow
- \ [| pprint-word
- dup vars>> pprint-vars
- \ | pprint-word
- f <inset body>> pprint-elements block>
- \ ] pprint-word
- block> ;
-
-: pprint-let ( let word -- )
- pprint-word
- [ body>> ] [ bindings>> ] bi
- \ | pprint-word
- t <inset
- <block
- [ <block [ pprint-var ] dip pprint* block> ] assoc-each
- block>
- \ | pprint-word
- <block pprint-elements block>
- block>
- \ ] pprint-word ;
-
-M: let pprint* \ [let pprint-let ;
-
-M: wlet pprint* \ [wlet pprint-let ;
-
-M: let* pprint* \ [let* pprint-let ;
-
-PREDICATE: lambda-word < word "lambda" word-prop >boolean ;
-
-M: lambda-word definer drop \ :: \ ; ;
-
-M: lambda-word definition
- "lambda" word-prop body>> ;
-
-M: lambda-word reset-word
- [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
-
-INTERSECTION: lambda-macro macro lambda-word ;
-
-M: lambda-macro definer drop \ MACRO:: \ ; ;
-
-M: lambda-macro definition
- "lambda" word-prop body>> ;
-
-M: lambda-macro reset-word
- [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
-
-INTERSECTION: lambda-method method-body lambda-word ;
-
-M: lambda-method definer drop \ M:: \ ; ;
-
-M: lambda-method definition
- "lambda" word-prop body>> ;
-
-M: lambda-method reset-word
- [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
-
-INTERSECTION: lambda-memoized memoized lambda-word ;
-
-M: lambda-memoized definer drop \ MEMO:: \ ; ;
-
-M: lambda-memoized definition
- "lambda" word-prop body>> ;
-
-M: lambda-memoized reset-word
- [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
-
-: method-stack-effect ( method -- effect )
- dup "lambda" word-prop vars>>
- swap "method-generic" word-prop stack-effect
- dup [ out>> ] when
- <effect> ;
-
-M: lambda-method synopsis*
- dup dup dup definer.
- "method-class" word-prop pprint-word
- "method-generic" word-prop pprint-word
- method-stack-effect effect>string comment. ;
-
-PRIVATE>
-
-! Locals and fry
-M: binding-form count-inputs body>> count-inputs ;
-
-M: lambda count-inputs body>> count-inputs ;
-
-M: lambda deep-fry
- clone [ shallow-fry swap ] change-body
- [ [ vars>> length ] keep '[ _ _ mnswap @ ] , ] [ drop [ncurry] % ] 2bi ;
+{
+ "locals.macros"
+ "locals.fry"
+} [ require ] each
-M: binding-form deep-fry
- clone [ fry '[ @ call ] ] change-body , ;
+"prettyprint" vocab [
+ "locals.definitions" require
+ "locals.prettyprint" require
+] when
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel locals.types macros.expander ;
+IN: locals.macros
+
+M: lambda expand-macros clone [ expand-macros ] change-body ;
+
+M: lambda expand-macros* expand-macros literal ;
+
+M: binding-form expand-macros
+ clone
+ [ [ expand-macros ] assoc-map ] change-bindings
+ [ expand-macros ] change-body ;
+
+M: binding-form expand-macros* expand-macros literal ;
+
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators effects.parser
+generic.parser kernel lexer locals.errors
+locals.rewrite.closures locals.types make namespaces parser
+quotations sequences splitting words ;
+IN: locals.parser
+
+: make-local ( name -- word )
+ "!" ?tail [
+ <local-reader>
+ dup <local-writer> dup name>> set
+ ] [ <local> ] if
+ dup dup name>> set ;
+
+: make-locals ( seq -- words assoc )
+ [ [ make-local ] map ] H{ } make-assoc ;
+
+: make-local-word ( name def -- word )
+ [ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
+ "local-word-def" set-word-prop ;
+
+SYMBOL: locals
+
+: push-locals ( assoc -- )
+ use get push ;
+
+: pop-locals ( assoc -- )
+ use get delete ;
+
+SYMBOL: in-lambda?
+
+: (parse-lambda) ( assoc end -- quot )
+ [
+ in-lambda? on
+ over locals set
+ over push-locals
+ parse-until >quotation
+ swap pop-locals
+ ] with-scope ;
+
+: parse-lambda ( -- lambda )
+ "|" parse-tokens make-locals
+ \ ] (parse-lambda) <lambda> ;
+
+: parse-binding ( end -- pair/f )
+ scan {
+ { [ dup not ] [ unexpected-eof ] }
+ { [ 2dup = ] [ 2drop f ] }
+ [ nip scan-object 2array ]
+ } cond ;
+
+: (parse-bindings) ( end -- )
+ dup parse-binding dup [
+ first2 [ make-local ] dip 2array ,
+ (parse-bindings)
+ ] [ 2drop ] if ;
+
+: parse-bindings ( end -- bindings vars )
+ [
+ [ (parse-bindings) ] H{ } make-assoc
+ ] { } make swap ;
+
+: parse-bindings* ( end -- words assoc )
+ [
+ [
+ namespace push-locals
+ (parse-bindings)
+ namespace pop-locals
+ ] { } make-assoc
+ ] { } make swap ;
+
+: (parse-wbindings) ( end -- )
+ dup parse-binding dup [
+ first2 [ make-local-word ] keep 2array ,
+ (parse-wbindings)
+ ] [ 2drop ] if ;
+
+: parse-wbindings ( end -- bindings vars )
+ [
+ [ (parse-wbindings) ] H{ } make-assoc
+ ] { } make swap ;
+
+: parse-locals ( -- vars assoc )
+ "(" expect ")" parse-effect
+ word [ over "declared-effect" set-word-prop ] when*
+ in>> [ dup pair? [ first ] when ] map make-locals ;
+
+: parse-locals-definition ( word -- word quot )
+ parse-locals \ ; (parse-lambda) <lambda>
+ 2dup "lambda" set-word-prop
+ rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ;
+
+: (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
+
+: (M::) ( -- word def )
+ CREATE-METHOD
+ [ parse-locals-definition ] with-method-definition ;
+
+: parsed-lambda ( accum form -- accum )
+ in-lambda? get [ parsed ] [ rewrite-closures over push-all ] if ;
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel locals locals.types
+prettyprint.backend prettyprint.sections prettyprint.custom
+sequences words ;
+IN: locals.prettyprint
+
+SYMBOL: |
+
+: pprint-var ( var -- )
+ #! Prettyprint a read/write local as its writer, just like
+ #! in the input syntax: [| x! | ... x 3 + x! ]
+ dup local-reader? [
+ "local-writer" word-prop
+ ] when pprint-word ;
+
+: pprint-vars ( vars -- ) [ pprint-var ] each ;
+
+M: lambda pprint*
+ <flow
+ \ [| pprint-word
+ dup vars>> pprint-vars
+ \ | pprint-word
+ f <inset body>> pprint-elements block>
+ \ ] pprint-word
+ block> ;
+
+: pprint-let ( let word -- )
+ pprint-word
+ [ body>> ] [ bindings>> ] bi
+ \ | pprint-word
+ t <inset
+ <block
+ [ <block [ pprint-var ] dip pprint* block> ] assoc-each
+ block>
+ \ | pprint-word
+ <block pprint-elements block>
+ block>
+ \ ] pprint-word ;
+
+M: let pprint* \ [let pprint-let ;
+
+M: wlet pprint* \ [wlet pprint-let ;
+
+M: let* pprint* \ [let* pprint-let ;
+
+M: def pprint*
+ <block \ :> pprint-word local>> pprint-word block> ;
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel locals.rewrite.point-free
+locals.rewrite.sugar locals.types macros.expander make
+quotations sequences sets words ;
+IN: locals.rewrite.closures
+
+! Step 2: identify free variables and make them into explicit
+! parameters of lambdas which are curried on
+
+GENERIC: rewrite-closures* ( obj -- )
+
+: (rewrite-closures) ( form -- form' )
+ [ [ rewrite-closures* ] each ] [ ] make ;
+
+: rewrite-closures ( form -- form' )
+ expand-macros (rewrite-sugar) (rewrite-closures) point-free ;
+
+GENERIC: defs-vars* ( seq form -- seq' )
+
+: defs-vars ( form -- vars ) { } [ defs-vars* ] reduce prune ;
+
+M: def defs-vars* local>> unquote suffix ;
+
+M: quotation defs-vars* [ defs-vars* ] each ;
+
+M: object defs-vars* drop ;
+
+GENERIC: uses-vars* ( seq form -- seq' )
+
+: uses-vars ( form -- vars ) { } [ uses-vars* ] reduce prune ;
+
+M: local-writer uses-vars* "local-reader" word-prop suffix ;
+
+M: lexical uses-vars* suffix ;
+
+M: quote uses-vars* local>> uses-vars* ;
+
+M: object uses-vars* drop ;
+
+M: quotation uses-vars* [ uses-vars* ] each ;
+
+: free-vars ( form -- seq )
+ [ uses-vars ] [ defs-vars ] bi diff ;
+
+M: callable rewrite-closures*
+ #! Turn free variables into bound variables, curry them
+ #! onto the body
+ dup free-vars [ <quote> ] map
+ [ % ]
+ [ var-defs prepend (rewrite-closures) point-free , ]
+ [ length \ curry <repetition> % ]
+ tri ;
+
+M: object rewrite-closures* , ;
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays fry kernel math quotations sequences
+words combinators make locals.backend locals.types
+locals.errors ;
+IN: locals.rewrite.point-free
+
+! Step 3: rewrite locals usage within a single quotation into
+! retain stack manipulation
+
+: local-index ( args obj -- n )
+ 2dup '[ unquote _ eq? ] find drop
+ dup [ 2nip ] [ drop bad-local ] if ;
+
+: read-local-quot ( args obj -- quot )
+ local-index neg [ get-local ] curry ;
+
+GENERIC: localize ( args obj -- args quot )
+
+M: local localize dupd read-local-quot ;
+
+M: quote localize dupd local>> read-local-quot ;
+
+M: local-word localize dupd read-local-quot [ call ] append ;
+
+M: local-reader localize dupd read-local-quot [ local-value ] append ;
+
+M: local-writer localize
+ dupd "local-reader" word-prop
+ read-local-quot [ set-local-value ] append ;
+
+M: def localize
+ local>> [ prefix ] [ local-reader? [ 1array >r ] [ >r ] ? ] bi ;
+
+M: object localize 1quotation ;
+
+! We special-case all the :> at the start of a quotation
+: load-locals-quot ( args -- quot )
+ [ [ ] ] [
+ dup [ local-reader? ] contains? [
+ dup [ local-reader? [ 1array ] [ ] ? ] map
+ spread>quot
+ ] [ [ ] ] if swap length [ load-locals ] curry append
+ ] if-empty ;
+
+: load-locals-index ( quot -- n )
+ [ [ dup def? [ local>> local-reader? ] [ drop t ] if ] find drop ]
+ [ length ] bi or ;
+
+: point-free-start ( quot -- args rest )
+ dup load-locals-index
+ cut [ [ local>> ] map dup <reversed> load-locals-quot % ] dip ;
+
+: point-free-body ( args quot -- args )
+ [ localize % ] each ;
+
+: drop-locals-quot ( args -- )
+ [ length , [ drop-locals ] % ] unless-empty ;
+
+: point-free-end ( args obj -- )
+ dup special?
+ [ localize % drop-locals-quot ]
+ [ [ drop-locals-quot ] [ , ] bi* ]
+ if ;
+
+: point-free ( quot -- newquot )
+ [
+ point-free-start
+ [ drop-locals-quot ] [
+ unclip-last
+ [ point-free-body ]
+ [ point-free-end ]
+ bi*
+ ] if-empty
+ ] [ ] make ;
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes classes.tuple fry
+generalizations hashtables kernel locals locals.backend
+locals.errors locals.types make quotations sequences vectors
+words ;
+IN: locals.rewrite.sugar
+
+! Step 1: rewrite [| [let [let* [wlet into :> forms, turn
+! literals with locals in them into code which constructs
+! the literal after pushing locals on the stack
+
+GENERIC: rewrite-sugar* ( obj -- )
+
+: (rewrite-sugar) ( form -- form' )
+ [ rewrite-sugar* ] [ ] make ;
+
+GENERIC: quotation-rewrite ( form -- form' )
+
+M: callable quotation-rewrite [ [ rewrite-sugar* ] each ] [ ] make ;
+
+: var-defs ( vars -- defs ) <reversed> [ <def> ] [ ] map-as ;
+
+M: lambda quotation-rewrite
+ [ body>> ] [ vars>> var-defs ] bi
+ prepend quotation-rewrite ;
+
+M: callable rewrite-sugar* quotation-rewrite , ;
+
+M: lambda rewrite-sugar* quotation-rewrite , ;
+
+GENERIC: rewrite-literal? ( obj -- ? )
+
+M: special rewrite-literal? drop t ;
+
+M: array rewrite-literal? [ rewrite-literal? ] contains? ;
+
+M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
+
+M: wrapper rewrite-literal? drop t ;
+
+M: hashtable rewrite-literal? drop t ;
+
+M: vector rewrite-literal? drop t ;
+
+M: tuple rewrite-literal? drop t ;
+
+M: object rewrite-literal? drop f ;
+
+GENERIC: rewrite-element ( obj -- )
+
+: rewrite-elements ( seq -- )
+ [ rewrite-element ] each ;
+
+: rewrite-sequence ( seq -- )
+ [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ;
+
+M: array rewrite-element
+ dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
+
+M: vector rewrite-element rewrite-sequence ;
+
+M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
+
+M: tuple rewrite-element
+ [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
+
+M: quotation rewrite-element rewrite-sugar* ;
+
+M: lambda rewrite-element rewrite-sugar* ;
+
+M: binding-form rewrite-element binding-form-in-literal-error ;
+
+M: local rewrite-element , ;
+
+M: local-reader rewrite-element , ;
+
+M: local-writer rewrite-element
+ local-writer-in-literal-error ;
+
+M: local-word rewrite-element
+ local-word-in-literal-error ;
+
+M: word rewrite-element literalize , ;
+
+M: wrapper rewrite-element
+ dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ;
+
+M: object rewrite-element , ;
+
+M: array rewrite-sugar* rewrite-element ;
+
+M: vector rewrite-sugar* rewrite-element ;
+
+M: tuple rewrite-sugar* rewrite-element ;
+
+M: def rewrite-sugar* , ;
+
+M: hashtable rewrite-sugar* rewrite-element ;
+
+M: wrapper rewrite-sugar* rewrite-element ;
+
+M: word rewrite-sugar*
+ dup { >r r> load-locals get-local drop-locals } memq?
+ [ >r/r>-in-lambda-error ] [ call-next-method ] if ;
+
+M: object rewrite-sugar* , ;
+
+: let-rewrite ( body bindings -- )
+ [ quotation-rewrite % <def> , ] assoc-each
+ quotation-rewrite % ;
+
+M: let rewrite-sugar*
+ [ body>> ] [ bindings>> ] bi let-rewrite ;
+
+M: let* rewrite-sugar*
+ [ body>> ] [ bindings>> ] bi let-rewrite ;
+
+M: wlet rewrite-sugar*
+ [ body>> ] [ bindings>> ] bi
+ [ '[ _ ] ] assoc-map
+ let-rewrite ;
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators kernel sequences words ;
+IN: locals.types
+
+TUPLE: lambda vars body ;
+
+C: <lambda> lambda
+
+TUPLE: binding-form bindings body ;
+
+TUPLE: let < binding-form ;
+
+C: <let> let
+
+TUPLE: let* < binding-form ;
+
+C: <let*> let*
+
+TUPLE: wlet < binding-form ;
+
+C: <wlet> wlet
+
+TUPLE: quote local ;
+
+C: <quote> quote
+
+: unquote ( quote -- local ) dup quote? [ local>> ] when ; inline
+
+TUPLE: def local ;
+
+C: <def> def
+
+PREDICATE: local < word "local?" word-prop ;
+
+: <local> ( name -- word )
+ #! Create a local variable identifier
+ f <word>
+ dup t "local?" set-word-prop ;
+
+PREDICATE: local-word < word "local-word?" word-prop ;
+
+: <local-word> ( name -- word )
+ f <word> dup t "local-word?" set-word-prop ;
+
+PREDICATE: local-reader < word "local-reader?" word-prop ;
+
+: <local-reader> ( name -- word )
+ f <word>
+ dup t "local-reader?" set-word-prop ;
+
+PREDICATE: local-writer < word "local-writer?" word-prop ;
+
+: <local-writer> ( reader -- word )
+ dup name>> "!" append f <word> {
+ [ nip t "local-writer?" set-word-prop ]
+ [ swap "local-reader" set-word-prop ]
+ [ "local-writer" set-word-prop ]
+ [ nip ]
+ } 2cleave ;
+
+UNION: lexical local local-reader local-writer local-word ;
+UNION: special lexical quote def ;
\r
: analyze-entry ( entry -- )\r
dup level>> { ERROR CRITICAL } memq? [ dup errors get push ] when\r
- 1 over word-name>> word-histogram get at+\r
+ dup word-name>> word-histogram get inc-at\r
dup word-name>> word-names get member? [\r
- 1 over [ level>> ] [ word-name>> ] [ message>> ] tri 3array\r
- message-histogram get at+\r
+ dup [ level>> ] [ word-name>> ] [ message>> ] tri 3array\r
+ message-histogram get inc-at\r
] when\r
drop ;\r
\r
: log-stream ( service -- stream )\r
log-files get [ open-log-stream ] cache ;\r
\r
-: multiline-header 20 CHAR: - <string> ; foldable\r
+: multiline-header ( -- string ) 20 CHAR: - <string> ; foldable\r
\r
: (write-message) ( msg name>> level multi? -- )\r
[\r
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private
-math.libm math.functions prettyprint.backend arrays
-math.functions.private sequences parser ;
+math.libm math.functions arrays math.functions.private sequences
+parser ;
IN: math.complex.private
M: real real-part ;
IN: syntax
: C{ \ } [ first2 rect> ] parse-literal ; parsing
-
-M: complex pprint-delims drop \ C{ \ } ;
-M: complex >pprint-sequence >rect 2array ;
-M: complex pprint* pprint-object ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math math.functions arrays prettyprint.custom kernel ;
+IN: math.complex.prettyprint
+
+M: complex pprint* pprint-object ;
+M: complex pprint-delims drop \ C{ \ } ;
+M: complex >pprint-sequence >rect 2array ;
{ $subsection interval-bitnot }
{ $subsection interval-recip }
{ $subsection interval-2/ }
-{ $subsection interval-abs } ;
+{ $subsection interval-abs }
+{ $subsection interval-log2 } ;
ARTICLE: "math-intervals-sets" "Set-theoretic operations on intervals"
{ $subsection interval-contains? }
{ $values { "i1" interval } { "i2" interval } }
{ $description "Absolute value of an interval." } ;
+HELP: interval-log2
+{ $values { "i1" interval } { "i2" interval } }
+{ $description "Integer-valued Base-2 logarithm of an interval." } ;
+
HELP: interval-intersect
{ $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval } " or " { $link f } } }
{ $description "Outputs the set-theoretic intersection of " { $snippet "i1" } " and " { $snippet "i2" } ". If " { $snippet "i1" } " and " { $snippet "i2" } " do not intersect, outputs " { $link f } "." } ;
! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
USING: accessors kernel sequences arrays math math.order
-combinators generic ;
+combinators generic layouts ;
IN: math.intervals
SYMBOL: empty-interval
2dup [ interval-nonnegative? ] both?
[
[ interval>points [ first ] bi@ ] bi@
- 4array supremum 0 swap next-power-of-2 [a,b]
+ 4array supremum 0 swap >integer next-power-of-2 [a,b]
] [ 2drop [-inf,inf] ] if
] do-empty-interval ;
#! Inaccurate.
interval-bitor ;
+: interval-log2 ( i1 -- i2 )
+ {
+ { empty-interval [ empty-interval ] }
+ { full-interval [ 0 [a,inf] ] }
+ [
+ to>> first 1 max dup most-positive-fixnum >
+ [ drop full-interval interval-log2 ]
+ [ 1+ >integer log2 0 swap [a,b] ]
+ if
+ ]
+ } case ;
+
: assume< ( i1 i2 -- i3 )
dup special-interval? [ drop ] [
to>> first [-inf,a) interval-intersect
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private words
-sequences parser namespaces make assocs quotations arrays locals
+sequences parser namespaces make assocs quotations arrays
generic generic.math hashtables effects compiler.units
-classes.algebra ;
+classes.algebra fry combinators ;
IN: math.partial-dispatch
PREDICATE: math-partial < word
{ bitnot fixnum-bitnot }
} at swap or ;
-:: fixnum-integer-op ( a b fix-word big-word -- c )
- b tag 0 eq? [
- a b fix-word execute
- ] [
- a fixnum>bignum b big-word execute
- ] if ; inline
-
-:: integer-fixnum-op ( a b fix-word big-word -- c )
- a tag 0 eq? [
- a b fix-word execute
- ] [
- a b fixnum>bignum big-word execute
- ] if ; inline
+: integer-fixnum-op-quot ( fix-word big-word -- quot )
+ [
+ [ over fixnum? ] %
+ [ '[ _ execute ] , ]
+ [ '[ fixnum>bignum _ execute ] , ] bi*
+ \ if ,
+ ] [ ] make ;
-:: integer-integer-op ( a b fix-word big-word -- c )
- b tag 0 eq? [
- a b fix-word big-word integer-fixnum-op
- ] [
- a dup tag 0 eq? [ fixnum>bignum ] when
- b big-word execute
- ] if ; inline
+: fixnum-integer-op-quot ( fix-word big-word -- quot )
+ [
+ [ dup fixnum? ] %
+ [ '[ _ execute ] , ]
+ [ '[ [ fixnum>bignum ] dip _ execute ] , ] bi*
+ \ if ,
+ ] [ ] make ;
-: integer-op-combinator ( triple -- word )
+: integer-integer-op-quot ( fix-word big-word -- quot )
[
- [ second name>> % "-" % ]
- [ third name>> % "-op" % ]
- bi
- ] "" make "math.partial-dispatch" lookup ;
+ [ dup fixnum? ] %
+ 2dup integer-fixnum-op-quot ,
+ [
+ [ over fixnum? [ [ fixnum>bignum ] dip ] when ] %
+ nip ,
+ ] [ ] make ,
+ \ if ,
+ ] [ ] make ;
: integer-op-word ( triple -- word )
[ name>> ] map "-" join "math.partial-dispatch" create ;
-: integer-op-quot ( triple fix-word big-word -- quot )
- rot integer-op-combinator 1quotation 2curry ;
+: integer-op-quot ( fix-word big-word triple -- quot )
+ [ second ] [ third ] bi 2array {
+ { { fixnum integer } [ fixnum-integer-op-quot ] }
+ { { integer fixnum } [ integer-fixnum-op-quot ] }
+ { { integer integer } [ integer-integer-op-quot ] }
+ } case ;
-: define-integer-op-word ( triple fix-word big-word -- )
+: define-integer-op-word ( fix-word big-word triple -- )
[
- [ 2drop integer-op-word ] [ integer-op-quot ] 3bi
+ [ 2nip integer-op-word ] [ integer-op-quot ] 3bi
(( x y -- z )) define-declared
] [
- 2drop
+ 2nip
[ integer-op-word ] keep
"derived-from" set-word-prop
] 3bi ;
: define-integer-op-words ( triples fix-word big-word -- )
- [ define-integer-op-word ] 2curry each ;
+ '[ [ _ _ ] dip define-integer-op-word ] each ;
: integer-op-triples ( word -- triples )
{
{ fixnum integer }
{ integer fixnum }
{ integer integer }
- } swap [ prefix ] curry map ;
+ } swap '[ _ prefix ] map ;
: define-integer-ops ( word fix-word big-word -- )
[
[ drop math-class-max swap specific-method >boolean ] if ;
: (derived-ops) ( word assoc -- words )
- swap [ rot first eq? nip ] curry assoc-filter ;
+ swap '[ swap first _ eq? nip ] assoc-filter ;
: derived-ops ( word -- words )
[ 1array ] [ math-ops get (derived-ops) values ] bi append ;
! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel memoize tools.test parser
+USING: math kernel memoize tools.test parser generalizations
prettyprint io.streams.string sequences eval ;
IN: memoize.tests
[ 89 ] [ 10 fib ] unit-test
-[ "USING: kernel math memoize ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail
+[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval ] must-fail
MEMO: see-test ( a -- b ) reverse ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sequences.private byte-arrays
-alien.c-types prettyprint.backend parser accessors ;
+alien.c-types prettyprint.custom parser accessors ;
IN: nibble-arrays
TUPLE: nibble-array
: n, ( obj n -- ) get-building-seq push ;
: n% ( seq n -- ) get-building-seq push-all ;
-: n# ( num n -- ) >r number>string r> n% ;
+: n# ( num n -- ) [ number>string ] dip n% ;
: 0, ( obj -- ) 0 n, ;
: 0% ( seq -- ) 0 n% ;
--- /dev/null
+USING: io kernel accessors math.parser sequences prettyprint
+debugger peg ;
+IN: peg.debugger
+
+M: parse-error error.
+ "Peg parsing error at character position " write dup position>> number>string write
+ "." print "Expected " write messages>> [ " or " write ] [ write ] interleave nl ;
+
+M: parse-failed error.
+ "The " write dup word>> pprint " word could not parse the following input:" print nl
+ input>> . ;
+
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 prettyprint combinators parser ;\r
+io combinators parser ;\r
IN: peg.ebnf\r
\r
: rule ( name word -- parser )\r
M: object build-locals ( code ast -- )\r
drop ;\r
\r
+ERROR: bad-effect quot effect ;\r
+\r
: check-action-effect ( quot -- quot )\r
dup infer {\r
{ [ dup (( a -- b )) effect<= ] [ drop ] }\r
{ [ dup (( -- b )) effect<= ] [ drop [ drop ] prepose ] }\r
- [\r
- [ \r
- "Bad effect: " write effect>string write \r
- " for quotation " write pprint\r
- ] with-string-writer throw\r
- ]\r
+ [ bad-effect ]\r
} cond ;\r
\r
M: ebnf-action (transform) ( ast -- parser )\r
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces make math assocs
-debugger io vectors arrays math.parser math.order
-vectors combinators classes sets unicode.categories
-compiler.units parser words quotations effects memoize accessors
-locals effects splitting combinators.short-circuit
-combinators.short-circuit.smart generalizations ;
+io vectors arrays math.parser math.order vectors combinators
+classes sets unicode.categories compiler.units parser words
+quotations effects memoize accessors locals effects splitting
+combinators.short-circuit generalizations ;
IN: peg
-USE: prettyprint
-
TUPLE: parse-result remaining ast ;
TUPLE: parse-error position messages ;
TUPLE: parser peg compiled id ;
C: <parse-result> parse-result
C: <parse-error> parse-error
-M: parse-error error.
- "Peg parsing error at character position " write dup position>> number>string write
- "." print "Expected " write messages>> [ " or " write ] [ write ] interleave nl ;
-
SYMBOL: error-stack
: (merge-errors) ( a b -- c )
nip
] if ;
-USE: prettyprint
-
: apply-rule ( r p -- ast )
! 2dup [ rule-id ] dip 2array "apply-rule: " write .
2dup recall [
: parser-body ( parser -- quot )
#! Return the body of the word that is the compiled version
#! of the parser.
- gensym 2dup swap peg>> (compile) 0 1 <effect> define-declared swap dupd id>> "peg-id" set-word-prop
+ gensym 2dup swap peg>> (compile) (( -- result )) define-declared
+ swap dupd id>> "peg-id" set-word-prop
[ execute-parser ] curry ;
: preset-parser-word ( parser -- parser word )
#! Work through all delayed parsers and recompile their
#! words to have the correct bodies.
delayed get [
- call compile-parser 1quotation 0 1 <effect> define-declared
+ call compile-parser 1quotation (( -- result )) define-declared
] assoc-each ;
: compile ( parser -- word )
[
parsers>> unclip compile-parser 1quotation [ parse-seq-element ] curry ,
[ compile-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each
- ] { } make , \ && ,
+ ] { } make , \ 1&& ,
] [ ] make ;
TUPLE: choice-parser parsers ;
[
parsers>> [ compile-parser ] map
unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each
- ] { } make , \ || ,
+ ] { } make , \ 0|| ,
] [ ] make ;
TUPLE: repeat0-parser p1 ;
ERROR: parse-failed input word ;
-M: parse-failed error.
- "The " write dup word>> pprint " word could not parse the following input:" print nl
- input>> . ;
-
: PEG:
(:)
[let | def [ ] word [ ] |
] with-compilation-unit
] over push-all
] ; parsing
+
+USING: vocabs vocabs.loader ;
+
+"debugger" vocab [
+ "peg.debugger" require
+] when
! Based on Clojure's PersistentHashMap by Rich Hickey.
USING: kernel math accessors assocs fry combinators parser
-prettyprint.backend make
+prettyprint.custom make
persistent.assocs
persistent.hashtables.nodes
persistent.hashtables.nodes.empty
! Based on Clojure's PersistentVector by Rich Hickey.
USING: math accessors kernel sequences.private sequences arrays
-combinators combinators.short-circuit parser prettyprint.backend
+combinators combinators.short-circuit parser prettyprint.custom
persistent.sequences ;
IN: persistent.vectors
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors math math.parser calendar calendar.format
-strings words kernel effects ;
+USING: accessors math math.parser strings words kernel effects ;
IN: present
GENERIC: present ( object -- string )
M: real present number>string ;
-M: timestamp present timestamp>string ;
-
M: string present ;
M: word present name>> ;
USING: help.markup help.syntax io kernel
-prettyprint.config prettyprint.sections words strings ;
+prettyprint.config prettyprint.sections prettyprint.custom
+words strings ;
IN: prettyprint.backend
ABOUT: "prettyprint-extension"
-HELP: pprint*
-{ $values { "obj" "an object" } }
-{ $contract "Adds sections to the current block corresponding to the prettyprinted representation of the object." }
-$prettyprinting-note ;
-
HELP: pprint-word
{ $values { "word" "a word" } }
{ $description "Adds a text section for the word. Unlike the " { $link word } " method of " { $link pprint* } ", this does not add a " { $link POSTPONE: POSTPONE: } " prefix to parsing words." }
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays byte-vectors generic
-hashtables io assocs kernel math namespaces make sequences
-strings sbufs io.styles vectors words prettyprint.config
+USING: accessors arrays byte-arrays generic hashtables io assocs
+kernel math namespaces make sequences strings sbufs io.styles
+vectors words prettyprint.config prettyprint.custom
prettyprint.sections quotations io io.files math.parser effects
classes.tuple math.order classes.tuple.private classes
combinators colors ;
IN: prettyprint.backend
-GENERIC: pprint* ( obj -- )
-
-M: effect pprint* effect>string "(" swap ")" 3append text ;
+M: effect pprint* effect>string "(" ")" surround text ;
: ?effect-height ( word -- n )
stack-effect [ effect-height ] [ 0 ] if* ;
[ [ pprint* ] each ] dip
[ "~" swap number>string " more~" 3append text ] when* ;
-GENERIC: pprint-delims ( obj -- start end )
-
M: quotation pprint-delims drop \ [ \ ] ;
M: curry pprint-delims drop \ [ \ ] ;
M: compose pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ;
-M: byte-vector pprint-delims drop \ BV{ \ } ;
M: vector pprint-delims drop \ V{ \ } ;
M: hashtable pprint-delims drop \ H{ \ } ;
M: tuple pprint-delims drop \ T{ \ } ;
M: wrapper pprint-delims drop \ W{ \ } ;
M: callstack pprint-delims drop \ CS{ \ } ;
-GENERIC: >pprint-sequence ( obj -- seq )
-
M: object >pprint-sequence ;
-
M: vector >pprint-sequence ;
-M: byte-vector >pprint-sequence ;
M: curry >pprint-sequence ;
M: compose >pprint-sequence ;
M: hashtable >pprint-sequence >alist ;
[ class ] [ tuple-slots ] bi
[ 1array ] [ [ f 2array ] dip append ] if-empty ;
-GENERIC: pprint-narrow? ( obj -- ? )
-
M: object pprint-narrow? drop f ;
-
M: array pprint-narrow? drop t ;
M: vector pprint-narrow? drop t ;
M: hashtable pprint-narrow? drop t ;
M: tuple pprint-narrow? drop t ;
-: pprint-object ( obj -- )
+M: object pprint-object ( obj -- )
[
<flow
dup pprint-delims [
M: object pprint* pprint-object ;
M: vector pprint* pprint-object ;
-M: byte-vector pprint* pprint-object ;
M: hashtable pprint* pprint-object ;
M: curry pprint* pprint-object ;
M: compose pprint* pprint-object ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel help.markup help.syntax ;
+IN: prettyprint.custom
+
+HELP: pprint*
+{ $values { "obj" object } }
+{ $contract "Adds sections to the current block corresponding to the prettyprinted representation of the object." }
+$prettyprinting-note ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: prettyprint.custom
+
+GENERIC: pprint* ( obj -- )
+GENERIC: pprint-object ( obj -- )
+GENERIC: pprint-delims ( obj -- start end )
+GENERIC: >pprint-sequence ( obj -- seq )
+GENERIC: pprint-narrow? ( obj -- ? )
-USING: prettyprint.backend prettyprint.config
+USING: prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections prettyprint.private help.markup help.syntax
io kernel words definitions quotations strings generic classes ;
IN: prettyprint
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic generic.standard assocs io kernel math
namespaces make sequences strings io.styles io.streams.string
-vectors words prettyprint.backend prettyprint.sections
-prettyprint.config sorting splitting grouping math.parser vocabs
-definitions effects classes.builtin classes.tuple io.files
-classes continuations hashtables classes.mixin classes.union
-classes.intersection classes.predicate classes.singleton
-combinators quotations sets accessors colors parser ;
+vectors words prettyprint.backend prettyprint.custom
+prettyprint.sections prettyprint.config sorting splitting
+grouping math.parser vocabs definitions effects classes.builtin
+classes.tuple io.files classes continuations hashtables
+classes.mixin classes.union classes.intersection
+classes.predicate classes.singleton combinators quotations sets
+accessors colors parser summary ;
IN: prettyprint
: make-pprint ( obj quot -- block in use )
[ synopsis* ] with-in
] with-string-writer ;
+M: word summary synopsis ;
+
: synopsis-alist ( definitions -- alist )
[ dup synopsis swap ] { } map>assoc ;
! Copyright (C) 2007, 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences assocs hashtables parser lexer
-vocabs words namespaces vocabs.loader debugger sets fry ;
+vocabs words namespaces vocabs.loader sets fry ;
IN: qualified
: define-qualified ( vocab-name prefix-name -- )
100 [ 100 random ] replicate ;
: test-rng ( seed quot -- )
- >r <mersenne-twister> r> with-random ;
+ [ <mersenne-twister> ] dip with-random ;
[ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators kernel math sequences strings
-sets assocs prettyprint.backend make lexer namespaces parser
-arrays fry regexp.backend regexp.utils regexp.parser regexp.nfa
-regexp.dfa regexp.traversal regexp.transition-tables splitting
-sorting ;
+USING: accessors combinators kernel math sequences strings sets
+assocs prettyprint.backend prettyprint.custom make lexer
+namespaces parser arrays fry regexp.backend regexp.utils
+regexp.parser regexp.nfa regexp.dfa regexp.traversal
+regexp.transition-tables splitting sorting ;
IN: regexp
: default-regexp ( string -- regexp )
[ bad-email-address ] unless ;
: mail-from ( fromaddr -- )
- "MAIL FROM:<" swap validate-address ">" 3append command ;
+ validate-address
+ "MAIL FROM:<" ">" surround command ;
: rcpt-to ( to -- )
- "RCPT TO:<" swap validate-address ">" 3append command ;
+ validate-address
+ "RCPT TO:<" ">" surround command ;
: data ( -- )
"DATA" command ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: functors sequences sequences.private prettyprint.backend
+USING: functors sequences sequences.private prettyprint.custom
kernel words classes math parser alien.c-types byte-arrays
accessors summary ;
IN: specialized-arrays.functor
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private growable
-prettyprint.backend kernel words classes math parser ;
+prettyprint.custom kernel words classes math parser ;
IN: specialized-vectors.functor
FUNCTOR: define-vector ( T -- )
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry arrays generic io io.streams.string kernel math
-namespaces parser prettyprint sequences strings vectors words
-quotations effects classes continuations debugger assocs
-combinators compiler.errors accessors math.order definitions
-sets generic.standard.engines.tuple hints stack-checker.state
-stack-checker.visitor stack-checker.errors
-stack-checker.values stack-checker.recursive-state ;
+namespaces parser sequences strings vectors words quotations
+effects classes continuations assocs combinators
+compiler.errors accessors math.order definitions sets
+generic.standard.engines.tuple hints stack-checker.state
+stack-checker.visitor stack-checker.errors stack-checker.values
+stack-checker.recursive-state ;
IN: stack-checker.backend
: push-d ( obj -- ) meta-d push ;
{ [ dup inline? ] [ drop f ] }
{ [ dup deferred? ] [ drop f ] }
{ [ dup crossref? not ] [ drop f ] }
- [ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ]
+ [ def>> [ word? ] contains? ]
} cond ;
: ?missing-effect ( word -- )
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel generic sequences prettyprint io words arrays
-summary effects debugger assocs accessors namespaces
-compiler.errors stack-checker.values
+USING: kernel generic sequences io words arrays summary effects
+assocs accessors namespaces compiler.errors stack-checker.values
stack-checker.recursive-state ;
IN: stack-checker.errors
M: inference-error compiler-error-type type>> ;
-M: inference-error error-help error>> error-help ;
-
: (inference-error) ( ... class type -- * )
[ boa ] dip
recursive-state get word>>
: inference-warning ( ... class -- * )
+warning+ (inference-error) ; inline
-M: inference-error error.
- [ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ;
-
TUPLE: literal-expected ;
-M: literal-expected summary
- drop "Literal value expected" ;
-
M: object (literal) \ literal-expected inference-warning ;
TUPLE: unbalanced-branches-error branches quots ;
: unbalanced-branches-error ( branches quots -- * )
\ unbalanced-branches-error inference-error ;
-M: unbalanced-branches-error error.
- "Unbalanced branches:" print
- [ quots>> ] [ branches>> [ length <effect> ] { } assoc>map ] bi zip
- [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
-
TUPLE: too-many->r ;
-M: too-many->r summary
- drop
- "Quotation pushes elements on retain stack without popping them" ;
-
TUPLE: too-many-r> ;
-M: too-many-r> summary
- drop
- "Quotation pops retain stack elements which it did not push" ;
-
TUPLE: missing-effect word ;
-M: missing-effect error.
- "The word " write
- word>> pprint
- " must declare a stack effect" print ;
-
TUPLE: effect-error word inferred declared ;
: effect-error ( word inferred declared -- * )
\ effect-error inference-error ;
-M: effect-error error.
- "Stack effects of the word " write
- [ word>> pprint " do not match." print ]
- [ "Inferred: " write inferred>> . ]
- [ "Declared: " write declared>> . ] tri ;
-
TUPLE: recursive-quotation-error quot ;
-M: recursive-quotation-error error.
- "The quotation " write
- quot>> pprint
- " calls itself." print
- "Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
-
TUPLE: undeclared-recursion-error word ;
-M: undeclared-recursion-error error.
- "The inline recursive word " write
- word>> pprint
- " must be declared recursive" print ;
-
TUPLE: diverging-recursion-error word ;
-M: diverging-recursion-error error.
- "The recursive word " write
- word>> pprint
- " digs arbitrarily deep into the stack" print ;
-
TUPLE: unbalanced-recursion-error word height ;
-M: unbalanced-recursion-error error.
- "The recursive word " write
- word>> pprint
- " leaves with the stack having the wrong height" print ;
-
TUPLE: inconsistent-recursive-call-error word ;
-M: inconsistent-recursive-call-error error.
- "The recursive word " write
- word>> pprint
- " calls itself with a different set of quotation parameters than were input" print ;
-
TUPLE: unknown-primitive-error ;
-
-M: unknown-primitive-error error.
- drop
- "Cannot determine stack effect statically" print ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel prettyprint io debugger
+sequences assocs stack-checker.errors summary effects ;
+IN: stack-checker.errors.prettyprint
+
+M: inference-error error-help error>> error-help ;
+
+M: inference-error error.
+ [ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ;
+
+M: literal-expected summary
+ drop "Literal value expected" ;
+
+M: unbalanced-branches-error error.
+ "Unbalanced branches:" print
+ [ quots>> ] [ branches>> [ length <effect> ] { } assoc>map ] bi zip
+ [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
+
+M: too-many->r summary
+ drop
+ "Quotation pushes elements on retain stack without popping them" ;
+
+M: too-many-r> summary
+ drop
+ "Quotation pops retain stack elements which it did not push" ;
+
+M: missing-effect error.
+ "The word " write
+ word>> pprint
+ " must declare a stack effect" print ;
+
+M: effect-error error.
+ "Stack effects of the word " write
+ [ word>> pprint " do not match." print ]
+ [ "Inferred: " write inferred>> . ]
+ [ "Declared: " write declared>> . ] tri ;
+
+M: recursive-quotation-error error.
+ "The quotation " write
+ quot>> pprint
+ " calls itself." print
+ "Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
+
+M: undeclared-recursion-error error.
+ "The inline recursive word " write
+ word>> pprint
+ " must be declared recursive" print ;
+
+M: diverging-recursion-error error.
+ "The recursive word " write
+ word>> pprint
+ " digs arbitrarily deep into the stack" print ;
+
+M: unbalanced-recursion-error error.
+ "The recursive word " write
+ word>> pprint
+ " leaves with the stack having the wrong height" print ;
+
+M: inconsistent-recursive-call-error error.
+ "The recursive word " write
+ word>> pprint
+ " calls itself with a different set of quotation parameters than were input" print ;
+
+M: unknown-primitive-error error.
+ drop
+ "Cannot determine stack effect statically" print ;
hashtables hashtables.private io io.backend io.files
io.files.private io.streams.c kernel kernel.private math
math.private memory namespaces namespaces.private parser
-prettyprint quotations quotations.private sbufs sbufs.private
+quotations quotations.private sbufs sbufs.private
sequences sequences.private slots.private strings
strings.private system threads.private classes.tuple
classes.tuple.private vectors vectors.private words definitions
words.private assocs summary compiler.units system.private
-combinators locals locals.backend locals.private words.private
+combinators locals locals.backend locals.types words.private
quotations.private stack-checker.values
stack-checker.alien
stack-checker.state
3 infer->r infer-call 3 infer-r> ;
: infer-dip ( -- )
- commit-literals
literals get
[ \ dip def>> infer-quot-here ]
[ pop 1 infer->r infer-quot-here 1 infer-r> ]
if-empty ;
: infer-2dip ( -- )
- commit-literals
literals get
[ \ 2dip def>> infer-quot-here ]
[ pop 2 infer->r infer-quot-here 2 infer-r> ]
if-empty ;
: infer-3dip ( -- )
- commit-literals
literals get
[ \ 3dip def>> infer-quot-here ]
[ pop 3 infer->r infer-quot-here 3 infer-r> ]
\ <complex> { real real } { complex } define-primitive
\ <complex> make-foldable
-\ both-fixnums? { object object } { object object object } define-primitive
+\ both-fixnums? { object object } { object } define-primitive
\ fixnum+ { fixnum fixnum } { integer } define-primitive
\ fixnum+ make-foldable
\r
: expect ( ch -- )\r
get-char 2dup = [ 2drop ] [\r
- >r 1string r> 1string expected\r
+ [ 1string ] bi@ expected\r
] if next ;\r
\r
: expect-string ( string -- )\r
swap [ init-parser call ] with-input-stream ; inline\r
\r
: string-parse ( input quot -- )\r
- >r <string-reader> r> state-parse ; inline\r
+ [ <string-reader> ] dip state-parse ; inline\r
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes sequences splitting kernel namespaces
-make words math math.parser io.styles prettyprint assocs ;
+USING: accessors classes sequences kernel namespaces
+make words math math.parser assocs ;
IN: summary
GENERIC: summary ( object -- string )
M: object summary object-summary ;
-M: input summary
- [
- "Input: " %
- string>> "\n" split1 swap %
- "..." "" ? %
- ] "" make ;
-
-M: word summary synopsis ;
-
M: sequence summary
[
dup class name>> %
USING: help.markup help.syntax kernel kernel.private io
threads.private continuations init quotations strings
-assocs heaps boxes namespaces deques ;
+assocs heaps boxes namespaces deques dlists ;
IN: threads
ARTICLE: "threads-start/stop" "Starting and stopping threads"
{ $notes "In most cases, user code should call " { $link spawn } " instead, however for control over the error handler quotation, threads can be created with " { $link <thread> } " then passed to " { $link (spawn) } "." } ;
HELP: run-queue
-{ $values { "queue" deque } }
+{ $values { "dlist" dlist } }
{ $var-description "Global variable holding the queue of runnable threads. Calls to " { $link yield } " switch to the thread which has been in the queue for the longest period of time."
$nl
"By convention, threads are queued with " { $link push-front }
{ $description "Adds a thread to the end of the run queue together with an object to pass to the thread. The thread must have previously been suspended by a call to " { $link suspend } "; the object is returned from the " { $link suspend } " call." } ;
HELP: sleep-queue
+{ $values { "heap" min-heap } }
{ $var-description "A " { $link min-heap } " storing the queue of sleeping threads." } ;
HELP: sleep-time
: tchange ( key quot -- )
tnamespace swap change-at ; inline
-: threads 64 getenv ;
+: threads ( -- assoc ) 64 getenv ;
: thread ( id -- thread ) threads at ;
: <thread> ( quot name -- thread )
\ thread new-thread ;
-: run-queue 65 getenv ;
+: run-queue ( -- dlist ) 65 getenv ;
-: sleep-queue 66 getenv ;
+: sleep-queue ( -- heap ) 66 getenv ;
: resume ( thread -- )
f >>state
ARTICLE: "tools.annotations" "Word annotations"
"The word annotation feature modifies word definitions to add debugging code. You can restore the old definition by calling " { $link reset } " on the word in question."
+$nl
+"Printing messages when a word is called or returns:"
{ $subsection watch }
+{ $subsection watch-vars }
+"Starting the walker when a word is called:"
{ $subsection breakpoint }
{ $subsection breakpoint-if }
+"Timing words:"
+{ $subsection reset-word-timing }
+{ $subsection add-timing }
+{ $subsection word-timing. }
"All of the above words are implemented using a single combinator which applies a quotation to a word definition to yield a new definition:"
{ $subsection annotate } ;
{ "seq" sequence } }
{ $description "Makes a sequence of the inputs to a word by counting the number of inputs in the stack effect and saving that many items from the datastack." } ;
+HELP: add-timing
+{ $values { "word" word } }
+{ $description "Adds timing code to a word, which records its total running time, including that of words it calls, on every invocation." }
+{ $see-also "timing" "profiling" } ;
+
+HELP: reset-word-timing
+{ $description "Resets the word timing table." } ;
+
+HELP: word-timing.
+{ $description "Prints the word timing table." } ;
-USING: tools.test tools.annotations math parser eval
+USING: tools.test tools.annotations tools.time math parser eval
io.streams.string kernel ;
IN: tools.annotations.tests
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel words parser io summary quotations
-sequences prettyprint continuations effects definitions
-compiler.units namespaces assocs tools.walker generic
-inspector fry ;
+USING: accessors kernel math sorting words parser io summary
+quotations sequences prettyprint continuations effects
+definitions compiler.units namespaces assocs tools.walker
+tools.time generic inspector fry ;
IN: tools.annotations
GENERIC: reset ( word -- )
f "unannotated-def" set-word-prop
] [ drop ] if ;
+ERROR: cannot-annotate-twice word ;
+
: annotate ( word quot -- )
over "unannotated-def" word-prop [
- "Cannot annotate a word twice" throw
+ over cannot-annotate-twice
] when
[
over dup def>> "unannotated-def" set-word-prop
: breakpoint-if ( word quot -- )
'[ [ _ [ [ break ] when ] ] dip 3append ] annotate-methods ;
+
+SYMBOL: word-timing
+
+word-timing global [ H{ } clone or ] change-at
+
+: reset-word-timing ( -- )
+ word-timing get clear-assoc ;
+
+: (add-timing) ( def word -- def' )
+ '[ _ benchmark _ word-timing get at+ ] ;
+
+: add-timing ( word -- )
+ dup '[ _ (add-timing) ] annotate ;
+
+: word-timing. ( -- )
+ word-timing get
+ >alist [ 1000000 /f ] assoc-map sort-values
+ simple-table. ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays cocoa.messages cocoa.runtime combinators
+prettyprint ;
+IN: tools.cocoa
+
+: method. ( method -- )
+ {
+ [ method_getName sel_getName ]
+ [ method-return-type ]
+ [ method-arg-types ]
+ [ method_getImplementation ]
+ } cleave 4array . ;
+
+: methods. ( class -- )
+ [ method. ] each-method-in-class ;
--- /dev/null
+unportable
continuations math definitions mirrors splitting parser classes
summary layouts vocabs.loader prettyprint.config prettyprint
debugger io.streams.c io.files io.backend quotations io.launcher
-words.private tools.deploy.config bootstrap.image
-io.encodings.utf8 destructors accessors ;
+words.private tools.deploy.config tools.deploy.config.editor
+bootstrap.image io.encodings.utf8 destructors accessors ;
IN: tools.deploy.backend
: copy-vm ( executable bundle-name extension -- vm )
dup staging-image-name exists?
[ drop ] [ make-staging-image ] if ;
+: make-deploy-config ( vocab -- file )
+ [ deploy-config unparse-use ]
+ [ "deploy-config-" prepend temp-file ] bi
+ [ utf8 set-file-contents ] keep ;
+
: deploy-command-line ( image vocab config -- flags )
[
bootstrap-profile ?make-staging-image
"-run=tools.deploy.shaker" ,
- "-deploy-vocab=" prepend ,
+ [ "-deploy-vocab=" prepend , ]
+ [ make-deploy-config "-deploy-config=" prepend , ] bi
"-output-image=" prepend ,
kernel math ;
IN: tools.deploy.config
-ARTICLE: "deploy-config" "Deployment configuration"
-"The deployment configuration is a key/value mapping stored in the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If this file does not exist, the default deployment configuration is used:"
-{ $subsection default-config }
-"The deployment configuration can be read and written with a pair of words:"
-{ $subsection deploy-config }
-{ $subsection set-deploy-config }
-"A utility word is provided to load the configuration, change a flag, and store it back to disk:"
-{ $subsection set-deploy-flag }
-"The " { $link "ui.tools.deploy" } " provides a graphical way of editing the configuration." ;
-
ARTICLE: "deploy-flags" "Deployment flags"
"There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
{ $subsection deploy-math? }
{ $subsection deploy-word-props? }
{ $subsection deploy-c-types? } ;
-ARTICLE: "prepare-deploy" "Preparing to deploy an application"
-"In order to deploy an application as a stand-alone image, the application's vocabulary must first be given a " { $link POSTPONE: MAIN: } " hook. Then, a " { $emphasis "deployment configuration" } " must be created."
-{ $subsection "deploy-config" }
-{ $subsection "deploy-flags" } ;
-
-ABOUT: "prepare-deploy"
+ABOUT: "deploy-flags"
HELP: deploy-name
{ $description "Deploy setting. The name of the executable."
HELP: default-config
{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } }
{ $description "Outputs the default deployment configuration for a vocabulary." } ;
-
-HELP: deploy-config
-{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } }
-{ $description "Loads a vocabulary's deployment configuration from the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If the file does not exist, the " { $link default-config } " is output." } ;
-
-HELP: set-deploy-config
-{ $values { "assoc" assoc } { "vocab" "a vocabulary specifier" } }
-{ $description "Stores a vocabulary's deployment configuration to the " { $snippet "deploy.factor" } " file in the vocabulary's directory." } ;
-
-HELP: set-deploy-flag
-{ $values { "value" object } { "key" object } { "vocab" "a vocabulary specifier" } }
-{ $description "Modifies an entry in a vocabulary's deployment configuration on disk." } ;
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: vocabs.loader io.files io kernel sequences assocs
-splitting parser prettyprint namespaces math vocabs
-hashtables tools.vocabs ;
+USING: io.files io kernel sequences assocs splitting parser
+namespaces math vocabs hashtables ;
IN: tools.deploy.config
SYMBOL: deploy-name
! default value for deploy.macosx
{ "stop-after-last-window?" t }
} assoc-union ;
-
-: deploy-config-path ( vocab -- string )
- vocab-dir "deploy.factor" append-path ;
-
-: deploy-config ( vocab -- assoc )
- dup default-config swap
- dup deploy-config-path vocab-file-contents
- parse-fresh [ first assoc-union ] unless-empty ;
-
-: set-deploy-config ( assoc vocab -- )
- [ unparse-use string-lines ] dip
- dup deploy-config-path set-vocab-file-contents ;
-
-: set-deploy-flag ( value key vocab -- )
- [ deploy-config [ set-at ] keep ] keep set-deploy-config ;
--- /dev/null
+USING: assocs help.markup help.syntax kernel
+tools.deploy.config ;
+IN: tools.deploy.config.editor
+
+ARTICLE: "deploy-config" "Deployment configuration"
+"The deployment configuration is a key/value mapping stored in the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If this file does not exist, the default deployment configuration is used:"
+{ $subsection default-config }
+"The deployment configuration can be read and written with a pair of words:"
+{ $subsection deploy-config }
+{ $subsection set-deploy-config }
+"A utility word is provided to load the configuration, change a flag, and store it back to disk:"
+{ $subsection set-deploy-flag }
+"The " { $link "ui.tools.deploy" } " provides a graphical way of editing the configuration." ;
+
+HELP: deploy-config
+{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } }
+{ $description "Loads a vocabulary's deployment configuration from the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If the file does not exist, the " { $link default-config } " is output." } ;
+
+HELP: set-deploy-config
+{ $values { "assoc" assoc } { "vocab" "a vocabulary specifier" } }
+{ $description "Stores a vocabulary's deployment configuration to the " { $snippet "deploy.factor" } " file in the vocabulary's directory." } ;
+
+HELP: set-deploy-flag
+{ $values { "value" object } { "key" object } { "vocab" "a vocabulary specifier" } }
+{ $description "Modifies an entry in a vocabulary's deployment configuration on disk." } ;
+
+ABOUT: "deploy-config"
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs io.files kernel parser prettyprint sequences
+splitting tools.deploy.config tools.vocabs vocabs.loader ;
+IN: tools.deploy.config.editor
+
+: deploy-config-path ( vocab -- string )
+ vocab-dir "deploy.factor" append-path ;
+
+: deploy-config ( vocab -- assoc )
+ dup default-config swap
+ dup deploy-config-path vocab-file-contents
+ parse-fresh [ first assoc-union ] unless-empty ;
+
+: set-deploy-config ( assoc vocab -- )
+ [ unparse-use string-lines ] dip
+ dup deploy-config-path set-vocab-file-contents ;
+
+: set-deploy-flag ( value key vocab -- )
+ [ deploy-config [ set-at ] keep ] keep set-deploy-config ;
kernel ;
IN: tools.deploy
+ARTICLE: "prepare-deploy" "Preparing to deploy an application"
+"In order to deploy an application as a stand-alone image, the application's vocabulary must first be given a " { $link POSTPONE: MAIN: } " hook. Then, a " { $emphasis "deployment configuration" } " must be created."
+{ $subsection "deploy-config" }
+{ $subsection "deploy-flags" } ;
+
ARTICLE: "tools.deploy" "Application deployment"
"The stand-alone application deployment tool compiles a vocabulary down to a native executable which runs the vocabulary's " { $link POSTPONE: MAIN: } " hook. Deployed executables do not depend on Factor being installed, and do not expose any source code, and thus are suitable for delivering commercial end-user applications."
$nl
IN: tools.deploy.tests\r
USING: tools.test system io.files kernel tools.deploy.config\r
-tools.deploy.backend math sequences io.launcher arrays\r
-namespaces continuations layouts accessors io.encodings.ascii\r
-urls math.parser ;\r
+tools.deploy.config.editor tools.deploy.backend math sequences\r
+io.launcher arrays namespaces continuations layouts accessors\r
+io.encodings.ascii urls math.parser ;\r
\r
: shake-and-bake ( vocab -- )\r
[ "test.image" temp-file delete-file ] ignore-errors\r
: small-enough? ( n -- ? )\r
[ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;\r
\r
-[ ] [ "hello-world" shake-and-bake ] unit-test\r
+[ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test\r
\r
-[ t ] [ 500000 small-enough? ] unit-test\r
+[ t ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test\r
\r
-[ ] [ "sudoku" shake-and-bake ] unit-test\r
-\r
-[ t ] [ 800000 small-enough? ] unit-test\r
-\r
-[ ] [ "hello-ui" shake-and-bake ] unit-test\r
-\r
-[ t ] [ 1300000 small-enough? ] unit-test\r
+[ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test\r
\r
[ "staging.math-compiler-threads-ui-strip.image" ] [\r
"hello-ui" deploy-config\r
[ bootstrap-profile staging-image-name file-name ] bind\r
] unit-test\r
\r
-[ ] [ "maze" shake-and-bake ] unit-test\r
-\r
-[ t ] [ 1200000 small-enough? ] unit-test\r
-\r
-[ ] [ "tetris" shake-and-bake ] unit-test\r
+[ t ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test\r
\r
-[ t ] [ 1500000 small-enough? ] unit-test\r
+[ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test\r
\r
-! [ ] [ "bunny" shake-and-bake ] unit-test\r
+[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test\r
\r
-! [ t ] [ 2500000 small-enough? ] unit-test\r
+os macosx? [\r
+ [ t ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test\r
+] when\r
\r
: run-temp-image ( -- )\r
vm\r
"tools.deploy.test.7" shake-and-bake\r
run-temp-image\r
] unit-test\r
+\r
+[ ] [\r
+ "tools.deploy.test.8" shake-and-bake\r
+ run-temp-image\r
+] unit-test\r
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.files kernel namespaces make sequences
-system tools.deploy.backend tools.deploy.config assocs
-hashtables prettyprint io.unix.backend cocoa io.encodings.utf8
-io.backend cocoa.application cocoa.classes cocoa.plists
-qualified combinators ;
+USING: io io.files kernel namespaces make sequences system
+tools.deploy.backend tools.deploy.config
+tools.deploy.config.editor assocs hashtables prettyprint
+io.unix.backend cocoa io.encodings.utf8 io.backend
+cocoa.application cocoa.classes cocoa.plists qualified
+combinators ;
IN: tools.deploy.macosx
: bundle-dir ( -- dir )
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors qualified io.backend io.streams.c init fry
-namespaces make assocs kernel parser lexer strings.parser
-tools.deploy.config vocabs sequences words words.private memory
-kernel.private continuations io prettyprint vocabs.loader
-debugger system strings sets vectors quotations byte-arrays
-sorting compiler.units definitions generic generic.standard ;
+namespaces make assocs kernel parser lexer strings.parser vocabs
+sequences words words.private memory kernel.private
+continuations io vocabs.loader system strings sets
+vectors quotations byte-arrays sorting compiler.units
+definitions generic generic.standard tools.deploy.config ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
QUALIFIED: definitions
QUALIFIED: init
QUALIFIED: layouts
-QUALIFIED: prettyprint.config
QUALIFIED: source-files
QUALIFIED: vocabs
IN: tools.deploy.shaker
] when ;
: strip-debugger ( -- )
- strip-debugger? [
+ strip-debugger? "debugger" vocab and [
"Stripping debugger" show
"resource:basis/tools/deploy/shaker/strip-debugger.factor"
run-file
>alist f like
] change-props drop
] each
- ] [
- "Remaining word properties:\n" show
- [ props>> keys ] gather unparse show
] [
H{ } clone '[
[ [ _ [ ] cache ] map ] change-props drop
] each
- ] tri ;
+ ] bi ;
: stripped-word-props ( -- seq )
[
strip-word-names? [ dup strip-word-names ] when
2drop ;
+: strip-default-methods ( -- )
+ strip-debugger? [
+ "Stripping default methods" show
+ [
+ [ generic? ] instances
+ [ "No method" throw ] define-temp
+ dup t "default" set-word-prop
+ '[
+ [ _ "default-method" set-word-prop ] [ make-generic ] bi
+ ] each
+ ] with-compilation-unit
+ ] when ;
+
: strip-vocab-globals ( except names -- words )
[ child-vocabs [ words ] map concat ] map concat swap diff ;
] when
strip-prettyprint? [
- {
- prettyprint.config:margin
- prettyprint.config:string-limit?
- prettyprint.config:boa-tuples?
- prettyprint.config:tab-size
- } %
+ { } { "prettyprint.config" } strip-vocab-globals %
] when
strip-debugger? [
'[ drop _ member? not ] assoc-filter
[ drop string? not ] assoc-filter ! strip CLI args
sift-assoc
- dup keys unparse show
21 setenv
] [ drop ] if ;
init-hooks get values concat %
,
strip-io? [ \ flush , ] unless
- ] [ ] make "Boot quotation: " show dup unparse show
+ ] [ ] make
set-boot-quot ;
: init-stripper ( -- )
: strip ( -- )
init-stripper
+ strip-default-methods
strip-libc
strip-cocoa
strip-debugger
deploy-vocab get vocab-main set-boot-quot*
stripped-word-props
stripped-globals strip-globals
- strip-words
compress-byte-arrays
compress-quotations
compress-strings
- compress-wrappers ;
+ compress-wrappers
+ strip-words ;
: (deploy) ( final-image vocab config -- )
#! Does the actual work of a deployment in the slave
deploy-vocab get require
strip
finish-deploy
- ] [
- print-error flush 1 exit
- ] recover
+ ] [ error-continuation get call>> callstack>array die 1 exit ] recover
] bind ;
: do-deploy ( -- )
"output-image" get
"deploy-vocab" get
"Deploying " write dup write "..." print
- dup deploy-config dup .
+ "deploy-config" get parse-file first
(deploy) ;
MAIN: do-deploy
global [
"stop-after-last-window?" "ui" lookup set
- "ui.cocoa" vocab [
- [ "MiniFactor.nib" load-nib ]
- "cocoa-init-hook" "ui.cocoa" lookup set-global
- ] when
-
! Only keeps those methods that we actually call
sent-messages get super-sent-messages get assoc-union
objc-methods [ assoc-intersect pool-values ] change
--- /dev/null
+USING: kernel ;
+IN: tools.deploy.test.8
+
+: literal-merge-test-1 ( -- x ) H{ { "lil" "wayne" } } ;
+: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ;
+
+: literal-merge-test ( -- )
+ literal-merge-test-1
+ literal-merge-test-2 eq? t assert= ;
+
+MAIN: literal-merge-test
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-name "tools.deploy.test.8" }
+ { deploy-c-types? f }
+ { deploy-word-props? f }
+ { deploy-ui? f }
+ { deploy-reflection 1 }
+ { deploy-compiler? f }
+ { deploy-unicode? f }
+ { deploy-io 1 }
+ { deploy-word-defs? f }
+ { deploy-threads? f }
+ { "stop-after-last-window?" t }
+ { deploy-math? f }
+}
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: io io.files io.backend kernel namespaces make sequences
-system tools.deploy.backend tools.deploy.config assocs
-hashtables prettyprint ;
+system tools.deploy.backend tools.deploy.config
+tools.deploy.config.editor assocs hashtables prettyprint ;
IN: tools.deploy.unix
: create-app-dir ( vocab bundle-name -- vm )
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.files kernel namespaces sequences system
-tools.deploy.backend tools.deploy.config assocs hashtables
-prettyprint combinators windows.shell32 windows.user32 ;
+tools.deploy.backend tools.deploy.config
+tools.deploy.config.editor assocs hashtables prettyprint
+combinators windows.shell32 windows.user32 ;
IN: tools.deploy.windows
: copy-dll ( bundle-name -- )
IN: tools.disassembler.tests\r
-USING: math classes.tuple prettyprint.backend tools.disassembler\r
-tools.test strings ;\r
+USING: math classes.tuple prettyprint.custom \r
+tools.disassembler tools.test strings ;\r
\r
[ ] [ \ + disassemble ] unit-test\r
[ ] [ { string pprint* } disassemble ] unit-test\r
\ directory. must-infer
[ ] [ "" directory. ] unit-test
+
+[ ]
+[ { device-name free-space used-space total-space percent-used } file-systems. ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators io io.files kernel
-math.parser sequences system vocabs.loader calendar ;
+math.parser sequences system vocabs.loader calendar math
+symbols fry prettyprint ;
IN: tools.files
<PRIVATE
: ls-time ( timestamp -- string )
[ hour>> ] [ minute>> ] bi
- [ number>string 2 CHAR: 0 pad-left ] bi@ ":" swap 3append ;
+ [ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ;
: ls-timestamp ( timestamp -- string )
[ month>> month-abbreviation ]
: directory. ( path -- )
[ (directory.) ] with-directory-files [ print ] each ;
+SYMBOLS: device-name mount-point type
+available-space free-space used-space total-space
+percent-used percent-free ;
+
+: percent ( real -- integer ) 100 * >integer ; inline
+
+: file-system-spec ( file-system-info obj -- str )
+ {
+ { device-name [ device-name>> ] }
+ { mount-point [ mount-point>> ] }
+ { type [ type>> ] }
+ { available-space [ available-space>> [ 0 ] unless* ] }
+ { free-space [ free-space>> [ 0 ] unless* ] }
+ { used-space [ used-space>> [ 0 ] unless* ] }
+ { total-space [ total-space>> [ 0 ] unless* ] }
+ { percent-used [
+ [ used-space>> ] [ total-space>> ] bi
+ [ [ 0 ] unless* ] bi@ dup 0 =
+ [ 2drop 0 ] [ / percent ] if
+ ] }
+ } case ;
+
+: file-systems-info ( spec -- seq )
+ file-systems swap '[ _ [ file-system-spec ] with map ] map ;
+
+: file-systems. ( spec -- )
+ [ file-systems-info ]
+ [ [ unparse ] map ] bi prefix simple-table. ;
+
{
{ [ os unix? ] [ "tools.files.unix" ] }
{ [ os windows? ] [ "tools.files.windows" ] }
: heap-stat-step ( obj counts sizes -- )
[ over ] dip
- [ [ [ drop 1 ] [ class ] bi ] dip at+ ]
+ [ [ class ] dip inc-at ]
[ [ [ size ] [ class ] bi ] dip at+ ] 2bi* ;
PRIVATE>
{ $description "Runs unit tests for all loaded vocabularies." } ;
HELP: run-all-tests
-{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } }
+{ $values { "failures" "an association list of unit test failures" } }
{ $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ;
HELP: test-failures.
--- /dev/null
+IN: tools.test.tests
+USING: tools.test ;
+
+\ test-all must-infer
: test ( prefix -- )
run-tests test-failures. ;
-: run-all-tests ( prefix -- failures )
+: run-all-tests ( -- failures )
"" run-tests ;
: test-all ( -- )
M: vocab-tag >link ;
M: vocab-tag article-title
- name>> "Vocabularies tagged ``" swap "''" 3append ;
+ name>> "Vocabularies tagged ``" "''" surround ;
M: vocab-tag article-name name>> ;
: walker-loop ( -- )
+running+ set-status
- [ status +stopped+ eq? not ] [
+ [ status +stopped+ eq? ] [
[
{
! ignore these commands while the thread is
[ walker-suspended ]
} case
] handle-synchronous
- ] [ ] while ;
+ ] [ ] until ;
: associate-thread ( walker -- )
walker-thread tset
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays strings sequences sequences.private
-fry kernel words parser lexer assocs math.order ;
+fry kernel words parser lexer assocs math math.order summary ;
IN: tr
+ERROR: bad-tr ;
+
+M: bad-tr summary
+ drop "TR: can only be used with ASCII characters" ;
+
<PRIVATE
+: ascii? ( ch -- ? ) 0 127 between? ; inline
+
+: tr-nth ( n mapping -- ch ) nth-unsafe 127 bitand ; inline
+
+: check-tr ( from to -- )
+ [ [ ascii? ] all? ] both? [ bad-tr ] unless ;
+
: compute-tr ( quot from to -- mapping )
- zip [ 256 ] 2dip '[ [ @ _ at ] keep or ] B{ } map-as ; inline
+ zip [ 128 ] 2dip '[ [ @ _ at ] keep or ] B{ } map-as ; inline
: tr-hints ( word -- )
{ { byte-array } { string } } "specializer" set-word-prop ;
create-in dup tr-hints ;
: tr-quot ( mapping -- quot )
- '[ [ dup 0 255 between? [ _ nth-unsafe ] when ] map ] ;
+ '[ [ dup ascii? [ _ tr-nth ] when ] map ] ;
: define-tr ( word mapping -- )
tr-quot (( seq -- translated )) define-declared ;
: fast-tr-quot ( mapping -- quot )
- '[ [ _ nth-unsafe ] change-each ] ;
+ '[ [ _ tr-nth ] change-each ] ;
: define-fast-tr ( word mapping -- )
fast-tr-quot (( seq -- )) define-declared ;
: TR:
scan parse-definition
unclip-last [ unclip-last ] dip compute-tr
+ [ check-tr ]
[ [ create-tr ] dip define-tr ]
- [ [ "-fast" append create-tr ] dip define-fast-tr ] 2bi ;
+ [ [ "-fast" append create-tr ] dip define-fast-tr ] 2tri ;
parsing
USING: accessors math arrays assocs cocoa cocoa.application
command-line kernel memory namespaces cocoa.messages
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
-cocoa.windows cocoa.classes cocoa.application sequences system
-ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
-ui.cocoa.views core-foundation threads math.geometry.rect fry ;
+cocoa.windows cocoa.classes cocoa.application cocoa.nibs
+sequences system ui ui.backend ui.clipboards ui.gadgets
+ui.gadgets.worlds ui.cocoa.views core-foundation threads
+math.geometry.rect fry ;
IN: ui.cocoa
TUPLE: handle view window ;
SYMBOL: cocoa-init-hook
-cocoa-init-hook global [ [ install-app-delegate ] or ] change-at
+cocoa-init-hook global [
+ [ "MiniFactor.nib" load-nib install-app-delegate ] or
+] change-at
M: cocoa-ui-backend ui
"UI" assert.app [
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.accessors alien.c-types arrays io kernel libc
-math math.vectors namespaces opengl opengl.gl prettyprint assocs
+math math.vectors namespaces opengl opengl.gl assocs
sequences io.files io.styles continuations freetype
ui.gadgets.worlds ui.render ui.backend byte-arrays accessors
locals specialized-arrays.direct.uchar ;
} at ;
: ttf-path ( name -- string )
- "resource:fonts/" swap ".ttf" 3append ;
+ "resource:fonts/" ".ttf" surround ;
: (open-face) ( path length -- face )
#! We use FT_New_Memory_Face, not FT_New_Face, since
USING: arrays ui.gadgets.buttons ui.gadgets.borders
ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.tracks ui.gadgets.theme ui.gadgets.frames
-ui.gadgets.grids io kernel math models namespaces prettyprint
+ui.gadgets.grids io kernel math models namespaces
sequences sequences words classes.tuple ui.gadgets ui.render
colors accessors ;
IN: ui.gadgets.labelled
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors definitions hashtables io kernel
-prettyprint sequences strings io.styles words help math models
+sequences strings io.styles words help math models
namespaces quotations
ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds
#! A scaling factor such that if x is a slider co-ordinate,
#! x*n is the screen position of the thumb, and conversely
#! for x/n. The '1 max' calls avoid division by zero.
- dup elevator-length over thumb-dim - 1 max
- swap slider-max* 1 max / ;
+ [ [ elevator-length ] [ thumb-dim ] bi - 1 max ]
+ [ slider-max* 1 max ]
+ bi / ;
: slider>screen ( m scale -- n ) slider-scale * ;
: screen>slider ( m scale -- n ) slider-scale / ;
USING: accessors arrays assocs continuations kernel math models
namespaces opengl sequences io combinators fry math.vectors
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-debugger math.geometry.rect ;
+math.geometry.rect ;
IN: ui.gadgets.worlds
TUPLE: world < track
SYMBOL: ui-error-hook
: ui-error ( error -- )
- ui-error-hook get [ call ] [ print-error ] if* ;
+ ui-error-hook get [ call ] [ die ] if* ;
ui-error-hook global [ [ rethrow ] or ] change-at
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: ui.gadgets colors kernel ui.render namespaces models
models.mapping sequences ui.gadgets.buttons ui.gadgets.packs
-ui.gadgets.labels tools.deploy.config namespaces
-ui.gadgets.editors ui.gadgets.borders ui.gestures ui.commands
-assocs ui.gadgets.tracks ui ui.tools.listener tools.deploy
-vocabs ui.tools.workspace system accessors fry ;
+ui.gadgets.labels tools.deploy.config tools.deploy.config.editor
+namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
+ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
+tools.deploy vocabs ui.tools.workspace system accessors fry ;
IN: ui.tools.deploy
TUPLE: deploy-gadget < pack vocab settings ;
: deploy-tool ( vocab -- )
vocab-name
[ <deploy-gadget> 10 <border> ]
- [ "Deploying \"" swap "\"" 3append ] bi
+ [ "Deploying \"" "\"" surround ] bi
open-window ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces make
-prettyprint dlists deques sequences threads sequences words
-debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
-ui.gestures ui.backend ui.render continuations init combinators
-hashtables concurrency.flags sets accessors calendar ;
+dlists deques sequences threads sequences words ui.gadgets
+ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend
+ui.render continuations init combinators hashtables
+concurrency.flags sets accessors calendar ;
IN: ui
! Assoc mapping aliens to gadgets
windows.nt windows threads libc combinators
combinators.short-circuit continuations command-line shuffle
opengl ui.render ascii math.bitwise locals symbols accessors
-math.geometry.rect math.order ascii calendar ;
+math.geometry.rect math.order ascii calendar
+io.encodings.utf16n ;
IN: ui.windows
SINGLETON: windows-ui-backend
assocs kernel math namespaces opengl sequences strings x11.xlib
x11.events x11.xim x11.glx x11.clipboard x11.constants
x11.windows io.encodings.string io.encodings.ascii
-io.encodings.utf8 combinators debugger command-line qualified
+io.encodings.utf8 combinators command-line qualified
math.vectors classes.tuple opengl.gl threads math.geometry.rect
environment ascii ;
IN: ui.x11
"lt" locale set
! Lithuanian casing tests
] with-scope
+
+[ t ] [ "asdf" lower? ] unit-test
+[ f ] [ "asdF" lower? ] unit-test
+
+[ t ] [ "ASDF" upper? ] unit-test
+[ f ] [ "ASDf" upper? ] unit-test
: >case-fold ( string -- fold )
>upper >lower ;
-: lower? ( string -- ? )
- dup >lower = ;
-: upper? ( string -- ? )
- dup >lower = ;
-: title? ( string -- ? )
- dup >title = ;
-: case-fold? ( string -- ? )
- dup >case-fold = ;
+: lower? ( string -- ? ) dup >lower = ;
+
+: upper? ( string -- ? ) dup >upper = ;
+
+: title? ( string -- ? ) dup >title = ;
+
+: case-fold? ( string -- ? ) dup >case-fold = ;
! See http://factorcode.org/license.txt for BSD license.
USING: unicode.data kernel math sequences parser lexer
bit-arrays namespaces make sequences.private arrays quotations
-assocs classes.predicate math.order eval ;
+assocs classes.predicate math.order strings.parser ;
IN: unicode.syntax
! Character classes (categories)
categories [ swap member? ] with map >bit-array ;
: as-string ( strings -- bit-array )
- concat "\"" tuck 3append eval ;
+ concat unescape-string ;
: [category] ( categories -- quot )
[
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: debugger prettyprint accessors unix io kernel ;
+IN: unix.debugger
+
+M: unix-error error.
+ "Unix system call failed:" print
+ nl
+ dup message>> write " (" write errno>> pprint ")" print ;
+
+M: unix-system-call-error error.
+ "Unix system call ``" write dup word>> pprint "'' failed:" print
+ nl
+ dup message>> write " (" write dup errno>> pprint ")" print
+ nl
+ "It was called with the following arguments:" print
+ nl
+ args>> stack. ;
--- /dev/null
+unportable
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax system sequences vocabs.loader words ;
+USING: alien.syntax system sequences vocabs.loader words
+accessors ;
IN: unix.kqueue
<< "unix.kqueue." os name>> append require >>
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax kernel libc
sequences continuations byte-arrays strings math namespaces
system combinators vocabs.loader qualified accessors
stack-checker macros locals generalizations unix.types
-debugger io prettyprint io.files ;
+io io.files vocabs vocabs.loader ;
IN: unix
: PROT_NONE 0 ; inline
ERROR: unix-error errno message ;
-M: unix-error error.
- "Unix system call failed:" print
- nl
- dup message>> write " (" write errno>> pprint ")" print ;
-
: (io-error) ( -- * ) err_no dup strerror unix-error ;
: io-error ( n -- ) 0 < [ (io-error) ] when ;
ERROR: unix-system-call-error args errno message word ;
-M: unix-system-call-error error.
- "Unix system call ``" write dup word>> pprint "'' failed:" print
- nl
- dup message>> write " (" write dup errno>> pprint ")" print
- nl
- "It was called with the following arguments:" print
- nl
- args>> stack. ;
-
MACRO:: unix-system-call ( quot -- )
[let | n [ quot infer in>> ]
word [ quot first ] |
{ [ os bsd? ] [ "unix.bsd" require ] }
{ [ os solaris? ] [ "unix.solaris" require ] }
} cond
+
+"debugger" vocab [
+ "unix.debugger" require
+] when
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel present prettyprint.custom prettyprint.backend urls ;
+IN: urls.prettyprint
+
+M: url pprint* dup present "URL\" " "\"" pprint-string ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ascii combinators combinators.short-circuit
sequences splitting fry namespaces make assocs arrays strings
-io.sockets io.encodings.string
-io.encodings.utf8 math math.parser accessors parser
-strings.parser lexer prettyprint.backend hashtables present
-peg.ebnf urls.encoding ;
+io.sockets io.encodings.string io.encodings.utf8 math
+math.parser accessors parser strings.parser lexer
+hashtables present peg.ebnf urls.encoding ;
IN: urls
TUPLE: url protocol username password host port path query anchor ;
! Literal syntax
: URL" lexer get skip-blank parse-string >url parsed ; parsing
-M: url pprint* dup present "URL\" " "\"" pprint-string ;
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [
+ "urls.prettyprint" require
+] when
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors sequences sequences.private
persistent.sequences assocs persistent.assocs kernel math
-vectors parser prettyprint.backend ;
+vectors parser prettyprint.custom ;
IN: vlists
TUPLE: vlist
USING: alien alien.c-types alien.strings alien.syntax combinators
kernel windows windows.user32 windows.ole32
-windows.com windows.com.syntax io.files ;
+windows.com windows.com.syntax io.files io.encodings.utf16n ;
IN: windows.shell32
: CSIDL_DESKTOP HEX: 00 ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax alien.c-types alien.strings arrays
combinators kernel math namespaces parser prettyprint sequences
-windows.errors windows.types windows.kernel32 words ;
+windows.errors windows.types windows.kernel32 words
+io.encodings.utf16n ;
IN: windows
: lo-word ( wparam -- lo ) <short> *short ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax arrays
byte-arrays kernel math sequences windows.types windows.kernel32
-windows.errors windows math.bitwise alias ;
+windows.errors windows math.bitwise alias io.encodings.utf16n ;
IN: windows.winsock
USE: libc
USING: alien alien.c-types alien.strings arrays byte-arrays
hashtables io io.encodings.string kernel math namespaces
sequences strings continuations x11.xlib specialized-arrays.uint
-accessors ;
+accessors io.encodings.utf16n ;
IN: x11.xim
SYMBOL: xim
: >array ( seq -- array ) { } clone-like ;
-M: object new-sequence drop
f <array> ;
+M: object new-sequence drop
0 <array> ;
-M: f new-sequence drop dup zero? [ drop f ] [
f <array> ] if ;
+M: f new-sequence drop dup zero? [ drop f ] [
0 <array> ] if ;
M: array equal?
over array? [ sequence= ] [ 2drop f ] if ;
{ $subsection rename-at }
{ $subsection change-at }
{ $subsection at+ }
+{ $subsection inc-at }
{ $see-also set-at delete-at clear-assoc push-at } ;
ARTICLE: "assocs-conversions" "Associative mapping conversions"
{ $examples
{ $unchecked-example
": discount ( prices n -- newprices )"
- " [ - ] curry assoc-each ;"
+ " [ - ] curry assoc-map ;"
"H{ { \"bananas\" 5 } { \"apples\" 42 } { \"pears\" 17 } }"
"2 discount ."
"H{ { \"bananas\" 3 } { \"apples\" 39 } { \"pears\" 15 } }"
{ $description "Adds " { $snippet "n" } " to the value associated with " { $snippet "key" } "; if there is no value, stores " { $snippet "n" } ", thus behaving as if the value was 0." }
{ $side-effects "assoc" } ;
+HELP: inc-at
+{ $values { "key" object } { "assoc" assoc } }
+{ $description "Adds 1 to the value associated with " { $snippet "key" } "; if there is no value, stores 1." }
+{ $side-effects "assoc" } ;
+
HELP: >alist
{ $values { "assoc" assoc } { "newassoc" "an array of key/value pairs" } }
{ $contract "Converts an associative structure into an association list." }
] if ; inline recursive
: assoc-stack ( key seq -- value )
- dup length 1- swap (assoc-stack) ;
+ dup length 1- swap (assoc-stack) ; flushable
: assoc-subset? ( assoc1 assoc2 -- ? )
[ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ;
: change-at ( key assoc quot -- )
[ [ at ] dip call ] 3keep drop set-at ; inline
-: at+ ( n key assoc -- )
- [ 0 or + ] change-at ;
+: at+ ( n key assoc -- ) [ 0 or + ] change-at ; inline
+
+: inc-at ( key assoc -- ) [ 1 ] 2dip at+ ; inline
: map>assoc ( seq quot exemplar -- assoc )
[ [ 2array ] compose { } map-as ] dip assoc-like ; inline
"alien.accessors"
"arrays"
"byte-arrays"
- "byte-vectors"
"classes.private"
"classes.tuple"
"classes.tuple.private"
} [ create-vocab drop ] each
! Builtin classes
-: define-builtin-predicate ( class -- )
- dup class>type [ builtin-instance? ] curry define-predicate ;
-
: lookup-type-number ( word -- n )
global [ target-word ] bind type-number ;
] [ ] make
define-predicate-class
+"array-capacity" "sequences.private" lookup
+[ >fixnum ] bootstrap-max-array-capacity <fake-bignum> [ fixnum-bitand ] curry append
+"coercer" set-word-prop
+
! Catch-all class for providing a default method.
"object" "kernel" create
[ f f { } intersection-class define-class ]
"math.integers" require
"math.floats" require
"memory" require
-
+
"io.streams.c" require
"vocabs.loader" require
"<PRIVATE"
"BIN:"
"B{"
- "BV{"
"C:"
"CHAR:"
"DEFER:"
+++ /dev/null
-USING: arrays byte-arrays help.markup help.syntax kernel\r
-byte-vectors.private combinators ;\r
-IN: byte-vectors\r
-\r
-ARTICLE: "byte-vectors" "Byte vectors"\r
-"A byte vector is a resizable mutable sequence of unsigned bytes. Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary."\r
-$nl\r
-"Byte vectors form a class:"\r
-{ $subsection byte-vector }\r
-{ $subsection byte-vector? }\r
-"Creating byte vectors:"\r
-{ $subsection >byte-vector }\r
-{ $subsection <byte-vector> }\r
-"Literal syntax:"\r
-{ $subsection POSTPONE: BV{ }\r
-"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"\r
-{ $code "BV{ } clone" } ;\r
-\r
-ABOUT: "byte-vectors"\r
-\r
-HELP: byte-vector\r
-{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ;\r
-\r
-HELP: <byte-vector>\r
-{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }\r
-{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;\r
-\r
-HELP: >byte-vector\r
-{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }\r
-{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }\r
-{ $errors "Throws an error if the sequence contains elements other than integers." } ;\r
-\r
-HELP: BV{\r
-{ $syntax "BV{ elements... }" }\r
-{ $values { "elements" "a list of bytes" } }\r
-{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } \r
-{ $examples { $code "BV{ 1 2 3 12 }" } } ;\r
+++ /dev/null
-IN: byte-vectors.tests\r
-USING: tools.test byte-vectors vectors sequences kernel\r
-prettyprint ;\r
-\r
-[ 0 ] [ 123 <byte-vector> length ] unit-test\r
-\r
-: do-it\r
- 123 [ over push ] each ;\r
-\r
-[ t ] [\r
- 3 <byte-vector> do-it\r
- 3 <vector> do-it sequence=\r
-] unit-test\r
-\r
-[ t ] [ BV{ } byte-vector? ] unit-test\r
-\r
-[ "BV{ }" ] [ BV{ } unparse ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays kernel kernel.private math sequences\r
-sequences.private growable byte-arrays accessors ;\r
-IN: byte-vectors\r
-\r
-TUPLE: byte-vector\r
-{ underlying byte-array }\r
-{ length array-capacity } ;\r
-\r
-: <byte-vector> ( n -- byte-vector )\r
- (byte-array) 0 byte-vector boa ; inline\r
-\r
-: >byte-vector ( seq -- byte-vector )\r
- T{ byte-vector f B{ } 0 } clone-like ;\r
-\r
-M: byte-vector like\r
- drop dup byte-vector? [\r
- dup byte-array?\r
- [ dup length byte-vector boa ] [ >byte-vector ] if\r
- ] unless ;\r
-\r
-M: byte-vector new-sequence\r
- drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;\r
-\r
-M: byte-vector equal?\r
- over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
-\r
-M: byte-array like\r
- #! If we have an byte-array, we're done.\r
- #! If we have a byte-vector, and it's at full capacity,\r
- #! we're done. Otherwise, call resize-byte-array, which is a\r
- #! relatively fast primitive.\r
- drop dup byte-array? [\r
- dup byte-vector? [\r
- [ length ] [ underlying>> ] bi\r
- 2dup length eq?\r
- [ nip ] [ resize-byte-array ] if\r
- ] [ >byte-array ] if\r
- ] unless ;\r
-\r
-M: byte-array new-resizable drop <byte-vector> ;\r
-\r
-INSTANCE: byte-vector growable\r
+++ /dev/null
-Growable byte arrays
+++ /dev/null
-collections
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences math.parser io io.streams.byte-array
-io.encodings.binary io.files kernel ;
+USING: sequences math.parser io io.encodings.binary io.files
+kernel ;
IN: checksums
MIXIN: checksum
GENERIC: checksum-lines ( lines checksum -- value )
-M: checksum checksum-bytes
- [ binary <byte-reader> ] dip checksum-stream ;
-
M: checksum checksum-stream
[ contents ] dip checksum-bytes ;
\r
ARTICLE: "class-operations" "Class operations"\r
"Set-theoretic operations on classes:"\r
+{ $subsection class= }\r
{ $subsection class< }\r
{ $subsection class<= }\r
{ $subsection class-and }\r
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes classes.algebra words kernel
kernel.private namespaces sequences math math.private
-combinators assocs ;
+combinators assocs quotations ;
IN: classes.builtin
SYMBOL: builtins
PREDICATE: builtin-class < class
"metaclass" word-prop builtin-class eq? ;
-: type>class ( n -- class ) builtins get-global nth ;
-
: class>type ( class -- n ) "type" word-prop ; foldable
+PREDICATE: lo-tag-class < builtin-class class>type 7 <= ;
+
+PREDICATE: hi-tag-class < builtin-class class>type 7 > ;
+
+: type>class ( n -- class ) builtins get-global nth ;
+
: bootstrap-type>class ( n -- class ) builtins get nth ;
M: hi-tag class hi-tag type>class ;
M: builtin-class rank-class drop 0 ;
-: builtin-instance? ( object n -- ? )
- #! 7 == tag-mask get
- #! 3 == hi-tag tag-number
- dup 7 fixnum<= [ swap tag eq? ] [
- swap dup tag 3 eq?
- [ hi-tag eq? ] [ 2drop f ] if
- ] if ; inline
+GENERIC: define-builtin-predicate ( class -- )
+
+M: lo-tag-class define-builtin-predicate
+ dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
+
+M: hi-tag-class define-builtin-predicate
+ dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation
+ [ dup tag 3 eq? ] [ [ drop f ] if ] surround
+ define-predicate ;
+
+M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ;
-M: builtin-class instance?
- class>type builtin-instance? ;
+M: hi-tag-class instance?
+ over tag 3 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ;
M: builtin-class (flatten-class) dup set ;
[ drop t ]
] [
unclip "predicate" word-prop swap [
- "predicate" word-prop [ dup ] swap [ not ] 3append
+ "predicate" word-prop [ dup ] [ not ] surround
[ drop f ]
] { } map>assoc alist>quot
] if-empty ;
ARTICLE: "tuple-examples" "Tuple examples"
"An example:"
-{ $code "TUPLE: employee name salary position ;" }
+{ $code "TUPLE: employee name position salary ;" }
"This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:"
{ $table
{ "Reader" "Writer" "Setter" "Changer" }
" checks counter check boa ;"
""
": biweekly-paycheck ( employee -- check )"
- " dup name>> swap salary>> 26 / <check> ;"
+ " [ name>> ] [ salary>> 26 / ] bi <check> ;"
}
"An example of using a changer:"
{ $code
2drop f
] if ; inline
-: tuple-instance-1? ( object class -- ? )
- swap dup tuple? [
- layout-of 7 slot eq?
- ] [ 2drop f ] if ; inline
+: tuple-predicate-quot/1 ( class -- quot )
+ #! Fast path for tuples with no superclass
+ [ ] curry [ layout-of 7 slot ] [ eq? ] surround 1quotation
+ [ dup tuple? ] [ [ drop f ] if ] surround ;
: tuple-instance? ( object class offset -- ? )
rot dup tuple? [
: layout-class-offset ( echelon -- n )
2 * 5 + ;
+: tuple-predicate-quot ( class echelon -- quot )
+ layout-class-offset [ tuple-instance? ] 2curry ;
+
: echelon-of ( class -- n )
tuple-layout third ;
: define-tuple-predicate ( class -- )
dup dup echelon-of {
- { 1 [ [ tuple-instance-1? ] curry ] }
- [ layout-class-offset [ tuple-instance? ] 2curry ]
+ { 1 [ tuple-predicate-quot/1 ] }
+ [ tuple-predicate-quot ]
} case define-predicate ;
: class-size ( class -- n )
: tuple-class-unchanged? ( class superclass slots -- ? )
[ over ] dip
- [ [ superclass ] dip = ]
+ [ [ superclass ] [ bootstrap-word ] bi* = ]
[ [ "slots" word-prop ] dip = ] 2bi* and ;
: valid-superclass? ( class -- ? )
ARTICLE: "combinators" "Additional combinators"
"The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators."
$nl
-"A looping combinator:"
-{ $subsection while }
"Generalization of " { $link bi } " and " { $link tri } ":"
{ $subsection cleave }
"Generalization of " { $link 2bi } " and " { $link 2tri } ":"
$nl
"A combinator which can help with implementing methods on " { $link hashcode* } ":"
{ $subsection recursive-hashcode }
-{ $subsection "assertions" }
{ $subsection "combinators-quot" }
{ $see-also "quotations" "dataflow" } ;
-ARTICLE: "assertions" "Assertions"
-"Some words to make assertions easier to enforce:"
-{ $subsection assert }
-{ $subsection assert= }
-"Runtime stack depth checking:"
-{ $subsection assert-depth } ;
-
ABOUT: "combinators"
HELP: cleave
{ $values { "n" "a fixnum" } { "array" "an array of quotations" } }
{ $description "Calls the " { $snippet "n" } "th quotation in the array." }
{ $warning "This word is in the " { $vocab-link "kernel.private" } " vocabulary because it is an implementation detail used by the generic word system to accelerate method dispatch. It does not perform type or bounds checks, and user code should not need to call it directly." } ;
-
-HELP: assert-depth
-{ $values { "quot" "a quotation" } }
-{ $description "Runs a quotation. Throws an error if the total number of elements on the stack is not the same before and after the quotation runs." } ;
[ drop linear-case-quot ]
} cond ;
-! assert-depth
-: trim-datastacks ( seq1 seq2 -- seq1' seq2' )
- 2dup [ length ] bi@ min tuck [ tail ] 2bi@ ;
-
-ERROR: relative-underflow stack ;
-
-ERROR: relative-overflow stack ;
-
-: assert-depth ( quot -- )
- [ datastack ] dip dip [ datastack ] dip
- 2dup [ length ] compare {
- { +lt+ [ trim-datastacks nip relative-underflow ] }
- { +eq+ [ 2drop ] }
- { +gt+ [ trim-datastacks drop relative-overflow ] }
- } case ; inline
-
! recursive-hashcode
: recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
{ $subsection with-return }
"Reflecting the datastack:"
{ $subsection with-datastack }
+{ $subsection assert-depth }
"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
{ $subsection "continuations.private" } ;
{ $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
} ;
+HELP: assert-depth
+{ $values { "quot" "a quotation" } }
+{ $description "Runs a quotation. Throws an error if the quotation attempts to take input values from the stack, or leave outputs on the stack." } ;
+
HELP: <continuation>
{ $description "Constructs a new continuation." }
{ $notes "User code should call " { $link continuation } " instead." } ;
] 3 (throw)
] callcc1 2nip ;
+: assert-depth ( quot -- )
+ { } swap with-datastack { } assert= ; inline
+
GENERIC: compute-restarts ( error -- seq )
<PRIVATE
: math-class-max ( class1 class2 -- class )
[ math-class<=> ] most ;
-: math-class-min ( class1 class2 -- class )
- [ swap math-class<=> ] most ;
-
: (math-upgrade) ( max class -- quot )
dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
drop
dup
[
- \ both-fixnums? ,
+ [ 2dup both-fixnums? ] %
dup fixnum bootstrap-word dup math-method ,
\ over [
dup math-class? [
USING: classes.private generic.standard.engines namespaces make
arrays assocs sequences.private quotations kernel.private
math slots.private math.private kernel accessors words
-layouts sorting sequences ;
+layouts sorting sequences combinators ;
IN: generic.standard.engines.tag
TUPLE: lo-tag-dispatch-engine methods ;
: sort-tags ( assoc -- alist ) >alist sort-keys reverse ;
+: tag-dispatch-test ( tag# -- quot )
+ picker [ tag ] append swap [ eq? ] curry append ;
+
+: tag-dispatch-quot ( alist -- quot )
+ [ default get ] dip
+ [ [ tag-dispatch-test ] dip ] assoc-map
+ alist>quot ;
+
M: lo-tag-dispatch-engine engine>quot
methods>> engines>quots*
[ [ lo-tag-number ] dip ] assoc-map
[
- picker % [ tag ] % [
- sort-tags linear-dispatch-quot
- ] [
- num-tags get direct-dispatch-quot
- ] if-small? %
+ [ sort-tags tag-dispatch-quot ]
+ [ picker % [ tag ] % num-tags get direct-dispatch-quot ]
+ if-small? %
] [ ] make ;
TUPLE: hi-tag-dispatch-engine methods ;
}
"The underlying sequence must implement a generic word:"
{ $subsection resize }
-{ $link "vectors" } ", " { $link "byte-vectors" } " and " { $link "sbufs" } " are implemented using the resizable sequence facility." ;
+{ $link "vectors" } " and " { $link "sbufs" } " are implemented using the resizable sequence facility." ;
ABOUT: "growable"
0 >>count 0 >>deleted drop ; inline
: reset-hash ( n hash -- )
- swap <hash-array> >>array init-hash ;
+ swap <hash-array> >>array init-hash ; inline
: (new-key@) ( key keys i -- keys n empty? )
3dup swap array-nth dup ((empty)) eq? [
: push-unsafe ( elt seq -- )
[ length ] keep
[ underlying>> set-array-nth ]
- [ [ 1+ ] dip (>>length) ]
+ [ [ 1 fixnum+fast { array-capacity } declare ] dip (>>length) ]
2bi ; inline
PRIVATE>
+++ /dev/null
-USING: help.syntax help.markup io byte-arrays quotations ;
-IN: io.streams.byte-array
-
-ABOUT: "io.streams.byte-array"
-
-ARTICLE: "io.streams.byte-array" "Byte-array streams"
-"Byte array streams:"
-{ $subsection <byte-reader> }
-{ $subsection <byte-writer> }
-"Utility combinators:"
-{ $subsection with-byte-reader }
-{ $subsection with-byte-writer } ;
-
-HELP: <byte-reader>
-{ $values { "byte-array" byte-array }
- { "encoding" "an encoding descriptor" }
- { "stream" "a new byte reader" } }
-{ $description "Creates an input stream reading from a byte array using an encoding." } ;
-
-HELP: <byte-writer>
-{ $values { "encoding" "an encoding descriptor" }
- { "stream" "a new byte writer" } }
-{ $description "Creates an output stream writing data to a byte array using an encoding." } ;
-
-HELP: with-byte-reader
-{ $values { "encoding" "an encoding descriptor" }
- { "quot" quotation } { "byte-array" byte-array } }
-{ $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream for reading from a byte array using an encoding." } ;
-
-HELP: with-byte-writer
-{ $values { "encoding" "an encoding descriptor" }
- { "quot" quotation }
- { "byte-array" byte-array } }
-{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an output stream writing data to a byte array using an encoding." } ;
+++ /dev/null
-USING: tools.test io.streams.byte-array io.encodings.binary
-io.encodings.utf8 io kernel arrays strings ;
-
-[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test
-[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
-
-[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
-[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test
-[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
+++ /dev/null
-USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
-sequences io namespaces io.encodings.private accessors ;
-IN: io.streams.byte-array
-
-: <byte-writer> ( encoding -- stream )
- 512 <byte-vector> swap <encoder> ;
-
-: with-byte-writer ( encoding quot -- byte-array )
- [ <byte-writer> ] dip [ output-stream get ] compose with-output-stream*
- dup encoder? [ stream>> ] when >byte-array ; inline
-
-: <byte-reader> ( byte-array encoding -- stream )
- [ >byte-vector dup reverse-here ] dip <decoder> ;
-
-: with-byte-reader ( byte-array encoding quot -- )
- [ <byte-reader> ] dip with-input-stream* ; inline
{ $errors "Throws an error if the input operation failed." } ;
HELP: stdin-handle
-{ $values { "in" "a C FILE* handle" } }
+{ $values { "alien" "a C FILE* handle" } }
{ $description "Outputs the console standard input file handle." } ;
HELP: stdout-handle
-{ $values { "out" "a C FILE* handle" } }
+{ $values { "alien" "a C FILE* handle" } }
{ $description "Outputs the console standard output file handle." } ;
HELP: stderr-handle
-{ $values { "out" "a C FILE* handle" } }
+{ $values { "alien" "a C FILE* handle" } }
{ $description "Outputs the console standard error file handle." } ;
M: c-io-backend init-io ;
-: stdin-handle 11 getenv ;
-: stdout-handle 12 getenv ;
-: stderr-handle 61 getenv ;
+: stdin-handle ( -- alien ) 11 getenv ;
+: stdout-handle ( -- alien ) 12 getenv ;
+: stderr-handle ( -- alien ) 61 getenv ;
: init-c-stdio ( -- stdin stdout stderr )
stdin-handle <c-reader>
HELP: while
{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
-{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "body" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
-{ $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used."
-$nl
-"Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:"
-{ $code
- "[ P ] [ Q ] [ T ] while"
- "[ P ] [ Q ] [ ] while T"
-}
-"However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference." } ;
+{ $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link f } "." } ;
+
+HELP: until
+{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
+{ $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link t } "." } ;
+
+HELP: do
+{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
+{ $description "Executes one iteration of a " { $link while } " or " { $link until } " loop." } ;
HELP: loop
{ $values
"3\n10\n6\n2\n9\n5\n1\n8\n4\n0\n7" }
} ;
+ARTICLE: "looping-combinators" "Looping combinators"
+"In most cases, loops should be written using high-level combinators (such as " { $link "sequences-combinators" } ") or tail recursion. However, sometimes, the best way to express intent is with a loop."
+{ $subsection while }
+{ $subsection until }
+"The above two combinators take a " { $snippet "tail" } " quotation. Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:"
+{ $code
+ "[ P ] [ Q ] [ T ] while"
+ "[ P ] [ Q ] [ ] while T"
+}
+"However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference."
+$nl
+"To execute one iteration of a loop, use the following word:"
+{ $subsection do }
+"This word is intended as a modifier. The normal " { $link while } " loop never executes the body if the predicate returns first on the first iteration. To ensure the body executes at least once, use " { $link do } ":"
+{ $code
+ "[ P ] [ Q ] [ T ] do while"
+}
+"A simpler looping combinator which executes a single quotation until it returns " { $link f } ":"
+{ $subsection loop } ;
+
HELP: assert
{ $values { "got" "the obtained value" } { "expect" "the expected value" } }
{ $description "Throws an " { $link assert } " error." }
"An object can be cloned; the clone has distinct identity but equal value:"
{ $subsection clone } ;
+ARTICLE: "assertions" "Assertions"
+"Some words to make assertions easier to enforce:"
+{ $subsection assert }
+{ $subsection assert= } ;
+
ARTICLE: "dataflow" "Data and control flow"
{ $subsection "evaluator" }
{ $subsection "words" }
{ $subsection "booleans" }
{ $subsection "shuffle-words" }
"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
+$nl
+"Data flow combinators:"
{ $subsection "slip-keep-combinators" }
{ $subsection "cleave-combinators" }
{ $subsection "spread-combinators" }
{ $subsection "apply-combinators" }
+"Control flow combinators:"
{ $subsection "conditionals" }
+{ $subsection "looping-combinators" }
+"Additional combinators:"
{ $subsection "compositional-combinators" }
{ $subsection "combinators" }
+"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "."
+$nl
"Advanced topics:"
+{ $subsection "assertions" }
{ $subsection "implementing-combinators" }
{ $subsection "errors" }
{ $subsection "continuations" } ;
: 2bi@ ( w x y z quot -- )
dup 2bi* ; inline
-: loop ( pred: ( -- ? ) -- )
- dup slip swap [ loop ] [ drop ] if ; inline recursive
-
-: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
- [ dup slip ] 2dip roll
- [ [ tuck 2slip ] dip while ]
- [ 2nip call ] if ; inline recursive
-
! Object protocol
GENERIC: hashcode* ( depth obj -- code )
M: identity-tuple equal? 2drop f ;
+USE: math.private
: = ( obj1 obj2 -- ? )
- 2dup eq? [ 2drop t ] [ equal? ] if ; inline
+ 2dup eq? [ 2drop t ] [
+ 2dup both-fixnums? [ 2drop f ] [ equal? ] if
+ ] if ; inline
GENERIC: clone ( obj -- cloned )
: most ( x y quot -- z )
[ 2dup ] dip call [ drop ] [ nip ] if ; inline
+! Loops
+: loop ( pred: ( -- ? ) -- )
+ dup slip swap [ loop ] [ drop ] if ; inline recursive
+
+: do ( pred body tail -- pred body tail )
+ over 3dip ; inline
+
+: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
+ [ pick 3dip [ do while ] 3curry ] keep if ; inline recursive
+
+: until ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
+ [ [ not ] compose ] 2dip while ; inline
+
! Error handling -- defined early so that other files can
! throw errors before continuations are loaded
: throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ;
M: fixnum bit? neg shift 1 bitand 0 > ;
-: (fixnum-log2) ( accum n -- accum )
- dup 1 number= [ drop ] [ [ 1+ ] [ 2/ ] bi* (fixnum-log2) ] if ;
- inline recursive
+: fixnum-log2 ( x -- n )
+ 0 swap [ dup 1 eq? ] [ [ 1+ ] [ 2/ ] bi* ] [ ] until drop ;
-M: fixnum (log2) 0 swap (fixnum-log2) ;
+M: fixnum (log2) fixnum-log2 ;
M: bignum >fixnum bignum>fixnum ;
M: bignum >bignum ;
M: bignum bitand bignum-bitand ;
M: bignum bitor bignum-bitor ;
M: bignum bitxor bignum-bitxor ;
-M: bignum shift bignum-shift ;
+M: bignum shift >fixnum bignum-shift ;
M: bignum bitnot bignum-bitnot ;
M: bignum bit? bignum-bit? ;
"log2 expects positive inputs" throw
] [
(log2)
- ] if ; foldable
+ ] if ; inline
: zero? ( x -- ? ) 0 number= ; inline
: 1+ ( x -- y ) 1 + ; inline
drop f
] if ;
-: (next-power-of-2) ( i n -- n )
- 2dup >= [
- drop
- ] [
- [ 1 shift ] dip (next-power-of-2)
- ] if ;
-
-: next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable
+: next-power-of-2 ( m -- n )
+ dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; inline
: power-of-2? ( n -- ? )
dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable
USING: generic kernel kernel.private math memory prettyprint io
sequences tools.test words namespaces layouts classes
-classes.builtin arrays quotations ;
+classes.builtin arrays quotations io.launcher system ;
IN: memory.tests
+! LOL
+[ ] [
+ vm
+ "-generations=2"
+ "-e=USING: memory io prettyprint system ; input-stream gc . 0 exit"
+ 3array try-process
+] unit-test
+
[ [ ] instances ] must-infer
! Code GC wasn't kicking in when needed
IN: memory
: (each-object) ( quot: ( obj -- ) -- )
- [ next-object dup ] swap [ drop ] while ; inline
+ next-object dup [
+ swap [ call ] keep (each-object)
+ ] [ 2drop ] if ; inline recursive
: each-object ( quot -- )
begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline
PRIVATE>
-: namespace ( -- namespace ) namestack* peek ;
+: namespace ( -- namespace ) namestack* peek ; inline
: namestack ( -- namestack ) namestack* clone ;
: set-namestack ( namestack -- ) >vector 0 setenv ;
: global ( -- g ) 21 getenv { hashtable } declare ; inline
: init-namespaces ( -- ) global 1array set-namestack ;
-: get ( variable -- value ) namestack* assoc-stack ; flushable
+: get ( variable -- value ) namestack* assoc-stack ; inline
: set ( value variable -- ) namespace set-at ;
: on ( variable -- ) t swap set ; inline
: off ( variable -- ) f swap set ; inline
: inc ( variable -- ) 1 swap +@ ; inline
: dec ( variable -- ) -1 swap +@ ; inline
: bind ( ns quot -- ) swap >n call ndrop ; inline
-: counter ( variable -- n ) global [ dup inc get ] bind ;
+: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ;
: make-assoc ( quot exemplar -- hash )
20 swap new-assoc [ >n call ndrop ] keep ; inline
vocabs.loader accessors eval combinators lexer ;
IN: parser.tests
+\ run-file must-infer
+
[
[ 1 [ 2 [ 3 ] 4 ] 5 ]
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ]
] times
[ "resource:core/parser/test/assert-depth.factor" run-file ]
-[ stack>> { 1 2 3 } sequence= ]
+[ got>> { 1 2 3 } sequence= ]
must-fail-with
2 [
: word-restarts ( name possibilities -- restarts )
natural-sort
- [ [ "Use the " swap vocabulary>> " vocabulary" 3append ] keep ] { } map>assoc
+ [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc
swap "Defer word in current vocabulary" swap 2array
suffix ;
dup vocabulary>>
[ (use+) ]
[ amended-use get dup [ push ] [ 2drop ] if ]
- [ "Added ``" swap "'' vocabulary to search path" 3append note. ]
+ [ "Added ``" "'' vocabulary to search path" surround note. ]
tri
] [ create-in ] if ;
] with-compilation-unit ;
: parse-file-restarts ( file -- restarts )
- "Load " swap " again" 3append t 2array 1array ;
+ "Load " " again" surround t 2array 1array ;
: parse-file ( file -- quot )
[
] recover ;
: run-file ( file -- )
- [ dup parse-file call ] assert-depth drop ;
+ [ parse-file call ] curry assert-depth ;
: ?run-file ( path -- )
dup exists? [ run-file ] [ drop ] if ;
{ $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." }
{ $example "USING: io sequences ;" "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ;
-HELP: cache-nth
-{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( i -- elt )" } } { "elt" object } }
-{ $description "If the sequence does not contain at least " { $snippet "i" } " elements or if the " { $snippet "i" } "th element of the sequence is " { $link f } ", calls the quotation to produce a new value, and stores it back into the sequence. Otherwise, this word outputs the " { $snippet "i" } "th element of the sequence." }
-{ $side-effects "seq" } ;
-
HELP: index
{ $values { "obj" object } { "seq" sequence } { "n" "an index" } }
{ $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs " { $link f } "." } ;
"Changing elements:"
{ $subsection change-each }
{ $subsection change-nth }
-{ $subsection cache-nth }
"Deleting elements:"
{ $subsection delete }
{ $subsection delq }
[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] bi@ ] unit-test
-[ 1 4 9 16 16 V{ f 1 4 9 16 } ] [
- V{ } clone "cache-test" set
- 1 "cache-test" get [ sq ] cache-nth
- 2 "cache-test" get [ sq ] cache-nth
- 3 "cache-test" get [ sq ] cache-nth
- 4 "cache-test" get [ sq ] cache-nth
- 4 "cache-test" get [ "wrong" ] cache-nth
- "cache-test" get
-] unit-test
-
[ 1 ] [ 0.5 { 1 2 3 } nth ] unit-test
! Pathological case
: harvest ( seq -- newseq )
[ empty? not ] filter ;
-: cache-nth ( i seq quot -- elt )
- 2over ?nth dup [
- [ 3drop ] dip
- ] [
- drop swap [ over [ call dup ] dip ] dip set-nth
- ] if ; inline
-
: mismatch ( seq1 seq2 -- i )
[ min-length ] 2keep
[ 2nth-unsafe = not ] 2curry
: supremum ( seq -- n ) dup first [ max ] reduce ;
-: flip ( matrix -- newmatrix )
- dup empty? [
- dup [ length ] map infimum
- swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as
- ] unless ;
-
: sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline
: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
+
+! We hand-optimize flip to such a degree because type hints
+! cannot express that an array is an array of arrays yet, and
+! this word happens to be performance-critical since the compiler
+! itself uses it. Optimizing it like this reduced compile time.
+<PRIVATE
+
+: generic-flip ( matrix -- newmatrix )
+ [ dup first length [ length min ] reduce ] keep
+ [ [ nth-unsafe ] with { } map-as ] curry { } map-as ; inline
+
+USE: arrays
+
+: array-length ( array -- len )
+ { array } declare length>> ;
+
+: array-flip ( matrix -- newmatrix )
+ [ dup first array-length [ array-length min ] reduce ] keep
+ [ [ array-nth ] with { } map-as ] curry { } map-as ;
+
+PRIVATE>
+
+: flip ( matrix -- newmatrix )
+ dup empty? [
+ dup array? [
+ dup [ array? ] all?
+ [ array-flip ] [ generic-flip ] if
+ ] [ generic-flip ] if
+ ] unless ;
define-typecheck ;
: writer-word ( name -- word )
- "(>>" swap ")" 3append (( value object -- )) create-accessor
+ "(>>" ")" surround (( value object -- )) create-accessor
dup t "writer" set-word-prop ;
ERROR: bad-slot-value value class ;
swap
peel-off-name
peel-off-class
- [ dup empty? not ] [ peel-off-attributes ] [ ] while drop
+ [ dup empty? ] [ peel-off-attributes ] [ ] until drop
check-initial-value ;
M: slot-spec make-slot
SYMBOL: file
-TUPLE: source-file-error file error ;
+TUPLE: source-file-error error file ;
: <source-file-error> ( msg -- error )
\ source-file-error new
--- /dev/null
+IN: strings.parser.tests
+USING: strings.parser tools.test ;
+
+[ "Hello\n\rworld" ] [ "Hello\\n\\rworld" unescape-string ] unit-test
lexer get [
[ swap tail-slice (parse-string) ] "" make swap
] change-lexer-column ;
+
+: (unescape-string) ( str -- str' )
+ dup [ CHAR: \\ = ] find [
+ cut-slice [ % ] dip rest-slice
+ next-escape [ , ] dip
+ (unescape-string)
+ ] [
+ drop %
+ ] if ;
+
+: unescape-string ( str -- str' )
+ [ (unescape-string) ] "" make ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien arrays byte-arrays byte-vectors
-definitions generic hashtables kernel math namespaces parser
-lexer sequences strings strings.parser sbufs vectors
-words quotations io assocs splitting classes.tuple
-generic.standard generic.math generic.parser classes io.files
-vocabs classes.parser classes.union
-classes.intersection classes.mixin classes.predicate
-classes.singleton classes.tuple.parser compiler.units
-combinators effects.parser slots ;
+USING: accessors alien arrays byte-arrays definitions generic
+hashtables kernel math namespaces parser lexer sequences strings
+strings.parser sbufs vectors words quotations io assocs
+splitting classes.tuple generic.standard generic.math
+generic.parser classes io.files vocabs classes.parser
+classes.union classes.intersection classes.mixin
+classes.predicate classes.singleton classes.tuple.parser
+compiler.units combinators effects.parser slots ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
"{" [ \ } [ >array ] parse-literal ] define-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
- "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
"T{" [ parse-tuple-literal parsed ] define-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
{ underlying array }
{ length array-capacity } ;
-: <vector> ( n -- vector )
f <array> 0 vector boa ; inline
+: <vector> ( n -- vector )
0 <array> 0 vector boa ; inline
: >vector ( seq -- vector ) V{ } clone-like ;
[ ] [ [ "vocabs.loader.test.e" forget-vocab ] with-compilation-unit ] unit-test
-[ "vocabs.loader.test.e" require ]
-[ relative-overflow? ] must-fail-with
-
0 "vocabs.loader.test.g" set-global
[
] with-compilation-unit
[ ] [ "vocabs.loader.test.h" require ] unit-test
+
+
+[
+ "vocabs.loader.test.j" forget-vocab
+ "vocabs.loader.test.k" forget-vocab
+] with-compilation-unit
+
+[ ] [ [ "vocabs.loader.test.j" require ] [ drop :1 ] recover ] unit-test
[
+parsing+ >>source-loaded?
dup vocab-source-path [ parse-file ] [ [ ] ] if*
+ [ +parsing+ >>source-loaded? ] dip
[ % ] [ assert-depth ] if-bootstrapping
+done+ >>source-loaded? drop
] [ ] [ f >>source-loaded? ] cleanup ;
--- /dev/null
+IN: vocabs.loader.test.j
+"vocabs.loader.test.k" require
--- /dev/null
+unportable
--- /dev/null
+IN: vocabs.loader.test.k
+USE: vocabs.loader.test.j
--- /dev/null
+unportable
dup [ 2nip ] [ drop <word> dup reveal ] if ;
: constructor-word ( name vocab -- word )
- [ "<" swap ">" 3append ] dip create ;
+ [ "<" ">" surround ] dip create ;
PREDICATE: parsing-word < word "parsing" word-prop ;
-USING: kernel parser lexer locals.private ;
+USING: kernel parser lexer locals.parser locals.types ;
IN: bind-in
USING: arrays bunny.model bunny.cel-shaded continuations
destructors kernel math multiline opengl opengl.shaders
-opengl.framebuffers opengl.gl opengl.demo-support
-opengl.capabilities sequences ui.gadgets combinators accessors ;
+opengl.framebuffers opengl.gl opengl.demo-support fry
+opengl.capabilities sequences ui.gadgets combinators accessors
+macros ;
IN: bunny.outlined
STRING: outlined-pass1-fragment-shader-main-source
} cleave
] [ drop ] if ;
+MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- )
+ '[ _ _ (framebuffer-texture) [ @ drop ] keep ] ;
+
+: (make-framebuffer-textures) ( draw dim -- draw color normal depth )
+ {
+ [ drop ]
+ [ GL_RGBA16F_ARB GL_RGBA [ >>color-texture ] (framebuffer-texture>>draw) ]
+ [ GL_RGBA16F_ARB GL_RGBA [ >>normal-texture ] (framebuffer-texture>>draw) ]
+ [
+ GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT
+ [ >>depth-texture ] (framebuffer-texture>>draw)
+ ]
+ } 2cleave ;
+
+: remake-framebuffer ( draw -- )
+ [ dispose-framebuffer ]
+ [ dup gadget>> dim>>
+ [ (make-framebuffer-textures) (make-framebuffer) >>framebuffer ]
+ [ >>framebuffer-dim drop ] bi
+ ] bi ;
+
: remake-framebuffer-if-needed ( draw -- )
dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi =
- [ drop ] [
- [ dispose-framebuffer ] [ dup ] [ gadget>> dim>> ] tri {
- [
- GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
- [ >>color-texture drop ] keep
- ] [
- GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
- [ >>normal-texture drop ] keep
- ] [
- GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture)
- [ >>depth-texture drop ] keep
- ]
- } 2cleave
- [ (make-framebuffer) >>framebuffer ] [ >>framebuffer-dim ] bi
- drop
- ] if ;
+ [ drop ] [ remake-framebuffer ] if ;
: clear-framebuffer ( -- )
GL_COLOR_ATTACHMENT0_EXT glDrawBuffer
[ { "foo" "xbarx" } ]
[
- { "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call
+ { "oof" "bar" } { [ reverse ] [ "x" dup surround ] } parallel-call
] unit-test
{ 1 1 } [
[ dip ] curry swap 1quotation [ keep ] curry compose
] { } assoc>map concat compose ;
-: either ( object first second -- ? )
- >r keep swap [ r> drop ] [ r> call ] ?if ; inline
-
: 2quot-with ( obj seq quot1 quot2 -- seq quot1 quot2 )
>r pick >r with r> r> swapd with ;
-: or? ( obj quot1 quot2 -- ? )
- [ keep ] dip rot [ 2nip ] [ call ] if* ; inline
-
-: and? ( obj quot1 quot2 -- ? )
- [ keep ] dip rot [ call ] [ 2drop f ] if ; inline
-
MACRO: multikeep ( word out-indexes -- ... )
[
dup >r [ \ npick \ >r 3array % ] each
-! Copyright (C) 2008 DoDoug Coleman.
+! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: crypto.barrett kernel math namespaces tools.test ;
IN: crypto.barrett.tests
#! size = word size in bits (8, 16, 32, 64, ...)
[ [ log2 1+ ] [ / 2 * ] bi* ]
[ 2^ rot ^ swap /i ] 2bi ;
-
-
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators checksums checksums.md5
checksums.sha1 checksums.md5.private io io.binary io.files
io.streams.byte-array kernel math math.vectors memoize sequences
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel math threads system calendar ;
IN: crypto.timing
ERROR: empty-xor-key ;
: xor-crypt ( seq key -- seq' )
- dup empty? [ empty-xor-key ] when
+ [ empty-xor-key ] when-empty
[ dup length ] dip '[ _ mod-nth bitxor ] 2map ;
-USING: words kernel sequences locals\r
-locals.private accessors parser namespaces continuations\r
+USING: words kernel sequences locals locals.parser\r
+locals.definitions accessors parser namespaces continuations\r
summary definitions generalizations arrays ;\r
IN: descriptive\r
\r
--- /dev/null
+Jose Antonio Ortega Ruiz
+Eduardo Cavazos
--- /dev/null
+! Copyright (C) 2008 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test fuel ;
+IN: fuel.tests
--- /dev/null
+! Copyright (C) 2008 Jose Antonio Ortega Ruiz.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors arrays classes classes.tuple compiler.units
+combinators continuations debugger definitions eval help
+io io.files io.streams.string kernel lexer listener listener.private
+make math namespaces parser prettyprint prettyprint.config
+quotations sequences strings source-files vectors vocabs.loader ;
+
+IN: fuel
+
+! Evaluation status:
+
+TUPLE: fuel-status in use ds? restarts ;
+
+SYMBOL: fuel-status-stack
+V{ } clone fuel-status-stack set-global
+
+SYMBOL: fuel-eval-result
+f clone fuel-eval-result set-global
+
+SYMBOL: fuel-eval-output
+f clone fuel-eval-result set-global
+
+SYMBOL: fuel-eval-res-flag
+t clone fuel-eval-res-flag set-global
+
+: fuel-eval-restartable? ( -- ? )
+ fuel-eval-res-flag get-global ; inline
+
+: fuel-eval-restartable ( -- )
+ t fuel-eval-res-flag set-global ; inline
+
+: fuel-eval-non-restartable ( -- )
+ f fuel-eval-res-flag set-global ; inline
+
+: push-fuel-status ( -- )
+ in get use get clone display-stacks? get restarts get-global clone
+ fuel-status boa
+ fuel-status-stack get push ;
+
+: pop-fuel-status ( -- )
+ fuel-status-stack get empty? [
+ fuel-status-stack get pop {
+ [ in>> in set ]
+ [ use>> clone use set ]
+ [ ds?>> display-stacks? swap [ on ] [ off ] if ]
+ [
+ restarts>> fuel-eval-restartable? [ drop ] [
+ clone restarts set-global
+ ] if
+ ]
+ } cleave
+ ] unless ;
+
+
+! Lispy pretty printing
+
+GENERIC: fuel-pprint ( obj -- )
+
+M: object fuel-pprint pprint ; inline
+
+M: f fuel-pprint drop "nil" write ; inline
+
+M: integer fuel-pprint pprint ; inline
+
+M: string fuel-pprint pprint ; inline
+
+M: sequence fuel-pprint
+ dup empty? [ drop f fuel-pprint ] [
+ "(" write
+ [ " " write ] [ fuel-pprint ] interleave
+ ")" write
+ ] if ;
+
+M: tuple fuel-pprint tuple>array fuel-pprint ; inline
+
+M: continuation fuel-pprint drop ":continuation" write ; inline
+
+M: restart fuel-pprint name>> fuel-pprint ; inline
+
+SYMBOL: :restarts
+
+: fuel-restarts ( obj -- seq )
+ compute-restarts :restarts prefix ; inline
+
+M: condition fuel-pprint
+ [ error>> ] [ fuel-restarts ] bi 2array condition prefix fuel-pprint ;
+
+M: source-file-error fuel-pprint
+ [ file>> ] [ error>> ] bi 2array source-file-error prefix
+ fuel-pprint ;
+
+M: source-file fuel-pprint path>> fuel-pprint ;
+
+! Evaluation vocabulary
+
+: fuel-eval-set-result ( obj -- )
+ clone fuel-eval-result set-global ; inline
+
+: fuel-retort ( -- )
+ error get
+ fuel-eval-result get-global
+ fuel-eval-output get-global
+ 3array fuel-pprint ;
+
+: fuel-forget-error ( -- ) f error set-global ; inline
+: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline
+: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline
+
+: (fuel-begin-eval) ( -- )
+ push-fuel-status
+ display-stacks? off
+ fuel-forget-error
+ fuel-forget-result
+ fuel-forget-output ;
+
+: (fuel-end-eval) ( quot -- )
+ with-string-writer fuel-eval-output set-global
+ fuel-retort pop-fuel-status ; inline
+
+: (fuel-eval) ( lines -- )
+ [ [ parse-lines ] with-compilation-unit call ] curry
+ [ print-error ] recover ; inline
+
+: (fuel-eval-each) ( lines -- )
+ [ 1vector (fuel-eval) ] each ; inline
+
+: (fuel-eval-usings) ( usings -- )
+ [ "USING: " prepend " ;" append ] map
+ (fuel-eval-each) fuel-forget-error fuel-forget-output ;
+
+: (fuel-eval-in) ( in -- )
+ [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline
+
+: fuel-eval-in-context ( lines in usings -- )
+ (fuel-begin-eval) [
+ (fuel-eval-usings)
+ (fuel-eval-in)
+ (fuel-eval)
+ ] (fuel-end-eval) ;
+
+: fuel-begin-eval ( in -- )
+ (fuel-begin-eval)
+ (fuel-eval-in)
+ fuel-retort ;
+
+: fuel-eval ( lines -- )
+ (fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ; inline
+
+: fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline
+
+: fuel-get-edit-location ( defspec -- )
+ where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ] when* ;
+
+: fuel-run-file ( path -- ) run-file ; inline
+
+: fuel-startup ( -- ) "listener" run ; inline
+
+MAIN: fuel-startup
-USING: windows.dinput windows.dinput.constants parser
-symbols alien.c-types windows.ole32 namespaces assocs kernel
-arrays vectors windows.kernel32 windows.com windows.dinput
-shuffle windows.user32 windows.messages sequences combinators
+USING: windows.dinput windows.dinput.constants parser symbols
+alien.c-types windows.ole32 namespaces assocs kernel arrays
+vectors windows.kernel32 windows.com windows.dinput shuffle
+windows.user32 windows.messages sequences combinators
math.geometry.rect ui.windows accessors math windows alien
-alien.strings io.encodings.utf16 continuations byte-arrays
-locals game-input.backend.dinput.keys-array ;
+alien.strings io.encodings.utf16 io.encodings.utf16n
+continuations byte-arrays locals
+game-input.backend.dinput.keys-array ;
<< "game-input" (use+) >>
IN: game-input.backend.dinput
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: system ;
-IN: hardware-info.backend
-
-HOOK: cpus os ( -- n )
-HOOK: cpu-mhz os ( -- n )
-HOOK: memory-load os ( -- n )
-HOOK: physical-mem os ( -- n )
-HOOK: available-mem os ( -- n )
-HOOK: total-page-file os ( -- n )
-HOOK: available-page-file os ( -- n )
-HOOK: total-virtual-mem os ( -- n )
-HOOK: available-virtual-mem os ( -- n )
-HOOK: available-virtual-extended-mem os ( -- n )
+++ /dev/null
-USING: alien.syntax kernel math prettyprint io math.parser
-combinators vocabs.loader hardware-info.backend system ;
-IN: hardware-info
-
-: write-unit ( x n str -- )
- [ 2^ /f number>string write bl ] [ write ] bi* ;
-
-: kb ( x -- ) 10 "kB" write-unit ;
-: megs ( x -- ) 20 "MB" write-unit ;
-: gigs ( x -- ) 30 "GB" write-unit ;
-: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
-
-<< {
- { [ os windows? ] [ "hardware-info.windows" ] }
- { [ os linux? ] [ "hardware-info.linux" ] }
- { [ os macosx? ] [ "hardware-info.macosx" ] }
- [ f ]
-} cond [ require ] when* >>
-
-: hardware-report. ( -- )
- "CPUs: " write cpus number>string write nl
- "CPU Speed: " write cpu-mhz ghz nl
- "Physical RAM: " write physical-mem megs nl ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: unix alien alien.c-types kernel math sequences strings
-io.unix.backend splitting ;
-IN: hardware-info.linux
-
-: (uname) ( buf -- int )
- "int" f "uname" { "char*" } alien-invoke ;
-
-: uname ( -- seq )
- 65536 "char" <c-array> [ (uname) io-error ] keep
- "\0" split harvest [ >string ] map
- 6 "" pad-right ;
-
-: sysname ( -- string ) uname first ;
-: nodename ( -- string ) uname second ;
-: release ( -- string ) uname third ;
-: version ( -- string ) uname fourth ;
-: machine ( -- string ) uname 4 swap nth ;
-: domainname ( -- string ) uname 5 swap nth ;
-
-: kernel-version ( -- seq )
- release ".-" split harvest 5 "" pad-right ;
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: alien alien.c-types alien.strings alien.syntax
-byte-arrays kernel namespaces sequences unix
-hardware-info.backend system io.unix.backend io.encodings.ascii
-;
-IN: hardware-info.macosx
-
-! See /usr/include/sys/sysctl.h for constants
-
-LIBRARY: libc
-FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, void* newp, size_t newlen ) ;
-
-: make-int-array ( seq -- byte-array )
- [ <int> ] map concat ;
-
-: (sysctl-query) ( name namelen oldp oldlenp -- oldp )
- over [ f 0 sysctl io-error ] dip ;
-
-: sysctl-query ( seq n -- byte-array )
- [ [ make-int-array ] [ length ] bi ] dip
- [ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
-
-: sysctl-query-string ( seq -- n )
- 4096 sysctl-query ascii malloc-string ;
-
-: sysctl-query-uint ( seq -- n )
- 4 sysctl-query *uint ;
-
-: sysctl-query-ulonglong ( seq -- n )
- 8 sysctl-query *ulonglong ;
-
-: machine ( -- str ) { 6 1 } sysctl-query-string ;
-: model ( -- str ) { 6 2 } sysctl-query-string ;
-M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ;
-: byte-order ( -- n ) { 6 4 } sysctl-query-uint ;
-M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
-: user-mem ( -- n ) { 6 6 } sysctl-query-uint ;
-: page-size ( -- n ) { 6 7 } sysctl-query-uint ;
-: disknames ( -- n ) { 6 8 } 8 sysctl-query ;
-: diskstats ( -- n ) { 6 9 } 8 sysctl-query ;
-: epoch ( -- n ) { 6 10 } sysctl-query-uint ;
-: floating-point ( -- n ) { 6 11 } sysctl-query-uint ;
-: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
-: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
-: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
-M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
-: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
-: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
-: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;
-: l2-cache-settings ( -- n ) { 6 19 } sysctl-query-uint ;
-: l2-cache-size ( -- n ) { 6 20 } sysctl-query-uint ;
-: l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ;
-: l3-cache-size ( -- n ) { 6 22 } sysctl-query-uint ;
-: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ;
-: mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ;
-: available-cpus ( -- n ) { 6 25 } sysctl-query-uint ;
-
+++ /dev/null
-unportable
+++ /dev/null
-Query the operating system for hardware information in a platform-independent way
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: alien.c-types hardware-info kernel math namespaces
-windows windows.kernel32 hardware-info.backend system ;
-IN: hardware-info.windows.ce
-
-: memory-status ( -- MEMORYSTATUS )
- "MEMORYSTATUS" <c-object>
- "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
- dup GlobalMemoryStatus ;
-
-M: wince cpus ( -- n ) 1 ;
-
-M: wince memory-load ( -- n )
- memory-status MEMORYSTATUS-dwMemoryLoad ;
-
-M: wince physical-mem ( -- n )
- memory-status MEMORYSTATUS-dwTotalPhys ;
-
-M: wince available-mem ( -- n )
- memory-status MEMORYSTATUS-dwAvailPhys ;
-
-M: wince total-page-file ( -- n )
- memory-status MEMORYSTATUS-dwTotalPageFile ;
-
-M: wince available-page-file ( -- n )
- memory-status MEMORYSTATUS-dwAvailPageFile ;
-
-M: wince total-virtual-mem ( -- n )
- memory-status MEMORYSTATUS-dwTotalVirtual ;
-
-M: wince available-virtual-mem ( -- n )
- memory-status MEMORYSTATUS-dwAvailVirtual ;
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: alien alien.c-types alien.strings
-kernel libc math namespaces hardware-info.backend
-hardware-info.windows windows windows.advapi32
-windows.kernel32 system byte-arrays ;
-IN: hardware-info.windows.nt
-
-M: winnt cpus ( -- n )
- system-info SYSTEM_INFO-dwNumberOfProcessors ;
-
-: memory-status ( -- MEMORYSTATUSEX )
- "MEMORYSTATUSEX" <c-object>
- "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength
- dup GlobalMemoryStatusEx win32-error=0/f ;
-
-M: winnt memory-load ( -- n )
- memory-status MEMORYSTATUSEX-dwMemoryLoad ;
-
-M: winnt physical-mem ( -- n )
- memory-status MEMORYSTATUSEX-ullTotalPhys ;
-
-M: winnt available-mem ( -- n )
- memory-status MEMORYSTATUSEX-ullAvailPhys ;
-
-M: winnt total-page-file ( -- n )
- memory-status MEMORYSTATUSEX-ullTotalPageFile ;
-
-M: winnt available-page-file ( -- n )
- memory-status MEMORYSTATUSEX-ullAvailPageFile ;
-
-M: winnt total-virtual-mem ( -- n )
- memory-status MEMORYSTATUSEX-ullTotalVirtual ;
-
-M: winnt available-virtual-mem ( -- n )
- memory-status MEMORYSTATUSEX-ullAvailVirtual ;
-
-: computer-name ( -- string )
- MAX_COMPUTERNAME_LENGTH 1+
- [ <byte-array> dup ] keep <uint>
- GetComputerName win32-error=0/f alien>native-string ;
-
-: username ( -- string )
- UNLEN 1+
- [ <byte-array> dup ] keep <uint>
- GetUserName win32-error=0/f alien>native-string ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-USING: alien alien.c-types kernel libc math namespaces
-windows windows.kernel32 windows.advapi32
-words combinators vocabs.loader hardware-info.backend
-system alien.strings ;
-IN: hardware-info.windows
-
-: system-info ( -- SYSTEM_INFO )
- "SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
-
-: page-size ( -- n )
- system-info SYSTEM_INFO-dwPageSize ;
-
-! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664)
-: processor-type ( -- n )
- system-info SYSTEM_INFO-dwProcessorType ;
-
-! 0 = x86, 6 = Intel Itanium, 9 = x64 (AMD or Intel), 10 = WOW64, 0xffff = Unk
-: processor-architecture ( -- n )
- system-info SYSTEM_INFO-dwOemId HEX: ffff0000 bitand ;
-
-: os-version ( -- os-version )
- "OSVERSIONINFO" <c-object>
- "OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize
- dup GetVersionEx win32-error=0/f ;
-
-: windows-major ( -- n )
- os-version OSVERSIONINFO-dwMajorVersion ;
-
-: windows-minor ( -- n )
- os-version OSVERSIONINFO-dwMinorVersion ;
-
-: windows-build# ( -- n )
- os-version OSVERSIONINFO-dwBuildNumber ;
-
-: windows-platform-id ( -- n )
- os-version OSVERSIONINFO-dwPlatformId ;
-
-: windows-service-pack ( -- string )
- os-version OSVERSIONINFO-szCSDVersion alien>native-string ;
-
-: feature-present? ( n -- ? )
- IsProcessorFeaturePresent zero? not ;
-
-: sse2? ( -- ? )
- PF_XMMI64_INSTRUCTIONS_AVAILABLE feature-present? ;
-
-: sse3? ( -- ? )
- PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ;
-
-: <u16-string-object> ( n -- obj )
- "ushort" <c-array> ;
-
-: get-directory ( word -- str )
- [ MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd ] dip
- execute win32-error=0/f alien>native-string ; inline
-
-: windows-directory ( -- str )
- \ GetWindowsDirectory get-directory ;
-
-: system-directory ( -- str )
- \ GetSystemDirectory get-directory ;
-
-: system-windows-directory ( -- str )
- \ GetSystemWindowsDirectory get-directory ;
-
-<<
-{
- { [ os wince? ] [ "hardware-info.windows.ce" ] }
- { [ os winnt? ] [ "hardware-info.windows.nt" ] }
-} cond require >>
USING: tools.deploy.config ;
H{
- { deploy-unicode? f }
- { deploy-reflection 1 }
- { deploy-word-props? f }
- { deploy-math? f }
{ deploy-name "Hello world (console)" }
- { deploy-word-defs? f }
- { "stop-after-last-window?" t }
+ { deploy-c-types? f }
+ { deploy-word-props? f }
{ deploy-ui? f }
+ { deploy-reflection 1 }
{ deploy-compiler? f }
+ { deploy-unicode? f }
{ deploy-io 2 }
- { deploy-c-types? f }
+ { deploy-word-defs? f }
+ { deploy-threads? f }
+ { "stop-after-last-window?" t }
+ { deploy-math? f }
}
[ ?head drop ] [ ?tail drop ] bi ;
: single-quote ( str -- newstr )
- "'" swap "'" 3append ;
+ "'" dup surround ;
: double-quote ( str -- newstr )
- "\"" swap "\"" 3append ;
+ "\"" dup surround ;
: quote ( str -- newstr )
CHAR: ' over member?
RENAME: _ fry => __
IN: inverse
-TUPLE: fail ;
-: fail ( -- * ) \ fail new throw ;
+ERROR: fail ;
M: fail summary drop "Unification failed" ;
: assure ( ? -- ) [ fail ] unless ;
-: =/fail ( obj1 obj2 -- )
- = assure ;
+: =/fail ( obj1 obj2 -- ) = assure ;
! Inverse of a quotation
pick 1quotation 3array "math-inverse" set-word-prop ;
: define-pop-inverse ( word n quot -- )
- >r dupd "pop-length" set-word-prop r>
+ [ dupd "pop-length" set-word-prop ] dip
"pop-inverse" set-word-prop ;
-TUPLE: no-inverse word ;
-: no-inverse ( word -- * ) \ no-inverse new throw ;
+ERROR: no-inverse word ;
M: no-inverse summary
drop "The word cannot be used in pattern matching" ;
+ERROR: bad-math-inverse ;
+
: next ( revquot -- revquot* first )
- [ "Badly formed math inverse" throw ]
+ [ bad-math-inverse ]
[ unclip-slice ] if-empty ;
: constant-word? ( word -- ? )
stack-effect
- [ out>> length 1 = ] keep
- in>> length 0 = and ;
+ [ out>> length 1 = ]
+ [ in>> empty? ] bi and ;
: assure-constant ( constant -- quot )
- dup word? [ "Badly formed math inverse" throw ] when 1quotation ;
+ dup word? [ bad-math-inverse ] when 1quotation ;
: swap-inverse ( math-inverse revquot -- revquot* quot )
next assure-constant rot second '[ @ swap @ ] ;
: ?word-prop ( word/object name -- value/f )
over word? [ word-prop ] [ 2drop f ] if ;
-: undo-literal ( object -- quot )
- [ =/fail ] curry ;
+: undo-literal ( object -- quot ) [ =/fail ] curry ;
PREDICATE: normal-inverse < word "inverse" word-prop ;
PREDICATE: math-inverse < word "math-inverse" word-prop ;
: enough? ( stack word -- ? )
dup deferred? [ 2drop f ] [
- [ >r length r> 1quotation infer in>> >= ]
+ [ [ length ] dip 1quotation infer in>> >= ]
[ 3drop f ] recover
] if ;
: fold-word ( stack word -- stack )
2dup enough?
- [ 1quotation with-datastack ] [ >r % r> , { } ] if ;
+ [ 1quotation with-datastack ] [ [ % ] dip , { } ] if ;
: fold ( quot -- folded-quot )
[ { } swap [ fold-word ] each % ] [ ] make ;
throw
] recover ;
+ERROR: undefined-inverse ;
+
GENERIC: inverse ( revquot word -- revquot* quot )
M: object inverse undo-literal ;
M: symbol inverse undo-literal ;
-M: word inverse drop "Inverse is undefined" throw ;
+M: word inverse undefined-inverse ;
M: normal-inverse inverse
"inverse" word-prop ;
[ drop swap-inverse ] [ pull-inverse ] if ;
M: pop-inverse inverse
- [ "pop-length" word-prop cut-slice swap >quotation ] keep
- "pop-inverse" word-prop compose call ;
+ [ "pop-length" word-prop cut-slice swap >quotation ]
+ [ "pop-inverse" word-prop ] bi compose call ;
: (undo) ( revquot -- )
[ unclip-slice inverse % (undo) ] unless-empty ;
\ dup [ [ =/fail ] keep ] define-inverse
\ 2dup [ over =/fail over =/fail ] define-inverse
\ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse
-\ pick [ >r pick r> =/fail ] define-inverse
+\ pick [ [ pick ] dip =/fail ] define-inverse
\ tuck [ swapd [ =/fail ] keep ] define-inverse
\ not [ not ] define-inverse
\ sq [ sqrt ] define-inverse
\ sqrt [ sq ] define-inverse
+ERROR: missing-literal ;
+
: assert-literal ( n -- n )
- dup [ word? ] keep symbol? not and
- [ "Literal missing in pattern matching" throw ] when ;
+ dup
+ [ word? ] [ symbol? not ] bi and
+ [ missing-literal ] when ;
\ + [ - ] [ - ] define-math-inverse
\ - [ + ] [ - ] define-math-inverse
\ * [ / ] [ / ] define-math-inverse
\ ? 2 [
[ assert-literal ] bi@
- [ swap >r over = r> swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
+ [ swap [ over = ] dip swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
2curry
] define-pop-inverse
dup wrapper? [ wrapped>> ] when ;
: boa-inverse ( class -- quot )
- [ deconstruct-pred ] keep slot-readers compose ;
+ [ deconstruct-pred ] [ slot-readers ] bi compose ;
\ boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
: recover-fail ( try fail -- )
[ drop call ] [
- >r nip r> dup fail?
+ [ nip ] dip dup fail?
[ drop call ] [ nip throw ] if
] recover ; inline
in>> [ ndrop f ] curry [ recover-fail ] curry ;
: [matches?] ( quot -- undoes?-quot )
- [undo] dup infer [ true-out ] keep false-recover curry ;
+ [undo] dup infer [ true-out ] [ false-recover ] bi curry ;
MACRO: matches? ( quot -- ? ) [matches?] ;
-TUPLE: no-match ;
-: no-match ( -- * ) \ no-match new throw ;
+ERROR: no-match ;
M: no-match summary drop "Fall through in switch" ;
: recover-chain ( seq -- quot )
: [switch] ( quot-alist -- quot )
[ dup quotation? [ [ ] swap 2array ] when ] map
- reverse [ >r [undo] r> compose ] { } assoc>map
+ reverse [ [ [undo] ] dip compose ] { } assoc>map
recover-chain ;
MACRO: switch ( quot-alist -- ) [switch] ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io.files kernel sequences accessors
-dlists deques arrays ;
-IN: io.paths
-
-TUPLE: directory-iterator path bfs queue ;
-
-: qualified-directory ( path -- seq )
- dup directory-files [ append-path ] with map ;
-
-: push-directory ( path iter -- )
- [ qualified-directory ] dip [
- dup queue>> swap bfs>>
- [ push-front ] [ push-back ] if
- ] curry each ;
-
-: <directory-iterator> ( path bfs? -- iterator )
- <dlist> directory-iterator boa
- dup path>> over push-directory ;
-
-: next-file ( iter -- file/f )
- dup queue>> deque-empty? [ drop f ] [
- dup queue>> pop-back dup link-info directory?
- [ over push-directory next-file ] [ nip ] if
- ] if ;
-
-: iterate-directory ( iter quot -- obj )
- over next-file [
- over call
- [ 2drop ] [ iterate-directory ] if
- ] [
- 2drop f
- ] if* ; inline recursive
-
-: find-file ( path bfs? quot -- path/f )
- [ <directory-iterator> ] dip
- [ keep and ] curry iterate-directory ; inline
-
-: each-file ( path bfs? quot -- )
- [ <directory-iterator> ] dip
- [ f ] compose iterate-directory drop ; inline
-
-: find-all-files ( path bfs? quot -- paths )
- [ <directory-iterator> ] dip
- pusher [ [ f ] compose iterate-directory drop ] dip ; inline
-
-: recursive-directory ( path bfs? -- paths )
- [ ] accumulator [ each-file ] dip ;
first2 [ >>who ] [ >>channel ] bi* ;
M: mode >>command-parameters ( mode params -- mode )
- dup length 3 = [
- first3 [ >>name ] [ >>mode ] [ >>parameter ] tri*
- ] [
- first2 [ >>name ] [ >>mode ] bi*
- ] if ;
+ dup length {
+ { 3 [ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* ] }
+ { 2 [ first2 [ >>name ] [ >>mode ] bi* ] }
+ [ drop first >>name dup trailing>> >>mode ]
+ } case ;
PRIVATE>
: copy-message-in ( command irc-message -- command )
{
- [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
[ line>> >>line ]
[ prefix>> >>prefix ]
[ command>> >>command ]
[ trailing>> >>trailing ]
[ timestamp>> >>timestamp ]
+ [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
} cleave ;
PRIVATE>
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels\r
io io.styles namespaces calendar calendar.format models continuations\r
irc.client irc.client.private irc.messages\r
- irc.ui.commandparser irc.ui.load vocabs.loader ;\r
+ irc.ui.commandparser irc.ui.load vocabs.loader classes prettyprint ;\r
\r
RENAME: join sequences => sjoin\r
\r
foreground associate format ;\r
: dark-red T{ rgba f 0.5 0.0 0.0 1 } ;\r
: dark-green T{ rgba f 0.0 0.5 0.0 1 } ;\r
+: dark-blue T{ rgba f 0.0 0.0 0.5 1 } ;\r
\r
: dot-or-parens ( string -- string )\r
[ "." ]\r
drop "* Ping" blue write-color ;\r
\r
M: privmsg write-irc\r
- "<" blue write-color\r
+ "<" dark-blue write-color\r
[ irc-message-sender write ] keep\r
- "> " blue write-color\r
+ "> " dark-blue write-color\r
trailing>> write ;\r
\r
M: notice write-irc\r
- [ type>> blue write-color ] keep\r
- ": " blue write-color\r
+ [ type>> dark-blue write-color ] keep\r
+ ": " dark-blue write-color\r
trailing>> write ;\r
\r
TUPLE: own-message message nick timestamp ;\r
now own-message boa ;\r
\r
M: own-message write-irc\r
- "<" blue write-color\r
+ "<" dark-blue write-color\r
[ nick>> bold font-style associate format ] keep\r
- "> " blue write-color\r
+ "> " dark-blue write-color\r
message>> write ;\r
\r
M: join write-irc\r
" from the channel" dark-red write-color\r
trailing>> dot-or-parens dark-red write-color ;\r
\r
-: full-mode ( message -- mode )\r
- parameters>> rest " " sjoin ;\r
-\r
M: mode write-irc\r
- "* " blue write-color\r
- [ irc-message-sender write ] keep\r
- " has applied mode " blue write-color\r
- [ full-mode write ] keep\r
- " to " blue write-color\r
- channel>> write ;\r
+ "* " dark-blue write-color\r
+ [ name>> write ] keep\r
+ " has applied mode " dark-blue write-color\r
+ [ mode>> write ] keep\r
+ " to " dark-blue write-color\r
+ parameter>> write ;\r
\r
M: nick write-irc\r
- "* " blue write-color\r
+ "* " dark-blue write-color\r
[ irc-message-sender write ] keep\r
" is now known as " blue write-color\r
trailing>> write ;\r
\r
M: unhandled write-irc\r
"UNHANDLED: " write\r
- line>> blue write-color ;\r
+ line>> dark-blue write-color ;\r
\r
M: irc-end write-irc\r
drop "* You have left IRC" dark-red write-color ;\r
drop ;\r
\r
M: irc-message write-irc\r
- drop ; ! catch all unimplemented writes, THIS WILL CHANGE \r
+ "UNIMPLEMENTED" write\r
+ [ class pprint ] keep\r
+ ": " write\r
+ line>> dark-blue write-color ;\r
\r
GENERIC: time-happened ( message -- timestamp )\r
\r
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: io lint kernel math tools.test ;
+IN: lint.tests
+
+! Don't write code like this
+: lint1 ( -- ) [ "hi" print ] [ ] if ; ! when
+
+[ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test
+
+: lint2 ( n -- n' ) 1 + ; ! 1+
+[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
+
+: lint3 dup -rot ; ! tuck
+
+[ { { lint3 { [ dup -rot ] } } } ] [ \ lint3 lint-word ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.accessors arrays assocs
+combinators.short-circuit fry hashtables html.elements io
+kernel math namespaces prettyprint quotations sequences
+sequences.deep sets slots.private vectors vocabs words
+kernel.private ;
+IN: lint
+
+SYMBOL: def-hash
+SYMBOL: def-hash-keys
+
+: set-hash-vector ( val key hash -- )
+ 2dup at -rot [ ?push ] 2dip set-at ;
+
+: more-defs ( hash -- )
+ {
+ { -rot [ swap >r swap r> ] }
+ { -rot [ swap swapd ] }
+ { rot [ >r swap r> swap ] }
+ { rot [ swapd swap ] }
+ { over [ dup swap ] }
+ { tuck [ dup -rot ] }
+ { swapd [ >r swap r> ] }
+ { 2nip [ nip nip ] }
+ { 2drop [ drop drop ] }
+ { 3drop [ drop drop drop ] }
+ { pop* [ pop drop ] }
+ { when [ [ ] if ] }
+ { >boolean [ f = not ] }
+ } swap '[ first2 _ set-hash-vector ] each ;
+
+: accessor-words ( -- seq )
+{
+ alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
+ alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
+ <displaced-alien> alien-unsigned-cell set-alien-signed-cell
+ set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
+ set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
+ set-alien-unsigned-8 set-alien-signed-8
+ alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
+ set-alien-float alien-float
+} ;
+
+: trivial-defs
+ {
+ [ drop ] [ 2array ]
+ [ bitand ]
+
+ [ . ]
+ [ get ]
+ [ t ] [ f ]
+ [ { } ]
+ [ drop f ]
+ [ "cdecl" ]
+ [ first ] [ second ] [ third ] [ fourth ]
+ [ ">" write-html ] [ "/>" write-html ]
+ } ;
+
+! ! Add definitions
+H{ } clone def-hash set-global
+
+all-words [
+ dup def>> dup callable?
+ [ def-hash get-global set-hash-vector ] [ drop ] if
+] each
+
+! ! Remove definitions
+
+! Remove empty word defs
+def-hash get-global [ drop empty? not ] assoc-filter
+
+! Remove constants [ 1 ]
+[ drop { [ length 1 = ] [ first number? ] } 1&& not ] assoc-filter
+
+! Remove words that are their own definition
+[ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
+
+! Remove set-alien-cell, etc.
+[ drop [ accessor-words diff ] keep [ length ] bi@ = ] assoc-filter
+
+! Remove trivial defs
+[ drop trivial-defs member? not ] assoc-filter
+
+! Remove numbers only defs
+[ drop [ number? ] all? not ] assoc-filter
+
+! Remove curry only defs
+[ drop [ \ curry = ] all? not ] assoc-filter
+
+! Remove tag defs
+[
+ drop {
+ [ length 3 = ]
+ [ first \ tag = ] [ second number? ] [ third \ eq? = ]
+ } 1&& not
+] assoc-filter
+
+[
+ drop {
+ [ [ wrapper? ] deep-contains? ]
+ [ [ hashtable? ] deep-contains? ]
+ } 1|| not
+] assoc-filter
+
+! Remove n m shift defs
+[
+ drop dup length 3 = [
+ [ first2 [ number? ] both? ]
+ [ third \ shift = ] bi and not
+ ] [ drop t ] if
+] assoc-filter
+
+! Remove [ n slot ]
+[
+ drop dup length 2 =
+ [ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if
+] assoc-filter
+
+
+dup more-defs
+
+[ def-hash set-global ] [ keys def-hash-keys set-global ] bi
+
+: find-duplicates ( -- seq )
+ def-hash get-global [ nip length 1 > ] assoc-filter ;
+
+GENERIC: lint ( obj -- seq )
+
+M: object lint ( obj -- seq ) drop f ;
+
+: subseq/member? ( subseq/member seq -- ? )
+ { [ start ] [ member? ] } 2|| ;
+
+M: callable lint ( quot -- seq )
+ [ def-hash-keys get-global ] dip '[ _ subseq/member? ] filter ;
+
+M: word lint ( word -- seq )
+ def>> dup callable? [ lint ] [ drop f ] if ;
+
+: word-path. ( word -- )
+ [ vocabulary>> ] [ unparse ] bi ":" glue print ;
+
+: 4bl ( -- ) bl bl bl bl ;
+
+: (lint.) ( pair -- )
+ first2 [ word-path. ] dip [
+ [ 4bl . "-----------------------------------" print ]
+ [ def-hash get-global at [ 4bl word-path. ] each nl ] bi
+ ] each nl nl ;
+
+: lint. ( alist -- ) [ (lint.) ] each ;
+
+GENERIC: run-lint ( obj -- obj )
+
+: (trim-self) ( val key -- obj ? )
+ def-hash get-global at*
+ [ dupd remove empty? not ] [ drop f ] if ;
+
+: trim-self ( seq -- newseq )
+ [ [ (trim-self) ] filter ] assoc-map ;
+
+: filter-symbols ( alist -- alist )
+ [
+ nip first dup def-hash get-global at
+ [ first ] bi@ literalize = not
+ ] assoc-filter ;
+
+M: sequence run-lint ( seq -- seq )
+ [ dup lint ] { } map>assoc trim-self
+ [ second empty? not ] filter filter-symbols ;
+
+M: word run-lint ( word -- seq ) 1array run-lint ;
+
+: lint-all ( -- seq ) all-words run-lint dup lint. ;
+
+: lint-vocab ( vocab -- seq ) words run-lint dup lint. ;
+
+: lint-word ( word -- seq ) 1array run-lint dup lint. ;
--- /dev/null
+Finds potential mistakes in code
--- /dev/null
+John Benediktsson
--- /dev/null
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: help.syntax help.markup kernel assocs sequences quotations ;
+
+IN: math.binpack
+
+HELP: binpack
+{ $values { "assoc" assoc } { "n" "number of bins" } { "bins" "packed bins" } }
+{ $description "Packs the (key, value) pairs into the specified number of bins, using the value as a weight." } ;
+
+HELP: binpack*
+{ $values { "items" sequence } { "n" "number of bins" } { "bins" "packed bins" } }
+{ $description "Packs a sequence of numbers into the specified number of bins." } ;
+
+HELP: binpack!
+{ $values { "items" sequence } { "quot" quotation } { "n" "number of bins" } { "bins" "packed bins" } }
+{ $description "Packs a sequence of items into the specified number of bins, using the quotatino to determine the weight." } ;
+
--- /dev/null
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: kernel tools.test math.binpack ;
+
+[ t ] [ { V{ } } { } 1 binpack = ] unit-test
+
+[ t ] [ { { 3 } { 2 1 } } { 1 2 3 } 2 binpack* = ] unit-test
+
+[ t ] [ { { 1000 } { 100 60 30 7 } { 70 60 40 23 3 } }
+ { 100 23 40 60 1000 30 60 07 70 03 } 3 binpack* = ] unit-test
+
+
--- /dev/null
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: sequences kernel arrays vectors accessors assocs sorting math math.functions ;
+
+IN: math.binpack
+
+: (binpack) ( bins item -- )
+ [ [ values sum ] map ] keep
+ zip sort-keys values first push ;
+
+: binpack ( assoc n -- bins )
+ [ sort-values <reversed> dup length ] dip
+ tuck / ceiling <array> [ <vector> ] map
+ tuck [ (binpack) ] curry each ;
+
+: binpack* ( items n -- bins )
+ [ dup zip ] dip binpack [ keys ] map ;
+
+: binpack! ( items quot n -- bins )
+ [ dupd map zip ] dip binpack [ keys ] map ;
+
--- /dev/null
+Bin-packing algorithms.
-! Copyright (C) 2008 John Benediktsson
+! Copyright (C) 2008 John Benediktsson, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license
-
-USING: help.markup help.syntax ;
-
+USING: help.markup help.syntax math ;
IN: math.finance
HELP: sma
{ $list "MOM[t] = SEQ[t] - SEQ[t-n]" }
} ;
+HELP: biweekly
+{ $values
+ { "x" number }
+ { "y" number }
+}
+{ $description "Divides a number by the number of two week periods in a year." } ;
+
+HELP: daily-360
+{ $values
+ { "x" number }
+ { "y" number }
+}
+{ $description "Divides a number by the number of days in a 360-day year." } ;
+
+HELP: daily-365
+{ $values
+ { "x" number }
+ { "y" number }
+}
+{ $description "Divides a number by the number of days in a 365-day year." } ;
+
+HELP: monthly
+{ $values
+ { "x" number }
+ { "y" number }
+}
+{ $description "Divides a number by the number of months in a year." } ;
+
+HELP: semimonthly
+{ $values
+ { "x" number }
+ { "y" number }
+}
+{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ;
+
+HELP: weekly
+{ $values
+ { "x" number }
+ { "y" number }
+}
+{ $description "Divides a number by the number of weeks in a year." } ;
+
+ARTICLE: "time-period-calculations" "Calculations over periods of time"
+{ $subsection monthly }
+{ $subsection semimonthly }
+{ $subsection biweekly }
+{ $subsection weekly }
+{ $subsection daily-360 }
+{ $subsection daily-365 } ;
+
+ARTICLE: "math.finance" "Financial math"
+"The " { $vocab-link "math.finance" } " vocabulary contains financial calculation words." $nl
+"Calculating payroll over periods of time:"
+{ $subsection "time-period-calculations" } ;
+
+ABOUT: "math.finance"
[ { 1 3 1 } ] [ { 1 3 2 6 3 } 2 momentum ] unit-test
+[ 4+1/6 ] [ 100 semimonthly ] unit-test
-! Copyright (C) 2008 John Benediktsson.
+! Copyright (C) 2008 John Benediktsson, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel grouping sequences shuffle
math math.functions math.statistics math.vectors ;
: momentum ( seq n -- newseq )
[ tail-slice ] 2keep [ dup length ] dip - head-slice v- ;
+: monthly ( x -- y ) 12 / ; inline
+
+: semimonthly ( x -- y ) 24 / ; inline
+
+: biweekly ( x -- y ) 26 / ; inline
+
+: weekly ( x -- y ) 52 / ; inline
+
+: daily-360 ( x -- y ) 360 / ; inline
+
+: daily-365 ( x -- y ) 365 / ; inline
math.vectors vectors ;
IN: math.numerical-integration
-SYMBOL: num-steps 180 num-steps set-global
+SYMBOL: num-steps
+
+180 num-steps set-global
: setup-simpson-range ( from to -- frange )
2dup swap - num-steps get / <range> ;
: generate-simpson-weights ( seq -- seq )
- { 1 4 }
- swap length 2 / 2 - { 2 4 } <repetition> concat
- { 1 } 3append ;
+ length 2 / 2 - { 2 4 } <repetition> concat
+ { 1 4 } { 1 } surround ;
: integrate-simpson ( from to f -- x )
[ setup-simpson-range dup ] dip
-USING: tools.test monads math kernel sequences lists promises ;
+USING: tools.test math kernel sequences lists promises monads ;
IN: monads.tests
[ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences vectors classes classes.algebra
combinators arrays words assocs parser namespaces make
-definitions prettyprint prettyprint.backend quotations
-generalizations debugger io compiler.units kernel.private
-effects accessors hashtables sorting shuffle math.order sets ;
+definitions prettyprint prettyprint.backend prettyprint.custom
+quotations generalizations debugger io compiler.units
+kernel.private effects accessors hashtables sorting shuffle
+math.order sets ;
IN: multi-methods
! PART I: Converting hook specializers
{ 0 [ [ dup ] ] }
{ 1 [ [ over ] ] }
{ 2 [ [ pick ] ] }
- [ 1- picker [ >r ] swap [ r> swap ] 3append ]
+ [ 1- picker [ >r ] [ r> swap ] surround ]
} case ;
: (multi-predicate) ( class picker -- quot )
: FOV 2.0 sqrt 1+ ; inline
: MOUSE-MOTION-SCALE 0.5 ; inline
-: KEY-ROTATE-STEP 1.0 ; inline
+: KEY-ROTATE-STEP 10.0 ; inline
SYMBOL: last-drag-loc
USING: arrays combinators kernel lists math math.parser
-namespaces parser lexer parser-combinators parser-combinators.simple
-promises quotations sequences strings math.order
-assocs prettyprint.backend memoize unicode.case unicode.categories
-combinators.short-circuit accessors make io ;
+namespaces parser lexer parser-combinators
+parser-combinators.simple promises quotations sequences strings
+math.order assocs prettyprint.backend prettyprint.custom memoize
+unicode.case unicode.categories combinators.short-circuit
+accessors make io ;
IN: parser-combinators.regexp
<PRIVATE
"commonly used in markup languages to indicate bold "
"faced text." }
{ $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"*foo*\" 'bold' parse-1 ." "\"foo\"" }
-{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"*foo*\" 'bold' [ \"<strong>\" swap \"</strong>\" 3append ] <@ parse-1 ." "\"<strong>foo</strong>\"" } ;
+{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"*foo*\" 'bold' [ \"<strong>\" \"</strong>\" surround ] <@ parse-1 ." "\"<strong>foo</strong>\"" } ;
HELP: 'italic'
{ $values
"faced text." }
{ $examples
{ $example "USING: parser-combinators parser-combinators.simple prettyprint ;" "\"_foo_\" 'italic' parse-1 ." "\"foo\"" }
-{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"_foo_\" 'italic' [ \"<emphasis>\" swap \"</emphasis>\" 3append ] <@ parse-1 ." "\"<emphasis>foo</emphasis>\"" } } ;
+{ $example "USING: kernel parser-combinators parser-combinators.simple prettyprint sequences ;" "\"_foo_\" 'italic' [ \"<emphasis>\" \"</emphasis>\" surround ] <@ parse-1 ." "\"<emphasis>foo</emphasis>\"" } } ;
HELP: comma-list
{ $values
{ "element" "a parser object" } { "parser" "a parser object" } }
+++ /dev/null
-
-USING: kernel arrays sequences math math.order qualified
- sequences.lib circular processing ui newfx processing.shapes ;
-
-IN: processing.gallery.trails
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Example 33-15 from the Processing book
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: point-list ( n -- seq ) [ drop 0 0 2array ] map <circular> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dot ( pos percent -- ) 1 swap - 25 * 5 max circle ;
-
-: step ( seq -- )
-
- no-stroke
- { 1 0.4 } fill
-
- 0 background
-
- mouse push-circular
- [ dot ]
- each-percent ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: go* ( -- )
-
- 500 500 size*
-
- [
- 100 point-list
- [ step ]
- curry
- draw
- ] setup
-
- run ;
-
-: go ( -- ) [ go* ] with-ui ;
-
-MAIN: go
<PRIVATE
-: short ( seq n -- seq n )
- over length min ;
-
: next ( seq -- )
[ 4 short tail* sum ] keep push ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: start-service ( name -- ) "/etc/init.d/" swap " start" 3append system drop ;
-: stop-service ( name -- ) "/etc/init.d/" swap " stop" 3append system drop ;
+: start-service ( name -- ) "/etc/init.d/" " start" surround system drop ;
+: stop-service ( name -- ) "/etc/init.d/" " stop" surround system drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors assocs math kernel shuffle generalizations\r
words quotations arrays combinators sequences math.vectors\r
-io.styles prettyprint vocabs sorting io generic locals.private\r
-math.statistics math.order combinators.lib ;\r
+io.styles prettyprint vocabs sorting io generic\r
+math.statistics math.order combinators.lib locals.types\r
+locals.definitions ;\r
IN: reports.noise\r
\r
: badness ( word -- n )\r
TUPLE: spheres-gadget < demo-gadget
plane-program solid-sphere-program texture-sphere-program
reflection-framebuffer reflection-depthbuffer
- reflection-texture ;
+ reflection-texture initialized? ;
: <spheres-gadget> ( -- gadget )
20.0 10.0 20.0 spheres-gadget new-demo-gadget ;
(make-reflection-texture) >>reflection-texture
(make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep
(make-reflection-framebuffer) >>reflection-framebuffer
+ t >>initialized?
drop ;
M: spheres-gadget ungraft* ( gadget -- )
+ f >>initialized?
dup find-gl-context
{
[ reflection-framebuffer>> [ delete-framebuffer ] when* ]
] bi ;
: reflection-frustum ( gadget -- -x x -y y near far )
- [ near-plane ] [ far-plane ] bi [
- drop dup [ -+ ] bi@
- ] 2keep ;
+ [ near-plane ] [ far-plane ] bi
+ [ drop dup [ -+ ] bi@ ] 2keep ;
: (reflection-face) ( gadget face -- )
swap reflection-texture>> >r >r
[ dim>> 0 0 rot first2 glViewport ]
} cleave ] with-framebuffer ;
-M: spheres-gadget draw-gadget* ( gadget -- )
+: (draw-gadget) ( gadget -- )
GL_DEPTH_TEST glEnable
GL_SCISSOR_TEST glDisable
0.15 0.15 1.0 1.0 glClearColor {
]
} cleave ;
+M: spheres-gadget draw-gadget* ( gadget -- )
+ dup initialized?>> [ (draw-gadget) ] [ drop ] if ;
+
: spheres-window ( -- )
[ <spheres-gadget> "Spheres" open-window ] with-ui ;
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: system ;
+IN: system-info.backend
+
+HOOK: cpus os ( -- n )
+HOOK: cpu-mhz os ( -- n )
+HOOK: memory-load os ( -- n )
+HOOK: physical-mem os ( -- n )
+HOOK: available-mem os ( -- n )
+HOOK: total-page-file os ( -- n )
+HOOK: available-page-file os ( -- n )
+HOOK: total-virtual-mem os ( -- n )
+HOOK: available-virtual-mem os ( -- n )
+HOOK: available-virtual-extended-mem os ( -- n )
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: unix alien alien.c-types kernel math sequences strings
+io.unix.backend splitting ;
+IN: system-info.linux
+
+: (uname) ( buf -- int )
+ "int" f "uname" { "char*" } alien-invoke ;
+
+: uname ( -- seq )
+ 65536 "char" <c-array> [ (uname) io-error ] keep
+ "\0" split harvest [ >string ] map
+ 6 "" pad-right ;
+
+: sysname ( -- string ) uname first ;
+: nodename ( -- string ) uname second ;
+: release ( -- string ) uname third ;
+: version ( -- string ) uname fourth ;
+: machine ( -- string ) uname 4 swap nth ;
+: domainname ( -- string ) uname 5 swap nth ;
+
+: kernel-version ( -- seq )
+ release ".-" split harvest 5 "" pad-right ;
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings alien.syntax
+byte-arrays kernel namespaces sequences unix
+system-info.backend system io.unix.backend io.encodings.utf8 ;
+IN: system-info.macosx
+
+! See /usr/include/sys/sysctl.h for constants
+
+LIBRARY: libc
+FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, void* newp, size_t newlen ) ;
+
+: make-int-array ( seq -- byte-array )
+ [ <int> ] map concat ;
+
+: (sysctl-query) ( name namelen oldp oldlenp -- oldp )
+ over [ f 0 sysctl io-error ] dip ;
+
+: sysctl-query ( seq n -- byte-array )
+ [ [ make-int-array ] [ length ] bi ] dip
+ [ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
+
+: sysctl-query-string ( seq -- n )
+ 4096 sysctl-query utf8 alien>string ;
+
+: sysctl-query-uint ( seq -- n )
+ 4 sysctl-query *uint ;
+
+: sysctl-query-ulonglong ( seq -- n )
+ 8 sysctl-query *ulonglong ;
+
+: machine ( -- str ) { 6 1 } sysctl-query-string ;
+: model ( -- str ) { 6 2 } sysctl-query-string ;
+M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ;
+: byte-order ( -- n ) { 6 4 } sysctl-query-uint ;
+M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
+: user-mem ( -- n ) { 6 6 } sysctl-query-uint ;
+: page-size ( -- n ) { 6 7 } sysctl-query-uint ;
+: disknames ( -- n ) { 6 8 } 8 sysctl-query ;
+: diskstats ( -- n ) { 6 9 } 8 sysctl-query ;
+: epoch ( -- n ) { 6 10 } sysctl-query-uint ;
+: floating-point ( -- n ) { 6 11 } sysctl-query-uint ;
+: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
+: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
+: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
+M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
+: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
+: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
+: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;
+: l2-cache-settings ( -- n ) { 6 19 } sysctl-query-uint ;
+: l2-cache-size ( -- n ) { 6 20 } sysctl-query-uint ;
+: l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ;
+: l3-cache-size ( -- n ) { 6 22 } sysctl-query-uint ;
+: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ;
+: mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ;
+: available-cpus ( -- n ) { 6 25 } sysctl-query-uint ;
--- /dev/null
+unportable
--- /dev/null
+Query the operating system for hardware information in a platform-independent way
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel math prettyprint io math.parser
+combinators vocabs.loader system-info.backend system ;
+IN: system-info
+
+: write-unit ( x n str -- )
+ [ 2^ /f number>string write bl ] [ write ] bi* ;
+
+: kb ( x -- ) 10 "kB" write-unit ;
+: megs ( x -- ) 20 "MB" write-unit ;
+: gigs ( x -- ) 30 "GB" write-unit ;
+: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
+
+<< {
+ { [ os windows? ] [ "system-info.windows" ] }
+ { [ os linux? ] [ "system-info.linux" ] }
+ { [ os macosx? ] [ "system-info.macosx" ] }
+ [ f ]
+} cond [ require ] when* >>
+
+: system-report. ( -- )
+ "CPUs: " write cpus number>string write nl
+ "CPU Speed: " write cpu-mhz ghz nl
+ "Physical RAM: " write physical-mem megs nl ;
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types system-info kernel math namespaces
+windows windows.kernel32 system-info.backend system ;
+IN: system-info.windows.ce
+
+: memory-status ( -- MEMORYSTATUS )
+ "MEMORYSTATUS" <c-object>
+ "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
+ dup GlobalMemoryStatus ;
+
+M: wince cpus ( -- n ) 1 ;
+
+M: wince memory-load ( -- n )
+ memory-status MEMORYSTATUS-dwMemoryLoad ;
+
+M: wince physical-mem ( -- n )
+ memory-status MEMORYSTATUS-dwTotalPhys ;
+
+M: wince available-mem ( -- n )
+ memory-status MEMORYSTATUS-dwAvailPhys ;
+
+M: wince total-page-file ( -- n )
+ memory-status MEMORYSTATUS-dwTotalPageFile ;
+
+M: wince available-page-file ( -- n )
+ memory-status MEMORYSTATUS-dwAvailPageFile ;
+
+M: wince total-virtual-mem ( -- n )
+ memory-status MEMORYSTATUS-dwTotalVirtual ;
+
+M: wince available-virtual-mem ( -- n )
+ memory-status MEMORYSTATUS-dwAvailVirtual ;
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings
+kernel libc math namespaces system-info.backend
+system-info.windows windows windows.advapi32
+windows.kernel32 system byte-arrays ;
+IN: system-info.windows.nt
+
+M: winnt cpus ( -- n )
+ system-info SYSTEM_INFO-dwNumberOfProcessors ;
+
+: memory-status ( -- MEMORYSTATUSEX )
+ "MEMORYSTATUSEX" <c-object>
+ "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength
+ dup GlobalMemoryStatusEx win32-error=0/f ;
+
+M: winnt memory-load ( -- n )
+ memory-status MEMORYSTATUSEX-dwMemoryLoad ;
+
+M: winnt physical-mem ( -- n )
+ memory-status MEMORYSTATUSEX-ullTotalPhys ;
+
+M: winnt available-mem ( -- n )
+ memory-status MEMORYSTATUSEX-ullAvailPhys ;
+
+M: winnt total-page-file ( -- n )
+ memory-status MEMORYSTATUSEX-ullTotalPageFile ;
+
+M: winnt available-page-file ( -- n )
+ memory-status MEMORYSTATUSEX-ullAvailPageFile ;
+
+M: winnt total-virtual-mem ( -- n )
+ memory-status MEMORYSTATUSEX-ullTotalVirtual ;
+
+M: winnt available-virtual-mem ( -- n )
+ memory-status MEMORYSTATUSEX-ullAvailVirtual ;
+
+: computer-name ( -- string )
+ MAX_COMPUTERNAME_LENGTH 1+
+ [ <byte-array> dup ] keep <uint>
+ GetComputerName win32-error=0/f alien>native-string ;
+
+: username ( -- string )
+ UNLEN 1+
+ [ <byte-array> dup ] keep <uint>
+ GetUserName win32-error=0/f alien>native-string ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types kernel libc math namespaces
+windows windows.kernel32 windows.advapi32
+words combinators vocabs.loader system-info.backend
+system alien.strings ;
+IN: system-info.windows
+
+: system-info ( -- SYSTEM_INFO )
+ "SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
+
+: page-size ( -- n )
+ system-info SYSTEM_INFO-dwPageSize ;
+
+! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664)
+: processor-type ( -- n )
+ system-info SYSTEM_INFO-dwProcessorType ;
+
+! 0 = x86, 6 = Intel Itanium, 9 = x64 (AMD or Intel), 10 = WOW64, 0xffff = Unk
+: processor-architecture ( -- n )
+ system-info SYSTEM_INFO-dwOemId HEX: ffff0000 bitand ;
+
+: os-version ( -- os-version )
+ "OSVERSIONINFO" <c-object>
+ "OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize
+ dup GetVersionEx win32-error=0/f ;
+
+: windows-major ( -- n )
+ os-version OSVERSIONINFO-dwMajorVersion ;
+
+: windows-minor ( -- n )
+ os-version OSVERSIONINFO-dwMinorVersion ;
+
+: windows-build# ( -- n )
+ os-version OSVERSIONINFO-dwBuildNumber ;
+
+: windows-platform-id ( -- n )
+ os-version OSVERSIONINFO-dwPlatformId ;
+
+: windows-service-pack ( -- string )
+ os-version OSVERSIONINFO-szCSDVersion alien>native-string ;
+
+: feature-present? ( n -- ? )
+ IsProcessorFeaturePresent zero? not ;
+
+: sse2? ( -- ? )
+ PF_XMMI64_INSTRUCTIONS_AVAILABLE feature-present? ;
+
+: sse3? ( -- ? )
+ PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ;
+
+: <u16-string-object> ( n -- obj )
+ "ushort" <c-array> ;
+
+: get-directory ( word -- str )
+ [ MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd ] dip
+ execute win32-error=0/f alien>native-string ; inline
+
+: windows-directory ( -- str )
+ \ GetWindowsDirectory get-directory ;
+
+: system-directory ( -- str )
+ \ GetSystemDirectory get-directory ;
+
+: system-windows-directory ( -- str )
+ \ GetSystemWindowsDirectory get-directory ;
+
+<<
+{
+ { [ os wince? ] [ "system-info.windows.ce" ] }
+ { [ os winnt? ] [ "system-info.windows.nt" ] }
+} cond require >>
USING: kernel money tools.test
taxes.usa taxes.usa.federal taxes.usa.mn
-calendar taxes.usa.w4 usa-cities ;
+calendar taxes.usa.w4 usa-cities math.finance ;
IN: taxes.usa.tests
[
--- /dev/null
+John Benediktsson
--- /dev/null
+
+USING: help.syntax help.markup kernel prettyprint sequences strings ;
+
+IN: time
+
+HELP: strftime
+{ $values { "format-string" string } }
+{ $description "Writes the timestamp (specified on the stack) formatted according to the format string." }
+;
+
+ARTICLE: "strftime" "Formatted timestamps"
+"The " { $vocab-link "time" } " vocabulary is used for formatted timestamps.\n"
+{ $subsection strftime }
+"\n"
+"Several format specifications exist for handling arguments of different types, and specifying attributes for the result string, including such things as maximum width, padding, and decimals.\n"
+{ $table
+ { "%a" "Abbreviated weekday name." }
+ { "%A" "Full weekday name." }
+ { "%b" "Abbreviated month name." }
+ { "%B" "Full month name." }
+ { "%c" "Date and time representation." }
+ { "%d" "Day of the month as a decimal number [01,31]." }
+ { "%H" "Hour (24-hour clock) as a decimal number [00,23]." }
+ { "%I" "Hour (12-hour clock) as a decimal number [01,12]." }
+ { "%j" "Day of the year as a decimal number [001,366]." }
+ { "%m" "Month as a decimal number [01,12]." }
+ { "%M" "Minute as a decimal number [00,59]." }
+ { "%p" "Either AM or PM." }
+ { "%S" "Second as a decimal number [00,59]." }
+ { "%U" "Week number of the year (Sunday as the first day of the week) as a decimal number [00,53]." }
+ { "%w" "Weekday as a decimal number [0(Sunday),6]." }
+ { "%W" "Week number of the year (Monday as the first day of the week) as a decimal number [00,53]." }
+ { "%x" "Date representation." }
+ { "%X" "Time representation." }
+ { "%y" "Year without century as a decimal number [00,99]." }
+ { "%Y" "Year with century as a decimal number." }
+ { "%Z" "Time zone name (no characters if no time zone exists)." }
+ { "%%" "A literal '%' character." }
+} ;
+
+ABOUT: "strftime"
+
+
--- /dev/null
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: kernel time tools.test calendar ;
+
+IN: time.tests
+
+[ "%H:%M:%S" strftime ] must-infer
+
+: testtime ( -- timestamp )
+ 2008 10 9 12 3 15 instant <timestamp> ;
+
+[ t ] [ "12:03:15" testtime "%H:%M:%S" strftime = ] unit-test
+[ t ] [ "12:03:15" testtime "%X" strftime = ] unit-test
+
+[ t ] [ "10/09/2008" testtime "%m/%d/%Y" strftime = ] unit-test
+[ t ] [ "10/09/2008" testtime "%x" strftime = ] unit-test
+
+[ t ] [ "Thu" testtime "%a" strftime = ] unit-test
+[ t ] [ "Thursday" testtime "%A" strftime = ] unit-test
+
+[ t ] [ "Oct" testtime "%b" strftime = ] unit-test
+[ t ] [ "October" testtime "%B" strftime = ] unit-test
+
--- /dev/null
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors arrays calendar io kernel fry macros math
+math.functions math.parser peg.ebnf sequences strings vectors ;
+
+IN: time
+
+: >timestring ( timestamp -- string )
+ [ hour>> ] keep [ minute>> ] keep second>> 3array
+ [ number>string 2 CHAR: 0 pad-left ] map ":" join ; inline
+
+: >datestring ( timestamp -- string )
+ [ month>> ] keep [ day>> ] keep year>> 3array
+ [ number>string 2 CHAR: 0 pad-left ] map "/" join ; inline
+
+: (week-of-year) ( timestamp day -- n )
+ [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
+ [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ;
+
+: week-of-year-sunday ( timestamp -- n ) 0 (week-of-year) ; inline
+
+: week-of-year-monday ( timestamp -- n ) 1 (week-of-year) ; inline
+
+
+<PRIVATE
+
+EBNF: parse-format-string
+
+fmt-% = "%" => [[ [ "%" ] ]]
+fmt-a = "a" => [[ [ dup day-of-week day-abbreviation3 ] ]]
+fmt-A = "A" => [[ [ dup day-of-week day-name ] ]]
+fmt-b = "b" => [[ [ dup month>> month-abbreviation ] ]]
+fmt-B = "B" => [[ [ dup month>> month-name ] ]]
+fmt-c = "c" => [[ [ "Not yet implemented" throw ] ]]
+fmt-d = "d" => [[ [ dup day>> number>string 2 CHAR: 0 pad-left ] ]]
+fmt-H = "H" => [[ [ dup hour>> number>string 2 CHAR: 0 pad-left ] ]]
+fmt-I = "I" => [[ [ dup hour>> 12 > [ 12 - ] when number>string 2 CHAR: 0 pad-left ] ]]
+fmt-j = "j" => [[ [ dup day-of-year number>string ] ]]
+fmt-m = "m" => [[ [ dup month>> number>string 2 CHAR: 0 pad-left ] ]]
+fmt-M = "M" => [[ [ dup minute>> number>string 2 CHAR: 0 pad-left ] ]]
+fmt-p = "p" => [[ [ dup hour>> 12 < [ "AM" ] [ "PM" ] ? ] ]]
+fmt-S = "S" => [[ [ dup second>> round number>string 2 CHAR: 0 pad-left ] ]]
+fmt-U = "U" => [[ [ dup week-of-year-sunday ] ]]
+fmt-w = "w" => [[ [ dup day-of-week number>string ] ]]
+fmt-W = "W" => [[ [ dup week-of-year-monday ] ]]
+fmt-x = "x" => [[ [ dup >datestring ] ]]
+fmt-X = "X" => [[ [ dup >timestring ] ]]
+fmt-y = "y" => [[ [ dup year>> 100 mod number>string ] ]]
+fmt-Y = "Y" => [[ [ dup year>> number>string ] ]]
+fmt-Z = "Z" => [[ [ "Not yet implemented" throw ] ]]
+unknown = (.)* => [[ "Unknown directive" throw ]]
+
+formats_ = fmt-%|fmt-a|fmt-A|fmt-b|fmt-B|fmt-c|fmt-d|fmt-H|fmt-I|
+ fmt-j|fmt-m|fmt-M|fmt-p|fmt-S|fmt-U|fmt-w|fmt-W|fmt-x|
+ fmt-X|fmt-y|fmt-Y|fmt-Z|unknown
+
+formats = "%" (formats_) => [[ second '[ _ dip ] ]]
+
+plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
+
+text = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]]
+
+;EBNF
+
+PRIVATE>
+
+MACRO: strftime ( format-string -- )
+ parse-format-string [ length ] keep [ ] join
+ '[ _ <vector> @ reverse concat nip ] ;
+
+
--- /dev/null
+
+USING: kernel accessors locals namespaces sequences sequences.lib threads
+ math math.order math.vectors
+ calendar
+ colors opengl ui ui.gadgets ui.gestures ui.render
+ circular
+ processing.shapes ;
+
+IN: trails
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Example 33-15 from the Processing book
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Return the mouse location relative to the current gadget
+
+: mouse ( -- point ) hand-loc get hand-gadget get screen-loc v- ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: point-list ( n -- seq ) [ drop { 0 0 } ] map <circular> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: percent->radius ( percent -- radius ) neg 1 + 25 * 5 max ;
+
+: dot ( pos percent -- ) percent->radius circle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <trails-gadget> < gadget paused points ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: iterate-system ( GADGET -- )
+
+ ! Add a valid point if the mouse is in the gadget
+ ! Otherwise, add an "invisible" point
+
+ hand-gadget get GADGET =
+ [ mouse GADGET points>> push-circular ]
+ [ { -10 -10 } GADGET points>> push-circular ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-trails-thread ( GADGET -- )
+ GADGET f >>paused drop
+ [
+ [
+ GADGET paused>>
+ [ f ]
+ [ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
+ if
+ ]
+ loop
+ ]
+ in-thread ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: <trails-gadget> pref-dim* ( <trails-gadget> -- dim ) drop { 500 500 } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M:: <trails-gadget> draw-gadget* ( GADGET -- )
+ origin get
+ [
+ T{ rgba f 1 1 1 0.4 } \ fill-color set ! White, with some transparency
+ T{ rgba f 0 0 0 0 } \ stroke-color set ! no stroke
+
+ black gl-clear
+
+ GADGET points>> [ dot ] each-percent
+ ]
+ with-translation ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: trails-gadget ( -- <trails-gadget> )
+
+ <trails-gadget> new-gadget
+
+ 300 point-list >>points
+
+ t >>clipped?
+
+ dup start-trails-thread ;
+
+: trails-window ( -- ) [ trails-gadget "Trails" open-window ] with-ui ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: trails-window
\ No newline at end of file
[ list-revisions ] >>entries ;
: rollback-description ( description -- description' )
- [ "Rollback of '" swap "'" 3append ] [ "Rollback" ] if* ;
+ [ "Rollback of '" "'" surround ] [ "Rollback" ] if* ;
: <rollback-action> ( -- action )
<action>
--- /dev/null
+FUEL, Factor's Ultimate Emacs Library
+-------------------------------------
+
+FUEL provides a complete environment for your Factor coding pleasure
+inside Emacs, including source code edition and interaction with a
+Factor listener instance running within Emacs.
+
+FUEL was started by Jose A Ortega as an extension to Ed Cavazos'
+original factor.el code.
+
+Installation
+------------
+
+FUEL comes bundled with Factor's distribution. The folder misc/fuel
+contains Elisp code, and there's a fuel vocabulary in extras/fuel.
+
+To install FUEL, either add this line to your Emacs initialisation:
+
+ (load-file "<path/to/factor/installation>/misc/fuel/fu.el")
+
+or
+
+ (add-to-list load-path "<path/to/factor/installation>/fuel")
+ (require 'fuel)
+
+If all you want is a major mode for editing Factor code with pretty
+font colors and indentation, without running the factor listener
+inside Emacs, you can use instead:
+
+ (add-to-list load-path "<path/to/factor/installation>/fuel")
+ (setq factor-mode-use-fuel nil)
+ (require 'factor-mode)
+
+Basic usage
+-----------
+
+If you're using the default factor binary and images locations inside
+the Factor's source tree, that should be enough to start using FUEL.
+Editing any file with the extension .factor will put you in
+factor-mode; try C-hm for a summary of available commands.
+
+To start the listener, try M-x run-factor.
+
+Many aspects of the environment can be customized:
+M-x customize-group fuel will show you how many.
+
+Quick key reference
+-------------------
+
+(Chords ending in a single letter <x> accept also C-<x> (e.g. C-cC-z is
+the same as C-cz)).
+
+* In factor files:
+
+ - C-cz : switch to listener
+ - C-co : cycle between code, tests and docs factor files
+
+ - M-. : edit word at point in Emacs (also in listener)
+
+ - C-cr, C-cC-er : eval region
+ - C-M-r, C-cC-ee : eval region, extending it to definition boundaries
+ - C-M-x, C-cC-ex : eval definition around point
+ - C-ck, C-cC-ek : compile file
+
+ - C-cC-da : toggle autodoc mode
+ - C-cC-dd : help for word at point
+ - C-cC-ds : short help word at point
+
+* In the debugger (it pops up upon eval/compilation errors):
+
+ - g : go to error
+ - <digit> : invoke nth restart
+ - q : bury buffer
+
+
--- /dev/null
+;;; factor-mode.el -- mode for editing Factor source
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages, fuel, factor
+;; Start date: Tue Dec 02, 2008 21:32
+
+;;; Comentary:
+
+;; Definition of factor-mode, a major Emacs for editing Factor source
+;; code.
+
+;;; Code:
+
+(require 'fuel-base)
+(require 'fuel-syntax)
+(require 'fuel-font-lock)
+
+(require 'ring)
+
+\f
+;;; Customization:
+
+(defgroup factor-mode nil
+ "Major mode for Factor source code"
+ :group 'fuel)
+
+(defcustom factor-mode-use-fuel t
+ "Whether to use the full FUEL facilities in factor mode.
+
+Set this variable to nil if you just want to use Emacs as the
+external editor of your Factor environment, e.g., by putting
+these lines in your .emacs:
+
+ (add-to-list 'load-path \"/path/to/factor/misc/fuel\")
+ (setq factor-mode-use-fuel nil)
+ (require 'factor-mode)
+"
+ :type 'boolean
+ :group 'factor-mode)
+
+(defcustom factor-mode-default-indent-width 4
+ "Default indentation width for factor-mode.
+
+This value will be used for the local variable
+`factor-mode-indent-width' in new factor buffers. For existing
+code, we first check if `factor-mode-indent-width' is set
+explicitly in a local variable section or line (e.g.
+'! -*- factor-mode-indent-witdth: 2 -*-'). If that's not the case,
+`factor-mode' tries to infer its correct value from the existing
+code in the buffer."
+ :type 'integer
+ :group 'fuel)
+
+(defcustom factor-mode-hook nil
+ "Hook run when entering Factor mode."
+ :type 'hook
+ :group 'factor-mode)
+
+\f
+;;; Faces:
+
+(fuel-font-lock--define-faces
+ factor-font-lock font-lock factor-mode
+ ((comment comment "comments")
+ (constructor type "constructors (<foo>)")
+ (declaration keyword "declaration words")
+ (parsing-word keyword "parsing words")
+ (setter-word function-name "setter words (>>foo)")
+ (stack-effect comment "stack effect specifications")
+ (string string "strings")
+ (symbol variable-name "name of symbol being defined")
+ (type-name type "type names")
+ (vocabulary-name constant "vocabulary names")
+ (word function-name "word, generic or method being defined")))
+
+\f
+;;; Syntax table:
+
+(defun factor-mode--syntax-setup ()
+ (set-syntax-table fuel-syntax--syntax-table)
+ (set (make-local-variable 'beginning-of-defun-function)
+ 'fuel-syntax--beginning-of-defun)
+ (set (make-local-variable 'end-of-defun-function) 'fuel-syntax--end-of-defun)
+ (set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil)
+ (fuel-syntax--enable-usings))
+
+\f
+;;; Indentation:
+
+(make-variable-buffer-local
+ (defvar factor-mode-indent-width factor-mode-default-indent-width
+ "Indentation width in factor buffers. A local variable."))
+
+(defun factor-mode--guess-indent-width ()
+ "Chooses an indentation value from existing code."
+ (let ((word-cont "^ +[^ ]")
+ (iw))
+ (save-excursion
+ (beginning-of-buffer)
+ (while (not iw)
+ (if (not (re-search-forward fuel-syntax--definition-start-regex nil t))
+ (setq iw factor-mode-default-indent-width)
+ (forward-line)
+ (when (looking-at word-cont)
+ (setq iw (current-indentation))))))
+ iw))
+
+(defun factor-mode--indent-in-brackets ()
+ (save-excursion
+ (beginning-of-line)
+ (when (> (fuel-syntax--brackets-depth) 0)
+ (let ((op (fuel-syntax--brackets-start))
+ (cl (fuel-syntax--brackets-end))
+ (ln (line-number-at-pos)))
+ (when (> ln (line-number-at-pos op))
+ (if (and (> cl 0) (= ln (line-number-at-pos cl)))
+ (fuel-syntax--indentation-at op)
+ (fuel-syntax--increased-indentation (fuel-syntax--indentation-at op))))))))
+
+(defun factor-mode--indent-definition ()
+ (save-excursion
+ (beginning-of-line)
+ (when (fuel-syntax--at-begin-of-def) 0)))
+
+(defun factor-mode--indent-setter-line ()
+ (when (fuel-syntax--at-setter-line)
+ (save-excursion
+ (let ((indent (and (fuel-syntax--at-constructor-line) (current-indentation))))
+ (while (not (or indent
+ (bobp)
+ (fuel-syntax--at-begin-of-def)
+ (fuel-syntax--at-end-of-def)))
+ (if (fuel-syntax--at-constructor-line)
+ (setq indent (fuel-syntax--increased-indentation))
+ (forward-line -1)))
+ indent))))
+
+(defun factor-mode--indent-continuation ()
+ (save-excursion
+ (forward-line -1)
+ (while (and (not (bobp))
+ (fuel-syntax--looking-at-emptiness))
+ (forward-line -1))
+ (cond ((or (fuel-syntax--at-end-of-def)
+ (fuel-syntax--at-setter-line))
+ (fuel-syntax--decreased-indentation))
+ ((and (fuel-syntax--at-begin-of-def)
+ (not (fuel-syntax--at-using)))
+ (fuel-syntax--increased-indentation))
+ (t (current-indentation)))))
+
+(defun factor-mode--calculate-indentation ()
+ "Calculate Factor indentation for line at point."
+ (or (and (bobp) 0)
+ (factor-mode--indent-definition)
+ (factor-mode--indent-in-brackets)
+ (factor-mode--indent-setter-line)
+ (factor-mode--indent-continuation)
+ 0))
+
+(defun factor-mode--indent-line ()
+ "Indent current line as Factor code"
+ (let ((target (factor-mode--calculate-indentation))
+ (pos (- (point-max) (point))))
+ (if (= target (current-indentation))
+ (if (< (current-column) (current-indentation))
+ (back-to-indentation))
+ (beginning-of-line)
+ (delete-horizontal-space)
+ (indent-to target)
+ (if (> (- (point-max) pos) (point))
+ (goto-char (- (point-max) pos))))))
+
+(defun factor-mode--indentation-setup ()
+ (set (make-local-variable 'indent-line-function) 'factor-mode--indent-line)
+ (setq factor-indent-width (factor-mode--guess-indent-width))
+ (setq indent-tabs-mode nil))
+
+\f
+;;; Buffer cycling:
+
+(defconst factor-mode--cycle-endings
+ '(".factor" "-tests.factor" "-docs.factor"))
+
+(defconst factor-mode--regex-cycle-endings
+ (format "\\(.*?\\)\\(%s\\)$"
+ (regexp-opt factor-mode--cycle-endings)))
+
+(defconst factor-mode--cycle-endings-ring
+ (let ((ring (make-ring (length factor-mode--cycle-endings))))
+ (dolist (e factor-mode--cycle-endings ring)
+ (ring-insert ring e))))
+
+(defun factor-mode--cycle-next (file)
+ (let* ((match (string-match factor-mode--regex-cycle-endings file))
+ (base (and match (match-string-no-properties 1 file)))
+ (ending (and match (match-string-no-properties 2 file)))
+ (idx (and ending (ring-member factor-mode--cycle-endings-ring ending)))
+ (gfl (lambda (i) (concat base (ring-ref factor-mode--cycle-endings-ring i)))))
+ (if (not idx) file
+ (let ((l (length factor-mode--cycle-endings)) (i 1) next)
+ (while (and (not next) (< i l))
+ (when (file-exists-p (funcall gfl (+ idx i)))
+ (setq next (+ idx i)))
+ (setq i (1+ i)))
+ (funcall gfl (or next idx))))))
+
+(defun factor-mode-visit-other-file (&optional file)
+ "Cycle between code, tests and docs factor files."
+ (interactive)
+ (find-file (factor-mode--cycle-next (or file (buffer-file-name)))))
+
+\f
+;;; Keymap:
+
+(defun factor-mode-insert-and-indent (n)
+ (interactive "p")
+ (self-insert-command n)
+ (indent-for-tab-command))
+
+(defvar factor-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [?\]] 'factor-mode-insert-and-indent)
+ (define-key map [?}] 'factor-mode-insert-and-indent)
+ (define-key map "\C-m" 'newline-and-indent)
+ (define-key map "\C-co" 'factor-mode-visit-other-file)
+ (define-key map "\C-c\C-o" 'factor-mode-visit-other-file)
+ map))
+
+(defun factor-mode--keymap-setup ()
+ (use-local-map factor-mode-map))
+
+\f
+;;; Factor mode:
+
+;;;###autoload
+(defun factor-mode ()
+ "A mode for editing programs written in the Factor programming language.
+\\{factor-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'factor-mode)
+ (setq mode-name "Factor")
+ (fuel-font-lock--font-lock-setup)
+ (factor-mode--keymap-setup)
+ (factor-mode--indentation-setup)
+ (factor-mode--syntax-setup)
+ (when factor-mode-use-fuel (require 'fuel-mode) (fuel-mode))
+ (run-hooks 'factor-mode-hook))
+
+\f
+(provide 'factor-mode)
+;;; factor-mode.el ends here
--- /dev/null
+;;; fu.el --- Startup file for FUEL
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages
+
+;;; Code:
+
+(add-to-list 'load-path (file-name-directory load-file-name))
+
+(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
+(autoload 'factor-mode "factor-mode.el"
+ "Major mode for editing Factor source." t)
+
+(autoload 'run-factor "fuel-listener.el"
+ "Start a Factor listener, or switch to a running one." t)
+
+(autoload 'fuel-autodoc-mode "fuel-help.el"
+ "Minor mode showing in the minibuffer a synopsis of Factor word at point."
+ t)
+
+
+\f
+;;; fu.el ends here
--- /dev/null
+;;; fuel-base.el --- Basic FUEL support code
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages
+
+;;; Commentary:
+
+;; Basic definitions likely to be used by all FUEL modules.
+
+;;; Code:
+
+(defconst fuel-version "1.0")
+
+;;;###autoload
+(defsubst fuel-version ()
+ "Echoes FUEL's version."
+ (interactive)
+ (message "FUEL %s" fuel-version))
+
+\f
+;;; Customization:
+
+;;;###autoload
+(defgroup fuel nil
+ "Factor's Ultimate Emacs Library"
+ :group 'language)
+
+\f
+;;; Emacs compatibility:
+
+(eval-after-load "ring"
+ '(when (not (fboundp 'ring-member))
+ (defun ring-member (ring item)
+ (catch 'found
+ (dotimes (ind (ring-length ring) nil)
+ (when (equal item (ring-ref ring ind))
+ (throw 'found ind)))))))
+
+\f
+;;; Utilities
+
+(defun fuel--shorten-str (str len)
+ (let ((sl (length str)))
+ (if (<= sl len) str
+ (let* ((sep " ... ")
+ (sepl (length sep))
+ (segl (/ (- len sepl) 2)))
+ (format "%s%s%s"
+ (substring str 0 segl)
+ sep
+ (substring str (- sl segl)))))))
+
+(defun fuel--shorten-region (begin end len)
+ (fuel--shorten-str (mapconcat 'identity
+ (split-string (buffer-substring begin end) nil t)
+ " ")
+ len))
+
+(provide 'fuel-base)
+;;; fuel-base.el ends here
--- /dev/null
+;;; fuel-debug.el -- debugging factor code
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages, fuel, factor
+;; Start date: Sun Dec 07, 2008 04:16
+
+;;; Comentary:
+
+;; A mode for displaying the results of run-file and evaluation, with
+;; support for restarts.
+
+;;; Code:
+
+(require 'fuel-base)
+(require 'fuel-eval)
+(require 'fuel-font-lock)
+
+\f
+;;; Customization:
+
+(defgroup fuel-debug nil
+ "Major mode for interaction with the Factor debugger"
+ :group 'fuel)
+
+(defcustom fuel-debug-mode-hook nil
+ "Hook run after `fuel-debug-mode' activates"
+ :group 'fuel-debug
+ :type 'hook)
+
+(defcustom fuel-debug-show-short-help t
+ "Whether to show short help on available keys in debugger"
+ :group 'fuel-debug
+ :type 'boolean)
+
+(fuel-font-lock--define-faces
+ fuel-debug-font-lock font-lock fuel-debug
+ ((error warning "highlighting errors")
+ (line variable-name "line numbers in errors/warnings")
+ (column variable-name "column numbers in errors/warnings")
+ (info comment "information headers")
+ (restart-number warning "restart numbers")
+ (restart-name function-name "restart names")))
+
+\f
+;;; Font lock and other pattern matching:
+
+(defconst fuel-debug--compiler-info-alist
+ '((":warnings" . ?w) (":errors" . ?e) (":linkage" . ?l)))
+
+(defconst fuel-debug--error-file-regex "^P\" \\([^\"]+\\)\"")
+(defconst fuel-debug--error-line-regex "\\([0-9]+\\):")
+(defconst fuel-debug--error-cont-regex "^ +\\(\\^\\)$")
+
+(defconst fuel-debug--error-regex
+ (format "%s\n%s"
+ fuel-debug--error-file-regex
+ fuel-debug--error-line-regex))
+
+(defconst fuel-debug--compiler-info-regex
+ (format "^\\(%s\\) "
+ (regexp-opt (mapcar 'car fuel-debug--compiler-info-alist))))
+
+(defconst fuel-debug--restart-regex "^:\\([0-9]+\\) \\(.+\\)")
+
+(defconst fuel-debug--font-lock-keywords
+ `((,fuel-debug--error-file-regex . 'fuel-debug-font-lock-error)
+ (,fuel-debug--error-line-regex 1 'fuel-debug-font-lock-line)
+ (,fuel-debug--error-cont-regex 1 'fuel-debug-font-lock-column)
+ (,fuel-debug--restart-regex (1 'fuel-debug-font-lock-restart-number)
+ (2 'fuel-debug-font-lock-restart-name))
+ (,fuel-debug--compiler-info-regex 1 'fuel-debug-font-lock-restart-number)
+ ("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-debug-font-lock-info)
+ ("^Error: " . 'fuel-debug-font-lock-error)))
+
+(defun fuel-debug--font-lock-setup ()
+ (set (make-local-variable 'font-lock-defaults)
+ '(fuel-debug--font-lock-keywords t nil nil nil)))
+
+\f
+;;; Debug buffer:
+
+(defvar fuel-debug--buffer nil)
+
+(make-variable-buffer-local
+ (defvar fuel-debug--last-ret nil))
+
+(make-variable-buffer-local
+ (defvar fuel-debug--file nil))
+
+(defun fuel-debug--buffer ()
+ (or (and (buffer-live-p fuel-debug--buffer) fuel-debug--buffer)
+ (with-current-buffer
+ (setq fuel-debug--buffer (get-buffer-create "*fuel dbg*"))
+ (fuel-debug-mode)
+ (current-buffer))))
+
+(defun fuel-debug--display-retort (ret &optional success-msg no-pop file)
+ (let ((err (fuel-eval--retort-error ret))
+ (inhibit-read-only t))
+ (with-current-buffer (fuel-debug--buffer)
+ (erase-buffer)
+ (fuel-debug--display-output ret)
+ (delete-blank-lines)
+ (newline)
+ (when (and (not err) success-msg)
+ (message "%s" success-msg)
+ (insert "\n" success-msg "\n"))
+ (when err
+ (fuel-debug--display-restarts err)
+ (delete-blank-lines)
+ (newline)
+ (let ((hstr (fuel-debug--help-string err file)))
+ (if fuel-debug-show-short-help
+ (insert "-----------\n" hstr "\n")
+ (message "%s" hstr))))
+ (setq fuel-debug--last-ret ret)
+ (setq fuel-debug--file file)
+ (goto-char (point-max))
+ (when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer))
+ (not err))))
+
+(defun fuel-debug--display-output (ret)
+ (let* ((last (fuel-eval--retort-output fuel-debug--last-ret))
+ (current (fuel-eval--retort-output ret))
+ (llen (length last))
+ (clen (length current))
+ (trail (and last (substring-no-properties last (/ llen 2))))
+ (err (fuel-eval--retort-error ret))
+ (p (point)))
+ (save-excursion (insert current))
+ (when (and (> clen llen) (> llen 0) (search-forward trail nil t))
+ (delete-region p (point)))
+ (goto-char (point-max))
+ (when err
+ (insert (format "\nError: %S\n\n" (fuel-eval--error-name err))))))
+
+(defun fuel-debug--display-restarts (err)
+ (let* ((rs (fuel-eval--error-restarts err))
+ (rsn (length rs)))
+ (when rs
+ (insert "Restarts:\n\n")
+ (dotimes (n rsn)
+ (insert (format ":%s %s\n" (1+ n) (nth n rs))))
+ (newline))))
+
+(defun fuel-debug--help-string (err &optional file)
+ (format "Press %s%s%sq bury buffer"
+ (if (or file (fuel-eval--error-file err)) "g go to file, " "")
+ (let ((rsn (length (fuel-eval--error-restarts err))))
+ (cond ((zerop rsn) "")
+ ((= 1 rsn) "1 invoke restart, ")
+ (t (format "1-%s invoke restarts, " rsn))))
+ (let ((str ""))
+ (dolist (ci fuel-debug--compiler-info-alist str)
+ (save-excursion
+ (goto-char (point-min))
+ (when (search-forward (car ci) nil t)
+ (setq str (format "%c %s, %s" (cdr ci) (car ci) str))))))))
+
+(defun fuel-debug--buffer-file ()
+ (with-current-buffer (fuel-debug--buffer)
+ (or fuel-debug--file
+ (and fuel-debug--last-ret
+ (fuel-eval--error-file
+ (fuel-eval--retort-error fuel-debug--last-ret))))))
+
+(defsubst fuel-debug--buffer-error ()
+ (fuel-eval--retort-error fuel-debug--last-ret))
+
+(defsubst fuel-debug--buffer-restarts ()
+ (fuel-eval--error-restarts (fuel-debug--buffer-error)))
+
+\f
+;;; Buffer navigation:
+
+(defun fuel-debug-goto-error ()
+ (interactive)
+ (let* ((err (or (fuel-debug--buffer-error)
+ (error "No errors reported")))
+ (file (or (fuel-debug--buffer-file)
+ (error "No file associated with error")))
+ (l/c (fuel-eval--error-line/column err))
+ (line (or (car l/c) 1))
+ (col (or (cdr l/c) 0)))
+ (find-file-other-window file)
+ (goto-line line)
+ (forward-char col)))
+
+(defun fuel-debug--read-restart-no ()
+ (let ((rs (fuel-debug--buffer-restarts)))
+ (unless rs (error "No restarts available"))
+ (let* ((rsn (length rs))
+ (prompt (format "Restart number? (1-%s): " rsn))
+ (no 0))
+ (while (or (> (setq no (read-number prompt)) rsn)
+ (< no 1)))
+ no)))
+
+(defun fuel-debug-exec-restart (&optional n confirm)
+ (interactive (list (fuel-debug--read-restart-no)))
+ (let ((n (or n 1))
+ (rs (fuel-debug--buffer-restarts)))
+ (when (zerop (length rs))
+ (error "No restarts available"))
+ (when (or (< n 1) (> n (length rs)))
+ (error "Restart %s not available" n))
+ (when (or (not confirm)
+ (y-or-n-p (format "Invoke restart %s? " n)))
+ (message "Invoking restart %s" n)
+ (let* ((file (fuel-debug--buffer-file))
+ (buffer (if file (find-file-noselect file) (current-buffer))))
+ (with-current-buffer buffer
+ (fuel-debug--display-retort
+ (fuel-eval--eval-string/context (format ":%s" n))
+ (format "Restart %s (%s) successful" n (nth (1- n) rs))))))))
+
+(defun fuel-debug-show--compiler-info (info)
+ (save-excursion
+ (goto-char (point-min))
+ (unless (re-search-forward (format "^%s" info) nil t)
+ (error "%s information not available" info))
+ (message "Retrieving %s info ..." info)
+ (unless (fuel-debug--display-retort
+ (fuel-eval--eval-string info) "" (fuel-debug--buffer-file))
+ (error "Sorry, no %s info available" info))))
+
+\f
+;;; Fuel Debug mode:
+
+(defvar fuel-debug-mode-map
+ (let ((map (make-keymap)))
+ (suppress-keymap map)
+ (define-key map "g" 'fuel-debug-goto-error)
+ (define-key map "\C-c\C-c" 'fuel-debug-goto-error)
+ (define-key map "n" 'next-line)
+ (define-key map "p" 'previous-line)
+ (define-key map "q" 'bury-buffer)
+ (dotimes (n 9)
+ (define-key map (vector (+ ?1 n))
+ `(lambda () (interactive) (fuel-debug-exec-restart ,(1+ n) t))))
+ (dolist (ci fuel-debug--compiler-info-alist)
+ (define-key map (vector (cdr ci))
+ `(lambda () (interactive) (fuel-debug-show--compiler-info ,(car ci)))))
+ map))
+
+(defun fuel-debug-mode ()
+ "A major mode for displaying Factor's compilation results and
+invoking restarts as needed.
+\\{fuel-debug-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'factor-mode)
+ (setq mode-name "Fuel Debug")
+ (use-local-map fuel-debug-mode-map)
+ (fuel-debug--font-lock-setup)
+ (setq fuel-debug--file nil)
+ (setq fuel-debug--last-ret nil)
+ (toggle-read-only 1)
+ (run-hooks 'fuel-debug-mode-hook))
+
+\f
+(provide 'fuel-debug)
+;;; fuel-debug.el ends here
--- /dev/null
+;;; fuel-eval.el --- utilities for communication with fuel-listener
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages
+;; Start date: Tue Dec 02, 2008
+
+;;; Commentary:
+
+;; Protocols for handling communications via a comint buffer running a
+;; factor listener.
+
+;;; Code:
+
+(require 'fuel-base)
+(require 'fuel-syntax)
+
+\f
+;;; Syncronous string sending:
+
+(defvar fuel-eval-log-max-length 16000)
+
+(defvar fuel-eval--default-proc-function nil)
+(defsubst fuel-eval--default-proc ()
+ (and fuel-eval--default-proc-function
+ (funcall fuel-eval--default-proc-function)))
+
+(defvar fuel-eval--proc nil)
+(defvar fuel-eval--log t)
+
+(defun fuel-eval--send-string (str)
+ (let ((proc (or fuel-eval--proc (fuel-eval--default-proc))))
+ (when proc
+ (with-current-buffer (get-buffer-create "*factor messages*")
+ (goto-char (point-max))
+ (when (and (> fuel-eval-log-max-length 0)
+ (> (point) fuel-eval-log-max-length))
+ (erase-buffer))
+ (when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256)))
+ (newline)
+ (let ((beg (point)))
+ (comint-redirect-send-command-to-process str (current-buffer) proc nil t)
+ (with-current-buffer (process-buffer proc)
+ (while (not comint-redirect-completed) (sleep-for 0 1)))
+ (goto-char beg)
+ (current-buffer))))))
+
+\f
+;;; Evaluation protocol
+
+(defsubst fuel-eval--retort-make (err result &optional output)
+ (list err result output))
+
+(defsubst fuel-eval--retort-error (ret) (nth 0 ret))
+(defsubst fuel-eval--retort-result (ret) (nth 1 ret))
+(defsubst fuel-eval--retort-output (ret) (nth 2 ret))
+
+(defsubst fuel-eval--retort-p (ret) (listp ret))
+
+(defsubst fuel-eval--make-parse-error-retort (str)
+ (fuel-eval--retort-make 'parse-retort-error nil str))
+
+(defun fuel-eval--parse-retort (buffer)
+ (save-current-buffer
+ (set-buffer buffer)
+ (condition-case nil
+ (read (current-buffer))
+ (error (fuel-eval--make-parse-error-retort
+ (buffer-substring-no-properties (point) (point-max)))))))
+
+(defsubst fuel-eval--send/retort (str)
+ (fuel-eval--parse-retort (fuel-eval--send-string str)))
+
+(defsubst fuel-eval--eval-begin ()
+ (fuel-eval--send/retort "fuel-begin-eval"))
+
+(defsubst fuel-eval--eval-end ()
+ (fuel-eval--send/retort "fuel-begin-eval"))
+
+(defsubst fuel-eval--factor-array (strs)
+ (format "V{ %S }" (mapconcat 'identity strs " ")))
+
+(defsubst fuel-eval--eval-strings (strs &optional no-restart)
+ (let ((str (format "fuel-eval-%s %s fuel-eval"
+ (if no-restart "non-restartable" "restartable")
+ (fuel-eval--factor-array strs))))
+ (fuel-eval--send/retort str)))
+
+(defsubst fuel-eval--eval-string (str &optional no-restart)
+ (fuel-eval--eval-strings (list str) no-restart))
+
+(defun fuel-eval--eval-strings/context (strs &optional no-restart)
+ (let ((usings (fuel-syntax--usings-update)))
+ (fuel-eval--send/retort
+ (format "fuel-eval-%s %s %S %s fuel-eval-in-context"
+ (if no-restart "non-restartable" "restartable")
+ (fuel-eval--factor-array strs)
+ (or fuel-syntax--current-vocab "f")
+ (if usings (fuel-eval--factor-array usings) "f")))))
+
+(defsubst fuel-eval--eval-string/context (str &optional no-restart)
+ (fuel-eval--eval-strings/context (list str) no-restart))
+
+(defun fuel-eval--eval-region/context (begin end &optional no-restart)
+ (let ((lines (split-string (buffer-substring-no-properties begin end)
+ "[\f\n\r\v]+" t)))
+ (when (> (length lines) 0)
+ (fuel-eval--eval-strings/context lines no-restart))))
+
+\f
+;;; Error parsing
+
+(defsubst fuel-eval--error-name (err) (car err))
+
+(defsubst fuel-eval--error-restarts (err)
+ (cdr (assoc :restarts (fuel-eval--error-name-p err 'condition))))
+
+(defun fuel-eval--error-name-p (err name)
+ (unless (null err)
+ (or (and (eq (fuel-eval--error-name err) name) err)
+ (assoc name err))))
+
+(defsubst fuel-eval--error-file (err)
+ (nth 1 (fuel-eval--error-name-p err 'source-file-error)))
+
+(defsubst fuel-eval--error-lexer-p (err)
+ (or (fuel-eval--error-name-p err 'lexer-error)
+ (fuel-eval--error-name-p (fuel-eval--error-name-p err 'source-file-error)
+ 'lexer-error)))
+
+(defsubst fuel-eval--error-line/column (err)
+ (let ((err (fuel-eval--error-lexer-p err)))
+ (cons (nth 1 err) (nth 2 err))))
+
+(defsubst fuel-eval--error-line-text (err)
+ (nth 3 (fuel-eval--error-lexer-p err)))
+
+\f
+(provide 'fuel-eval)
+;;; fuel-eval.el ends here
--- /dev/null
+;;; fuel-font-lock.el -- font lock for factor code
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages, fuel, factor
+;; Start date: Wed Dec 03, 2008 21:40
+
+;;; Comentary:
+
+;; Font lock setup for highlighting Factor code.
+
+;;; Code:
+
+(require 'fuel-base)
+(require 'fuel-syntax)
+
+(require 'font-lock)
+
+\f
+;;; Faces:
+
+(defmacro fuel-font-lock--make-face (prefix def-prefix group face def doc)
+ (let ((face (intern (format "%s-%s" prefix face)))
+ (def (intern (format "%s-%s-face" def-prefix def))))
+ `(defface ,face (face-default-spec ,def)
+ ,(format "Face for %s." doc)
+ :group ',group
+ :group 'faces)))
+
+(defmacro fuel-font-lock--define-faces (prefix def-prefix group faces)
+ (let ((setup (make-symbol (format "%s--faces-setup" prefix))))
+ `(progn
+ (defmacro ,setup ()
+ (cons 'progn
+ (mapcar (lambda (f) (append '(fuel-font-lock--make-face
+ ,prefix ,def-prefix ,group) f))
+ ',faces)))
+ (,setup))))
+
+\f
+;;; Font lock:
+
+(defconst fuel-font-lock--parsing-lock-keywords
+ (cons '("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
+ (mapcar (lambda (w) `(,(format "\\(^\\| \\)\\(%s\\)\\($\\| \\)" w)
+ 2 'factor-font-lock-parsing-word))
+ fuel-syntax--parsing-words)))
+
+(defconst fuel-font-lock--font-lock-keywords
+ `(,@fuel-font-lock--parsing-lock-keywords
+ (,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
+ (,fuel-syntax--parsing-words-ext-regex . 'factor-font-lock-parsing-word)
+ (,fuel-syntax--declaration-words-regex 1 'factor-font-lock-declaration)
+ (,fuel-syntax--word-definition-regex 2 'factor-font-lock-word)
+ (,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name)
+ (,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name)
+ (2 'factor-font-lock-word))
+ (,fuel-syntax--parent-type-regex 1 'factor-font-lock-type)
+ (,fuel-syntax--constructor-regex . 'factor-font-lock-constructor)
+ (,fuel-syntax--setter-regex . 'factor-font-lock-setter-word)
+ (,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol)
+ (,fuel-syntax--use-line-regex 1 'factor-font-lock-vocabulary-name))
+ "Font lock keywords definition for Factor mode.")
+
+(defun fuel-font-lock--font-lock-setup (&optional keywords no-syntax)
+ (set (make-local-variable 'comment-start) "! ")
+ (set (make-local-variable 'parse-sexp-lookup-properties) t)
+ (set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment)
+ (set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string)
+ (set (make-local-variable 'font-lock-defaults)
+ `(,(or keywords 'fuel-font-lock--font-lock-keywords)
+ nil nil nil nil
+ ,@(if no-syntax nil
+ (list (cons 'font-lock-syntactic-keywords
+ fuel-syntax--syntactic-keywords))))))
+
+\f
+(provide 'fuel-font-lock)
+;;; fuel-font-lock.el ends here
--- /dev/null
+;;; fuel-help.el -- accessing Factor's help system
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages, fuel, factor
+;; Start date: Wed Dec 03, 2008 21:41
+
+;;; Comentary:
+
+;; Modes and functions interfacing Factor's 'see' and 'help'
+;; utilities, as well as an ElDoc-based autodoc mode.
+
+;;; Code:
+
+(require 'fuel-base)
+(require 'fuel-font-lock)
+(require 'fuel-eval)
+
+\f
+;;; Customization:
+
+(defgroup fuel-help nil
+ "Options controlling FUEL's help system"
+ :group 'fuel)
+
+(defcustom fuel-help-minibuffer-font-lock t
+ "Whether to use font lock for info messages in the minibuffer."
+ :group 'fuel-help
+ :type 'boolean)
+
+(defcustom fuel-help-always-ask t
+ "When enabled, always ask for confirmation in help prompts."
+ :type 'boolean
+ :group 'fuel-help)
+
+(defcustom fuel-help-use-minibuffer t
+ "When enabled, use the minibuffer for short help messages."
+ :type 'boolean
+ :group 'fuel-help)
+
+(defcustom fuel-help-mode-hook nil
+ "Hook run by `factor-help-mode'."
+ :type 'hook
+ :group 'fuel-help)
+
+(defface fuel-help-font-lock-headlines '((t (:bold t :weight bold)))
+ "Face for headlines in help buffers."
+ :group 'fuel-help
+ :group 'faces)
+
+\f
+;;; Autodoc mode:
+
+(defvar fuel-help--font-lock-buffer
+ (let ((buffer (get-buffer-create " *fuel help minibuffer messages*")))
+ (set-buffer buffer)
+ (fuel-font-lock--font-lock-setup)
+ buffer))
+
+(defun fuel-help--font-lock-str (str)
+ (set-buffer fuel-help--font-lock-buffer)
+ (erase-buffer)
+ (insert str)
+ (let ((font-lock-verbose nil)) (font-lock-fontify-buffer))
+ (buffer-string))
+
+(defun fuel-help--word-synopsis (&optional word)
+ (let ((word (or word (fuel-syntax-symbol-at-point)))
+ (fuel-eval--log t))
+ (when word
+ (let ((ret (fuel-eval--eval-string/context
+ (format "\\ %s synopsis fuel-eval-set-result" word)
+ t)))
+ (when (not (fuel-eval--retort-error ret))
+ (if fuel-help-minibuffer-font-lock
+ (fuel-help--font-lock-str (fuel-eval--retort-result ret))
+ (fuel-eval--retort-result ret)))))))
+
+(make-variable-buffer-local
+ (defvar fuel-autodoc-mode-string " A"
+ "Modeline indicator for fuel-autodoc-mode"))
+
+(define-minor-mode fuel-autodoc-mode
+ "Toggle Fuel's Autodoc mode.
+With no argument, this command toggles the mode.
+Non-null prefix argument turns on the mode.
+Null prefix argument turns off the mode.
+
+When Autodoc mode is enabled, a synopsis of the word at point is
+displayed in the minibuffer."
+ :init-value nil
+ :lighter fuel-autodoc-mode-string
+ :group 'fuel
+
+ (set (make-local-variable 'eldoc-documentation-function)
+ (when fuel-autodoc-mode 'fuel-help--word-synopsis))
+ (set (make-local-variable 'eldoc-minor-mode-string) nil)
+ (eldoc-mode fuel-autodoc-mode)
+ (message "Fuel Autodoc %s" (if fuel-autodoc-mode "enabled" "disabled")))
+
+\f
+;;;; Factor help mode:
+
+(defvar fuel-help-mode-map (make-sparse-keymap)
+ "Keymap for Factor help mode.")
+
+(define-key fuel-help-mode-map [(return)] 'fuel-help)
+
+(defconst fuel-help--headlines
+ (regexp-opt '("Class description"
+ "Definition"
+ "Examples"
+ "Generic word contract"
+ "Inputs and outputs"
+ "Methods"
+ "Notes"
+ "Parent topics:"
+ "See also"
+ "Syntax"
+ "Vocabulary"
+ "Warning"
+ "Word description")
+ t))
+
+(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines))
+
+(defconst fuel-help--font-lock-keywords
+ `(,@fuel-font-lock--font-lock-keywords
+ (,fuel-help--headlines-regexp . 'fuel-help-font-lock-headlines)))
+
+(defun fuel-help-mode ()
+ "Major mode for displaying Factor documentation.
+\\{fuel-help-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map fuel-help-mode-map)
+ (setq mode-name "Factor Help")
+ (setq major-mode 'fuel-help-mode)
+
+ (fuel-font-lock--font-lock-setup fuel-help--font-lock-keywords t)
+
+ (set (make-local-variable 'view-no-disable-on-exit) t)
+ (view-mode)
+ (setq view-exit-action
+ (lambda (buffer)
+ ;; Use `with-current-buffer' to make sure that `bury-buffer'
+ ;; also removes BUFFER from the selected window.
+ (with-current-buffer buffer
+ (bury-buffer))))
+
+ (setq fuel-autodoc-mode-string "")
+ (fuel-autodoc-mode)
+ (run-mode-hooks 'fuel-help-mode-hook))
+
+(defun fuel-help--help-buffer ()
+ (with-current-buffer (get-buffer-create "*fuel-help*")
+ (fuel-help-mode)
+ (current-buffer)))
+
+(defvar fuel-help--history nil)
+
+(defun fuel-help--show-help (&optional see)
+ (let* ((def (fuel-syntax-symbol-at-point))
+ (prompt (format "See%s help on%s: " (if see " short" "")
+ (if def (format " (%s)" def) "")))
+ (ask (or (not (memq major-mode '(factor-mode fuel-help-mode)))
+ (not def)
+ fuel-help-always-ask))
+ (def (if ask (read-string prompt nil 'fuel-help--history def) def))
+ (cmd (format "\\ %s %s" def (if see "see" "help")))
+ (fuel-eval--log nil)
+ (ret (fuel-eval--eval-string/context cmd t))
+ (out (fuel-eval--retort-output ret)))
+ (if (or (fuel-eval--retort-error ret) (empty-string-p out))
+ (message "No help for '%s'" def)
+ (let ((hb (fuel-help--help-buffer))
+ (inhibit-read-only t)
+ (font-lock-verbose nil))
+ (set-buffer hb)
+ (erase-buffer)
+ (insert out)
+ (set-buffer-modified-p nil)
+ (pop-to-buffer hb)
+ (goto-char (point-min))))))
+
+\f
+;;; Interface: see/help commands
+
+(defun fuel-help-short (&optional arg)
+ "See a help summary of symbol at point.
+By default, the information is shown in the minibuffer. When
+called with a prefix argument, the information is displayed in a
+separate help buffer."
+ (interactive "P")
+ (if (if fuel-help-use-minibuffer (not arg) arg)
+ (fuel-help--word-synopsis)
+ (fuel-help--show-help t)))
+
+(defun fuel-help ()
+ "Show extended help about the symbol at point, using a help
+buffer."
+ (interactive)
+ (fuel-help--show-help))
+
+\f
+(provide 'fuel-help)
+;;; fuel-help.el ends here
--- /dev/null
+;;; fuel-listener.el --- starting the fuel listener
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages
+
+;;; Commentary:
+
+;; Utilities to maintain and switch to a factor listener comint
+;; buffer, with an accompanying major fuel-listener-mode.
+
+;;; Code:
+
+(require 'fuel-eval)
+(require 'fuel-base)
+(require 'comint)
+
+\f
+;;; Customization:
+
+(defgroup fuel-listener nil
+ "Interacting with a Factor listener inside Emacs"
+ :group 'fuel)
+
+(defcustom fuel-listener-factor-binary "~/factor/factor"
+ "Full path to the factor executable to use when starting a listener."
+ :type '(file :must-match t)
+ :group 'fuel-listener)
+
+(defcustom fuel-listener-factor-image "~/factor/factor.image"
+ "Full path to the factor image to use when starting a listener."
+ :type '(file :must-match t)
+ :group 'fuel-listener)
+
+(defcustom fuel-listener-use-other-window t
+ "Use a window other than the current buffer's when switching to
+the factor-listener buffer."
+ :type 'boolean
+ :group 'fuel-listener)
+
+(defcustom fuel-listener-window-allow-split t
+ "Allow window splitting when switching to the fuel listener
+buffer."
+ :type 'boolean
+ :group 'fuel-listener)
+
+\f
+;;; Fuel listener buffer/process:
+
+(defvar fuel-listener-buffer nil
+ "The buffer in which the Factor listener is running.")
+
+(defun fuel-listener--start-process ()
+ (let ((factor (expand-file-name fuel-listener-factor-binary))
+ (image (expand-file-name fuel-listener-factor-image)))
+ (unless (file-executable-p factor)
+ (error "Could not run factor: %s is not executable" factor))
+ (unless (file-readable-p image)
+ (error "Could not run factor: image file %s not readable" image))
+ (setq fuel-listener-buffer (get-buffer-create "*fuel listener*"))
+ (with-current-buffer fuel-listener-buffer
+ (fuel-listener-mode)
+ (message "Starting FUEL listener ...")
+ (comint-exec fuel-listener-buffer "factor"
+ factor nil `("-run=fuel" ,(format "-i=%s" image)))
+ (fuel-listener--wait-for-prompt 20)
+ (fuel-eval--send-string "USE: fuel")
+ (message "FUEL listener up and running!"))))
+
+(defun fuel-listener--process (&optional start)
+ (or (and (buffer-live-p fuel-listener-buffer)
+ (get-buffer-process fuel-listener-buffer))
+ (if (not start)
+ (error "No running factor listener (try M-x run-factor)")
+ (fuel-listener--start-process)
+ (fuel-listener--process))))
+
+(setq fuel-eval--default-proc-function 'fuel-listener--process)
+
+\f
+;;; Prompt chasing
+
+(defun fuel-listener--wait-for-prompt (&optional timeout)
+ (let ((proc (get-buffer-process fuel-listener-buffer))
+ (seen))
+ (with-current-buffer fuel-listener-buffer
+ (while (progn (goto-char comint-last-input-end)
+ (not (or seen
+ (setq seen
+ (re-search-forward comint-prompt-regexp nil t))
+ (not (accept-process-output proc timeout))))))
+ (goto-char (point-max)))
+ (unless seen
+ (pop-to-buffer fuel-listener-buffer)
+ (error "No prompt found!"))))
+
+\f
+;;; Interface: starting fuel listener
+
+(defalias 'switch-to-factor 'run-factor)
+(defalias 'switch-to-fuel-listener 'run-factor)
+;;;###autoload
+(defun run-factor (&optional arg)
+ "Show the fuel-listener buffer, starting the process if needed."
+ (interactive)
+ (let ((buf (process-buffer (fuel-listener--process t)))
+ (pop-up-windows fuel-listener-window-allow-split))
+ (if fuel-listener-use-other-window
+ (pop-to-buffer buf)
+ (switch-to-buffer buf))))
+
+\f
+;;; Fuel listener mode:
+
+(defconst fuel-listener--prompt-regex "( [^)]* ) ")
+
+(define-derived-mode fuel-listener-mode comint-mode "Fuel Listener"
+ "Major mode for interacting with an inferior Factor listener process.
+\\{fuel-listener-mode-map}"
+ (set (make-local-variable 'comint-prompt-regexp)
+ fuel-listener--prompt-regex)
+ (set (make-local-variable 'comint-prompt-read-only) t)
+ (setq fuel-listener--compilation-begin nil))
+
+(define-key fuel-listener-mode-map "\C-ch" 'fuel-help)
+(define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point)
+(define-key fuel-listener-mode-map "\C-ck" 'fuel-run-file)
+
+\f
+(provide 'fuel-listener)
+;;; fuel-listener.el ends here
--- /dev/null
+;;; fuel-mode.el -- Minor mode enabling FUEL niceties
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages, fuel, factor
+;; Start date: Sat Dec 06, 2008 00:52
+
+;;; Comentary:
+
+;; Enhancements to vanilla factor-mode (notably, listener interaction)
+;; enabled by means of a minor mode.
+
+;;; Code:
+
+(require 'factor-mode)
+(require 'fuel-base)
+(require 'fuel-syntax)
+(require 'fuel-font-lock)
+(require 'fuel-debug)
+(require 'fuel-help)
+(require 'fuel-eval)
+(require 'fuel-listener)
+
+\f
+;;; Customization:
+
+(defgroup fuel-mode nil
+ "Mode enabling FUEL's ultimate abilities."
+ :group 'fuel)
+
+(defcustom fuel-mode-autodoc-p t
+ "Whether `fuel-autodoc-mode' gets enable by default in fuel buffers."
+ :group 'fuel-mode
+ :type 'boolean)
+
+\f
+;;; User commands
+
+(defun fuel-run-file (&optional arg)
+ "Sends the current file to Factor for compilation.
+With prefix argument, ask for the file to run."
+ (interactive "P")
+ (let* ((file (or (and arg (read-file-name "File: " nil (buffer-file-name) t))
+ (buffer-file-name)))
+ (file (expand-file-name file))
+ (buffer (find-file-noselect file))
+ (cmd (format "%S fuel-run-file" file)))
+ (when buffer
+ (with-current-buffer buffer
+ (message "Compiling %s ..." file)
+ (let ((r (fuel-debug--display-retort (fuel-eval--eval-string/context cmd)
+ (format "%s successfully compiled" file)
+ nil
+ file)))
+ (if r (message "Compiling %s ... OK!" file) (message "")))))))
+
+(defun fuel-eval-region (begin end &optional arg)
+ "Sends region to Fuel's listener for evaluation.
+Unless called with a prefix, switchs to the compilation results
+buffer in case of errors."
+ (interactive "r\nP")
+ (fuel-debug--display-retort
+ (fuel-eval--eval-region/context begin end)
+ (format "%s%s"
+ (if fuel-syntax--current-vocab
+ (format "IN: %s " fuel-syntax--current-vocab)
+ "")
+ (fuel--shorten-region begin end 70))
+ arg
+ (buffer-file-name)))
+
+(defun fuel-eval-extended-region (begin end &optional arg)
+ "Sends region extended outwards to nearest definitions,
+to Fuel's listener for evaluation.
+Unless called with a prefix, switchs to the compilation results
+buffer in case of errors."
+ (interactive "r\nP")
+ (fuel-eval-region (save-excursion (goto-char begin) (mark-defun) (point))
+ (save-excursion (goto-char end) (mark-defun) (mark))
+ arg))
+
+(defun fuel-eval-definition (&optional arg)
+ "Sends definition around point to Fuel's listener for evaluation.
+Unless called with a prefix, switchs to the compilation results
+buffer in case of errors."
+ (interactive "P")
+ (save-excursion
+ (mark-defun)
+ (let* ((begin (point))
+ (end (mark)))
+ (unless (< begin end) (error "No evaluable definition around point"))
+ (fuel-eval-region begin end arg))))
+
+(defun fuel-edit-word-at-point (&optional arg)
+ "Opens a new window visiting the definition of the word at point.
+With prefix, asks for the word to edit."
+ (interactive "P")
+ (let* ((word (fuel-syntax-symbol-at-point))
+ (ask (or arg (not word)))
+ (word (if ask
+ (read-string nil
+ (format "Edit word%s: "
+ (if word (format " (%s)" word) ""))
+ word)
+ word)))
+ (let* ((ret (fuel-eval--eval-string/context
+ (format "\\ %s fuel-get-edit-location" word)))
+ (err (fuel-eval--retort-error ret))
+ (loc (fuel-eval--retort-result ret)))
+ (when (or err (not loc) (not (listp loc)) (not (stringp (car loc))))
+ (error "Couldn't find edit location for '%s'" word))
+ (unless (file-readable-p (car loc))
+ (error "Couldn't open '%s' for read" (car loc)))
+ (find-file-other-window (car loc))
+ (goto-line (if (numberp (cadr loc)) (cadr loc) 1)))))
+
+\f
+;;; Minor mode definition:
+
+(make-variable-buffer-local
+ (defvar fuel-mode-string " F"
+ "Modeline indicator for fuel-mode"))
+
+(defvar fuel-mode-map (make-sparse-keymap)
+ "Key map for fuel-mode")
+
+(define-minor-mode fuel-mode
+ "Toggle Fuel's mode.
+With no argument, this command toggles the mode.
+Non-null prefix argument turns on the mode.
+Null prefix argument turns off the mode.
+
+When Fuel mode is enabled, a host of nice utilities for
+interacting with a factor listener is at your disposal.
+\\{fuel-mode-map}"
+ :init-value nil
+ :lighter fuel-mode-string
+ :group 'fuel
+ :keymap fuel-mode-map
+
+ (setq fuel-autodoc-mode-string "/A")
+ (when fuel-mode-autodoc-p (fuel-autodoc-mode fuel-mode)))
+
+\f
+;;; Keys:
+
+(defun fuel-mode--key-1 (k c)
+ (define-key fuel-mode-map (vector '(control ?c) k) c)
+ (define-key fuel-mode-map (vector '(control ?c) `(control ,k)) c))
+
+(defun fuel-mode--key (p k c)
+ (define-key fuel-mode-map (vector '(control ?c) `(control ,p) k) c)
+ (define-key fuel-mode-map (vector '(control ?c) `(control ,p) `(control ,k)) c))
+
+(fuel-mode--key-1 ?z 'run-factor)
+
+(fuel-mode--key-1 ?k 'fuel-run-file)
+(fuel-mode--key ?e ?k 'fuel-run-file)
+
+(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
+(fuel-mode--key ?e ?x 'fuel-eval-definition)
+
+(fuel-mode--key-1 ?r 'fuel-eval-region)
+(fuel-mode--key ?e ?r 'fuel-eval-region)
+
+(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)
+(fuel-mode--key ?e ?e 'fuel-eval-extended-region)
+
+(define-key fuel-mode-map "\M-." 'fuel-edit-word-at-point)
+
+(fuel-mode--key ?d ?a 'fuel-autodoc-mode)
+(fuel-mode--key ?d ?d 'fuel-help)
+(fuel-mode--key ?d ?s 'fuel-help-short)
+
+\f
+(provide 'fuel-mode)
+;;; fuel-mode.el ends here
--- /dev/null
+;;; fuel-syntax.el --- auxiliar definitions for factor code navigation.
+
+;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
+;; See http://factorcode.org/license.txt for BSD license.
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Keywords: languages
+
+;;; Commentary:
+
+;; Auxiliar constants and functions to parse factor code.
+
+;;; Code:
+
+(require 'thingatpt)
+
+\f
+;;; Thing-at-point support for factor symbols:
+
+(defun fuel-syntax--beginning-of-symbol ()
+ "Move point to the beginning of the current symbol."
+ (while (eq (char-before) ?:) (backward-char))
+ (skip-syntax-backward "w_"))
+
+(defun fuel-syntax--end-of-symbol ()
+ "Move point to the end of the current symbol."
+ (skip-syntax-forward "w_")
+ (while (looking-at ":") (forward-char)))
+
+(put 'factor-symbol 'end-op 'fuel-syntax--end-of-symbol)
+(put 'factor-symbol 'beginning-op 'fuel-syntax--beginning-of-symbol)
+
+(defsubst fuel-syntax-symbol-at-point ()
+ (let ((s (substring-no-properties (thing-at-point 'factor-symbol))))
+ (and (> (length s) 0) s)))
+
+\f
+;;; Regexps galore:
+
+(defconst fuel-syntax--parsing-words
+ '("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
+ "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
+ "DEFER:" "ERROR:" "EXCLUDE:" "FORGET:"
+ "GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{"
+ "IN:" "INSTANCE:" "INTERSECTION:"
+ "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:"
+ "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
+ "REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
+ "TUPLE:" "T{" "t\\??" "TYPEDEF:"
+ "UNION:" "USE:" "USING:" "V{" "VARS:" "W{"))
+
+(defconst fuel-syntax--parsing-words-ext-regex
+ (regexp-opt '("B" "call-next-method" "delimiter" "f" "initial:" "read-only")
+ 'words))
+
+(defconst fuel-syntax--declaration-words
+ '("flushable" "foldable" "inline" "parsing" "recursive"))
+
+(defconst fuel-syntax--declaration-words-regex
+ (regexp-opt fuel-syntax--declaration-words 'words))
+
+(defsubst fuel-syntax--second-word-regex (prefixes)
+ (format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t)))
+
+(defconst fuel-syntax--method-definition-regex
+ "^M: +\\([^ ]+\\) +\\([^ ]+\\)")
+
+(defconst fuel-syntax--word-definition-regex
+ (fuel-syntax--second-word-regex '(":" "::" "GENERIC:")))
+
+(defconst fuel-syntax--type-definition-regex
+ (fuel-syntax--second-word-regex '("TUPLE:" "SINGLETON:")))
+
+(defconst fuel-syntax--parent-type-regex "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)")
+
+(defconst fuel-syntax--constructor-regex "<[^ >]+>")
+
+(defconst fuel-syntax--setter-regex "\\W>>[^ ]+\\b")
+
+(defconst fuel-syntax--symbol-definition-regex
+ (fuel-syntax--second-word-regex '("SYMBOL:" "VAR:")))
+
+(defconst fuel-syntax--stack-effect-regex " ( .* )")
+
+(defconst fuel-syntax--using-lines-regex "^USING: +\\([^;]+\\);")
+
+(defconst fuel-syntax--use-line-regex "^USE: +\\(.*\\)$")
+
+(defconst fuel-syntax--current-vocab-regex "^IN: +\\([^ \r\n\f]+\\)")
+
+(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
+
+(defconst fuel-syntax--definition-starters-regex
+ (regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" ":" "")))
+
+(defconst fuel-syntax--definition-start-regex
+ (format "^\\(%s:\\) " fuel-syntax--definition-starters-regex))
+
+(defconst fuel-syntax--definition-end-regex
+ (format "\\(\\(^\\| +\\);\\( +%s\\)*\\($\\| +\\)\\)"
+ fuel-syntax--declaration-words-regex))
+
+(defconst fuel-syntax--single-liner-regex
+ (format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:"
+ "PRIVATE>" "<PRIVATE"
+ "SINGLETON:" "SYMBOL:" "USE:" "VAR:"))))
+
+(defconst fuel-syntax--begin-of-def-regex
+ (format "^USING: \\|\\(%s\\)\\|\\(%s .*\\)"
+ fuel-syntax--definition-start-regex
+ fuel-syntax--single-liner-regex))
+
+(defconst fuel-syntax--end-of-def-line-regex
+ (format "^.*%s" fuel-syntax--definition-end-regex))
+
+(defconst fuel-syntax--end-of-def-regex
+ (format "\\(%s\\)\\|\\(%s .*\\)"
+ fuel-syntax--end-of-def-line-regex
+ fuel-syntax--single-liner-regex))
+\f
+;;; Factor syntax table
+
+(defvar fuel-syntax--syntax-table
+ (let ((i 0)
+ (table (make-syntax-table)))
+ ;; Default is atom-constituent
+ (while (< i 256)
+ (modify-syntax-entry i "_ " table)
+ (setq i (1+ i)))
+
+ ;; Word components.
+ (setq i ?0)
+ (while (<= i ?9)
+ (modify-syntax-entry i "w " table)
+ (setq i (1+ i)))
+ (setq i ?A)
+ (while (<= i ?Z)
+ (modify-syntax-entry i "w " table)
+ (setq i (1+ i)))
+ (setq i ?a)
+ (while (<= i ?z)
+ (modify-syntax-entry i "w " table)
+ (setq i (1+ i)))
+
+ ;; Whitespace
+ (modify-syntax-entry ?\t " " table)
+ (modify-syntax-entry ?\f " " table)
+ (modify-syntax-entry ?\r " " table)
+ (modify-syntax-entry ? " " table)
+
+ ;; (end of) Comments
+ (modify-syntax-entry ?\n ">" table)
+
+ ;; Parenthesis
+ (modify-syntax-entry ?\[ "(] " table)
+ (modify-syntax-entry ?\] ")[ " table)
+ (modify-syntax-entry ?{ "(} " table)
+ (modify-syntax-entry ?} "){ " table)
+
+ (modify-syntax-entry ?\( "()" table)
+ (modify-syntax-entry ?\) ")(" table)
+
+ ;; Strings
+ (modify-syntax-entry ?\" "\"" table)
+ (modify-syntax-entry ?\\ "/" table)
+ table)
+ "Syntax table used while in Factor mode.")
+
+(defconst fuel-syntax--syntactic-keywords
+ `(("\\(#!\\)" (1 "<"))
+ (" \\(!\\)" (1 "<"))
+ ("^\\(!\\)" (1 "<"))
+ ("\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
+ ("\\([[({]\\)\\([^ \"\n]\\)" (1 "_") (2 "_"))
+ ("\\([^ \"\n]\\)\\([])}]\\)" (1 "_") (2 "_"))))
+
+\f
+;;; Source code analysis:
+
+(defsubst fuel-syntax--brackets-depth ()
+ (nth 0 (syntax-ppss)))
+
+(defsubst fuel-syntax--brackets-start ()
+ (nth 1 (syntax-ppss)))
+
+(defun fuel-syntax--brackets-end ()
+ (save-excursion
+ (goto-char (fuel-syntax--brackets-start))
+ (condition-case nil
+ (progn (forward-sexp)
+ (1- (point)))
+ (error -1))))
+
+(defsubst fuel-syntax--indentation-at (pos)
+ (save-excursion (goto-char pos) (current-indentation)))
+
+(defsubst fuel-syntax--increased-indentation (&optional i)
+ (+ (or i (current-indentation)) factor-indent-width))
+(defsubst fuel-syntax--decreased-indentation (&optional i)
+ (- (or i (current-indentation)) factor-indent-width))
+
+(defsubst fuel-syntax--at-begin-of-def ()
+ (looking-at fuel-syntax--begin-of-def-regex))
+
+(defsubst fuel-syntax--at-end-of-def ()
+ (looking-at fuel-syntax--end-of-def-regex))
+
+(defsubst fuel-syntax--looking-at-emptiness ()
+ (looking-at "^[ \t]*$"))
+
+(defun fuel-syntax--at-setter-line ()
+ (save-excursion
+ (beginning-of-line)
+ (if (not (fuel-syntax--looking-at-emptiness))
+ (re-search-forward fuel-syntax--setter-regex (line-end-position) t)
+ (forward-line -1)
+ (or (fuel-syntax--at-constructor-line)
+ (fuel-syntax--at-setter-line)))))
+
+(defun fuel-syntax--at-constructor-line ()
+ (save-excursion
+ (beginning-of-line)
+ (re-search-forward fuel-syntax--constructor-regex (line-end-position) t)))
+
+(defsubst fuel-syntax--at-using ()
+ (looking-at fuel-syntax--using-lines-regex))
+
+(defsubst fuel-syntax--beginning-of-defun (&optional times)
+ (re-search-backward fuel-syntax--begin-of-def-regex nil t times))
+
+(defsubst fuel-syntax--end-of-defun ()
+ (re-search-forward fuel-syntax--end-of-def-regex nil t))
+
+\f
+;;; USING/IN:
+
+(make-variable-buffer-local
+ (defvar fuel-syntax--current-vocab nil))
+
+(make-variable-buffer-local
+ (defvar fuel-syntax--usings nil))
+
+(defun fuel-syntax--current-vocab ()
+ (let ((ip
+ (save-excursion
+ (when (re-search-backward fuel-syntax--current-vocab-regex nil t)
+ (setq fuel-syntax--current-vocab (match-string-no-properties 1))
+ (point)))))
+ (when ip
+ (let ((pp (save-excursion
+ (when (re-search-backward fuel-syntax--sub-vocab-regex ip t)
+ (point)))))
+ (when (and pp (> pp ip))
+ (let ((sub (match-string-no-properties 1)))
+ (unless (save-excursion (search-backward (format "%s>" sub) pp t))
+ (setq fuel-syntax--current-vocab
+ (format "%s.%s" fuel-syntax--current-vocab (downcase sub)))))))))
+ fuel-syntax--current-vocab)
+
+(defun fuel-syntax--usings-update ()
+ (save-excursion
+ (setq fuel-syntax--usings (list (fuel-syntax--current-vocab)))
+ (while (re-search-backward fuel-syntax--using-lines-regex nil t)
+ (dolist (u (split-string (match-string-no-properties 1) nil t))
+ (push u fuel-syntax--usings)))
+ fuel-syntax--usings))
+
+(defsubst fuel-syntax--usings-update-hook ()
+ (fuel-syntax--usings-update)
+ nil)
+
+(defun fuel-syntax--enable-usings ()
+ (add-hook 'before-save-hook 'fuel-syntax--usings-update-hook nil t)
+ (fuel-syntax--usings-update))
+
+(defsubst fuel-syntax--usings ()
+ (or fuel-syntax--usings (fuel-syntax--usings-update)))
+
+\f
+(provide 'fuel-syntax)
+;;; fuel-syntax.el ends here
+++ /dev/null
-This directory contains Factor code that is not part of the core
-library, but is useful enough to ship with the Factor distribution.
-
-Modules can be loaded from the listener:
-
- "libs/modulename" require
-
-Available libraries:
-
-- alarms -- call a quotation at a calendar date (Doug Coleman)
-- alien -- Alien utility words (Eduardo Cavazos)
-- base64 -- base64 encoding/decoding (Doug Coleman)
-- basic-authentication -- basic authentication implementation for HTTP server (Chris Double)
-- cairo -- cairo bindings (Sampo Vuori)
-- calendar -- timestamp/calendar with timezones (Doug Coleman)
-- canvas -- Gadget which renders an OpenGL display list (Slava Pestov)
-- cocoa-callbacks -- Allows you to use Factor quotations as actions (Slava Pestov)
-- concurrency -- Erlang/Termite-style distibuted concurrency (Chris Double)
-- coroutines -- coroutines (Chris Double)
-- cryptlib -- cryptlib binding (Elie Chaftari)
-- crypto -- Various cryptographic algorithms (Doug Coleman)
-- csv -- Comma-separated values parser (Daniel Ehrenberg)
-- dlists -- double-linked-lists (Mackenzie Straight)
-- editpadpro -- EditPadPro integration for Windows (Ryan Murphy)
-- emacs -- emacs integration (Eduardo Cavazos)
-- farkup -- Wiki-style markup (Matthew Willis)
-- file-appender -- append to existing files (Doug Coleman)
-- fjsc -- Factor to Javascript compiler (Chris Double)
-- furnace -- Web framework (Slava Pestov)
-- gap-buffer -- Efficient text editor buffer (Alex Chapman)
-- graphics -- Graphics library in Factor (Doug Coleman)
-- hardware-info -- Information about your computer (Doug Coleman)
-- handler -- Gesture handler mixin (Eduardo Cavazos)
-- heap -- Binary min heap implementation (Ryan Murphy)
-- hexdump -- Hexdump routine (Doug Coleman)
-- http -- Code shared by HTTP server and client (Slava Pestov)
-- http-client -- HTTP client (Slava Pestov)
-- id3 -- ID3 parser (Adam Wendt)
-- io -- mmap, filesystem utils (Doug Coleman)
-- jedit -- jEdit editor integration (Slava Pestov)
-- jni -- Java Native Interface Wrapper (Chris Double)
-- json -- JSON reader and writer (Chris Double)
-- koszul -- Lie algebra cohomology and central representation (Slava Pestov)
-- lazy-lists -- Lazy evaluation lists (Chris Double, Matthew Willis)
-- locals -- Crappy local variables (Slava Pestov)
-- mad -- Wrapper for libmad MP3 decoder (Adam Wendt)
-- match -- pattern matching (Chris Double)
-- math -- extended math library (Doug Coleman, Slava Pestov)
-- matrices -- Matrix math (Slava Pestov)
-- memoize -- memoization (caching word results) (Slava Pestov)
-- mmap -- memory mapped files (Doug Coleman)
-- mysql -- MySQL binding (Berlin Brown)
-- null-stream -- Something akin to /dev/null (Slava Pestov)
-- odbc -- Wrapper for ODBC library (Chris Double)
-- ogg -- Wrapper for libogg library (Chris Double)
-- openal -- Wrapper for OpenAL and alut sound libraries (Chris Double)
-- oracle -- Oracle binding (Elie Chaftari)
-- parser-combinators -- Haskell-style parser combinators (Chris Double)
-- porter-stemmer -- Porter stemming algorithm (Slava Pestov)
-- postgresql -- PostgreSQL binding (Doug Coleman)
-- process -- Run external programs (Slava Pestov, Doug Coleman)
-- qualified -- Qualified names for words in other vocabularies (Daniel Ehrenberg)
-- rewrite-closures -- Turn quotations into closures (Eduardo Cavazos)
-- scite -- SciTE editor integration (Clemens F. Hofreither)
-- sequences -- Non-core sequence words (Eduardo Cavazos)
-- serialize -- Binary object serialization (Chris Double)
-- server -- The with-server combinator formely found in the core (Slava Pestov)
-- slate -- Framework for graphical demos (Eduardo Cavazos)
-- shuffle -- Shuffle words not in the core library (Chris Double)
-- smtp -- SMTP client library (Elie Chaftari)
-- splay-trees -- Splay trees (Mackenzie Straight)
-- sqlite -- SQLite binding (Chris Double)
-- state-machine -- Finite state machine abstraction (Daniel Ehrenberg)
-- state-parser -- State-based parsing mechanism (Daniel Ehrenberg)
-- textmate -- TextMate integration (Benjamin Pollack)
-- theora -- Wrapper for libtheora library (Chris Double)
-- trees -- Binary search and AVL (balanced) trees (Alex Chapman)
-- usb -- Wrapper for libusb (Chris Double)
-- unicode -- Partial Unicode support beyond the core (Daniel Ehrenberg)
-- units -- Unit conversion (Doug Coleman)
-- vars -- Alternative syntax for variables (Eduardo Cavazos)
-- vim -- VIM integration (Alex Chapman)
-- visitor -- Double dispatch through the visitor pattern (Daniel Ehrenberg)
-- vorbis -- Wrapper for Ogg Vorbis library (Chris Double)
-- x11 -- X Window System client library (Eduardo Cavazos)
-- xml -- XML parser (Daniel Ehrenberg)
-- xml-rpc -- XML-RPC client and server (Daniel Ehrenberg)
-- yahoo -- Yahoo! automated search (Daniel Ehrenberg)
+++ /dev/null
-This directory contains Factor code that is not part of the core
-library, but is useful enough to ship with the Factor distribution.
-
-Modules can be loaded from the listener:
-
- "apps/modulename" require
-
-Available applications:
-
-- article-manager -- Web-based content management system (Chris Double)
-- automata -- Graphics demo for the UI (Eduardo Cavazos)
-- benchmarks -- Various performance benchmarks (Slava Pestov)
-- boids -- Graphics demo for the UI (Eduardo Cavazos)
-- factory -- X11 window manager (Eduardo Cavazos)
-- furnace-fjsc -- Web frontend for libs/fjsc (Chris Double)
-- furnace-onigiri -- Weblog engine (Matthew Willis)
-- furnace-pastebin -- demo app for Furnace (Slava Pestov)
-- help-lint -- online documentation typo checker (Slava Pestov)
-- icfp-2006 -- implements the icfp 2006 vm, boundvariable.org (Gavin Harrison)
-- http-server -- HTTP server (Slava Pestov, Chris Double)
-- lindenmayer -- L-systems tool (Eduardo Cavazos)
-- lisppaste -- Lisppaste XML-RPC demo (Slava Pestov)
-- ogg-player -- Ogg Vorbis (audio) and Theora (video) player (Chris Double)
-- print-dataflow -- Code to print compiler dataflow IR to the console, or show it in the UI (Slava Pestov)
-- random-tester -- Random compiler tester (Doug Coleman)
-- rss -- An RSS1, RSS2 and Atom parser and aggregator (Chris Double, Daniel Ehrenberg)
-- space-invaders -- Intel 8080-based Space Invaders arcade machine emulator (Chris Double)
-- tetris -- Tetris game (Alex Chapman)
-- turing -- Turing machine demo (Slava Pestov)
-- wee-url -- Web app to make short URLs from long ones (Doug Coleman)
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: io lint kernel math tools.test ;
-IN: lint.tests
-
-! Don't write code like this
-: lint1
- [ "hi" print ] [ ] if ; ! when
-
-[ { [ [ ] if ] } ] [ \ lint1 lint ] unit-test
-
-: lint2
- 1 + ; ! 1+
-[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
-
-: lint3
- dup -rot ; ! tuck
-
-[ { [ dup -rot ] } ] [ \ lint3 lint ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.accessors arrays assocs
-combinators.lib io kernel macros math namespaces prettyprint
-quotations sequences vectors vocabs words html.elements sets
-slots.private combinators.short-circuit math.order hashtables
-sequences.deep ;
-IN: lint
-
-SYMBOL: def-hash
-SYMBOL: def-hash-keys
-
-: set-hash-vector ( val key hash -- )
- 2dup at -rot [ ?push ] 2dip set-at ;
-
-: add-word-def ( word quot -- )
- dup callable? [
- def-hash get-global set-hash-vector
- ] [
- 2drop
- ] if ;
-
-: more-defs ( -- )
- {
- { [ swap >r swap r> ] -rot }
- { [ swap swapd ] -rot }
- { [ >r swap r> swap ] rot }
- { [ swapd swap ] rot }
- { [ dup swap ] over }
- { [ dup -rot ] tuck }
- { [ >r swap r> ] swapd }
- { [ nip nip ] 2nip }
- { [ drop drop ] 2drop }
- { [ drop drop drop ] 3drop }
- { [ 0 = ] zero? }
- { [ pop drop ] pop* }
- { [ [ ] if ] when }
- { [ f = not ] >boolean }
- } [ first2 swap add-word-def ] each ;
-
-: accessor-words ( -- seq )
-{
- alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
- alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
- <displaced-alien> alien-unsigned-cell set-alien-signed-cell
- set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
- set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
- set-alien-unsigned-8 set-alien-signed-8
- alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
- set-alien-float alien-float
-} ;
-
-: trivial-defs
- {
- [ get ] [ t ] [ { } ] [ . ] [ drop f ]
- [ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ]
- [ ">" write-html ] [ "/>" write-html ]
- } ;
-
-H{ } clone def-hash set-global
-all-words [ dup def>> add-word-def ] each
-more-defs
-
-! Remove empty word defs
-def-hash get-global [
- drop empty? not
-] assoc-filter
-
-! Remove constants [ 1 ]
-[
- drop { [ length 1 = ] [ first number? ] } 1&& not
-] assoc-filter
-
-! Remove set-alien-cell, etc.
-[
- drop [ accessor-words diff ] keep [ length ] bi@ =
-] assoc-filter
-
-! Remove trivial defs
-[
- drop trivial-defs member? not
-] assoc-filter
-
-[
- drop {
- [ [ wrapper? ] deep-contains? ]
- [ [ hashtable? ] deep-contains? ]
- } 1|| not
-] assoc-filter
-
-! Remove n m shift defs
-[
- drop dup length 3 = [
- dup first2 [ number? ] both?
- swap third \ shift = and not
- ] [ drop t ] if
-] assoc-filter
-
-! Remove [ n slot ]
-[
- drop dup length 2 = [
- first2 \ slot = swap number? and not
- ] [ drop t ] if
-] assoc-filter def-hash set-global
-
-: find-duplicates ( -- seq )
- def-hash get-global [
- nip length 1 >
- ] assoc-filter ;
-
-def-hash get-global keys def-hash-keys set-global
-
-GENERIC: lint ( obj -- seq )
-
-M: object lint ( obj -- seq )
- drop f ;
-
-: subseq/member? ( subseq/member seq -- ? )
- { [ start ] [ member? ] } 2|| ;
-
-M: callable lint ( quot -- seq )
- def-hash-keys get [
- swap subseq/member?
- ] with filter ;
-
-M: word lint ( word -- seq )
- def>> dup callable? [ lint ] [ drop f ] if ;
-
-: word-path. ( word -- )
- [ vocabulary>> ":" ] keep unparse 3append write nl ;
-
-: (lint.) ( pair -- )
- first2 >r word-path. r> [
- bl bl bl bl
- dup .
- "-----------------------------------" print
- def-hash get at [ bl bl bl bl word-path. ] each
- nl
- ] each nl nl ;
-
-: lint. ( alist -- )
- [ (lint.) ] each ;
-
-
-GENERIC: run-lint ( obj -- obj )
-
-: (trim-self) ( val key -- obj ? )
- def-hash get-global at* [
- dupd remove empty? not
- ] [
- drop f
- ] if ;
-
-: trim-self ( seq -- newseq )
- [ [ (trim-self) ] filter ] assoc-map ;
-
-: filter-symbols ( alist -- alist )
- [
- nip first dup def-hash get at
- [ first ] bi@ literalize = not
- ] assoc-filter ;
-
-M: sequence run-lint ( seq -- seq )
- [
- global [ dup . flush ] bind
- dup lint
- ] { } map>assoc
- trim-self
- [ second empty? not ] filter
- filter-symbols ;
-
-M: word run-lint ( word -- seq )
- 1array run-lint ;
-
-: lint-all ( -- seq )
- all-words run-lint dup lint. ;
-
-: lint-vocab ( vocab -- seq )
- words run-lint dup lint. ;
-
-: lint-word ( word -- seq )
- 1array run-lint dup lint. ;
+++ /dev/null
-Finds potential mistakes in code
}
#define BIGNUM_REDUCE_LENGTH(source, length) \
- source = reallot_array(source,length + 1,0)
+ source = reallot_array(source,length + 1)
/* allocates memory */
bignum_type
/* Perform all fixups on a code block */
void relocate_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
+ compiled->last_scan = NURSERY;
+
if(compiled->relocation != F)
{
F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
data_heap->gen_count = gens;
CELL total_size;
- if(data_heap->gen_count == 1)
- total_size = 2 * tenured_size;
- else if(data_heap->gen_count == 2)
+ if(data_heap->gen_count == 2)
total_size = young_size + 2 * tenured_size;
else if(data_heap->gen_count == 3)
total_size = young_size + 2 * aging_size + 2 * tenured_size;
}
gc();
- iterate_code_heap(relocate_code_block);
+
+ compile_all_words();
}
CELL find_all_words(void)
/* the oldest generation */
#define TENURED (data_heap->gen_count-1)
+#define MIN_GEN_COUNT 1
#define MAX_GEN_COUNT 3
/* used during garbage collection only */
print_string("*** Stage 2 early init... ");
fflush(stdout);
- CELL words = find_all_words();
-
- REGISTER_ROOT(words);
-
- CELL i;
- CELL length = array_capacity(untag_object(words));
- for(i = 0; i < length; i++)
- {
- F_WORD *word = untag_word(array_nth(untag_array(words),i));
- REGISTER_UNTAGGED(word);
- default_word_code(word,false);
- UNREGISTER_UNTAGGED(word);
- update_word_xt(word);
- }
-
- UNREGISTER_ROOT(words);
-
- iterate_code_heap(relocate_code_block);
-
+ compile_all_words();
userenv[STAGE2_ENV] = T;
print_string("done\n");
void primitive_bignum_shift(void)
{
- F_FIXNUM y = to_fixnum(dpop());
+ F_FIXNUM y = untag_fixnum_fast(dpop());
F_ARRAY* x = untag_object(dpop());
dpush(tag_bignum(bignum_arithmetic_shift(x,y)));
}
F_QUOTATION *quot = untag_quotation(dpeek());
drepl(allot_cell((CELL)quot->xt));
}
+
+void compile_all_words(void)
+{
+ CELL words = find_all_words();
+
+ REGISTER_ROOT(words);
+
+ CELL i;
+ CELL length = array_capacity(untag_object(words));
+ for(i = 0; i < length; i++)
+ {
+ F_WORD *word = untag_word(array_nth(untag_array(words),i));
+ REGISTER_UNTAGGED(word);
+ if(word->compiledp == F)
+ default_word_code(word,false);
+ UNREGISTER_UNTAGGED(word);
+ update_word_xt(word);
+ }
+
+ UNREGISTER_ROOT(words);
+
+ iterate_code_heap(relocate_code_block);
+}
void primitive_array_to_quotation(void);
void primitive_quotation_xt(void);
void primitive_jit_compile(void);
+void compile_all_words(void);
return tag_object(a);
}
-F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill)
+F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity)
{
- int i;
- F_ARRAY* new_array;
-
CELL to_copy = array_capacity(array);
if(capacity < to_copy)
to_copy = capacity;
REGISTER_UNTAGGED(array);
- REGISTER_ROOT(fill);
-
- new_array = allot_array_internal(untag_header(array->header),capacity);
-
- UNREGISTER_ROOT(fill);
+ F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity);
UNREGISTER_UNTAGGED(array);
memcpy(new_array + 1,array + 1,to_copy * CELLS);
-
- for(i = to_copy; i < capacity; i++)
- put(AREF(new_array,i),fill);
+ memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS);
return new_array;
}
{
F_ARRAY* array = untag_array(dpop());
CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_array(array,capacity,F)));
+ dpush(tag_object(reallot_array(array,capacity)));
}
F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count)
if(*result_count == array_capacity(result))
{
- result = reallot_array(result,
- *result_count * 2,F);
+ result = reallot_array(result,*result_count * 2);
}
UNREGISTER_ROOT(elt);
CELL new_size = *result_count + elts_size;
if(new_size >= array_capacity(result))
- result = reallot_array(result,new_size * 2,F);
+ result = reallot_array(result,new_size * 2);
UNREGISTER_UNTAGGED(elts);
dpush(tag_object(allot_string(length,initial)));
}
-void primitive_uninitialized_string(void)
-{
- CELL length = unbox_array_size();
- dpush(tag_object(allot_string_internal(length)));
-}
-
-F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill)
+F_STRING* reallot_string(F_STRING* string, CELL capacity)
{
CELL to_copy = string_capacity(string);
if(capacity < to_copy)
REGISTER_UNTAGGED(string);
REGISTER_UNTAGGED(new_string);
- fill_string(new_string,to_copy,capacity,fill);
+ fill_string(new_string,to_copy,capacity,'\0');
UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
{
F_STRING* string = untag_string(dpop());
CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_string(string,capacity,0)));
+ dpush(tag_object(reallot_string(string,capacity)));
}
/* Some ugly macros to prevent a 2x code duplication */
void primitive_uninitialized_byte_array(void);
void primitive_clone(void);
-F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
+F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity);
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
void primitive_resize_array(void);
void primitive_resize_byte_array(void);
F_STRING* allot_string(CELL capacity, CELL fill);
void primitive_uninitialized_string(void);
void primitive_string(void);
-F_STRING *reallot_string(F_STRING *string, CELL capacity, CELL fill);
+F_STRING *reallot_string(F_STRING *string, CELL capacity);
void primitive_resize_string(void);
F_STRING *memory_to_char_string(const char *string, CELL length);
result = tag_object(growable_array_append(untag_object(result),elts,&result##_count))
#define GROWABLE_ARRAY_TRIM(result) \
- result = tag_object(reallot_array(untag_object(result),result##_count,F))
+ result = tag_object(reallot_array(untag_object(result),result##_count))
/* Macros to simulate a byte vector in C */
#define GROWABLE_BYTE_ARRAY(result) \
projects / factor.git / commitdiff