From f50821af6e14025dcd049601645dfaf17a62e014 Mon Sep 17 00:00:00 2001
From: Matthew Willis <matthew.willis@mac.com>
Date: Wed, 12 Mar 2008 02:11:03 -0700
Subject: [PATCH 001/127] Implement sequence matching in extra/match.
---
extra/match/match.factor | 23 +++++++++++++++++++++++
1 file changed, 23 insertions(+)
diff --git a/extra/match/match.factor b/extra/match/match.factor
index 722c330a32..36af5c990a 100755
--- a/extra/match/match.factor
+++ b/extra/match/match.factor
@@ -65,3 +65,26 @@ MACRO: match-cond ( assoc -- )
-rot
match [ "Pattern does not match" throw ] unless*
[ replace-patterns ] bind ;
+
+: ?1-tail ( seq -- tail/f )
+ dup length zero? not [ 1 tail ] [ drop f ] if ;
+
+: (match-first) ( seq pattern-seq -- bindings leftover/f )
+ 2dup [ length ] 2apply < [ 2drop f f ]
+ [
+ 2dup length head over match
+ [ nip swap ?1-tail ] [ >r 1 tail r> (match-first) ] if*
+ ] if ;
+
+: match-first ( seq pattern-seq -- bindings )
+ (match-first) drop ;
+
+: (match-all) ( seq pattern-seq -- )
+ tuck (match-first) swap
+ [
+ , [ swap (match-all) ] [ drop ] if*
+ ] [ 2drop ] if* ;
+
+: match-all ( seq pattern-seq -- bindings-seq )
+ [ (match-all) ] { } make ;
+
From 78633e03a0d9951407e33c01c8e33eac0205657e Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sun, 30 Mar 2008 19:01:47 +1300
Subject: [PATCH 002/127] Allow var names in ebnf but ignore them for now
---
extra/peg/ebnf/ebnf.factor | 7 +++++++
1 file changed, 7 insertions(+)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index af61c3aae0..0ae1430c8c 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -19,6 +19,7 @@ TUPLE: ebnf-repeat1 group ;
TUPLE: ebnf-optional group ;
TUPLE: ebnf-rule symbol elements ;
TUPLE: ebnf-action parser code ;
+TUPLE: ebnf-var parser name ;
TUPLE: ebnf rules ;
C: <ebnf-non-terminal> ebnf-non-terminal
@@ -34,6 +35,7 @@ C: <ebnf-repeat1> ebnf-repeat1
C: <ebnf-optional> ebnf-optional
C: <ebnf-rule> ebnf-rule
C: <ebnf-action> ebnf-action
+C: <ebnf-var> ebnf-var
C: <ebnf> ebnf
: syntax ( string -- parser )
@@ -79,6 +81,7 @@ C: <ebnf> ebnf
[ dup CHAR: * = ]
[ dup CHAR: + = ]
[ dup CHAR: ? = ]
+ [ dup CHAR: : = ]
} || not nip
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
@@ -200,6 +203,7 @@ DEFER: 'choice'
: 'actioned-sequence' ( -- parser )
[
[ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 <ebnf-action> ] action ,
+ [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
'sequence' ,
] choice* ;
@@ -270,6 +274,9 @@ M: ebnf-action (transform) ( ast -- parser )
[ parser>> (transform) ] keep
code>> string-lines [ parse-lines ] with-compilation-unit action ;
+M: ebnf-var (transform) ( ast -- parser )
+ parser>> (transform) ;
+
M: ebnf-terminal (transform) ( ast -- parser )
symbol>> token sp ;
From f49d26e8d060c745b31dd72454462d0625cef2eb Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Sun, 30 Mar 2008 01:13:29 -0500
Subject: [PATCH 003/127] make copy-tree and delete-tree symlink aware
---
core/io/files/files.factor | 30 ++++++++++++++++++------------
extra/io/unix/files/files.factor | 19 +++++++++++++++----
extra/unix/unix.factor | 4 ++++
3 files changed, 37 insertions(+), 16 deletions(-)
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 48098e612d..4dbbb869c4 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -3,7 +3,7 @@
USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations io.encodings
-io.encodings.binary init ;
+io.encodings.binary init accessors ;
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
@@ -145,8 +145,14 @@ PRIVATE>
TUPLE: file-info type size permissions modified ;
HOOK: file-info io-backend ( path -- info )
+
+! Symlinks
HOOK: link-info io-backend ( path -- info )
+HOOK: make-link io-backend ( path1 path2 -- )
+
+HOOK: read-link io-backend ( path -- info )
+
SYMBOL: +regular-file+
SYMBOL: +directory+
SYMBOL: +character-device+
@@ -218,14 +224,14 @@ HOOK: delete-file io-backend ( path -- )
HOOK: delete-directory io-backend ( path -- )
-: (delete-tree) ( path dir? -- )
- [
- dup directory* [ (delete-tree) ] assoc-each
- delete-directory
- ] [ delete-file ] if ;
-
: delete-tree ( path -- )
- dup directory? (delete-tree) ;
+ dup link-info type>> +directory+ = [
+ dup directory over [
+ [ first delete-tree ] each
+ ] with-directory delete-directory
+ ] [
+ delete-file
+ ] if ;
: to-directory over file-name append-path ;
@@ -258,10 +264,10 @@ M: object copy-file
DEFER: copy-tree-into
: copy-tree ( from to -- )
- over directory? [
- >r dup directory swap r> [
- >r swap first append-path r> copy-tree-into
- ] 2curry each
+ over link-info type>> +directory+ = [
+ >r dup directory r> rot [
+ [ >r first r> copy-tree-into ] curry each
+ ] with-directory
] [
copy-file
] if ;
diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor
index 3b493d2fe4..759ac2bec1 100755
--- a/extra/io/unix/files/files.factor
+++ b/extra/io/unix/files/files.factor
@@ -3,7 +3,7 @@
USING: io.backend io.nonblocking io.unix.backend io.files io
unix unix.stat unix.time kernel math continuations
math.bitfields byte-arrays alien combinators calendar
-io.encodings.binary ;
+io.encodings.binary accessors sequences strings ;
IN: io.unix.files
@@ -49,7 +49,7 @@ M: unix-io touch-file ( path -- )
close ;
M: unix-io move-file ( from to -- )
- [ normalize-pathname ] 2apply rename io-error ;
+ [ normalize-pathname ] bi@ rename io-error ;
M: unix-io delete-file ( path -- )
normalize-pathname unlink io-error ;
@@ -69,7 +69,7 @@ M: unix-io delete-directory ( path -- )
] with-disposal ;
M: unix-io copy-file ( from to -- )
- [ normalize-pathname ] 2apply
+ [ normalize-pathname ] bi@
[ (copy-file) ]
[ swap file-info file-info-permissions chmod io-error ]
2bi ;
@@ -84,7 +84,7 @@ M: unix-io copy-file ( from to -- )
{ [ dup S_ISLNK ] [ +symbolic-link+ ] }
{ [ dup S_ISSOCK ] [ +socket+ ] }
{ [ t ] [ +unknown+ ] }
- } cond nip ;
+ } cond nip ;
: stat>file-info ( stat -- info )
{
@@ -100,3 +100,14 @@ M: unix-io file-info ( path -- info )
M: unix-io link-info ( path -- info )
normalize-pathname lstat* stat>file-info ;
+
+M: unix-io make-link ( path1 path2 -- )
+ normalize-pathname symlink io-error ;
+
+M: unix-io read-link ( path -- path' )
+ normalize-pathname
+ PATH_MAX [ <byte-array> tuck ] [ ] bi readlink
+ dup io-error head-slice >string ;
+
+: copy-link ( path1 path2 -- )
+ >r read-link r> make-link ;
diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index bed87ebd0f..ffd102901c 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -77,6 +77,7 @@ FUNCTION: int pclose ( void* file ) ;
FUNCTION: int pipe ( int* filedes ) ;
FUNCTION: void* popen ( char* command, char* type ) ;
FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ;
+FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ;
FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ;
FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ;
FUNCTION: int rename ( char* from, char* to ) ;
@@ -93,6 +94,7 @@ FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_
FUNCTION: int setuid ( uid_t uid ) ;
FUNCTION: int socket ( int domain, int type, int protocol ) ;
FUNCTION: char* strerror ( int errno ) ;
+FUNCTION: int symlink ( char* path1, char* path2 ) ;
FUNCTION: int system ( char* command ) ;
FUNCTION: int unlink ( char* path ) ;
FUNCTION: int utimes ( char* path, timeval[2] times ) ;
@@ -102,6 +104,8 @@ FUNCTION: int utimes ( char* path, timeval[2] times ) ;
FUNCTION: int kill ( pid_t pid, int sig ) ;
+: PATH_MAX 1024 ; inline
+
: PRIO_PROCESS 0 ; inline
: PRIO_PGRP 1 ; inline
: PRIO_USER 2 ; inline
From b4d2a0b1051061b37a68e80a92bd8673eaa30fb5 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Sun, 30 Mar 2008 01:14:28 -0500
Subject: [PATCH 004/127] add constant to grovel
---
build-support/grovel.c | 2 ++
1 file changed, 2 insertions(+)
diff --git a/build-support/grovel.c b/build-support/grovel.c
index 2eee054dab..db16aa9bca 100644
--- a/build-support/grovel.c
+++ b/build-support/grovel.c
@@ -42,6 +42,7 @@
#include <sys/socket.h>
#include <sys/errno.h>
#include <sys/mman.h>
+ #include <sys/syslimits.h>
#include <fcntl.h>
#include <unistd.h>
#endif
@@ -146,6 +147,7 @@ void unix_constants()
constant(PROT_WRITE);
constant(MAP_FILE);
constant(MAP_SHARED);
+ constant(PATH_MAX);
grovel(pid_t);
}
From bb8198d3d0163e0cacc701e21588c16e858d2b08 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Sun, 30 Mar 2008 23:24:02 +1300
Subject: [PATCH 005/127] Declare stack effects for compiled parsers
---
extra/peg/ebnf/ebnf.factor | 4 ++--
extra/peg/peg.factor | 8 ++++----
2 files changed, 6 insertions(+), 6 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 0ae1430c8c..41b5a1b655 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -3,7 +3,7 @@
USING: kernel compiler.units parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
peg.parsers unicode.categories multiline combinators.lib
- splitting accessors ;
+ splitting accessors effects ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
@@ -310,5 +310,5 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
: EBNF:
CREATE-WORD dup
";EBNF" parse-multiline-string
- ebnf>quot swapd define "ebnf-parser" set-word-prop ; parsing
+ ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop ; parsing
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 8621b43a7f..a09962783b 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -3,7 +3,7 @@
USING: kernel sequences strings namespaces math assocs shuffle
vectors arrays combinators.lib math.parser match
unicode.categories sequences.lib compiler.units parser
- words quotations effects memoize accessors locals ;
+ words quotations effects memoize accessors locals effects ;
IN: peg
USE: prettyprint
@@ -206,7 +206,7 @@ GENERIC: (compile) ( parser -- quot )
:: parser-body ( parser -- quot )
#! Return the body of the word that is the compiled version
#! of the parser.
- [let* | rule [ parser (compile) define-temp dup parser "peg" set-word-prop ]
+ [let* | rule [ gensym dup parser (compile) 0 1 <effect> define-declared dup parser "peg" set-word-prop ]
|
[
rule pos get apply-rule dup fail = [
@@ -216,7 +216,7 @@ GENERIC: (compile) ( parser -- quot )
] if
]
] ;
-
+
: compiled-parser ( parser -- word )
#! Look to see if the given parser has been compiled.
#! If not, compile it to a temporary word, cache it,
@@ -227,7 +227,7 @@ GENERIC: (compile) ( parser -- quot )
dup compiled>> [
nip
] [
- gensym tuck >>compiled 2dup parser-body define dupd "peg" set-word-prop
+ gensym tuck >>compiled 2dup parser-body 0 1 <effect> define-declared dupd "peg" set-word-prop
] if* ;
: compile ( parser -- word )
From 5989680a7b992b392dbb57ca99f3909140f2b879 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Mon, 31 Mar 2008 00:53:33 +1300
Subject: [PATCH 006/127] Ensure box parsers are never cached
---
extra/peg/peg.factor | 14 +++++++++++---
1 file changed, 11 insertions(+), 3 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index a09962783b..e07942a3cd 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -488,8 +488,11 @@ M: box-parser (compile) ( parser -- quot )
#! Calls the quotation at compile time
#! to produce the parser to be compiled.
#! This differs from 'delay' which calls
- #! it at run time.
- quot>> call compiled-parser 1quotation ;
+ #! it at run time. Due to using the runtime
+ #! environment at compile time, this parser
+ #! must not be cached, so we clear out the
+ #! delgates cache.
+ f >>compiled quot>> call compiled-parser 1quotation ;
PRIVATE>
@@ -560,7 +563,12 @@ PRIVATE>
delay-parser construct-boa init-parser ;
: box ( quot -- parser )
- box-parser construct-boa init-parser ;
+ #! because a box has its quotation run at compile time
+ #! it must always have a new parser delgate created,
+ #! not a cached one. This is because the same box,
+ #! compiled twice can have a different compiled word
+ #! due to running at compile time.
+ box-parser construct-boa next-id f <parser> over set-delegate ;
: PEG:
(:) [
From 8bc2589a7a75bdee2e8c5c057b240a74f5eab062 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 30 Mar 2008 08:16:07 -0500
Subject: [PATCH 007/127] Documentation updates
---
core/kernel/kernel-docs.factor | 69 ++++++++++++++++++++++++-----
extra/help/cookbook/cookbook.factor | 33 ++++++++++----
2 files changed, 84 insertions(+), 18 deletions(-)
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index a446869096..1c88f5a485 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -7,6 +7,8 @@ IN: kernel
ARTICLE: "shuffle-words" "Shuffle words"
"Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions."
$nl
+"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "."
+$nl
"Removing stack elements:"
{ $subsection drop }
{ $subsection 2drop }
@@ -39,9 +41,28 @@ $nl
{ $code
": foo ( m ? n -- m+n/n )"
" >r [ r> + ] [ drop r> ] if ; ! This is OK"
-}
-"An alternative to using " { $link >r } " and " { $link r> } " is the following:"
-{ $subsection dip } ;
+} ;
+
+ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
+"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
+$nl
+"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:"
+{ $code
+ ": keep [ ] bi ;"
+ ": 2keep [ ] 2bi ;"
+ ": 3keep [ ] 3bi ;"
+ ""
+ ": dup [ ] [ ] bi ;"
+ ": 2dup [ ] [ ] 2bi ;"
+ ": 3dup [ ] [ ] 3bi ;"
+ ""
+ ": tuck [ nip ] [ ] 2bi ;"
+ ": swap [ nip ] [ drop ] 2bi ;"
+ ""
+ ": over [ ] [ drop ] 2bi ;"
+ ": pick [ ] [ 2drop ] 3bi ;"
+ ": 2over [ ] [ drop ] 3bi ;"
+} ;
ARTICLE: "cleave-combinators" "Cleave combinators"
"The cleave combinators apply multiple quotations to a single value."
@@ -49,9 +70,11 @@ $nl
"Two quotations:"
{ $subsection bi }
{ $subsection 2bi }
+{ $subsection 3bi }
"Three quotations:"
{ $subsection tri }
{ $subsection 2tri }
+{ $subsection 3tri }
"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
{ $code
"! First alternative; uses keep"
@@ -66,13 +89,38 @@ $nl
"The latter is more aesthetically pleasing than the former."
$nl
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
+{ $subsection "cleave-shuffle-equivalence" } ;
+
+ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
+"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "."
$nl
-"From the Merriam-Webster Dictionary: "
-$nl
-{ $strong "cleave" }
-{ $list
- { $emphasis "To divide by or as if by a cutting blow" }
- { $emphasis "To separate into distinct parts and especially into groups having divergent views" }
+"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
+{ $code
+ ": dip [ ] bi* ;"
+ ""
+ ": slip [ call ] [ ] bi* ;"
+ ": 2slip [ call ] [ ] [ ] tri* ;"
+ ""
+ ": nip [ drop ] [ ] bi* ;"
+ ": 2nip [ drop ] [ drop ] [ ] tri* ;"
+ ""
+ ": rot"
+ " [ [ drop ] [ ] [ drop ] tri* ]"
+ " [ [ drop ] [ drop ] [ ] tri* ]"
+ " [ [ ] [ drop ] [ drop ] tri* ]"
+ " 3tri ;"
+ ""
+ ": -rot"
+ " [ [ drop ] [ drop ] [ ] tri* ]"
+ " [ [ ] [ drop ] [ drop ] tri* ]"
+ " [ [ drop ] [ ] [ drop ] tri* ]"
+ " 3tri ;"
+ ""
+ ": spin"
+ " [ [ drop ] [ drop ] [ ] tri* ]"
+ " [ [ drop ] [ ] [ drop ] tri* ]"
+ " [ [ ] [ drop ] [ drop ] tri* ]"
+ " 3tri ;"
} ;
ARTICLE: "spread-combinators" "Spread combinators"
@@ -96,7 +144,8 @@ $nl
}
$nl
-"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." ;
+"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
+{ $subsection "spread-shuffle-equivalence" } ;
ARTICLE: "apply-combinators" "Apply combinators"
"The apply combinators apply multiple quotations to multiple values. The " { $snippet "@" } " suffix signifies application."
diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor
index 319dd1586b..075ce2d0e8 100755
--- a/extra/help/cookbook/cookbook.factor
+++ b/extra/help/cookbook/cookbook.factor
@@ -267,16 +267,33 @@ $nl
} ;
ARTICLE: "cookbook-philosophy" "Factor philosophy"
-"Factor is a high-level language with automatic memory management, runtime type checking, and strong typing. Factor code should be as simple as possible, but not simpler. If you are coming to Factor from another programming language, one of your first observations might be related to the amount of code you " { $emphasis "don't" } " have to write."
+"Learning a stack language is like learning to ride a bicycle: it takes a bit of practice and you might graze your knees a couple of times, but once you get the hang of it, it becomes second nature."
$nl
-"If you try to write Factor word definitions which are longer than a couple of lines, you will find it hard to keep track of the stack contents. Well-written Factor code is " { $emphasis "factored" } " into short definitions, where each definition is easy to test interactively, and has a clear purpose. Well-chosen word names are critical, and having a thesaurus on hand really helps."
-$nl
-"If you run into problems with stack shuffling, take a deep breath and a step back, and reconsider the problem. A much simpler solution is waiting right around the corner, a natural solution which requires far less stack shuffling and far less code. As a last resort, if no simple solution exists, consider defining a domain-specific language."
-$nl
-"Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition and save yourself some debugging time."
-$nl
-"In addition to writing short definitions and testing them interactively, a great habit to get into is writing unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } "."
+"The most common difficulty encountered by beginners is trouble reading and writing code as a result of trying to place too many values on the stack at a time."
$nl
+"Keep the following guidelines in mind to avoid losing your sense of balance:"
+{ $list
+ "SImplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines."
+ "In addition to keeping your words short, keep them meaningful. Give them good names, and make sure each word only does one thing. Try documenting your words; if the documentation for a word is unclear or complex, chances are the word definition is too. Don't be afraid to refactor your code."
+ "If your code looks repetitive, factor it some more."
+ "If after factoring, your code still looks repetitive, introduce combinators."
+ "If after introducing combinators, your code still looks repetitive, look into using meta-programming techniques."
+ "Try to place items on the stack in the order in which they are needed. If everything is in the correct order, no shuffling needs to be performed."
+ "If you find yourself writing a stack comment in the middle of a word, break the word up."
+ { "Use " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " instead of " { $link "shuffle-words" } " to give your code more structure." }
+ { "Not everything has to go on the stack. The " { $vocab-link "namespaces" } " vocabulary provides dynamically-scoped variables, and the " { $vocab-link "locals" } " vocabulary provides lexically-scoped variables. Learn both and use them where they make sense, but keep in mind that overuse of variables makes code harder to factor." }
+ "Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition."
+ { "Learn to use the " { $link "inference" } " tool." }
+ { "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." }
+ "Don't write Factor as if it were C. Imperitive programming and indexed loops are almost always not the most idiomatic solution."
+ { "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." }
+ { "If you find yourself writing a loop with a sequence and an index, there's almost always a better way. Learn the " { $link "sequences-combinators" } " by heart." }
+ { "If you find yourself writing a heavily nested loop which performs several steps on each iteration, there is almost always a better way. Break the problem down into a series of passes over the data instead, gradually transforming it into the desired result with a series of simple loops. Factor the loops out and reuse them. If you're working on anything math-related, learn " { $link "math-vectors" } " by heart." }
+ { "If you find yourself wishing you could iterate over the datastack, or capture the contents of the datastack into a sequence, or push each element of a sequence onto the datastack, there is almost always a better way. Use " { $link "sequences" } " instead." }
+ "Don't use meta-programming if there's a simpler way."
+ "Don't worry about efficiency unless your program is too slow. Don't prefer complex code to simple code just because you feel it will be more efficient. The Factor compiler is designed to make idiomatic code run fast."
+ { "None of the above are hard-and-fast rules: there are exceptions to all of them. But one rule unconditionally holds: " { $emphasis "there is always a simpler way" } "." }
+}
"Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such manual memory management, pointer arithmetic, and inline assembly code."
$nl
"Unsafe features are tucked away so that you will not invoke them by accident, or have to use them to solve conventional programming problems. However when the need arises, unsafe features are invaluable, for example you might have to do some pointer arithmetic when interfacing directly with C libraries." ;
From df8dabaf5e56c00fb5eacdb8de167bf6c63d6675 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 30 Mar 2008 08:16:19 -0500
Subject: [PATCH 008/127] Update JSON writer for inheritance
---
extra/json/writer/writer.factor | 17 ++++++-----------
1 file changed, 6 insertions(+), 11 deletions(-)
diff --git a/extra/json/writer/writer.factor b/extra/json/writer/writer.factor
index 1741b96e75..6ad0774e38 100644
--- a/extra/json/writer/writer.factor
+++ b/extra/json/writer/writer.factor
@@ -26,32 +26,27 @@ M: number json-print ( num -- )
M: integer json-print ( num -- )
number>string write ;
-M: sequence json-print ( array -- string )
+M: sequence json-print ( array -- )
CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ;
-: (jsvar-encode) ( char -- char )
- #! Convert the given character to a character usable in
- #! javascript variable names.
- dup H{ { CHAR: - CHAR: _ } } at dup [ nip ] [ drop ] if ;
-
: jsvar-encode ( string -- string )
#! Convert the string so that it contains characters usable within
#! javascript variable names.
- [ (jsvar-encode) ] map ;
+ { { CHAR: - CHAR: _ } } substitute ;
-: tuple>fields ( object -- string )
+: tuple>fields ( object -- seq )
<mirror> [
[ swap jsvar-encode >json % " : " % >json % ] "" make
] { } assoc>map ;
-M: tuple json-print ( tuple -- string )
+M: tuple json-print ( tuple -- )
CHAR: { write1 tuple>fields "," join write CHAR: } write1 ;
-M: hashtable json-print ( hashtable -- string )
+M: hashtable json-print ( hashtable -- )
CHAR: { write1
[ [ swap jsvar-encode >json % CHAR: : , >json % ] "" make ]
{ } assoc>map "," join write
CHAR: } write1 ;
-M: object json-print ( object -- string )
+M: object json-print ( object -- )
unparse json-print ;
From 87539b8f4eb4b8be3f3770155dcc9ddf608ceced Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 30 Mar 2008 08:16:30 -0500
Subject: [PATCH 009/127] Clean up db.types
---
extra/db/types/types.factor | 20 ++++++--------------
1 file changed, 6 insertions(+), 14 deletions(-)
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index 3c73a933e9..9babfbcdb0 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -131,25 +131,17 @@ TUPLE: no-sql-modifier ;
HOOK: bind% db ( spec -- )
-TUPLE: no-slot-named ;
-: no-slot-named ( -- * ) T{ no-slot-named } throw ;
-
-: slot-spec-named ( str class -- slot-spec )
- "slots" word-prop [ slot-spec-name = ] with find nip
- [ no-slot-named ] unless* ;
-
: offset-of-slot ( str obj -- n )
- class slot-spec-named slot-spec-offset ;
+ class "slots" word-prop slot-named slot-spec-offset ;
-: get-slot-named ( str obj -- value )
- tuck offset-of-slot [ no-slot-named ] unless* slot ;
+: get-slot-named ( name obj -- value )
+ tuck offset-of-slot slot ;
-: set-slot-named ( value str obj -- )
- tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
+: set-slot-named ( value name obj -- )
+ tuck offset-of-slot set-slot ;
: tuple>filled-slots ( tuple -- alist )
- dup <mirror> mirror-slots [ slot-spec-name ] map
- swap tuple-slots 2array flip [ nip ] assoc-subset ;
+ <mirror> [ nip ] assoc-subset ;
: tuple>params ( specs tuple -- obj )
[
From 856173f54e20f82ab8eb78e99f58e0c4234b930f Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 30 Mar 2008 10:46:07 -0500
Subject: [PATCH 010/127] Add unit test
---
extra/io/sockets/sockets-tests.factor | 4 ++++
1 file changed, 4 insertions(+)
create mode 100644 extra/io/sockets/sockets-tests.factor
diff --git a/extra/io/sockets/sockets-tests.factor b/extra/io/sockets/sockets-tests.factor
new file mode 100644
index 0000000000..1810b8587b
--- /dev/null
+++ b/extra/io/sockets/sockets-tests.factor
@@ -0,0 +1,4 @@
+IN: io.sockets.tests
+USING: io.sockets sequences math tools.test ;
+
+[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test
From cb7d655639a412581b8c7036c68ae8141d900f17 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 30 Mar 2008 10:55:47 -0500
Subject: [PATCH 011/127] move addrinfo into *bsd files
---
extra/unix/bsd/bsd.factor | 10 ----------
extra/unix/bsd/freebsd/freebsd.factor | 11 +++++++++++
extra/unix/bsd/macosx/macosx.factor | 11 +++++++++++
extra/unix/bsd/netbsd/netbsd.factor | 11 +++++++++++
extra/unix/bsd/openbsd/openbsd.factor | 11 +++++++++++
5 files changed, 44 insertions(+), 10 deletions(-)
diff --git a/extra/unix/bsd/bsd.factor b/extra/unix/bsd/bsd.factor
index cb7b347c20..6cb5d6385b 100755
--- a/extra/unix/bsd/bsd.factor
+++ b/extra/unix/bsd/bsd.factor
@@ -24,16 +24,6 @@ IN: unix
: F_SETFL 4 ; inline
: O_NONBLOCK 4 ; inline
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "char*" "canonname" }
- { "void*" "addr" }
- { "addrinfo*" "next" } ;
-
C-STRUCT: sockaddr-in
{ "uchar" "len" }
{ "uchar" "family" }
diff --git a/extra/unix/bsd/freebsd/freebsd.factor b/extra/unix/bsd/freebsd/freebsd.factor
index 94bb708527..f25cbd1537 100644
--- a/extra/unix/bsd/freebsd/freebsd.factor
+++ b/extra/unix/bsd/freebsd/freebsd.factor
@@ -1,3 +1,14 @@
+USING: alien.syntax ;
IN: unix
: FD_SETSIZE 1024 ;
+
+C-STRUCT: addrinfo
+ { "int" "flags" }
+ { "int" "family" }
+ { "int" "socktype" }
+ { "int" "protocol" }
+ { "socklen_t" "addrlen" }
+ { "char*" "canonname" }
+ { "void*" "addr" }
+ { "addrinfo*" "next" } ;
diff --git a/extra/unix/bsd/macosx/macosx.factor b/extra/unix/bsd/macosx/macosx.factor
index 3c0617ad17..edef2aaa0c 100644
--- a/extra/unix/bsd/macosx/macosx.factor
+++ b/extra/unix/bsd/macosx/macosx.factor
@@ -1,3 +1,14 @@
+USING: alien.syntax ;
IN: unix
: FD_SETSIZE 1024 ; inline
+
+C-STRUCT: addrinfo
+ { "int" "flags" }
+ { "int" "family" }
+ { "int" "socktype" }
+ { "int" "protocol" }
+ { "socklen_t" "addrlen" }
+ { "char*" "canonname" }
+ { "void*" "addr" }
+ { "addrinfo*" "next" } ;
diff --git a/extra/unix/bsd/netbsd/netbsd.factor b/extra/unix/bsd/netbsd/netbsd.factor
index ac18749830..071daa682d 100644
--- a/extra/unix/bsd/netbsd/netbsd.factor
+++ b/extra/unix/bsd/netbsd/netbsd.factor
@@ -1,3 +1,14 @@
+USING: alien.syntax ;
IN: unix
: FD_SETSIZE 256 ; inline
+
+C-STRUCT: addrinfo
+ { "int" "flags" }
+ { "int" "family" }
+ { "int" "socktype" }
+ { "int" "protocol" }
+ { "socklen_t" "addrlen" }
+ { "char*" "canonname" }
+ { "void*" "addr" }
+ { "addrinfo*" "next" } ;
diff --git a/extra/unix/bsd/openbsd/openbsd.factor b/extra/unix/bsd/openbsd/openbsd.factor
index 3c0617ad17..29b44f7da6 100644
--- a/extra/unix/bsd/openbsd/openbsd.factor
+++ b/extra/unix/bsd/openbsd/openbsd.factor
@@ -1,3 +1,14 @@
+USING: alien.syntax ;
IN: unix
: FD_SETSIZE 1024 ; inline
+
+C-STRUCT: addrinfo
+ { "int" "flags" }
+ { "int" "family" }
+ { "int" "socktype" }
+ { "int" "protocol" }
+ { "socklen_t" "addrlen" }
+ { "void*" "addr" }
+ { "char*" "canonname" }
+ { "addrinfo*" "next" } ;
From d367dc8462397b6de8f162098516d57b18533959 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@forth.internal.stack-effects.com>
Date: Sun, 30 Mar 2008 12:21:44 -0500
Subject: [PATCH 012/127] fix gdb on freebsd
---
extra/tools/disassembler/disassembler.factor | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)
diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor
index 479ae9c42c..927f7111fa 100755
--- a/extra/tools/disassembler/disassembler.factor
+++ b/extra/tools/disassembler/disassembler.factor
@@ -26,11 +26,14 @@ M: pair make-disassemble-cmd
M: method-spec make-disassemble-cmd
first2 method make-disassemble-cmd ;
+: gdb-binary ( -- string )
+ os "freebsd" = "gdb66" "gdb" ? ;
+
: run-gdb ( -- lines )
<process>
+closed+ >>stdin
out-file >>stdout
- [ "gdb" , "-x" , in-file , "-batch" , ] { } make >>command
+ [ gdb-binary , "-x" , in-file , "-batch" , ] { } make >>command
try-process
out-file ascii file-lines ;
From 6ece2fbde270b4b1c725f84e09e701fc66723642 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Sun, 30 Mar 2008 14:48:49 -0500
Subject: [PATCH 013/127] fix copy-tree
---
core/io/files/files.factor | 20 +++++++++++++-------
extra/io/unix/files/files.factor | 3 ---
2 files changed, 13 insertions(+), 10 deletions(-)
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 4dbbb869c4..458a9145a6 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -153,6 +153,9 @@ HOOK: make-link io-backend ( path1 path2 -- )
HOOK: read-link io-backend ( path -- info )
+: copy-link ( path1 path2 -- )
+ >r read-link r> make-link ;
+
SYMBOL: +regular-file+
SYMBOL: +directory+
SYMBOL: +character-device+
@@ -264,13 +267,16 @@ M: object copy-file
DEFER: copy-tree-into
: copy-tree ( from to -- )
- over link-info type>> +directory+ = [
- >r dup directory r> rot [
- [ >r first r> copy-tree-into ] curry each
- ] with-directory
- ] [
- copy-file
- ] if ;
+ over link-info type>>
+ {
+ { +symbolic-link+ [ copy-link ] }
+ { +directory+ [
+ >r dup directory r> rot [
+ [ >r first r> copy-tree-into ] curry each
+ ] with-directory
+ ] }
+ [ drop copy-file ]
+ } case ;
: copy-tree-into ( from to -- )
to-directory copy-tree ;
diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor
index 759ac2bec1..c4e506d37f 100755
--- a/extra/io/unix/files/files.factor
+++ b/extra/io/unix/files/files.factor
@@ -108,6 +108,3 @@ M: unix-io read-link ( path -- path' )
normalize-pathname
PATH_MAX [ <byte-array> tuck ] [ ] bi readlink
dup io-error head-slice >string ;
-
-: copy-link ( path1 path2 -- )
- >r read-link r> make-link ;
From 2d80153b073bca7332f38c15e928c396aa028d7b Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 30 Mar 2008 14:39:13 -0600
Subject: [PATCH 014/127] builder: Add support for gmake
---
extra/builder/builder.factor | 24 ++++++++++++++++++++----
1 file changed, 20 insertions(+), 4 deletions(-)
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 461d951209..75664ce5e5 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -48,15 +48,31 @@ IN: builder
: record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ;
-: do-make-clean ( -- ) { "make" "clean" } try-process ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gnu-make ( -- string )
+ os { "freebsd" "openbsd" "netbsd" } member?
+ [ "gmake" ]
+ [ "make" ]
+ if ;
+
+! : do-make-clean ( -- ) { "make" "clean" } try-process ;
+
+: do-make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! : make-vm ( -- desc )
+! <process>
+! { "make" } >>command
+! "../compile-log" >>stdout
+! +stdout+ >>stderr ;
+
: make-vm ( -- desc )
<process>
- { "make" } >>command
- "../compile-log" >>stdout
- +stdout+ >>stderr ;
+ { gnu-make } to-strings >>command
+ "../compile-log" >>stdout
+ +stdout+ >>stderr ;
: do-make-vm ( -- )
make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ;
From 71283f7fc59ca52e8b63ebae8320d0cdbc79e529 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 30 Mar 2008 17:21:58 -0500
Subject: [PATCH 015/127] Documentation update
---
core/kernel/kernel-docs.factor | 39 +++++++++++++++++++++++++++++++++-
1 file changed, 38 insertions(+), 1 deletion(-)
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 1c88f5a485..b1120de8e6 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -545,7 +545,7 @@ HELP: 2bi
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y -- z )" } ", then the following two lines are equivalent:"
{ $code
"[ p ] [ q ] 2bi"
- "2dup p swap q"
+ "2dup p -rot q"
}
"In general, the following two lines are equivalent:"
{ $code
@@ -554,6 +554,27 @@ HELP: 2bi
}
} ;
+HELP: 3bi
+{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } }
+{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values." }
+{ $examples
+ "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] 3bi"
+ "3dup p q"
+ }
+ "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- w )" } ", then the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] 3bi"
+ "3dup p -roll q"
+ }
+ "In general, the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] 3bi"
+ "[ p ] 3keep q"
+ }
+} ;
+
HELP: tri
{ $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } ", and finally applies " { $snippet "r" } " to " { $snippet "x" } "." }
@@ -591,6 +612,22 @@ HELP: 2tri
}
} ;
+HELP: 3tri
+{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } }
+{ $description "Applies " { $snippet "p" } " to the three input values, then applies " { $snippet "q" } " to the three input values, and finally applies " { $snippet "r" } " to the three input values." }
+{ $examples
+ "If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] [ r ] 3tri"
+ "3dup p 3dup q r"
+ }
+ "In general, the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] [ r ] 3tri"
+ "[ p ] 3keep [ q ] 3keep r"
+ }
+} ;
+
HELP: bi*
{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y -- ... )" } } }
From cd85b545bd28d0c1cde36376a2f60acc98a1cf12 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 30 Mar 2008 17:23:42 -0500
Subject: [PATCH 016/127] Cleaning up tuples
---
core/classes/tuple/tuple.factor | 99 ++++++++++++++++++++-------------
core/slots/slots.factor | 3 -
2 files changed, 59 insertions(+), 43 deletions(-)
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index a452d0eeec..401a421c51 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -23,8 +23,15 @@ M: class tuple-layout "layout" word-prop ;
M: tuple tuple-layout 1 slot ;
+M: tuple-layout tuple-layout ;
: tuple-size tuple-layout layout-size ; inline
+: prepare-tuple>array ( tuple -- n tuple layout )
+ [ tuple-size ] [ ] [ tuple-layout ] tri ;
+
+: copy-tuple-slots ( n tuple first -- array )
+ [ array-nth ] curry map r> add* ;
+
PRIVATE>
: check-tuple ( class -- )
@@ -32,28 +39,29 @@ PRIVATE>
[ drop ] [ no-tuple-class ] if ;
: tuple>array ( tuple -- array )
- dup tuple-layout
- [ layout-size swap [ array-nth ] curry map ] keep
- layout-class add* ;
+ prepare-tuple>array >r copy-tuple-slots r> layout-class add* ;
-: >tuple ( seq -- tuple )
- dup first tuple-layout <tuple> [
- >r 1 tail-slice dup length r>
- [ tuple-size min ] keep
- [ set-array-nth ] curry
- 2each
+: tuple-slots ( tuple -- array )
+ prepare-tuple>array drop copy-tuple-slots ;
+
+: slots>tuple ( tuple class -- array )
+ tuple-layout <tuple> [
+ [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
] keep ;
+: >tuple ( tuple -- array )
+ unclip slots>tuple ;
+
: slot-names ( class -- seq )
- "slots" word-prop [ name>> ] map ;
+ "slot-names" word-prop ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
- over tuple-layout over tuple-layout eq? [
- dup tuple-size -rot
- [ >r over r> array-nth >r array-nth r> = ] 2curry
- all-integers?
+ 2dup [ tuple-layout ] bi@ eq? [
+ [ drop tuple-size ]
+ [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
+ 2bi all-integers?
] [
2drop f
] if ;
@@ -92,18 +100,19 @@ PRIVATE>
superclasses 1 head-slice*
[ slot-names length ] map sum ;
-: generate-tuple-slots ( class slots -- slots )
+: generate-tuple-slots ( class slots -- slot-specs )
over superclass-size 2 + simple-slots ;
-: define-tuple-slots ( class slots -- )
- dupd generate-tuple-slots
+: define-tuple-slots ( class -- )
+ dup dup slot-names generate-tuple-slots
[ "slots" set-word-prop ]
- [ define-accessors ]
- [ define-slots ] 2tri ;
+ [ define-accessors ] ! new
+ [ define-slots ] ! old
+ 2tri ;
: make-tuple-layout ( class -- layout )
[ ]
- [ [ superclass-size ] [ "slots" word-prop length ] bi + ]
+ [ [ superclass-size ] [ slot-names length ] bi + ]
[ superclasses dup length 1- ] tri
<tuple-layout> ;
@@ -113,7 +122,7 @@ PRIVATE>
: removed-slots ( class newslots -- seq )
swap slot-names seq-diff ;
-: forget-slots ( class slots -- )
+: forget-removed-slots ( class slots -- )
dupd removed-slots [
[ reader-word forget-method ]
[ writer-word forget-method ] 2bi
@@ -122,36 +131,48 @@ PRIVATE>
: permutation ( seq1 seq2 -- permutation )
swap [ index ] curry map ;
-: reshape-tuple ( oldtuple permutation -- newtuple )
- >r tuple>array 2 cut r>
- [ [ swap ?nth ] [ drop f ] if* ] with map
- append >tuple ;
+: all-slot-names ( class -- slots )
+ superclasses [ slot-names ] map concat \ class add* ;
-: reshape-tuples ( class superclass newslots -- )
- nip
- >r dup slot-names r> permutation
- [
- >r "predicate" word-prop instances dup
- r> [ reshape-tuple ] curry map
- become
- ] 2curry after-compilation ;
+: slot-permutation ( class superclass newslots -- n permutation )
+ [ all-slot-names ] [ all-slot-names ] [ ] tri* append
+ [ drop length ] [ permutation ] 2bi ;
+
+: permute-direct-slots ( oldslots permutation -- newslots )
+ [ [ swap ?nth ] [ drop f ] if* ] with map ;
+
+: permute-all-slots ( oldslots n permutation -- newslots )
+ [ >r head r> permute-direct-slots ] [ drop tail ] 3bi append ;
+
+: change-tuple ( tuple quot -- newtuple )
+ >r tuple>array r> call >tuple ; inline
+
+: update-tuples ( predicate n permutation -- )
+ [ permute-all-slots ] 2curry [ change-tuple ] curry
+ >r "predicate" word-prop instances dup r> map
+ become ; inline
+
+: update-tuples-after ( class superclass newslots -- )
+ [ 2drop ] [ slot-permutation ] 3bi
+ [ update-tuples ] 3curry after-compilation ;
: define-new-tuple-class ( class superclass slots -- )
[ drop f tuple-class define-class ]
- [ nip define-tuple-slots ] [
+ [ nip "slot-names" set-word-prop ] [
2drop
class-usages keys [ tuple-class? ] subset [
+ [ define-tuple-slots ]
[ define-tuple-layout ]
[ define-tuple-predicate ]
- bi
+ tri
] each
] 3tri ;
: redefine-tuple-class ( class superclass slots -- )
- [ reshape-tuples ]
+ [ update-tuples-after ]
[
nip
- [ forget-slots ]
+ [ forget-removed-slots ]
[ drop changed-word ]
[ drop redefined ]
2tri
@@ -175,7 +196,7 @@ M: tuple-class define-tuple-class
3drop ;
: define-error-class ( class superclass slots -- )
- pick >r define-tuple-class r>
+ [ define-tuple-class ] [ 2drop ] 3bi
dup [ construct-boa throw ] curry define ;
M: tuple clone
@@ -196,8 +217,6 @@ M: tuple hashcode*
] 2curry reduce
] recursive-hashcode ;
-: tuple-slots ( tuple -- seq ) tuple>array 2 tail ;
-
! Definition protocol
M: tuple-class reset-class
{ "metaclass" "superclass" "slots" "layout" } reset-props ;
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index dfd5c1b32a..eeb0926308 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -23,9 +23,6 @@ C: <slot-spec> slot-spec
[ drop ] [ 1array , \ declare , ] if
] [ ] make ;
-: slot-named ( name specs -- spec/f )
- [ slot-spec-name = ] with find nip ;
-
: create-accessor ( name effect -- word )
>r "accessors" create dup r>
"declared-effect" set-word-prop ;
From c30a8a68ee6216b3140836e9f77c7306f48a5111 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.gateway.2wire.net>
Date: Sun, 30 Mar 2008 18:22:35 -0500
Subject: [PATCH 017/127] refactor mersenne-twister to not use new-effects
---
.../mersenne-twister/mersenne-twister.factor | 38 ++++++++++---------
1 file changed, 20 insertions(+), 18 deletions(-)
diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor
index ad9dae51ae..4c4bc8286f 100755
--- a/extra/random/mersenne-twister/mersenne-twister.factor
+++ b/extra/random/mersenne-twister/mersenne-twister.factor
@@ -4,11 +4,14 @@
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
USING: arrays kernel math namespaces sequences system init
-accessors math.ranges new-effects random ;
+accessors math.ranges random ;
IN: random.mersenne-twister
<PRIVATE
+: curry2 ( w quot1 quot2 -- quot1 quot2 )
+ >r over r> [ curry ] 2bi@ ;
+
TUPLE: mersenne-twister seq i ;
: mt-n 624 ; inline
@@ -19,34 +22,33 @@ TUPLE: mersenne-twister seq i ;
: wrap ( x n -- y ) 2dup >= [ - ] [ drop ] if ; inline
: mt-wrap ( x -- y ) mt-n wrap ; inline
-: set-generated ( mt y from-elt to -- )
- >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi
- r> bitxor bitxor r> new-set-nth drop ; inline
+: set-generated ( y from-elt to seq -- )
+ >r >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi
+ r> bitxor bitxor r> r> set-nth ; inline
-: calculate-y ( mt y1 y2 -- y )
- >r over r>
- [ new-nth mt-hi ] [ new-nth mt-lo ] 2bi* bitor ; inline
+: calculate-y ( y1 y2 mt -- y )
+ [ nth mt-hi ] [ nth mt-lo ] curry2 bi* bitor ; inline
-: (mt-generate) ( mt-seq n -- y to from-elt )
- [ dup 1+ mt-wrap calculate-y ]
- [ mt-m + mt-wrap new-nth ]
- [ nip ] 2tri ;
+: (mt-generate) ( n mt-seq -- y to from-elt )
+ [ >r dup 1+ mt-wrap r> calculate-y ]
+ [ >r mt-m + mt-wrap r> nth ]
+ [ drop ] 2tri ;
: mt-generate ( mt -- )
- [ seq>> mt-n [ dupd (mt-generate) set-generated ] with each ]
+ [ >r mt-n r> seq>> [ [ (mt-generate) ] keep set-generated ] curry each ]
[ 0 >>i drop ] bi ;
: init-mt-first ( seed -- seq )
>r mt-n 0 <array> r>
- HEX: ffffffff bitand 0 new-set-nth ;
+ HEX: ffffffff bitand 0 pick set-nth ;
: init-mt-formula ( seq i -- f(seq[i]) )
- tuck new-nth dup -30 shift bitxor 1812433253 * +
+ tuck swap nth dup -30 shift bitxor 1812433253 * +
1+ HEX: ffffffff bitand ;
: init-mt-rest ( seq -- )
mt-n 1- [0,b) [
- dupd [ init-mt-formula ] keep 1+ new-set-nth drop
+ dupd [ init-mt-formula ] keep 1+ rot set-nth
] with each ;
: init-mt-seq ( seed -- seq )
@@ -68,7 +70,7 @@ M: mersenne-twister seed-random ( mt seed -- )
init-mt-seq >>seq drop ;
M: mersenne-twister random-32* ( mt -- r )
- dup [ seq>> ] [ i>> ] bi
- dup mt-n < [ drop 0 pick mt-generate ] unless
- new-nth mt-temper
+ dup [ i>> ] [ seq>> ] bi
+ over mt-n < [ nip >r dup mt-generate 0 r> ] unless
+ nth mt-temper
swap [ 1+ ] change-i drop ;
From 55a69392faadff0988a49696f734562491e484d0 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Mon, 31 Mar 2008 13:52:42 +1300
Subject: [PATCH 018/127] First cut at variables in ebnf
---
extra/peg/ebnf/ebnf.factor | 28 ++++++++++++++++++++++------
1 file changed, 22 insertions(+), 6 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 41b5a1b655..e9ec0dc4e2 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -3,7 +3,7 @@
USING: kernel compiler.units parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
peg.parsers unicode.categories multiline combinators.lib
- splitting accessors effects ;
+ splitting accessors effects sequences.deep ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
@@ -227,15 +227,17 @@ GENERIC: (transform) ( ast -- parser )
SYMBOL: parser
SYMBOL: main
+SYMBOL: vars
: transform ( ast -- object )
- H{ } clone dup dup [ parser set swap (transform) main set ] bind ;
+ H{ } clone dup dup [ parser set V{ } vars set swap (transform) main set ] bind ;
M: ebnf (transform) ( ast -- parser )
rules>> [ (transform) ] map peek ;
M: ebnf-rule (transform) ( ast -- parser )
- dup elements>> (transform) [
+ dup elements>>
+ vars get clone vars [ (transform) ] with-variable [
swap symbol>> set
] keep ;
@@ -270,12 +272,26 @@ M: ebnf-repeat1 (transform) ( ast -- parser )
M: ebnf-optional (transform) ( ast -- parser )
transform-group optional ;
+: build-locals ( string vars -- string )
+ dup empty? [
+ drop
+ ] [
+ [
+ "[let* | " %
+ [ dup % " [ \"" % % "\" get ] " % ] each
+ " | " %
+ %
+ " ] with-locals" %
+ ] "" make
+ ] if ;
+
M: ebnf-action (transform) ( ast -- parser )
[ parser>> (transform) ] keep
- code>> string-lines [ parse-lines ] with-compilation-unit action ;
+ code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit action ;
M: ebnf-var (transform) ( ast -- parser )
- parser>> (transform) ;
+ [ parser>> (transform) ] [ name>> ] bi
+ dup vars get push [ dupd set ] curry action ;
M: ebnf-terminal (transform) ( ast -- parser )
symbol>> token sp ;
@@ -303,7 +319,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
: ebnf>quot ( string -- hashtable quot )
'ebnf' parse check-parse-result
parse-result-ast transform dup dup parser [ main swap at compile ] with-variable
- [ compiled-parse ] curry ;
+ [ compiled-parse ] curry [ with-scope ] curry ;
: [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing
From a098790634503dfc03eb24969a4fbaff7f7512f5 Mon Sep 17 00:00:00 2001
From: Matthew Willis <matthew.willis@mac.com>
Date: Sun, 30 Mar 2008 17:58:47 -0700
Subject: [PATCH 019/127] Updated extra/match to use bi@ instead of 2apply.
Ran "peg" test for testing.
---
extra/match/match.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/match/match.factor b/extra/match/match.factor
index dbc42f53e3..825d58c7c2 100755
--- a/extra/match/match.factor
+++ b/extra/match/match.factor
@@ -70,7 +70,7 @@ MACRO: match-cond ( assoc -- )
dup length zero? not [ 1 tail ] [ drop f ] if ;
: (match-first) ( seq pattern-seq -- bindings leftover/f )
- 2dup [ length ] 2apply < [ 2drop f f ]
+ 2dup [ length ] bi@ < [ 2drop f f ]
[
2dup length head over match
[ nip swap ?1-tail ] [ >r 1 tail r> (match-first) ] if*
From ee2194d1dc1eb4df9072dae9ce50a9bb13353b98 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Mon, 31 Mar 2008 14:03:16 +1300
Subject: [PATCH 020/127] Allow variable names on elements
---
extra/peg/ebnf/ebnf.factor | 8 +++++++-
1 file changed, 7 insertions(+), 1 deletion(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index e9ec0dc4e2..f98b08093a 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -102,7 +102,7 @@ C: <ebnf> ebnf
"]" syntax ,
] seq* [ first >string <ebnf-range> ] action ;
-: 'element' ( -- parser )
+: ('element') ( -- parser )
#! An element of a rule. It can be a terminal or a
#! non-terminal but must not be followed by a "=".
#! The latter indicates that it is the beginning of a
@@ -120,6 +120,12 @@ C: <ebnf> ebnf
] choice* ,
] seq* [ first ] action ;
+: 'element' ( -- parser )
+ [
+ [ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
+ ('element') ,
+ ] choice* ;
+
DEFER: 'choice'
: grouped ( quot suffix -- parser )
From 729ac1d6dc18ddfd26aebae44d27c6ea62eec767 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Mon, 31 Mar 2008 14:59:22 +1300
Subject: [PATCH 021/127] Some ebnf tweaks and tests to do with variables
---
extra/peg/ebnf/ebnf-tests.factor | 9 ++++++++-
extra/peg/ebnf/ebnf.factor | 2 +-
2 files changed, 9 insertions(+), 2 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 7aa61e84da..cf16fad2cd 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg peg.ebnf words ;
+USING: kernel tools.test peg peg.ebnf words math math.parser ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
@@ -160,6 +160,13 @@ IN: peg.ebnf.tests
"1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call parse-result-ast
] unit-test
+{ 6 } [
+ "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ drop x y + ]] EBNF] call parse-result-ast
+] unit-test
+
+{ 6 } [
+ "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call parse-result-ast
+] unit-test
{ V{ V{ 49 } "+" V{ 49 } } } [
#! Test direct left recursion.
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index f98b08093a..74b3e3540d 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -283,7 +283,7 @@ M: ebnf-optional (transform) ( ast -- parser )
drop
] [
[
- "[let* | " %
+ "USING: locals namespaces ; [let* | " %
[ dup % " [ \"" % % "\" get ] " % ] each
" | " %
%
From c45eba68987e41ad14e0cc817079801e713af1b8 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Mon, 31 Mar 2008 16:34:59 +1300
Subject: [PATCH 022/127] Add semantic parser
---
extra/peg/peg-docs.factor | 13 +++++++++++++
extra/peg/peg.factor | 20 ++++++++++++++++++++
2 files changed, 33 insertions(+)
diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor
index e7bd255569..c54a39b7b0 100644
--- a/extra/peg/peg-docs.factor
+++ b/extra/peg/peg-docs.factor
@@ -95,6 +95,19 @@ HELP: optional
"Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "
"'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;
+HELP: semantic
+{ $values
+ { "parser" "a parser" }
+ { "quot" "a quotation with stack effect ( object -- bool )" }
+}
+{ $description
+ "Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "
+ "the AST produced by 'p1' on the stack returns true." }
+{ $examples
+ { $example "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse" "f" }
+ { $example "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast " "67" }
+} ;
+
HELP: ensure
{ $values
{ "parser" "a parser" }
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 43eb9e8d9e..9e35c5b9be 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -414,6 +414,23 @@ TUPLE: optional-parser p1 ;
M: optional-parser (compile) ( parser -- quot )
p1>> compiled-parser \ ?quot optional-pattern match-replace ;
+TUPLE: semantic-parser p1 quot ;
+
+MATCH-VARS: ?parser ;
+
+: semantic-pattern ( -- quot )
+ [
+ ?parser [
+ dup parse-result-ast ?quot call [ drop f ] unless
+ ] [
+ f
+ ] if*
+ ] ;
+
+M: semantic-parser (compile) ( parser -- quot )
+ [ p1>> compiled-parser ] [ quot>> ] bi
+ 2array { ?parser ?quot } semantic-pattern match-replace ;
+
TUPLE: ensure-parser p1 ;
: ensure-pattern ( -- quot )
@@ -546,6 +563,9 @@ PRIVATE>
: optional ( parser -- parser )
optional-parser construct-boa init-parser ;
+: semantic ( parser quot -- parser )
+ semantic-parser construct-boa init-parser ;
+
: ensure ( parser -- parser )
ensure-parser construct-boa init-parser ;
From 8aa676ab1eda35b0d6011fbbb2689e12215664f7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 30 Mar 2008 22:42:36 -0500
Subject: [PATCH 023/127] Documentation fixes
---
core/continuations/continuations-docs.factor | 1 +
core/debugger/debugger-docs.factor | 10 +++++++++-
extra/help/handbook/handbook.factor | 1 +
extra/help/markup/markup.factor | 3 +--
4 files changed, 12 insertions(+), 3 deletions(-)
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
index 7209b7ec4d..ca7af930f2 100755
--- a/core/continuations/continuations-docs.factor
+++ b/core/continuations/continuations-docs.factor
@@ -29,6 +29,7 @@ $nl
{ $subsection ignore-errors }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsection "errors-restartable" }
+{ $subsection "debugger" }
{ $subsection "errors-post-mortem" }
"When Factor encouters a critical error, it calls the following word:"
{ $subsection die } ;
diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor
index 5e8b6df34a..f8b53d4abc 100755
--- a/core/debugger/debugger-docs.factor
+++ b/core/debugger/debugger-docs.factor
@@ -86,7 +86,15 @@ HELP: error-hook
HELP: try
{ $values { "quot" "a quotation" } }
-{ $description "Calls the quotation. If it throws an error, calls " { $link error-hook } " with the error and restores the data stack." } ;
+{ $description "Attempts to call a quotation; if it throws an error, the " { $link error-hook } " gets called, stacks are restored, and execution continues after the call to " { $link try } "." }
+{ $examples
+ "The following example prints an error and keeps going:"
+ { $code
+ "[ \"error\" throw ] try"
+ "\"still running...\" print"
+ }
+ { $link "listener" } " uses " { $link try } " to recover from user errors."
+} ;
HELP: expired-error.
{ $error-description "Thrown by " { $link alien-address } " and " { $link alien-invoke } " if an " { $link alien } " object passed in as a parameter has expired. Alien objects expire if they are saved an image which is subsequently loaded; this prevents a certain class of programming errors, usually attempts to use uninitialized objects, since holding a C address is meaningless between sessions." }
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index 912c3c35f3..1c2dfde85c 100755
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -206,6 +206,7 @@ ARTICLE: "tools" "Developer tools"
{ $subsection "tools.vocabs" }
"Exploratory tools:"
{ $subsection "editor" }
+{ $subsection "listener" }
{ $subsection "tools.crossref" }
{ $subsection "inspector" }
"Debugging tools:"
diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor
index 5dc7255eed..f8d360fd0a 100755
--- a/extra/help/markup/markup.factor
+++ b/extra/help/markup/markup.factor
@@ -138,8 +138,7 @@ M: f print-element drop ;
link-style get [ write-object ] with-style ;
: ($link) ( article -- )
- dup article-name swap >link write-link
- span last-element set ;
+ [ dup article-name swap >link write-link ] ($span) ;
: $link ( element -- )
first ($link) ;
From f66774e87564aa5f6d66f80dd00c72b2db456700 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Mon, 31 Mar 2008 16:50:05 +1300
Subject: [PATCH 024/127] Add tests for semantic and add syntax for it to ebnf
Syntax is ?[ ...]? For example: [EBNF num=. ?[ number? ]? list=list:x num:y
=> [[ drop x y + ]] | num EBNF] { 1 2 3 4 5 6 } swap call .
---
extra/peg/ebnf/ebnf-tests.factor | 12 ++++++++++++
extra/peg/ebnf/ebnf.factor | 16 ++++++++++++----
extra/peg/peg-tests.factor | 13 +++++++++++--
3 files changed, 35 insertions(+), 6 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index cf16fad2cd..4f802c5207 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -168,6 +168,18 @@ IN: peg.ebnf.tests
"4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call parse-result-ast
] unit-test
+{ 10 } [
+ { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
+] unit-test
+
+{ f } [
+ { "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call
+] unit-test
+
+{ 3 } [
+ { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
+] unit-test
+
{ V{ V{ 49 } "+" V{ 49 } } } [
#! Test direct left recursion.
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 74b3e3540d..4f00edbd3c 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -20,6 +20,7 @@ TUPLE: ebnf-optional group ;
TUPLE: ebnf-rule symbol elements ;
TUPLE: ebnf-action parser code ;
TUPLE: ebnf-var parser name ;
+TUPLE: ebnf-semantic parser code ;
TUPLE: ebnf rules ;
C: <ebnf-non-terminal> ebnf-non-terminal
@@ -36,6 +37,7 @@ C: <ebnf-optional> ebnf-optional
C: <ebnf-rule> ebnf-rule
C: <ebnf-action> ebnf-action
C: <ebnf-var> ebnf-var
+C: <ebnf-semantic> ebnf-semantic
C: <ebnf> ebnf
: syntax ( string -- parser )
@@ -156,6 +158,7 @@ DEFER: 'choice'
: 'factor-code' ( -- parser )
[
"]]" token ensure-not ,
+ "]?" token ensure-not ,
[ drop t ] satisfy ,
] seq* [ first ] action repeat0 [ >string ] action ;
@@ -193,14 +196,15 @@ DEFER: 'choice'
: 'action' ( -- parser )
"[[" 'factor-code' "]]" syntax-pack ;
+: 'semantic' ( -- parser )
+ "?[" 'factor-code' "]?" syntax-pack ;
+
: 'sequence' ( -- parser )
#! A sequence of terminals and non-terminals, including
#! groupings of those.
[
- [
- ('sequence') ,
- 'action' ,
- ] seq* [ first2 <ebnf-action> ] action ,
+ [ ('sequence') , 'action' , ] seq* [ first2 <ebnf-action> ] action ,
+ [ ('sequence') , 'semantic' , ] seq* [ first2 <ebnf-semantic> ] action ,
('sequence') ,
] choice* repeat1 [
dup length 1 = [ first ] [ <ebnf-sequence> ] if
@@ -295,6 +299,10 @@ M: ebnf-action (transform) ( ast -- parser )
[ parser>> (transform) ] keep
code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit action ;
+M: ebnf-semantic (transform) ( ast -- parser )
+ [ parser>> (transform) ] keep
+ code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit semantic ;
+
M: ebnf-var (transform) ( ast -- parser )
[ parser>> (transform) ] [ name>> ] bi
dup vars get push [ dupd set ] curry action ;
diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor
index f57fe83220..fcec33f7c2 100644
--- a/extra/peg/peg-tests.factor
+++ b/extra/peg/peg-tests.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words ;
+USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words math ;
IN: peg.tests
{ f } [
@@ -182,4 +182,13 @@ IN: peg.tests
[ f , "a" token , ] seq*
dup parsers>>
dupd 0 swap set-nth compile word?
-] unit-test
\ No newline at end of file
+] unit-test
+
+{ f } [
+ "A" [ drop t ] satisfy [ 66 >= ] semantic parse
+] unit-test
+
+{ CHAR: B } [
+ "B" [ drop t ] satisfy [ 66 >= ] semantic parse parse-result-ast
+] unit-test
+
From a41f8ef7338d565329ca8d0cb646e3746032ccd2 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Mon, 31 Mar 2008 17:26:42 +1300
Subject: [PATCH 025/127] Mention how to fail from action in pegs
---
extra/peg/peg-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor
index c54a39b7b0..5f200be78e 100644
--- a/extra/peg/peg-docs.factor
+++ b/extra/peg/peg-docs.factor
@@ -137,7 +137,7 @@ HELP: action
"Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "
"from that parse. The result of the quotation is then used as the final AST. This can be used "
"for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
- "the default AST." }
+ "the default AST. If the quotation returns " { $link fail } " then the parser fails." }
{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
HELP: sp
From d87667f903c3dd33fda10e5cc8a74fc3cc0e02de Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 30 Mar 2008 23:54:57 -0500
Subject: [PATCH 026/127] Add inline declaration
---
extra/random/mersenne-twister/mersenne-twister.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor
index 4c4bc8286f..ce1749ce62 100755
--- a/extra/random/mersenne-twister/mersenne-twister.factor
+++ b/extra/random/mersenne-twister/mersenne-twister.factor
@@ -10,7 +10,7 @@ IN: random.mersenne-twister
<PRIVATE
: curry2 ( w quot1 quot2 -- quot1 quot2 )
- >r over r> [ curry ] 2bi@ ;
+ >r over r> [ curry ] 2bi@ ; inline
TUPLE: mersenne-twister seq i ;
From 2ebb7d22718b1b1e90943c5fd35a6a4915fb4e34 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 31 Mar 2008 01:19:21 -0500
Subject: [PATCH 027/127] Clean up bootstrap code a bit
---
core/bootstrap/image/image.factor | 116 ++++++++++++++----------------
core/bootstrap/primitives.factor | 49 +++++++------
2 files changed, 84 insertions(+), 81 deletions(-)
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index deb54fdeeb..5d49203554 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -12,7 +12,7 @@ io.encodings.binary ;
IN: bootstrap.image
: my-arch ( -- arch )
- cpu dup "ppc" = [ os "-" rot 3append ] when ;
+ cpu dup "ppc" = [ >r os "-" r> 3append ] when ;
: boot-image-name ( arch -- string )
"boot." swap ".image" 3append ;
@@ -55,7 +55,7 @@ IN: bootstrap.image
: quot-xt@ 3 bootstrap-cells object tag-number - ;
: jit-define ( quot rc rt offset name -- )
- >r >r >r >r { } make r> r> r> 4array r> set ;
+ >r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ;
! The image being constructed; a vector of word-size integers
SYMBOL: image
@@ -134,10 +134,10 @@ SYMBOL: undefined-quot
: here ( -- size ) heap-size data-base + ;
-: here-as ( tag -- pointer ) here swap bitor ;
+: here-as ( tag -- pointer ) here bitor ;
: align-here ( -- )
- here 8 mod 4 = [ heap-size drop 0 emit ] when ;
+ here 8 mod 4 = [ 0 emit ] when ;
: emit-fixnum ( n -- ) tag-fixnum emit ;
@@ -164,7 +164,7 @@ GENERIC: ' ( obj -- ptr )
userenv-size [ f ' emit ] times ;
: emit-userenv ( symbol -- )
- dup get ' swap userenv-offset fixup ;
+ [ get ' ] [ userenv-offset ] bi fixup ;
! Bignums
@@ -175,14 +175,15 @@ GENERIC: ' ( obj -- ptr )
: bignum>seq ( n -- seq )
#! n is positive or zero.
[ dup 0 > ]
- [ dup bignum-bits neg shift swap bignum-radix bitand ]
+ [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
[ ] unfold nip ;
-USE: continuations
: emit-bignum ( n -- )
- dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
- dup length 1+ emit-fixnum
- swap emit emit-seq ;
+ dup dup 0 < [ neg ] when bignum>seq
+ [ nip length 1+ emit-fixnum ]
+ [ drop 0 < 1 0 ? emit ]
+ [ nip emit-seq ]
+ 2tri ;
M: bignum '
bignum tag-number dup [ emit-bignum ] emit-object ;
@@ -221,28 +222,33 @@ M: f '
! Words
: emit-word ( word -- )
- dup subwords [ emit-word ] each
[
- dup hashcode ' ,
- dup word-name ' ,
- dup word-vocabulary ' ,
- dup word-def ' ,
- dup word-props ' ,
- f ' ,
- 0 , ! count
- 0 , ! xt
- 0 , ! code
- 0 , ! profiling
- ] { } make
- \ word type-number object tag-number
- [ emit-seq ] emit-object
- swap objects get set-at ;
+ [ subwords [ emit-word ] each ]
+ [
+ [
+ {
+ [ hashcode , ]
+ [ word-name , ]
+ [ word-vocabulary , ]
+ [ word-def , ]
+ [ word-props , ]
+ } cleave
+ f ,
+ 0 , ! count
+ 0 , ! xt
+ 0 , ! code
+ 0 , ! profiling
+ ] { } make [ ' ] map
+ ] bi
+ \ word type-number object tag-number
+ [ emit-seq ] emit-object
+ ] keep objects get set-at ;
: word-error ( word msg -- * )
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
: transfer-word ( word -- word )
- dup target-word swap or ;
+ [ target-word ] keep or ;
: fixup-word ( word -- offset )
transfer-word dup objects get at
@@ -285,9 +291,10 @@ M: string '
length 0 assert= ;
: emit-dummy-array ( obj type -- ptr )
- swap assert-empty
- type-number object tag-number
- [ 0 emit-fixnum ] emit-object ;
+ [ assert-empty ] [
+ type-number object tag-number
+ [ 0 emit-fixnum ] emit-object
+ ] bi* ;
M: byte-array ' byte-array emit-dummy-array ;
@@ -296,29 +303,28 @@ M: bit-array ' bit-array emit-dummy-array ;
M: float-array ' float-array emit-dummy-array ;
! Tuples
+: (emit-tuple) ( tuple -- pointer )
+ [ tuple>array 1 tail-slice ]
+ [ class transfer-word tuple-layout ] bi add* [ ' ] map
+ tuple type-number dup [ emit-seq ] emit-object ;
+
: emit-tuple ( tuple -- pointer )
- [
- [
- dup class transfer-word tuple-layout ' ,
- tuple>array 1 tail-slice [ ' ] map %
- ] { } make
- tuple type-number dup [ emit-seq ] emit-object
- ]
- ! Hack
- over class word-name "tombstone" =
- [ objects get swap cache ] [ call ] if ;
+ dup class word-name "tombstone" =
+ [ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
M: tuple ' emit-tuple ;
M: tuple-layout '
objects get [
[
- dup layout-hashcode ' ,
- dup layout-class ' ,
- dup layout-size ' ,
- dup layout-superclasses ' ,
- layout-echelon ' ,
- ] { } make
+ {
+ [ layout-hashcode , ]
+ [ layout-class , ]
+ [ layout-size , ]
+ [ layout-superclasses , ]
+ [ layout-echelon , ]
+ } cleave
+ ] { } make [ ' ] map
\ tuple-layout type-number
object tag-number [ emit-seq ] emit-object
] cache ;
@@ -329,14 +335,9 @@ M: tombstone '
word-def first objects get [ emit-tuple ] cache ;
! Arrays
-: emit-array ( list type tag -- pointer )
- >r >r [ ' ] map r> r> [
- dup length emit-fixnum
- emit-seq
- ] emit-object ;
-
M: array '
- array type-number object tag-number emit-array ;
+ [ ' ] map array type-number object tag-number
+ [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
! Quotations
@@ -351,13 +352,6 @@ M: quotation '
] emit-object
] cache ;
-! Curries
-
-M: curry '
- dup curry-quot ' swap curry-obj '
- \ curry type-number object tag-number
- [ emit emit ] emit-object ;
-
! End of the image
: emit-words ( -- )
@@ -437,8 +431,8 @@ M: curry '
: write-image ( image -- )
"Writing image to " write
architecture get boot-image-name resource-path
- dup write "..." print flush
- binary <file-writer> [ (write-image) ] with-stream ;
+ [ write "..." print flush ]
+ [ binary <file-writer> [ (write-image) ] with-stream ] bi ;
PRIVATE>
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 2e1a7f9f57..bc876c2dec 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -5,7 +5,8 @@ hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes
classes.tuple classes.tuple.private kernel.private vocabs
vocabs.loader source-files definitions slots.deprecated
-classes.union compiler.units bootstrap.image.private io.files ;
+classes.union compiler.units bootstrap.image.private io.files
+accessors combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
@@ -102,33 +103,36 @@ num-types get f <array> builtins set
! Builtin classes
: builtin-predicate-quot ( class -- quot )
[
- "type" word-prop dup
- \ tag-mask get < \ tag \ type ? , , \ eq? ,
+ "type" word-prop
+ [ tag-mask get < \ tag \ type ? , ] [ , ] bi
+ \ eq? ,
] [ ] make ;
: define-builtin-predicate ( class -- )
- dup
- dup builtin-predicate-quot define-predicate
- predicate-word make-inline ;
+ [ dup builtin-predicate-quot define-predicate ]
+ [ predicate-word make-inline ]
+ bi ;
: lookup-type-number ( word -- n )
global [ target-word ] bind type-number ;
: register-builtin ( class -- )
- dup
- dup lookup-type-number "type" set-word-prop
- dup "type" word-prop builtins get set-nth ;
+ [ dup lookup-type-number "type" set-word-prop ]
+ [ dup "type" word-prop builtins get set-nth ]
+ bi ;
: define-builtin-slots ( symbol slotspec -- )
- dupd 1 simple-slots
- 2dup "slots" set-word-prop
- define-slots ;
+ [ drop ] [ 1 simple-slots ] 2bi
+ [ "slots" set-word-prop ] [ define-slots ] 2bi ;
: define-builtin ( symbol slotspec -- )
>r
- dup register-builtin
- dup f f builtin-class define-class
- dup define-builtin-predicate
+ {
+ [ register-builtin ]
+ [ f f builtin-class define-class ]
+ [ define-builtin-predicate ]
+ [ ]
+ } cleave
r> define-builtin-slots ;
! Forward definitions
@@ -335,7 +339,10 @@ define-builtin
{ "set-delegate" "kernel" }
}
}
-define-tuple-slots
+[ drop ] [ generate-tuple-slots ] 2bi
+[ [ name>> ] map "slot-names" set-word-prop ]
+[ "slots" set-word-prop ]
+[ define-slots ] 2tri
"tuple" "kernel" lookup define-tuple-layout
@@ -495,8 +502,9 @@ f builtins get num-tags get tail union-class define-class
} define-tuple-class
"curry" "kernel" lookup
-dup f "inline" set-word-prop
-dup tuple-layout [ <tuple-boa> ] curry define
+[ f "inline" set-word-prop ]
+[ ]
+[ tuple-layout [ <tuple-boa> ] curry ] tri define
"compose" "kernel" create
"tuple" "kernel" lookup
@@ -515,8 +523,9 @@ dup tuple-layout [ <tuple-boa> ] curry define
} define-tuple-class
"compose" "kernel" lookup
-dup f "inline" set-word-prop
-dup tuple-layout [ <tuple-boa> ] curry define
+[ f "inline" set-word-prop ]
+[ ]
+[ tuple-layout [ <tuple-boa> ] curry ] tri define
! Primitive words
: make-primitive ( word vocab n -- )
From 6995e2adf5535194440fe5cac34087da2efda99e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 31 Mar 2008 01:19:34 -0500
Subject: [PATCH 028/127] Tuple reshaping now works with inheritance
---
core/classes/tuple/tuple-docs.factor | 14 +----
core/classes/tuple/tuple-tests.factor | 88 +++++++++++++++++++++++---
core/classes/tuple/tuple.factor | 90 ++++++++++++++++-----------
core/compiler/units/units.factor | 14 ++---
core/slots/slots.factor | 3 +
5 files changed, 142 insertions(+), 67 deletions(-)
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 7123d5c7c8..18c8143654 100755
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -153,23 +153,11 @@ HELP: tuple=
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
{ $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
-HELP: permutation
-{ $values { "seq1" sequence } { "seq2" sequence } { "permutation" "a sequence whose elements are integers or " { $link f } } }
-{ $description "Outputs a permutation for taking " { $snippet "seq1" } " to " { $snippet "seq2" } "." } ;
-
-HELP: reshape-tuple
-{ $values { "oldtuple" tuple } { "permutation" "a sequence whose elements are integers or " { $link f } } { "newtuple" tuple } }
-{ $description "Permutes the slots of a tuple. If a tuple class is redefined at runtime, this word is called on every instance to change its shape to conform to the new layout." } ;
-
-HELP: reshape-tuples
-{ $values { "class" tuple-class } { "superclass" class } { "newslots" "a sequence of strings" } }
-{ $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ;
-
HELP: removed-slots
{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } }
{ $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ;
-HELP: forget-slots
+HELP: forget-removed-slots
{ $values { "class" tuple-class } { "slots" "a sequence of strings" } }
{ $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ;
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 9b8228155b..0fac0c3779 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -265,9 +265,13 @@ C: <laptop> laptop
[ t ] [ "laptop" get computer? ] unit-test
[ t ] [ "laptop" get tuple? ] unit-test
-[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
-[ 128 ] [ "laptop" get ram>> ] unit-test
-[ t ] [ "laptop" get battery>> 3 hours = ] unit-test
+: test-laptop-slot-values
+ [ laptop ] [ "laptop" get class ] unit-test
+ [ "Pentium" ] [ "laptop" get cpu>> ] unit-test
+ [ 128 ] [ "laptop" get ram>> ] unit-test
+ [ t ] [ "laptop" get battery>> 3 hours = ] unit-test ;
+
+test-laptop-slot-values
[ laptop ] [
"laptop" get tuple-layout
@@ -294,9 +298,13 @@ C: <server> server
[ t ] [ "server" get computer? ] unit-test
[ t ] [ "server" get tuple? ] unit-test
-[ "PowerPC" ] [ "server" get cpu>> ] unit-test
-[ 64 ] [ "server" get ram>> ] unit-test
-[ "1U" ] [ "server" get rackmount>> ] unit-test
+: test-server-slot-values
+ [ server ] [ "server" get class ] unit-test
+ [ "PowerPC" ] [ "server" get cpu>> ] unit-test
+ [ 64 ] [ "server" get ram>> ] unit-test
+ [ "1U" ] [ "server" get rackmount>> ] unit-test ;
+
+test-server-slot-values
[ f ] [ "server" get laptop? ] unit-test
[ f ] [ "laptop" get server? ] unit-test
@@ -316,10 +324,10 @@ C: <server> server
"IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval
] must-fail
-! Reshaping with inheritance
+! Dynamically changing inheritance hierarchy
TUPLE: electronic-device ;
-[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
[ f ] [ electronic-device laptop class< ] unit-test
[ t ] [ server electronic-device class< ] unit-test
@@ -335,11 +343,73 @@ TUPLE: electronic-device ;
[ f ] [ "server" get laptop? ] unit-test
[ t ] [ "server" get server? ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: computer ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test
[ f ] [ "laptop" get electronic-device? ] unit-test
[ t ] [ "laptop" get computer? ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test
+
+test-laptop-slot-values
+test-server-slot-values
+
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test
+
+test-laptop-slot-values
+test-server-slot-values
+
+TUPLE: make-me-some-accessors voltage grounded? ;
+
+[ f ] [ "laptop" get voltage>> ] unit-test
+[ f ] [ "server" get voltage>> ] unit-test
+
+[ ] [ "laptop" get 220 >>voltage drop ] unit-test
+[ ] [ "server" get 110 >>voltage drop ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test
+
+test-laptop-slot-values
+test-server-slot-values
+
+[ 220 ] [ "laptop" get voltage>> ] unit-test
+[ 110 ] [ "server" get voltage>> ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test
+
+test-laptop-slot-values
+test-server-slot-values
+
+[ 220 ] [ "laptop" get voltage>> ] unit-test
+[ 110 ] [ "server" get voltage>> ] unit-test
+
+! Reshaping superclass and subclass simultaneously
+"IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval
+
+test-laptop-slot-values
+test-server-slot-values
+
+[ 220 ] [ "laptop" get voltage>> ] unit-test
+[ 110 ] [ "server" get voltage>> ] unit-test
+
+! Reshape crash
+TUPLE: test1 a ; TUPLE: test2 < test1 b ;
+
+T{ test2 f "a" "b" } "test" set
+
+: test-a/b
+ [ "a" ] [ "test" get a>> ] unit-test
+ [ "b" ] [ "test" get b>> ] unit-test ;
+
+test-a/b
+
+[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test
+
+test-a/b
+
+[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test
+
+test-a/b
+
! Redefinition problem
TUPLE: redefinition-problem ;
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 401a421c51..158ea9fc55 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -24,13 +24,14 @@ M: class tuple-layout "layout" word-prop ;
M: tuple tuple-layout 1 slot ;
M: tuple-layout tuple-layout ;
+
: tuple-size tuple-layout layout-size ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
[ tuple-size ] [ ] [ tuple-layout ] tri ;
-: copy-tuple-slots ( n tuple first -- array )
- [ array-nth ] curry map r> add* ;
+: copy-tuple-slots ( n tuple -- array )
+ [ array-nth ] curry map ;
PRIVATE>
@@ -128,48 +129,63 @@ PRIVATE>
[ writer-word forget-method ] 2bi
] with each ;
-: permutation ( seq1 seq2 -- permutation )
- swap [ index ] curry map ;
-
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class add* ;
-: slot-permutation ( class superclass newslots -- n permutation )
- [ all-slot-names ] [ all-slot-names ] [ ] tri* append
- [ drop length ] [ permutation ] 2bi ;
+: compute-slot-permutation ( class old-slot-names -- permutation )
+ >r all-slot-names r> [ index ] curry map ;
-: permute-direct-slots ( oldslots permutation -- newslots )
+: apply-slot-permutation ( old-values permutation -- new-values )
[ [ swap ?nth ] [ drop f ] if* ] with map ;
-: permute-all-slots ( oldslots n permutation -- newslots )
- [ >r head r> permute-direct-slots ] [ drop tail ] 3bi append ;
+: permute-slots ( old-values -- new-values )
+ dup first dup outdated-tuples get at
+ compute-slot-permutation
+ apply-slot-permutation ;
: change-tuple ( tuple quot -- newtuple )
>r tuple>array r> call >tuple ; inline
-: update-tuples ( predicate n permutation -- )
- [ permute-all-slots ] 2curry [ change-tuple ] curry
- >r "predicate" word-prop instances dup r> map
- become ; inline
+: update-tuple ( tuple -- newtuple )
+ [ permute-slots ] change-tuple ;
-: update-tuples-after ( class superclass newslots -- )
- [ 2drop ] [ slot-permutation ] 3bi
- [ update-tuples ] 3curry after-compilation ;
+: update-tuples ( -- )
+ outdated-tuples get
+ dup assoc-empty? [ drop ] [
+ [ >r class r> key? ] curry instances
+ dup [ update-tuple ] map become
+ ] if ;
+
+[ update-tuples ] update-tuples-hook set-global
+
+: update-tuples-after ( class -- )
+ outdated-tuples get [ all-slot-names ] cache drop ;
+
+: subclasses ( class -- classes )
+ class-usages keys [ tuple-class? ] subset ;
+
+: each-subclass ( class quot -- )
+ >r subclasses r> each ; inline
+
+: define-tuple-shape ( class -- )
+ [ define-tuple-slots ]
+ [ define-tuple-layout ]
+ [ define-tuple-predicate ]
+ tri ;
: define-new-tuple-class ( class superclass slots -- )
[ drop f tuple-class define-class ]
- [ nip "slot-names" set-word-prop ] [
+ [ nip "slot-names" set-word-prop ]
+ [
2drop
- class-usages keys [ tuple-class? ] subset [
- [ define-tuple-slots ]
- [ define-tuple-layout ]
- [ define-tuple-predicate ]
- tri
- ] each
+ [ define-tuple-shape ] each-subclass
] 3tri ;
: redefine-tuple-class ( class superclass slots -- )
- [ update-tuples-after ]
+ [
+ 2drop
+ [ update-tuples-after ] each-subclass
+ ]
[
nip
[ forget-removed-slots ]
@@ -205,11 +221,6 @@ M: tuple clone
M: tuple equal?
over tuple? [ tuple= ] [ 2drop f ] if ;
-: delegates ( obj -- seq )
- [ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
-
-: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
-
M: tuple hashcode*
[
dup tuple-size -rot 0 -rot [
@@ -217,21 +228,26 @@ M: tuple hashcode*
] 2curry reduce
] recursive-hashcode ;
-! Definition protocol
M: tuple-class reset-class
{ "metaclass" "superclass" "slots" "layout" } reset-props ;
M: object get-slots ( obj slots -- ... )
[ execute ] with each ;
-M: object set-slots ( ... obj slots -- )
- <reversed> get-slots ;
-
M: object construct-empty ( class -- tuple )
tuple-layout <tuple> ;
+M: object construct-boa ( ... class -- tuple )
+ tuple-layout <tuple-boa> ;
+
+! Deprecated
+M: object set-slots ( ... obj slots -- )
+ <reversed> get-slots ;
+
M: object construct ( ... slots class -- tuple )
construct-empty [ swap set-slots ] keep ;
-M: object construct-boa ( ... class -- tuple )
- tuple-layout <tuple-boa> ;
+: delegates ( obj -- seq )
+ [ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
+
+: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index 9849ddca7d..f87c1ec985 100755
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -69,21 +69,19 @@ GENERIC: definitions-changed ( assoc obj -- )
dup [ drop crossref? ] assoc-contains?
modify-code-heap ;
-SYMBOL: post-compile-tasks
-
-: after-compilation ( quot -- )
- post-compile-tasks get push ;
+SYMBOL: outdated-tuples
+SYMBOL: update-tuples-hook
: call-recompile-hook ( -- )
changed-words get keys
compiled-usages recompile-hook get call ;
-: call-post-compile-tasks ( -- )
- post-compile-tasks get [ call ] each ;
+: call-update-tuples-hook ( -- )
+ update-tuples-hook get call ;
: finish-compilation-unit ( -- )
call-recompile-hook
- call-post-compile-tasks
+ call-update-tuples-hook
dup [ drop crossref? ] assoc-contains? modify-code-heap
changed-definitions notify-definition-observers ;
@@ -91,7 +89,7 @@ SYMBOL: post-compile-tasks
[
H{ } clone changed-words set
H{ } clone forgotten-definitions set
- V{ } clone post-compile-tasks set
+ H{ } clone outdated-tuples set
<definitions> new-definitions set
<definitions> old-definitions set
[ finish-compilation-unit ]
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index eeb0926308..b674ec8c2a 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -79,3 +79,6 @@ C: <slot-spec> slot-spec
dup slot-spec-offset swap slot-spec-name
define-slot-methods
] with each ;
+
+: slot-named ( name specs -- spec/f )
+ [ slot-spec-name = ] with find nip ;
From 75497d721219261a7b45a47f018d6314d2fe533a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 31 Mar 2008 01:26:09 -0500
Subject: [PATCH 029/127] Add another unit test
---
core/classes/tuple/tuple-tests.factor | 8 ++++++++
1 file changed, 8 insertions(+)
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 0fac0c3779..950650dbf0 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -410,6 +410,14 @@ test-a/b
test-a/b
+! Twice in the same compilation unit
+[
+ test1 tuple { "a" "x" "y" } define-tuple-class
+ test1 tuple { "a" "y" } define-tuple-class
+] with-compilation-unit
+
+test-a/b
+
! Redefinition problem
TUPLE: redefinition-problem ;
From 30a7238f71fa930b46fceea9024fc1e9cbceef2a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 31 Mar 2008 02:30:06 -0500
Subject: [PATCH 030/127] Clean up serialization
---
extra/serialize/serialize.factor | 21 ++++++++++++---------
1 file changed, 12 insertions(+), 9 deletions(-)
diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor
index ac247057f4..7a2fbfae9e 100755
--- a/extra/serialize/serialize.factor
+++ b/extra/serialize/serialize.factor
@@ -90,13 +90,13 @@ M: float (serialize) ( obj -- )
M: complex (serialize) ( obj -- )
CHAR: c write1
- dup real-part (serialize)
- imaginary-part (serialize) ;
+ [ real-part (serialize) ]
+ [ imaginary-part (serialize) ] bi ;
M: ratio (serialize) ( obj -- )
CHAR: r write1
- dup numerator (serialize)
- denominator (serialize) ;
+ [ numerator (serialize) ]
+ [ denominator (serialize) ] bi ;
: serialize-seq ( obj code -- )
[
@@ -120,7 +120,8 @@ M: array (serialize) ( obj -- )
M: quotation (serialize) ( obj -- )
[
- CHAR: q write1 [ >array (serialize) ] [ add-object ] bi
+ CHAR: q write1
+ [ >array (serialize) ] [ add-object ] bi
] serialize-shared ;
M: hashtable (serialize) ( obj -- )
@@ -234,10 +235,12 @@ SYMBOL: deserialized
] if ;
: deserialize-gensym ( -- word )
- gensym
- dup intern-object
- dup (deserialize) define
- dup (deserialize) swap set-word-props ;
+ gensym {
+ [ intern-object ]
+ [ (deserialize) define ]
+ [ (deserialize) swap set-word-props ]
+ [ ]
+ } cleave ;
: deserialize-wrapper ( -- wrapper )
(deserialize) <wrapper> ;
From 8f0530daa6f8ce5a71dbea6f9edf081229301dc8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 31 Mar 2008 03:40:27 -0500
Subject: [PATCH 031/127] More inheritance fixes
---
core/classes/tuple/tuple-tests.factor | 44 ++++++++++++++++++++++++++-
core/classes/tuple/tuple.factor | 15 +++++----
2 files changed, 50 insertions(+), 9 deletions(-)
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 950650dbf0..db0e25f091 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -3,7 +3,7 @@ math.constants parser sequences tools.test words assocs
namespaces quotations sequences.private classes continuations
generic.standard effects classes.tuple classes.tuple.private
arrays vectors strings compiler.units accessors classes.algebra
-calendar prettyprint io.streams.string splitting ;
+calendar prettyprint io.streams.string splitting inspector ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
@@ -418,6 +418,48 @@ test-a/b
test-a/b
+! Moving slots up and down
+TUPLE: move-up-1 a b ;
+TUPLE: move-up-2 < move-up-1 c ;
+
+T{ move-up-2 f "a" "b" "c" } "move-up" set
+
+: test-move-up
+ [ "a" ] [ "move-up" get a>> ] unit-test
+ [ "b" ] [ "move-up" get b>> ] unit-test
+ [ "c" ] [ "move-up" get c>> ] unit-test ;
+
+test-move-up
+
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval ] unit-test
+
+test-move-up
+
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval ] unit-test
+
+test-move-up
+
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval ] unit-test
+
+test-move-up
+
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval ] unit-test
+
+! Constructors must be recompiled when changing superclass
+TUPLE: constructor-update-1 xxx ;
+
+TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ;
+
+C: <constructor-update-2> constructor-update-2
+
+{ 3 1 } [ <constructor-update-2> ] must-infer-as
+
+[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test
+
+{ 5 1 } [ <constructor-update-2> ] must-infer-as
+
+[ { f 1 2 3 4 5 } ] [ 1 2 3 4 5 <constructor-update-2> tuple-slots ] unit-test
+
! Redefinition problem
TUPLE: redefinition-problem ;
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 158ea9fc55..a3d0238d1c 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -184,15 +184,14 @@ PRIVATE>
: redefine-tuple-class ( class superclass slots -- )
[
2drop
- [ update-tuples-after ] each-subclass
- ]
- [
- nip
- [ forget-removed-slots ]
- [ drop changed-word ]
- [ drop redefined ]
- 2tri
+ [
+ [ update-tuples-after ]
+ [ changed-word ]
+ [ redefined ]
+ tri
+ ] each-subclass
]
+ [ nip forget-removed-slots ]
[ define-new-tuple-class ]
3tri ;
From 23bdf2faa7ac92bd433671539e5153166839122c Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@self.internal.stack-effects.com>
Date: Mon, 31 Mar 2008 08:57:16 -0500
Subject: [PATCH 032/127] add using
---
extra/io/unix/sockets/sockets.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor
index dea7dc17b5..c7931c6f0c 100755
--- a/extra/io/unix/sockets/sockets.factor
+++ b/extra/io/unix/sockets/sockets.factor
@@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces
io.nonblocking parser threads unix sequences
byte-arrays io.sockets io.binary io.unix.backend
io.streams.duplex io.sockets.impl math.parser continuations libc
-combinators ;
+combinators io.backend ;
IN: io.unix.sockets
: pending-init-error ( port -- )
From b21d83b53130a87f6adc9498cf06c086081ce260 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 31 Mar 2008 12:47:39 -0500
Subject: [PATCH 033/127] remove failing unit test for now
---
extra/openssl/openssl-tests.factor | 11 ++++++-----
1 file changed, 6 insertions(+), 5 deletions(-)
diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor
index c689f729d1..c85c0ee218 100755
--- a/extra/openssl/openssl-tests.factor
+++ b/extra/openssl/openssl-tests.factor
@@ -11,11 +11,12 @@ namespaces math math.parser openssl prettyprint sequences tools.test ;
]
[ "Hello world from the openssl binding" >md5 ] unit-test
-[
- B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49
- 82 115 0 }
-]
-[ "Hello world from the openssl binding" >sha1 ] unit-test
+! Not found on netbsd, windows -- why?
+! [
+ ! B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49
+ ! 82 115 0 }
+! ]
+! [ "Hello world from the openssl binding" >sha1 ] unit-test
! =========================================================
! Initialize context
From 13b31be060071a645bdef5ed61e258d6173e93a6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 31 Mar 2008 13:43:42 -0500
Subject: [PATCH 034/127] fix copy-tree
---
core/io/files/files.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 458a9145a6..f397af606b 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -4,6 +4,7 @@ USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations io.encodings
io.encodings.binary init accessors ;
+USE: tools.walker
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
@@ -267,6 +268,7 @@ M: object copy-file
DEFER: copy-tree-into
: copy-tree ( from to -- )
+ normalize-pathname
over link-info type>>
{
{ +symbolic-link+ [ copy-link ] }
From b13ac1e17f323f826669f6758a90453940e4cbb5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 31 Mar 2008 13:51:24 -0500
Subject: [PATCH 035/127] remove using
---
core/io/files/files.factor | 1 -
1 file changed, 1 deletion(-)
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index f397af606b..099acb157e 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -4,7 +4,6 @@ USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations io.encodings
io.encodings.binary init accessors ;
-USE: tools.walker
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
From a8e223f47143bf193d5df8f7b3bfe2308c7cb574 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 31 Mar 2008 13:51:34 -0500
Subject: [PATCH 036/127] fix unix domain socket test
---
extra/io/sockets/sockets.factor | 3 ++-
extra/io/unix/sockets/sockets.factor | 4 ++--
2 files changed, 4 insertions(+), 3 deletions(-)
diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor
index 1dc7f4883d..e1cc36cd2e 100755
--- a/extra/io/sockets/sockets.factor
+++ b/extra/io/sockets/sockets.factor
@@ -6,7 +6,8 @@ IN: io.sockets
TUPLE: local path ;
-C: <local> local
+: <local> ( path -- addrspec )
+ normalize-pathname local construct-boa ;
TUPLE: inet4 host port ;
diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor
index c7931c6f0c..69ce6a3069 100755
--- a/extra/io/unix/sockets/sockets.factor
+++ b/extra/io/unix/sockets/sockets.factor
@@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces
io.nonblocking parser threads unix sequences
byte-arrays io.sockets io.binary io.unix.backend
io.streams.duplex io.sockets.impl math.parser continuations libc
-combinators io.backend ;
+combinators io.backend io.files ;
IN: io.unix.sockets
: pending-init-error ( port -- )
@@ -189,7 +189,7 @@ M: local protocol-family drop PF_UNIX ;
M: local sockaddr-type drop "sockaddr-un" c-type ;
M: local make-sockaddr
- local-path normalize-pathname
+ local-path cwd prepend-path
dup length 1 + max-un-path > [ "Path too long" throw ] when
"sockaddr-un" <c-object>
AF_UNIX over set-sockaddr-un-family
From 0a63a8fb40dd290b36958bad7cda4b2751b961c6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 31 Mar 2008 14:38:11 -0500
Subject: [PATCH 037/127] normalize-pathname in local sockets
---
extra/io/unix/sockets/sockets.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor
index bd7dfd9ce1..dea7dc17b5 100755
--- a/extra/io/unix/sockets/sockets.factor
+++ b/extra/io/unix/sockets/sockets.factor
@@ -189,7 +189,7 @@ M: local protocol-family drop PF_UNIX ;
M: local sockaddr-type drop "sockaddr-un" c-type ;
M: local make-sockaddr
- local-path
+ local-path normalize-pathname
dup length 1 + max-un-path > [ "Path too long" throw ] when
"sockaddr-un" <c-object>
AF_UNIX over set-sockaddr-un-family
From f49c72bb05fd5a2af16622f20b6771a857b10fac Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 31 Mar 2008 15:31:51 -0500
Subject: [PATCH 038/127] remove curry2 from mersenne.private...
---
extra/random/mersenne-twister/mersenne-twister.factor | 5 +----
1 file changed, 1 insertion(+), 4 deletions(-)
diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor
index ce1749ce62..8ddbdac6f4 100755
--- a/extra/random/mersenne-twister/mersenne-twister.factor
+++ b/extra/random/mersenne-twister/mersenne-twister.factor
@@ -9,9 +9,6 @@ IN: random.mersenne-twister
<PRIVATE
-: curry2 ( w quot1 quot2 -- quot1 quot2 )
- >r over r> [ curry ] 2bi@ ; inline
-
TUPLE: mersenne-twister seq i ;
: mt-n 624 ; inline
@@ -27,7 +24,7 @@ TUPLE: mersenne-twister seq i ;
r> bitxor bitxor r> r> set-nth ; inline
: calculate-y ( y1 y2 mt -- y )
- [ nth mt-hi ] [ nth mt-lo ] curry2 bi* bitor ; inline
+ tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline
: (mt-generate) ( n mt-seq -- y to from-elt )
[ >r dup 1+ mt-wrap r> calculate-y ]
From c2fdd797bcbff592ac1a65cba2044d7f8aef719f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 31 Mar 2008 16:20:09 -0500
Subject: [PATCH 039/127] Try to fix inotify again
---
extra/io/unix/linux/linux.factor | 25 +++++++++++++------------
1 file changed, 13 insertions(+), 12 deletions(-)
diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor
index 7580e7bf6b..3a8fad3d4d 100755
--- a/extra/io/unix/linux/linux.factor
+++ b/extra/io/unix/linux/linux.factor
@@ -3,8 +3,8 @@
USING: kernel io.backend io.monitors io.monitors.private
io.files io.buffers io.nonblocking io.timeouts io.unix.backend
io.unix.select io.unix.launcher unix.linux.inotify assocs
-namespaces threads continuations init math
-alien.c-types alien vocabs.loader ;
+namespaces threads continuations init math alien.c-types alien
+vocabs.loader accessors ;
IN: io.unix.linux
TUPLE: linux-io ;
@@ -18,18 +18,16 @@ TUPLE: linux-monitor ;
TUPLE: inotify watches ;
-: watches ( -- assoc ) inotify get-global inotify-watches ;
+: watches ( -- assoc ) inotify get-global watches>> ;
: wd>monitor ( wd -- monitor ) watches at ;
: <inotify> ( -- port/f )
H{ } clone
- inotify_init dup 0 < [ 2drop f ] [
- inotify <buffered-port>
- { set-inotify-watches set-delegate } inotify construct
- ] if ;
+ inotify_init [ io-error ] [ inotify <buffered-port> ] bi
+ { set-inotify-watches set-delegate } inotify construct ;
-: inotify-fd inotify get-global port-handle ;
+: inotify-fd inotify get-global handle>> ;
: (add-watch) ( path mask -- wd )
inotify-fd -rot inotify_add_watch dup io-error ;
@@ -80,10 +78,10 @@ M: linux-monitor dispose ( monitor -- )
parse-action swap alien>char-string ;
: events-exhausted? ( i buffer -- ? )
- buffer-fill >= ;
+ fill>> >= ;
: inotify-event@ ( i buffer -- alien )
- buffer-ptr <displaced-alien> ;
+ ptr>> <displaced-alien> ;
: next-event ( i buffer -- i buffer )
2dup inotify-event@
@@ -111,14 +109,17 @@ TUPLE: inotify-task ;
f inotify-task <input-task> ;
: init-inotify ( mx -- )
- <inotify> dup inotify set-global
+ <inotify>
+ dup inotify set-global
<inotify-task> swap register-io-task ;
M: inotify-task do-io-task ( task -- )
io-task-port read-notifications f ;
M: linux-io init-io ( -- )
- <select-mx> dup mx set-global init-inotify ;
+ <select-mx>
+ [ mx set-global ]
+ [ [ init-inotify ] ignore-errors ] bi ;
T{ linux-io } set-io-backend
From 8742c3f2dcb95f5e6efcdf9ac94e52819096b1e0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 31 Mar 2008 16:20:22 -0500
Subject: [PATCH 040/127] Oops
---
extra/io/unix/linux/linux.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor
index 3a8fad3d4d..2ae4065fb6 100755
--- a/extra/io/unix/linux/linux.factor
+++ b/extra/io/unix/linux/linux.factor
@@ -119,7 +119,7 @@ M: inotify-task do-io-task ( task -- )
M: linux-io init-io ( -- )
<select-mx>
[ mx set-global ]
- [ [ init-inotify ] ignore-errors ] bi ;
+ [ [ init-inotify ] curry ignore-errors ] bi ;
T{ linux-io } set-io-backend
From ecf59b716844aa429e51be4dfcbc73c93bb44980 Mon Sep 17 00:00:00 2001
From: "U-CUTLER\\dharmatech" <dharmatech@cutler.(none)>
Date: Mon, 31 Mar 2008 15:27:32 -0600
Subject: [PATCH 041/127] Move ldap to unmaintained
---
{extra => unmaintained}/ldap/authors.txt | 0
{extra => unmaintained}/ldap/conf/addentry.ldif | 0
{extra => unmaintained}/ldap/conf/createdit.ldif | 0
{extra => unmaintained}/ldap/conf/slapd.conf | 0
{extra => unmaintained}/ldap/ldap-tests.factor | 0
{extra => unmaintained}/ldap/ldap.factor | 0
{extra => unmaintained}/ldap/libldap/authors.txt | 0
{extra => unmaintained}/ldap/libldap/libldap.factor | 0
{extra => unmaintained}/ldap/libldap/tags.txt | 0
{extra => unmaintained}/ldap/summary.txt | 0
{extra => unmaintained}/ldap/tags.txt | 0
11 files changed, 0 insertions(+), 0 deletions(-)
rename {extra => unmaintained}/ldap/authors.txt (100%)
rename {extra => unmaintained}/ldap/conf/addentry.ldif (100%)
rename {extra => unmaintained}/ldap/conf/createdit.ldif (100%)
rename {extra => unmaintained}/ldap/conf/slapd.conf (100%)
rename {extra => unmaintained}/ldap/ldap-tests.factor (100%)
rename {extra => unmaintained}/ldap/ldap.factor (100%)
rename {extra => unmaintained}/ldap/libldap/authors.txt (100%)
rename {extra => unmaintained}/ldap/libldap/libldap.factor (100%)
rename {extra => unmaintained}/ldap/libldap/tags.txt (100%)
rename {extra => unmaintained}/ldap/summary.txt (100%)
rename {extra => unmaintained}/ldap/tags.txt (100%)
diff --git a/extra/ldap/authors.txt b/unmaintained/ldap/authors.txt
similarity index 100%
rename from extra/ldap/authors.txt
rename to unmaintained/ldap/authors.txt
diff --git a/extra/ldap/conf/addentry.ldif b/unmaintained/ldap/conf/addentry.ldif
similarity index 100%
rename from extra/ldap/conf/addentry.ldif
rename to unmaintained/ldap/conf/addentry.ldif
diff --git a/extra/ldap/conf/createdit.ldif b/unmaintained/ldap/conf/createdit.ldif
similarity index 100%
rename from extra/ldap/conf/createdit.ldif
rename to unmaintained/ldap/conf/createdit.ldif
diff --git a/extra/ldap/conf/slapd.conf b/unmaintained/ldap/conf/slapd.conf
similarity index 100%
rename from extra/ldap/conf/slapd.conf
rename to unmaintained/ldap/conf/slapd.conf
diff --git a/extra/ldap/ldap-tests.factor b/unmaintained/ldap/ldap-tests.factor
similarity index 100%
rename from extra/ldap/ldap-tests.factor
rename to unmaintained/ldap/ldap-tests.factor
diff --git a/extra/ldap/ldap.factor b/unmaintained/ldap/ldap.factor
similarity index 100%
rename from extra/ldap/ldap.factor
rename to unmaintained/ldap/ldap.factor
diff --git a/extra/ldap/libldap/authors.txt b/unmaintained/ldap/libldap/authors.txt
similarity index 100%
rename from extra/ldap/libldap/authors.txt
rename to unmaintained/ldap/libldap/authors.txt
diff --git a/extra/ldap/libldap/libldap.factor b/unmaintained/ldap/libldap/libldap.factor
similarity index 100%
rename from extra/ldap/libldap/libldap.factor
rename to unmaintained/ldap/libldap/libldap.factor
diff --git a/extra/ldap/libldap/tags.txt b/unmaintained/ldap/libldap/tags.txt
similarity index 100%
rename from extra/ldap/libldap/tags.txt
rename to unmaintained/ldap/libldap/tags.txt
diff --git a/extra/ldap/summary.txt b/unmaintained/ldap/summary.txt
similarity index 100%
rename from extra/ldap/summary.txt
rename to unmaintained/ldap/summary.txt
diff --git a/extra/ldap/tags.txt b/unmaintained/ldap/tags.txt
similarity index 100%
rename from extra/ldap/tags.txt
rename to unmaintained/ldap/tags.txt
From 01d0ab20c67c8b6e240f0ceaa6092cfca55ef919 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 31 Mar 2008 15:28:21 -0600
Subject: [PATCH 042/127] sequences: new words: prefix and suffix
---
core/sequences/sequences.factor | 19 ++++++++++++++++---
1 file changed, 16 insertions(+), 3 deletions(-)
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 1f2a6c5501..26c1013c28 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -478,18 +478,31 @@ M: sequence <=>
: push-new ( elt seq -- ) [ delete ] 2keep push ;
+: add* ( seq elt -- newseq )
+ over >r over length 1+ r> [
+ [ 0 swap set-nth-unsafe ] keep
+ [ 1 swap copy ] keep
+ ] new-like ;
+
+: prefix ( seq elt -- newseq )
+ over >r over length 1+ r> [
+ [ 0 swap set-nth-unsafe ] keep
+ [ 1 swap copy ] keep
+ ] new-like ;
+
: add ( seq elt -- newseq )
over >r over length 1+ r> [
[ >r over length r> set-nth-unsafe ] keep
[ 0 swap copy ] keep
] new-like ;
-: add* ( seq elt -- newseq )
+: suffix ( seq elt -- newseq )
over >r over length 1+ r> [
- [ 0 swap set-nth-unsafe ] keep
- [ 1 swap copy ] keep
+ [ >r over length r> set-nth-unsafe ] keep
+ [ 0 swap copy ] keep
] new-like ;
+
: seq-diff ( seq1 seq2 -- newseq )
swap [ member? not ] curry subset ;
From 4181728ecaf15c2d6fcc8ea5b237a9354685b72a Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 31 Mar 2008 15:29:22 -0600
Subject: [PATCH 043/127] ui.gadgets.slate: add some gesture handling for
processing demos
---
extra/ui/gadgets/slate/slate.factor | 104 +++++++++++++++++++++++++++-
1 file changed, 102 insertions(+), 2 deletions(-)
diff --git a/extra/ui/gadgets/slate/slate.factor b/extra/ui/gadgets/slate/slate.factor
index 5ea1ec20fa..ab2abeec5b 100644
--- a/extra/ui/gadgets/slate/slate.factor
+++ b/extra/ui/gadgets/slate/slate.factor
@@ -3,7 +3,11 @@ USING: kernel namespaces opengl ui.render ui.gadgets ;
IN: ui.gadgets.slate
-TUPLE: slate action dim graft ungraft ;
+TUPLE: slate action dim graft ungraft
+ button-down
+ button-up
+ key-down
+ key-up ;
: <slate> ( action -- slate )
slate construct-gadget
@@ -19,4 +23,100 @@ M: slate draw-gadget* ( slate -- )
M: slate graft* ( slate -- ) slate-graft call ;
-M: slate ungraft* ( slate -- ) slate-ungraft call ;
\ No newline at end of file
+M: slate ungraft* ( slate -- ) slate-ungraft call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: key-pressed-value
+
+: key-pressed? ( -- ? ) key-pressed-value get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: mouse-pressed-value
+
+: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: key-value
+
+: key ( -- key ) key-value get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: button-value
+
+: button ( -- val ) button-value get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: combinators ui.gestures accessors ;
+
+! M: slate handle-gesture* ( gadget gesture delegate -- ? )
+! drop nip
+! {
+! {
+! [ dup key-down? ]
+! [
+
+! key-down-sym key-value set
+! key-pressed-value on
+! t
+! ]
+! }
+! { [ dup key-up? ] [ drop key-pressed-value off t ] }
+! {
+! [ dup button-down? ]
+! [
+! button-down-# mouse-button-value set
+! mouse-pressed-value on
+! t
+! ]
+! }
+! { [ dup button-up? ] [ drop mouse-pressed-value off t ] }
+! { [ t ] [ drop t ] }
+! }
+! cond ;
+
+M: slate handle-gesture* ( gadget gesture delegate -- ? )
+ rot drop swap ! delegate gesture
+ {
+ {
+ [ dup key-down? ]
+ [
+ key-down-sym key-value set
+ key-pressed-value on
+ key-down>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ {
+ [ dup key-up? ]
+ [
+ key-pressed-value off
+ drop
+ key-up>> dup [ call ] [ drop ] if
+ t
+ ] }
+ {
+ [ dup button-down? ]
+ [
+ button-down-# button-value set
+ mouse-pressed-value on
+ button-down>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ {
+ [ dup button-up? ]
+ [
+ mouse-pressed-value off
+ drop
+ button-up>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ { [ t ] [ 2drop t ] }
+ }
+ cond ;
\ No newline at end of file
From 72bfd57f308a6b2efe7c8b9697282eab00588856 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Tue, 1 Apr 2008 11:28:14 +1300
Subject: [PATCH 044/127] Make ebnf forgiving of whitespace at end of
expression
---
extra/peg/ebnf/ebnf.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 4f00edbd3c..26e5d68df8 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -320,7 +320,7 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
: check-parse-result ( result -- result )
dup [
- dup parse-result-remaining empty? [
+ dup parse-result-remaining [ blank? ] trim empty? [
[
"Unable to fully parse EBNF. Left to parse was: " %
parse-result-remaining %
From aa40350aa76805e1aed683966647aaeea2d7ed28 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 31 Mar 2008 18:18:05 -0600
Subject: [PATCH 045/127] replace add* and add with prefix and suffix
---
core/alien/c-types/c-types.factor | 12 ++++++------
core/alien/compiler/compiler.factor | 2 +-
core/alien/structs/structs-docs.factor | 10 +++++-----
core/alien/structs/structs.factor | 2 +-
core/classes/algebra/algebra.factor | 8 ++++----
core/classes/classes.factor | 2 +-
core/classes/mixin/mixin.factor | 2 +-
core/classes/tuple/tuple.factor | 2 +-
core/combinators/combinators.factor | 4 ++--
core/cpu/x86/assembler/assembler.factor | 2 +-
core/cpu/x86/intrinsics/intrinsics.factor | 4 ++--
core/cpu/x86/sse2/sse2.factor | 4 ++--
core/generic/generic.factor | 2 +-
core/generic/standard/standard.factor | 6 +++---
core/inference/backend/backend.factor | 6 +++---
core/inference/class/class.factor | 2 +-
core/inference/dataflow/dataflow.factor | 2 +-
core/inference/transforms/transforms.factor | 2 +-
core/io/encodings/encodings.factor | 2 +-
core/optimizer/known-words/known-words.factor | 2 +-
core/optimizer/specializers/specializers.factor | 2 +-
core/parser/parser.factor | 2 +-
core/slots/slots.factor | 2 +-
core/splitting/splitting.factor | 2 +-
core/vocabs/loader/loader.factor | 2 +-
core/vocabs/vocabs.factor | 2 +-
extra/benchmark/fasta/fasta.factor | 2 +-
extra/cfdg/cfdg.factor | 2 +-
extra/color-picker/color-picker.factor | 2 +-
extra/delegate/delegate.factor | 2 +-
extra/editors/editors.factor | 2 +-
extra/faq/faq.factor | 2 +-
extra/fry/fry.factor | 2 +-
extra/help/markup/markup.factor | 2 +-
extra/koszul/koszul.factor | 4 ++--
extra/lazy-lists/lazy-lists.factor | 2 +-
extra/locals/locals.factor | 8 ++++----
extra/logging/logging.factor | 2 +-
extra/lsys/tortoise/graphics/graphics.factor | 2 +-
extra/math/combinatorics/combinatorics.factor | 2 +-
extra/multi-methods/multi-methods.factor | 4 ++--
extra/opengl/gl/extensions/extensions.factor | 2 +-
extra/oracle/oracle.factor | 4 ++--
extra/parser-combinators/parser-combinators.factor | 6 +++---
extra/peg/peg.factor | 4 ++--
extra/project-euler/043/043.factor | 4 ++--
extra/project-euler/common/common.factor | 4 ++--
extra/qualified/qualified.factor | 2 +-
extra/regexp/regexp.factor | 2 +-
extra/regexp2/regexp2.factor | 2 +-
extra/sequences/lib/lib.factor | 2 +-
extra/springies/springies.factor | 4 ++--
extra/state-machine/state-machine.factor | 2 +-
extra/tetris/board/board.factor | 2 +-
extra/tools/deploy/backend/backend.factor | 4 ++--
extra/tools/vocabs/vocabs.factor | 4 ++--
extra/tools/walker/walker.factor | 6 +++---
extra/ui/commands/commands-docs.factor | 2 +-
extra/ui/gadgets/grid-lines/grid-lines.factor | 2 +-
extra/ui/gadgets/panes/panes.factor | 2 +-
extra/unix/process/process.factor | 2 +-
extra/xmode/rules/rules.factor | 2 +-
62 files changed, 97 insertions(+), 97 deletions(-)
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index d874243d71..ae99f9e6bf 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -45,7 +45,7 @@ GENERIC: c-type ( name -- type ) foldable
: parse-array-type ( name -- array )
"[" split unclip
- >r [ "]" ?tail drop string>number ] map r> add* ;
+ >r [ "]" ?tail drop string>number ] map r> prefix ;
M: string c-type ( name -- type )
CHAR: ] over member? [
@@ -162,7 +162,7 @@ DEFER: >c-ushort-array
>r >c-ushort-array r> byte-array>memory ;
: (define-nth) ( word type quot -- )
- >r heap-size [ rot * ] swap add* r> append define-inline ;
+ >r heap-size [ rot * ] swap prefix r> append define-inline ;
: nth-word ( name vocab -- word )
>r "-nth" append r> create ;
@@ -199,12 +199,12 @@ M: long-long-type box-return ( type -- )
f swap box-parameter ;
: define-deref ( name vocab -- )
- >r dup CHAR: * add* r> create
- swap c-getter 0 add* define-inline ;
+ >r dup CHAR: * prefix r> create
+ swap c-getter 0 prefix define-inline ;
: define-out ( name vocab -- )
over [ <c-object> tuck 0 ] over c-setter append swap
- >r >r constructor-word r> r> add* define-inline ;
+ >r >r constructor-word r> r> prefix define-inline ;
: c-bool> ( int -- ? )
zero? not ;
@@ -257,7 +257,7 @@ M: long-long-type box-return ( type -- )
#! staging violations
dup array? [
unclip >r [ dup word? [ word-def call ] when ] map
- r> add*
+ r> prefix
] when ;
: malloc-file-contents ( path -- alien len )
diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor
index 3e0062c85a..1a9d5b5392 100755
--- a/core/alien/compiler/compiler.factor
+++ b/core/alien/compiler/compiler.factor
@@ -18,7 +18,7 @@ IN: alien.compiler
: alien-node-parameters* ( node -- seq )
dup parameters>>
- swap return>> large-struct? [ "void*" add* ] when ;
+ swap return>> large-struct? [ "void*" prefix ] when ;
: alien-node-return* ( node -- ctype )
return>> dup large-struct? [ drop "void" ] when ;
diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor
index 6c7775de2b..e7e576293f 100755
--- a/core/alien/structs/structs-docs.factor
+++ b/core/alien/structs/structs-docs.factor
@@ -8,7 +8,7 @@ kernel words slots assocs namespaces ;
dup ?word-name swap 2array
over slot-spec-name
rot slot-spec-type 2array 2array
- [ { $instance } swap add ] assoc-map ;
+ [ { $instance } swap suffix ] assoc-map ;
: $spec-reader-values ( slot-spec class -- )
($spec-reader-values) $values ;
@@ -16,9 +16,9 @@ kernel words slots assocs namespaces ;
: $spec-reader-description ( slot-spec class -- )
[
"Outputs the value stored in the " ,
- { $snippet } rot slot-spec-name add ,
+ { $snippet } rot slot-spec-name suffix ,
" slot of " ,
- { $instance } swap add ,
+ { $instance } swap suffix ,
" instance." ,
] { } make $description ;
@@ -43,9 +43,9 @@ M: word slot-specs "slots" word-prop ;
: $spec-writer-description ( slot-spec class -- )
[
"Stores a new value to the " ,
- { $snippet } rot slot-spec-name add ,
+ { $snippet } rot slot-spec-name suffix ,
" slot of " ,
- { $instance } swap add ,
+ { $instance } swap suffix ,
" instance." ,
] { } make $description ;
diff --git a/core/alien/structs/structs.factor b/core/alien/structs/structs.factor
index e5de8ab83e..491f4351a3 100755
--- a/core/alien/structs/structs.factor
+++ b/core/alien/structs/structs.factor
@@ -16,7 +16,7 @@ IN: alien.structs
] reduce ;
: define-struct-slot-word ( spec word quot -- )
- rot slot-spec-offset add* define-inline ;
+ rot slot-spec-offset prefix define-inline ;
: define-getter ( type spec -- )
[ set-reader-props ] keep
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index 2945bd2546..5d7c114cbc 100755
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -138,10 +138,10 @@ C: <anonymous-complement> anonymous-complement
members>> [ class-and ] with map <anonymous-union> ;
: left-anonymous-intersection-and ( first second -- class )
- >r members>> r> add <anonymous-intersection> ;
+ >r members>> r> suffix <anonymous-intersection> ;
: right-anonymous-intersection-and ( first second -- class )
- members>> swap add <anonymous-intersection> ;
+ members>> swap suffix <anonymous-intersection> ;
: (class-and) ( first second -- class )
{
@@ -158,10 +158,10 @@ C: <anonymous-complement> anonymous-complement
} cond ;
: left-anonymous-union-or ( first second -- class )
- >r members>> r> add <anonymous-union> ;
+ >r members>> r> suffix <anonymous-union> ;
: right-anonymous-union-or ( first second -- class )
- members>> swap add <anonymous-union> ;
+ members>> swap suffix <anonymous-union> ;
: (class-or) ( first second -- class )
{
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 435c7413a3..d6d1a72121 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -72,7 +72,7 @@ M: word reset-class drop ;
! update-map
: class-uses ( class -- seq )
- dup members swap superclass [ add ] when* ;
+ dup members swap superclass [ suffix ] when* ;
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index eb6b3bd6e2..b771aa8920 100755
--- a/core/classes/mixin/mixin.factor
+++ b/core/classes/mixin/mixin.factor
@@ -35,7 +35,7 @@ TUPLE: check-mixin-class mixin ;
swap redefine-mixin-class ; inline
: add-mixin-instance ( class mixin -- )
- [ 2drop ] [ [ add ] change-mixin-class ] if-mixin-member? ;
+ [ 2drop ] [ [ suffix ] change-mixin-class ] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- )
[ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index a452d0eeec..fcce6a7b45 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -34,7 +34,7 @@ PRIVATE>
: tuple>array ( tuple -- array )
dup tuple-layout
[ layout-size swap [ array-nth ] curry map ] keep
- layout-class add* ;
+ layout-class prefix ;
: >tuple ( seq -- tuple )
dup first tuple-layout <tuple> [
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index e19847dbd4..484c7ab730 100755
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -43,7 +43,7 @@ ERROR: no-case ;
: with-datastack ( stack quot -- newstack )
datastack >r
>r >array set-datastack r> call
- datastack r> swap add set-datastack 2nip ; inline
+ datastack r> swap suffix set-datastack 2nip ; inline
: recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
@@ -66,7 +66,7 @@ M: hashtable hashcode*
reverse [ no-cond ] swap alist>quot ;
: linear-case-quot ( default assoc -- quot )
- [ >r [ dupd = ] curry r> \ drop add* ] assoc-map
+ [ >r [ dupd = ] curry r> \ drop prefix ] assoc-map
alist>quot ;
: (distribute-buckets) ( buckets pair keys -- )
diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor
index 796388ffe1..a3ab256ea1 100755
--- a/core/cpu/x86/assembler/assembler.factor
+++ b/core/cpu/x86/assembler/assembler.factor
@@ -230,7 +230,7 @@ UNION: operand register indirect ;
: opcode-or ( opcode mask -- opcode' )
swap dup array?
- [ 1 cut* first rot bitor add ] [ bitor ] if ;
+ [ 1 cut* first rot bitor suffix ] [ bitor ] if ;
: 1-operand ( op reg rex.w opcode -- )
#! The 'reg' is not really a register, but a value for the
diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor
index f5409a24f5..261ada025b 100755
--- a/core/cpu/x86/intrinsics/intrinsics.factor
+++ b/core/cpu/x86/intrinsics/intrinsics.factor
@@ -156,7 +156,7 @@ IN: cpu.x86.intrinsics
! Fixnums
: fixnum-op ( op hash -- pair )
- >r [ "x" operand "y" operand ] swap add r> 2array ;
+ >r [ "x" operand "y" operand ] swap suffix r> 2array ;
: fixnum-value-op ( op -- pair )
H{
@@ -251,7 +251,7 @@ IN: cpu.x86.intrinsics
\ fixnum- \ SUB overflow-template
: fixnum-jump ( op inputs -- pair )
- >r [ "x" operand "y" operand CMP ] swap add r> 2array ;
+ >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
: fixnum-value-jump ( op -- pair )
{ { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
diff --git a/core/cpu/x86/sse2/sse2.factor b/core/cpu/x86/sse2/sse2.factor
index 98e42fa7fe..9c477b4132 100755
--- a/core/cpu/x86/sse2/sse2.factor
+++ b/core/cpu/x86/sse2/sse2.factor
@@ -8,7 +8,7 @@ math.floats.private layouts quotations ;
IN: cpu.x86.sse2
: define-float-op ( word op -- )
- [ "x" operand "y" operand ] swap add H{
+ [ "x" operand "y" operand ] swap suffix H{
{ +input+ { { float "x" } { float "y" } } }
{ +output+ { "x" } }
} define-intrinsic ;
@@ -23,7 +23,7 @@ IN: cpu.x86.sse2
] each
: define-float-jump ( word op -- )
- [ "x" operand "y" operand UCOMISD ] swap add
+ [ "x" operand "y" operand UCOMISD ] swap suffix
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 131b7e57c9..7dba7eb709 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -157,7 +157,7 @@ M: assoc update-methods ( assoc -- )
M: generic subwords
dup "methods" word-prop values
- swap "default-method" word-prop add ;
+ swap "default-method" word-prop suffix ;
M: generic forget-word
dup subwords [ forget ] each (forget-word) ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 4447c5a264..13b5278735 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -34,8 +34,8 @@ ERROR: no-method object generic ;
: empty-method ( word -- quot )
[
picker % [ delegate dup ] %
- unpicker over add ,
- error-method \ drop add* , \ if ,
+ unpicker over suffix ,
+ error-method \ drop prefix , \ if ,
] [ ] make ;
: class-predicates ( assoc -- assoc )
@@ -137,7 +137,7 @@ ERROR: no-method object generic ;
] if ;
: standard-methods ( word -- alist )
- dup methods swap default-method add*
+ dup methods swap default-method prefix
[ 1quotation ] assoc-map ;
M: standard-combination make-default-method
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index 2a2e6995eb..5ca9b1b2e7 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -92,7 +92,7 @@ M: wrapper apply-object
r> recursive-state set ;
: infer-quot-recursive ( quot word label -- )
- recursive-state get -rot 2array add* infer-quot ;
+ recursive-state get -rot 2array prefix infer-quot ;
: time-bomb ( error -- )
[ throw ] curry recursive-state get infer-quot ;
@@ -109,7 +109,7 @@ TUPLE: recursive-quotation-error quot ;
dup value-literal callable? [
dup value-literal
over value-recursion
- rot f 2array add* infer-quot
+ rot f 2array prefix infer-quot
] [
drop bad-call
] if
@@ -430,7 +430,7 @@ M: #call-label collect-recursion*
[ [ swap collect-recursion* ] curry each-node ] { } make ;
: join-values ( node -- )
- collect-recursion [ node-in-d ] map meta-d get add
+ collect-recursion [ node-in-d ] map meta-d get suffix
unify-lengths unify-stacks
meta-d [ length tail* ] change ;
diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor
index ed36ca4890..4aac98ce41 100755
--- a/core/inference/class/class.factor
+++ b/core/inference/class/class.factor
@@ -289,7 +289,7 @@ M: #label infer-classes-around ( #label -- )
dup annotate-node
dup infer-classes-before
dup infer-children
- dup collect-recursion over add
+ dup collect-recursion over suffix
pick annotate-entry
node-child (infer-classes) ;
diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor
index 0b6cf04028..7fa2fbbcd3 100755
--- a/core/inference/dataflow/dataflow.factor
+++ b/core/inference/dataflow/dataflow.factor
@@ -205,7 +205,7 @@ UNION: #branch #if #dispatch ;
2dup 2slip rot [
2drop t
] [
- >r dup node-children swap node-successor add r>
+ >r dup node-children swap node-successor suffix r>
[ node-exists? ] curry contains?
] if
] [
diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor
index 200208c6a5..4cfe0432a5 100755
--- a/core/inference/transforms/transforms.factor
+++ b/core/inference/transforms/transforms.factor
@@ -56,7 +56,7 @@ M: pair (bitfield-quot) ( spec -- quot )
[ shift bitor ] append 2curry ;
: bitfield-quot ( spec -- quot )
- [ (bitfield-quot) ] map [ 0 ] add* concat ;
+ [ (bitfield-quot) ] map [ 0 ] prefix concat ;
\ bitfield [ bitfield-quot ] 1 define-transform
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
index 2ef26096e0..398fb6a068 100755
--- a/core/io/encodings/encodings.factor
+++ b/core/io/encodings/encodings.factor
@@ -59,7 +59,7 @@ M: tuple <decoder> f decoder construct-boa ;
over decoder-cr [
over cr-
"\n" ?head [
- over stream-read1 [ add ] when*
+ over stream-read1 [ suffix ] when*
] when
] when nip ;
diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor
index aef48452de..108c715ef0 100755
--- a/core/optimizer/known-words/known-words.factor
+++ b/core/optimizer/known-words/known-words.factor
@@ -60,7 +60,7 @@ sequences.private combinators ;
[ value-literal sequence? ] [ drop f ] if ;
: member-quot ( seq -- newquot )
- [ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ;
+ [ [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ;
: expand-member ( #call -- )
dup node-in-d peek value-literal member-quot f splice-quot ;
diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor
index 560a174289..cbdb1b9ec4 100755
--- a/core/optimizer/specializers/specializers.factor
+++ b/core/optimizer/specializers/specializers.factor
@@ -32,7 +32,7 @@ IN: optimizer.specializers
: method-declaration ( method -- quot )
dup "method-generic" word-prop dispatch# object <array>
- swap "method-class" word-prop add* ;
+ swap "method-class" word-prop prefix ;
: specialize-method ( quot method -- quot' )
method-declaration [ declare ] curry prepend ;
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 36e5decd05..58c68a3614 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -294,7 +294,7 @@ M: no-word-error summary
scan {
{ ";" [ tuple f ] }
{ "<" [ scan-word ";" parse-tokens ] }
- [ >r tuple ";" parse-tokens r> add* ]
+ [ >r tuple ";" parse-tokens r> prefix ]
} case ;
ERROR: staging-violation word ;
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index dfd5c1b32a..945678a0d8 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -14,7 +14,7 @@ C: <slot-spec> slot-spec
>r create-method r> define ;
: define-slot-word ( class slot word quot -- )
- rot >fixnum add* define-typecheck ;
+ rot >fixnum prefix define-typecheck ;
: reader-quot ( decl -- quot )
[
diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor
index 9be1d5fc64..260a08c044 100755
--- a/core/splitting/splitting.factor
+++ b/core/splitting/splitting.factor
@@ -76,5 +76,5 @@ INSTANCE: groups sequence
1 head-slice* [
"\r" ?tail drop "\r" split
] map
- ] keep peek "\r" split add concat
+ ] keep peek "\r" split suffix concat
] if ;
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 57947eefb0..1489750154 100755
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -20,7 +20,7 @@ V{
: vocab-dir+ ( vocab str/f -- path )
>r vocab-name "." split r>
- [ >r dup peek r> append add ] when*
+ [ >r dup peek r> append suffix ] when*
"/" join ;
: vocab-dir? ( root name -- ? )
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index 886417b715..a6a5a014a7 100755
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -82,7 +82,7 @@ SYMBOL: load-vocab-hook ! ( name -- )
: child-vocab? ( prefix name -- ? )
2dup = pick empty? or
- [ 2drop t ] [ swap CHAR: . add head? ] if ;
+ [ 2drop t ] [ swap CHAR: . suffix head? ] if ;
: child-vocabs ( vocab -- seq )
vocab-name vocabs [ child-vocab? ] with subset ;
diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor
index 30c3beb1ef..215b677e16 100755
--- a/extra/benchmark/fasta/fasta.factor
+++ b/extra/benchmark/fasta/fasta.factor
@@ -49,7 +49,7 @@ HINTS: random fixnum ;
: make-cumulative ( freq -- chars floats )
dup keys >byte-array
- swap values >float-array unclip [ + ] accumulate swap add ;
+ swap values >float-array unclip [ + ] accumulate swap suffix ;
:: select-random ( seed chars floats -- seed elt )
floats seed random -rot
diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor
index 8a1d93aceb..63fd55a550 100644
--- a/extra/cfdg/cfdg.factor
+++ b/extra/cfdg/cfdg.factor
@@ -32,7 +32,7 @@ VAR: color
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi add ;
+: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi suffix ;
: gl-set-hsba ( hsva -- ) hsva>rgba gl-color ;
diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor
index 647c83d667..0480235dfe 100755
--- a/extra/color-picker/color-picker.factor
+++ b/extra/color-picker/color-picker.factor
@@ -21,7 +21,7 @@ M: color-preview model-changed
swap model-value over set-gadget-interior relayout-1 ;
: <color-model> ( model -- model )
- [ [ 256 /f ] map 1 add <solid> ] <filter> ;
+ [ [ 256 /f ] map 1 suffix <solid> ] <filter> ;
: <color-sliders> ( -- model gadget )
3 [ drop 0 0 0 255 <range> ] map
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index 7f24d6258f..eadd1a03e8 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -27,7 +27,7 @@ M: tuple-class group-words
swap [ slot-spec-writer ] map append ;
: define-consult-method ( word class quot -- )
- pick add >r swap create-method r> define ;
+ pick suffix >r swap create-method r> define ;
: define-consult ( class group quot -- )
>r group-words swap r>
diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor
index 85d58e7572..c442dfaa94 100755
--- a/extra/editors/editors.factor
+++ b/extra/editors/editors.factor
@@ -43,7 +43,7 @@ SYMBOL: edit-hook
: fix ( word -- )
"Fixing " write dup pprint " and all usages..." print nl
- dup usage swap add* [
+ dup usage swap prefix [
"Editing " write dup .
"RETURN moves on to the next usage, C+d stops." print
flush
diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor
index c6d9cd04d2..1022a02d7e 100644
--- a/extra/faq/faq.factor
+++ b/extra/faq/faq.factor
@@ -69,7 +69,7 @@ C: <faq> faq
: html>faq ( div -- faq )
unclip swap { "h3" "ol" } [ tags-named ] with map
- first2 >r f add* r> [ html>question-list ] 2map <faq> ;
+ first2 >r f prefix r> [ html>question-list ] 2map <faq> ;
: header, ( faq -- )
dup faq-header ,
diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor
index 490ce992ab..d983bd2715 100755
--- a/extra/fry/fry.factor
+++ b/extra/fry/fry.factor
@@ -28,7 +28,7 @@ DEFER: (fry)
! to avoid confusion, remove if fry goes core
{ namespaces:, [ [ curry ] ((fry)) ] }
- [ swap >r add r> (fry) ]
+ [ swap >r suffix r> (fry) ]
} case
] if ;
diff --git a/extra/help/markup/markup.factor b/extra/help/markup/markup.factor
index 5dc7255eed..e933894674 100755
--- a/extra/help/markup/markup.factor
+++ b/extra/help/markup/markup.factor
@@ -235,7 +235,7 @@ M: string ($instance)
: values-row ( seq -- seq )
unclip \ $snippet swap ?word-name 2array
- swap dup first word? [ \ $instance add* ] when 2array ;
+ swap dup first word? [ \ $instance prefix ] when 2array ;
: $values ( element -- )
"Inputs and outputs" $heading
diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor
index f286690d37..add37173b7 100755
--- a/extra/koszul/koszul.factor
+++ b/extra/koszul/koszul.factor
@@ -184,7 +184,7 @@ DEFER: (d)
[ length ] keep [ (graded-ker/im-d) ] curry map ;
: graded-betti ( generators -- seq )
- basis graded graded-ker/im-d flip first2 1 head* 0 add* v- ;
+ basis graded graded-ker/im-d flip first2 1 head* 0 prefix v- ;
! Bi-graded for two-step complexes
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )
@@ -203,7 +203,7 @@ DEFER: (d)
[ basis graded ] bi@ tensor bigraded-ker/im-d
[ [ [ first ] map ] map ] keep
[ [ second ] map 2 head* { 0 0 } prepend ] map
- 1 tail dup first length 0 <array> add
+ 1 tail dup first length 0 <array> suffix
[ v- ] 2map ;
! Laplacian
diff --git a/extra/lazy-lists/lazy-lists.factor b/extra/lazy-lists/lazy-lists.factor
index 52cca64b2f..f642d8881c 100644
--- a/extra/lazy-lists/lazy-lists.factor
+++ b/extra/lazy-lists/lazy-lists.factor
@@ -365,7 +365,7 @@ M: lazy-concat nil? ( lazy-concat -- bool )
drop nil
] [
[ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
- swap [ swap [ add ] lmap-with ] lmap-with lconcat
+ swap [ swap [ suffix ] lmap-with ] lmap-with lconcat
] reduce
] if ;
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index 5da0225be9..fe4bd65c14 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -108,7 +108,7 @@ UNION: special local quote local-word local-reader local-writer ;
: point-free-end ( quot args -- newquot )
over peek special?
[ drop-locals >r >r peek r> localize r> append ]
- [ drop-locals nip swap peek add ]
+ [ drop-locals nip swap peek suffix ]
if ;
: (point-free) ( quot args -- newquot )
@@ -130,9 +130,9 @@ GENERIC: free-vars ( form -- vars )
: add-if-free ( vars object -- vars )
{
- { [ dup local-writer? ] [ "local-reader" word-prop add ] }
- { [ dup lexical? ] [ add ] }
- { [ dup quote? ] [ quote-local add ] }
+ { [ dup local-writer? ] [ "local-reader" word-prop suffix ] }
+ { [ dup lexical? ] [ suffix ] }
+ { [ dup quote? ] [ quote-local suffix ] }
{ [ t ] [ free-vars append ] }
} cond ;
diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor
index 42545500a5..664337c3d3 100755
--- a/extra/logging/logging.factor
+++ b/extra/logging/logging.factor
@@ -17,7 +17,7 @@ SYMBOL: CRITICAL
{ DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;
: send-to-log-server ( array string -- )
- add* "log-server" get send ;
+ prefix "log-server" get send ;
SYMBOL: log-service
diff --git a/extra/lsys/tortoise/graphics/graphics.factor b/extra/lsys/tortoise/graphics/graphics.factor
index d8429e7aaf..87536476ee 100644
--- a/extra/lsys/tortoise/graphics/graphics.factor
+++ b/extra/lsys/tortoise/graphics/graphics.factor
@@ -77,7 +77,7 @@ VAR: color-table
{ 0.25 0.25 0.25 } ! dark grey
{ 0.75 0.75 0.75 } ! medium grey
{ 1 1 1 } ! white
-} [ 1 add ] map >color-table ;
+} [ 1 suffix ] map >color-table ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor
index 99a098ca09..487d9828ea 100644
--- a/extra/math/combinatorics/combinatorics.factor
+++ b/extra/math/combinatorics/combinatorics.factor
@@ -18,7 +18,7 @@ IN: math.combinatorics
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] unfold reverse 2nip ;
: (>permutation) ( seq n -- seq )
- [ [ dupd >= [ 1+ ] when ] curry map ] keep add* ;
+ [ [ dupd >= [ 1+ ] when ] curry map ] keep prefix ;
: >permutation ( factoradic -- permutation )
reverse 1 cut [ (>permutation) ] each ;
diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor
index ac62fb08f9..5ea19bc957 100755
--- a/extra/multi-methods/multi-methods.factor
+++ b/extra/multi-methods/multi-methods.factor
@@ -191,14 +191,14 @@ M: hook-combination generic-prologue
[ delete-at ] with-methods ;
: method>spec ( method -- spec )
- dup method-classes swap method-generic add* ;
+ dup method-classes swap method-generic prefix ;
: parse-method ( -- quot classes generic )
parse-definition dup 2 tail over second rot first ;
: METHOD:
location
- >r parse-method [ define-method ] 2keep add* r>
+ >r parse-method [ define-method ] 2keep prefix r>
remember-definition ; parsing
! For compatibility
diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor
index 01725ee9a9..fd9be4eb12 100644
--- a/extra/opengl/gl/extensions/extensions.factor
+++ b/extra/opengl/gl/extensions/extensions.factor
@@ -38,7 +38,7 @@ reset-gl-function-number-counter
gl-function-calling-convention
scan
scan dup
- scan drop "}" parse-tokens swap add*
+ scan drop "}" parse-tokens swap prefix
gl-function-number
[ gl-function-pointer ] 2curry swap
";" parse-tokens [ "()" subseq? not ] subset
diff --git a/extra/oracle/oracle.factor b/extra/oracle/oracle.factor
index d725de5994..a30ce64854 100644
--- a/extra/oracle/oracle.factor
+++ b/extra/oracle/oracle.factor
@@ -236,13 +236,13 @@ C: <connection> connection
: fetch-each ( object -- object )
fetch-statement [
- buf get alien>char-string res get swap add res set
+ buf get alien>char-string res get swap suffix res set
fetch-each
] [ ] if ;
: run-query ( object -- object )
execute-statement [
- buf get alien>char-string res get swap add res set
+ buf get alien>char-string res get swap suffix res set
fetch-each
] [ ] if ;
diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor
index d6aacf9645..d8fccfb8f9 100755
--- a/extra/parser-combinators/parser-combinators.factor
+++ b/extra/parser-combinators/parser-combinators.factor
@@ -132,7 +132,7 @@ TUPLE: and-parser parsers ;
: <&> ( parser1 parser2 -- parser )
over and-parser? [
- >r and-parser-parsers r> add
+ >r and-parser-parsers r> suffix
] [
2array
] if and-parser construct-boa ;
@@ -239,11 +239,11 @@ M: some-parser parse ( input parser -- result )
: <:&> ( parser1 parser2 -- result )
#! Same as <&> except flatten the result.
- <&> [ first2 add ] <@ ;
+ <&> [ first2 suffix ] <@ ;
: <&:> ( parser1 parser2 -- result )
#! Same as <&> except flatten the result.
- <&> [ first2 swap add* ] <@ ;
+ <&> [ first2 swap prefix ] <@ ;
: <:&:> ( parser1 parser2 -- result )
#! Same as <&> except flatten the result.
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 68aab7d820..514a29781e 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -104,7 +104,7 @@ C: <head> peg-head
:: (setup-lr) ( r l s -- )
s head>> l head>> eq? [
l head>> s (>>head)
- l head>> [ s rule>> add ] change-involved-set drop
+ l head>> [ s rule>> suffix ] change-involved-set drop
r l s next>> (setup-lr)
] unless ;
@@ -136,7 +136,7 @@ C: <head> peg-head
h [ p heads get at ]
|
h [
- m r h involved-set>> h rule>> add member? not and [
+ m r h involved-set>> h rule>> suffix member? not and [
fail p <memo-entry>
] [
r h eval-set>> member? [
diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor
index ffe3a4bca1..cf09277f31 100644
--- a/extra/project-euler/043/043.factor
+++ b/extra/project-euler/043/043.factor
@@ -76,10 +76,10 @@ PRIVATE>
dup first 2 tail* swap second 2 head = ;
: clean ( seq -- seq )
- [ unclip 1 head add* concat ] map [ all-unique? ] subset ;
+ [ unclip 1 head prefix concat ] map [ all-unique? ] subset ;
: add-missing-digit ( seq -- seq )
- dup natural-sort 10 seq-diff first add* ;
+ dup natural-sort 10 seq-diff first prefix ;
: interesting-pandigitals ( -- seq )
17 candidates { 13 11 7 5 3 2 } [
diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index 087b216b3a..5829f66c01 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -72,7 +72,7 @@ PRIVATE>
: max-path ( triangle -- n )
dup length 1 > [
- 2 cut* first2 max-children [ + ] 2map add max-path
+ 2 cut* first2 max-children [ + ] 2map suffix max-path
] [
first first
] if ;
@@ -95,7 +95,7 @@ PRIVATE>
! Not strictly needed, but it is nice to be able to dump the triangle after the
! propagation
: propagate-all ( triangle -- newtriangle )
- reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap add ;
+ reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap suffix ;
: sum-divisors ( n -- sum )
dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
diff --git a/extra/qualified/qualified.factor b/extra/qualified/qualified.factor
index b4eb4558fa..69e4c09b6e 100644
--- a/extra/qualified/qualified.factor
+++ b/extra/qualified/qualified.factor
@@ -4,7 +4,7 @@ IN: qualified
: define-qualified ( vocab-name -- )
dup require
- dup vocab-words swap CHAR: : add
+ dup vocab-words swap CHAR: : suffix
[ -rot >r append r> ] curry assoc-map
use get push ;
diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor
index fa36a7c6f8..b0cd61bd8f 100755
--- a/extra/regexp/regexp.factor
+++ b/extra/regexp/regexp.factor
@@ -21,7 +21,7 @@ SYMBOL: ignore-case?
if 2curry ;
: or-predicates ( quots -- quot )
- [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ;
+ [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
: <@literal [ nip ] curry <@ ;
diff --git a/extra/regexp2/regexp2.factor b/extra/regexp2/regexp2.factor
index 1f2bbde171..8c26d880f1 100644
--- a/extra/regexp2/regexp2.factor
+++ b/extra/regexp2/regexp2.factor
@@ -21,7 +21,7 @@ SYMBOL: ignore-case?
if 2curry ;
: or-predicates ( quots -- quot )
- [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ;
+ [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
: literal-action [ nip ] curry action ;
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 0b93552e76..d246b16b8d 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -94,7 +94,7 @@ MACRO: firstn ( n -- )
: monotonic-split ( seq quot -- newseq )
[
- >r dup unclip add r>
+ >r dup unclip suffix r>
v, [ pick ,, call [ v, ] unless ] curry 2each ,v
] { } make ;
diff --git a/extra/springies/springies.factor b/extra/springies/springies.factor
index 3a1af786e2..cd6e1a7cfb 100644
--- a/extra/springies/springies.factor
+++ b/extra/springies/springies.factor
@@ -235,7 +235,7 @@ C: <spring> spring
6 nrot 6 nrot 2array
5 nrot 5 nrot 2array
0 0 2array <node>
- nodes> swap add >nodes ;
+ nodes> swap suffix >nodes ;
: spng ( id id-a id-b k damp rest-length -- )
6 nrot drop
@@ -243,4 +243,4 @@ C: <spring> spring
5 nrot node-id
5 nrot node-id
<spring>
- springs> swap add >springs ;
+ springs> swap suffix >springs ;
diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor
index cd3cfc6324..489b7aaeb4 100755
--- a/extra/state-machine/state-machine.factor
+++ b/extra/state-machine/state-machine.factor
@@ -6,7 +6,7 @@ IN: state-machine
! STATES: set-name state1 state2 ... ;
";" parse-tokens
[ length ] keep
- unclip add
+ unclip suffix
[ create-in swap 1quotation define ] 2each ; parsing
TUPLE: state place data ;
diff --git a/extra/tetris/board/board.factor b/extra/tetris/board/board.factor
index 13850f6bd7..93bbebf34f 100644
--- a/extra/tetris/board/board.factor
+++ b/extra/tetris/board/board.factor
@@ -37,7 +37,7 @@ TUPLE: board width height rows ;
: add-row ( board -- )
dup board-rows over board-width f <array>
- add* swap set-board-rows ;
+ prefix swap set-board-rows ;
: top-up-rows ( board -- )
dup board-height over board-rows length = [
diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor
index b019326ed5..395c4ff924 100755
--- a/extra/tools/deploy/backend/backend.factor
+++ b/extra/tools/deploy/backend/backend.factor
@@ -46,7 +46,7 @@ IN: tools.deploy.backend
: staging-image-name ( profile -- name )
"staging."
- swap strip-word-names? [ "strip" add ] when
+ swap strip-word-names? [ "strip" suffix ] when
"-" join ".image" 3append temp-file ;
DEFER: ?make-staging-image
@@ -75,7 +75,7 @@ DEFER: ?make-staging-image
] { } make ;
: run-factor ( vm flags -- )
- swap add* dup . run-with-output ; inline
+ swap prefix dup . run-with-output ; inline
: make-staging-image ( profile -- )
vm swap staging-command-line run-factor ;
diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor
index d7610c21c8..2f941ad2ce 100755
--- a/extra/tools/vocabs/vocabs.factor
+++ b/extra/tools/vocabs/vocabs.factor
@@ -230,7 +230,7 @@ MEMO: all-vocabs-seq ( -- seq )
try-everything load-failures. ;
: unrooted-child-vocabs ( prefix -- seq )
- dup empty? [ CHAR: . add ] unless
+ dup empty? [ CHAR: . suffix ] unless
vocabs
[ find-vocab-root not ] subset
[
@@ -242,7 +242,7 @@ MEMO: all-vocabs-seq ( -- seq )
vocab-roots get [
dup pick (all-child-vocabs) [ >vocab-link ] map
] { } map>assoc
- swap unrooted-child-vocabs f swap 2array add ;
+ swap unrooted-child-vocabs f swap 2array suffix ;
: all-child-vocabs-seq ( prefix -- assoc )
vocab-roots get swap [
diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor
index 2aed793a59..d548c0a4f5 100755
--- a/extra/tools/walker/walker.factor
+++ b/extra/tools/walker/walker.factor
@@ -49,10 +49,10 @@ DEFER: start-walker-thread
\ break t "break?" set-word-prop
: walk ( quot -- quot' )
- \ break add* [ break rethrow ] recover ;
+ \ break prefix [ break rethrow ] recover ;
: add-breakpoint ( quot -- quot' )
- dup [ break ] head? [ \ break add* ] unless ;
+ dup [ break ] head? [ \ break prefix ] unless ;
: (step-into-quot) ( quot -- ) add-breakpoint call ;
@@ -114,7 +114,7 @@ SYMBOL: +stopped+
] change-frame ;
: step-out-msg ( continuation -- continuation' )
- [ nip \ break add ] change-frame ;
+ [ nip \ break suffix ] change-frame ;
{
{ call [ (step-into-quot) ] }
diff --git a/extra/ui/commands/commands-docs.factor b/extra/ui/commands/commands-docs.factor
index 789d9b9e6a..ed524148e3 100644
--- a/extra/ui/commands/commands-docs.factor
+++ b/extra/ui/commands/commands-docs.factor
@@ -14,7 +14,7 @@ IN: ui.commands
: command-map. ( command-map -- )
[ command-map-row ] map
{ "Shortcut" "Command" "Word" "Notes" }
- [ \ $strong swap ] { } map>assoc add*
+ [ \ $strong swap ] { } map>assoc prefix
$table ;
: $command-map ( element -- )
diff --git a/extra/ui/gadgets/grid-lines/grid-lines.factor b/extra/ui/gadgets/grid-lines/grid-lines.factor
index fce88c0ebb..533116824b 100755
--- a/extra/ui/gadgets/grid-lines/grid-lines.factor
+++ b/extra/ui/gadgets/grid-lines/grid-lines.factor
@@ -18,7 +18,7 @@ SYMBOL: grid-dim
grid-dim get spin set-axis ;
: draw-grid-lines ( gaps orientation -- )
- grid get rot grid-positions grid get rect-dim add [
+ grid get rot grid-positions grid get rect-dim suffix [
grid-line-from/to gl-line
] with each ;
diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor
index 52c5ca8a02..91b7f0f225 100755
--- a/extra/ui/gadgets/panes/panes.factor
+++ b/extra/ui/gadgets/panes/panes.factor
@@ -352,7 +352,7 @@ M: f sloppy-pick-up*
: sloppy-pick-up ( loc gadget -- path )
2dup sloppy-pick-up* dup
- [ [ wet-and-sloppy sloppy-pick-up ] keep add* ]
+ [ [ wet-and-sloppy sloppy-pick-up ] keep prefix ]
[ 3drop { } ]
if ;
diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor
index fc8103b656..ba02f15c7a 100755
--- a/extra/unix/process/process.factor
+++ b/extra/unix/process/process.factor
@@ -9,7 +9,7 @@ IN: unix.process
! io.launcher instead.
: >argv ( seq -- alien )
- [ malloc-char-string ] map f add >c-void*-array ;
+ [ malloc-char-string ] map f suffix >c-void*-array ;
: exec ( pathname argv -- int )
[ malloc-char-string ] [ >argv ] bi* execv ;
diff --git a/extra/xmode/rules/rules.factor b/extra/xmode/rules/rules.factor
index 28237a7b2c..8c74d61656 100755
--- a/extra/xmode/rules/rules.factor
+++ b/extra/xmode/rules/rules.factor
@@ -113,7 +113,7 @@ M: regexp text-hash-char drop f ;
: rule-chars* ( rule -- string )
dup rule-chars
swap rule-start matcher-text
- text-hash-char [ add ] when* ;
+ text-hash-char [ suffix ] when* ;
: add-rule ( rule ruleset -- )
>r dup rule-chars* >upper swap
From 9e96befa6981f39a27d120de93bab283d7468668 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 31 Mar 2008 19:24:29 -0600
Subject: [PATCH 046/127] Remove add and add*
---
core/sequences/sequences.factor | 13 -------------
1 file changed, 13 deletions(-)
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 26c1013c28..ca46066861 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -478,31 +478,18 @@ M: sequence <=>
: push-new ( elt seq -- ) [ delete ] 2keep push ;
-: add* ( seq elt -- newseq )
- over >r over length 1+ r> [
- [ 0 swap set-nth-unsafe ] keep
- [ 1 swap copy ] keep
- ] new-like ;
-
: prefix ( seq elt -- newseq )
over >r over length 1+ r> [
[ 0 swap set-nth-unsafe ] keep
[ 1 swap copy ] keep
] new-like ;
-: add ( seq elt -- newseq )
- over >r over length 1+ r> [
- [ >r over length r> set-nth-unsafe ] keep
- [ 0 swap copy ] keep
- ] new-like ;
-
: suffix ( seq elt -- newseq )
over >r over length 1+ r> [
[ >r over length r> set-nth-unsafe ] keep
[ 0 swap copy ] keep
] new-like ;
-
: seq-diff ( seq1 seq2 -- newseq )
swap [ member? not ] curry subset ;
From e75222d039076608fee57a25b5a7fefefdd1a5c5 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 31 Mar 2008 19:24:48 -0600
Subject: [PATCH 047/127] More add and add* cleanups
---
core/math/intervals/intervals-tests.factor | 2 +-
core/prettyprint/prettyprint-tests.factor | 2 +-
core/quotations/quotations-tests.factor | 4 ++--
core/sequences/sequences-docs.factor | 16 ++++++++--------
extra/sequences/deep/deep-tests.factor | 2 +-
5 files changed, 13 insertions(+), 13 deletions(-)
diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor
index f6317e7475..5204d7d45a 100755
--- a/core/math/intervals/intervals-tests.factor
+++ b/core/math/intervals/intervals-tests.factor
@@ -188,7 +188,7 @@ IN: math.intervals.tests
{ max interval-max }
}
"math.ratios.private" vocab [
- { / interval/ } add
+ { / interval/ } suffix
] when
random ;
diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor
index 35b30ac46f..27b63ec26f 100755
--- a/core/prettyprint/prettyprint-tests.factor
+++ b/core/prettyprint/prettyprint-tests.factor
@@ -192,7 +192,7 @@ unit-test
"IN: prettyprint.tests"
": another-soft-break-layout ( node -- quot )"
" parse-error-file"
- " [ <reversed> \"hello world foo\" add ] [ ] make ;"
+ " [ <reversed> \"hello world foo\" suffix ] [ ] make ;"
} ;
[ t ] [
diff --git a/core/quotations/quotations-tests.factor b/core/quotations/quotations-tests.factor
index a4c9a619b5..d311dfad71 100755
--- a/core/quotations/quotations-tests.factor
+++ b/core/quotations/quotations-tests.factor
@@ -10,8 +10,8 @@ IN: quotations.tests
] unit-test
[ [ 1 2 3 4 ] ] [ [ 1 2 ] [ 3 4 ] append ] unit-test
-[ [ 1 2 3 ] ] [ [ 1 2 ] 3 add ] unit-test
-[ [ 3 1 2 ] ] [ [ 1 2 ] 3 add* ] unit-test
+[ [ 1 2 3 ] ] [ [ 1 2 ] 3 suffix ] unit-test
+[ [ 3 1 2 ] ] [ [ 1 2 ] 3 prefix ] unit-test
[ [ "hi" ] ] [ "hi" 1quotation ] unit-test
diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index 9e8dcd6559..f5e5bfcdb3 100755
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -61,8 +61,8 @@ ARTICLE: "sequences-access" "Accessing sequence elements"
ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
"Adding elements:"
-{ $subsection add }
-{ $subsection add* }
+{ $subsection prefix }
+{ $subsection suffix }
"Removing elements:"
{ $subsection remove }
{ $subsection seq-diff } ;
@@ -641,22 +641,22 @@ HELP: push-new
}
{ $side-effects "seq" } ;
-{ push push-new add add* } related-words
+{ push push-new prefix suffix } related-words
-HELP: add
+HELP: suffix
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
{ $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the end of " { $snippet "seq" } "." }
{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
{ $examples
- { $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 add ." "{ 1 2 3 4 }" }
+ { $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 suffix ." "{ 1 2 3 4 }" }
} ;
-HELP: add*
+HELP: prefix
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
{ $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the beginning of " { $snippet "seq" } "." }
{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
{ $examples
-{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 add* ." "{ 0 1 2 3 }" }
+{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 prefix ." "{ 0 1 2 3 }" }
} ;
HELP: seq-diff
@@ -940,7 +940,7 @@ HELP: unclip
{ $values { "seq" sequence } { "rest" sequence } { "first" object } }
{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first." }
{ $examples
- { $example "USING: prettyprint sequences ;" "{ 1 2 3 } unclip add ." "{ 2 3 1 }" }
+ { $example "USING: prettyprint sequences ;" "{ 1 2 3 } unclip suffix ." "{ 2 3 1 }" }
} ;
HELP: unclip-slice
diff --git a/extra/sequences/deep/deep-tests.factor b/extra/sequences/deep/deep-tests.factor
index 541570f3f9..9629d569cb 100755
--- a/extra/sequences/deep/deep-tests.factor
+++ b/extra/sequences/deep/deep-tests.factor
@@ -11,7 +11,7 @@ IN: sequences.deep.tests
[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] deep-find* ] unit-test
: change-something ( seq -- newseq )
- dup array? [ "hi" add ] [ "hello" append ] if ;
+ dup array? [ "hi" suffix ] [ "hello" append ] if ;
[ { { "heyhello" "hihello" } "hihello" } ]
[ "hey" 1array 1array [ change-something ] deep-map ] unit-test
From 122fd50d4a7fee989bdcf69dc699d7bcf4246600 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Tue, 1 Apr 2008 14:49:20 +1300
Subject: [PATCH 048/127] Throw error when ebnf uses a non-existant
non-terminal
---
extra/peg/ebnf/ebnf.factor | 7 ++++++-
1 file changed, 6 insertions(+), 1 deletion(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 26e5d68df8..a6567ce8f3 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -310,9 +310,14 @@ M: ebnf-var (transform) ( ast -- parser )
M: ebnf-terminal (transform) ( ast -- parser )
symbol>> token sp ;
+: parser-not-found ( name -- * )
+ [
+ "Parser " % % " not found." %
+ ] "" make throw ;
+
M: ebnf-non-terminal (transform) ( ast -- parser )
symbol>> [
- , parser get , \ at , \ sp ,
+ , \ dup , parser get , \ at , [ parser-not-found ] , \ unless* , \ sp , \ nip ,
] [ ] make box ;
: transform-ebnf ( string -- object )
From cc5ddd8d78fcdb9b18b438002fe415738a12880b Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 31 Mar 2008 20:05:06 -0600
Subject: [PATCH 049/127] Resolve more add/add* items
---
core/bootstrap/image/image.factor | 2 +-
core/classes/tuple/tuple.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 5d49203554..fc963683b6 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -305,7 +305,7 @@ M: float-array ' float-array emit-dummy-array ;
! Tuples
: (emit-tuple) ( tuple -- pointer )
[ tuple>array 1 tail-slice ]
- [ class transfer-word tuple-layout ] bi add* [ ' ] map
+ [ class transfer-word tuple-layout ] bi prefix [ ' ] map
tuple type-number dup [ emit-seq ] emit-object ;
: emit-tuple ( tuple -- pointer )
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index de1e3bddb8..3cacef25a1 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -130,7 +130,7 @@ PRIVATE>
] with each ;
: all-slot-names ( class -- slots )
- superclasses [ slot-names ] map concat \ class add* ;
+ superclasses [ slot-names ] map concat \ class prefix ;
: compute-slot-permutation ( class old-slot-names -- permutation )
>r all-slot-names r> [ index ] curry map ;
From c71a3e05c6a666ceba1353243b89c2d301c8cbd5 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 31 Mar 2008 20:29:12 -0600
Subject: [PATCH 050/127] Fix add references
---
core/cpu/ppc/intrinsics/intrinsics.factor | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index 7aa78ce52e..07698eaa92 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -94,14 +94,14 @@ IN: cpu.ppc.intrinsics
} define-intrinsics
: fixnum-register-op ( op -- pair )
- [ "out" operand "y" operand "x" operand ] swap add H{
+ [ "out" operand "y" operand "x" operand ] swap suffix H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} 2array ;
: fixnum-value-op ( op -- pair )
- [ "out" operand "x" operand "y" operand ] swap add H{
+ [ "out" operand "x" operand "y" operand ] swap suffix H{
{ +input+ { { f "x" } { [ small-tagged? ] "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
@@ -205,11 +205,11 @@ IN: cpu.ppc.intrinsics
} define-intrinsic
: fixnum-register-jump ( op -- pair )
- [ "x" operand 0 "y" operand CMP ] swap add
+ [ "x" operand 0 "y" operand CMP ] swap suffix
{ { f "x" } { f "y" } } 2array ;
: fixnum-value-jump ( op -- pair )
- [ 0 "x" operand "y" operand CMPI ] swap add
+ [ 0 "x" operand "y" operand CMPI ] swap suffix
{ { f "x" } { [ small-tagged? ] "y" } } 2array ;
: define-fixnum-jump ( word op -- )
@@ -336,7 +336,7 @@ IN: cpu.ppc.intrinsics
} define-intrinsic
: define-float-op ( word op -- )
- [ "z" operand "x" operand "y" operand ] swap add H{
+ [ "z" operand "x" operand "y" operand ] swap suffix H{
{ +input+ { { float "x" } { float "y" } } }
{ +scratch+ { { float "z" } } }
{ +output+ { "z" } }
@@ -352,7 +352,7 @@ IN: cpu.ppc.intrinsics
] each
: define-float-jump ( word op -- )
- [ "x" operand 0 "y" operand FCMPU ] swap add
+ [ "x" operand 0 "y" operand FCMPU ] swap suffix
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
From 6a2ab7393811e75e1b697a9180a3287f66bdf859 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 31 Mar 2008 20:32:31 -0600
Subject: [PATCH 051/127] Fix more add/add* occurances
---
extra/cocoa/subclassing/subclassing.factor | 2 +-
extra/windows/com/syntax/syntax.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/cocoa/subclassing/subclassing.factor b/extra/cocoa/subclassing/subclassing.factor
index 42ddce1206..48f45f21c0 100755
--- a/extra/cocoa/subclassing/subclassing.factor
+++ b/extra/cocoa/subclassing/subclassing.factor
@@ -76,7 +76,7 @@ IN: cocoa.subclassing
r> <method-list> class_addMethods ;
: encode-types ( return types -- encoding )
- swap add* [
+ swap prefix [
alien>objc-types get at "0" append
] map concat ;
diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor
index 238ff18c39..acd3848f10 100755
--- a/extra/windows/com/syntax/syntax.factor
+++ b/extra/windows/com/syntax/syntax.factor
@@ -40,7 +40,7 @@ unless
: (parse-com-function) ( tokens -- definition )
[ second ]
[ first ]
- [ 3 tail 2 group [ first ] map "void*" add* ]
+ [ 3 tail 2 group [ first ] map "void*" prefix ]
tri
<com-function-definition> ;
From 38cb4f13b682f577bd30ef27c7e6daf6fee43c6b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 1 Apr 2008 01:40:12 -0500
Subject: [PATCH 052/127] Add 3cleave
---
core/combinators/combinators.factor | 8 +++++++-
core/inference/transforms/transforms.factor | 2 ++
2 files changed, 9 insertions(+), 1 deletion(-)
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index e19847dbd4..276e4cb184 100755
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -12,11 +12,17 @@ hashtables sorting ;
[ [ keep ] curry ] map concat [ drop ] append ;
: 2cleave ( x seq -- )
- [ [ call ] 3keep drop ] each 2drop ;
+ [ 2keep ] each 2drop ;
: 2cleave>quot ( seq -- quot )
[ [ 2keep ] curry ] map concat [ 2drop ] append ;
+: 3cleave ( x seq -- )
+ [ 3keep ] each 3drop ;
+
+: 3cleave>quot ( seq -- quot )
+ [ [ 3keep ] curry ] map concat [ 3drop ] append ;
+
: spread>quot ( seq -- quot )
[ length [ >r ] <repetition> concat ]
[ [ [ r> ] prepend ] map concat ] bi
diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor
index 200208c6a5..4d636c24f2 100755
--- a/core/inference/transforms/transforms.factor
+++ b/core/inference/transforms/transforms.factor
@@ -43,6 +43,8 @@ IN: inference.transforms
\ 2cleave [ 2cleave>quot ] 1 define-transform
+\ 3cleave [ 3cleave>quot ] 1 define-transform
+
\ spread [ spread>quot ] 1 define-transform
! Bitfields
From 2223633b432cd5f103fceefcf026d2b382e71f64 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 1 Apr 2008 01:40:30 -0500
Subject: [PATCH 053/127] Tweak
---
core/generic/standard/standard.factor | 4 +---
1 file changed, 1 insertion(+), 3 deletions(-)
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 4447c5a264..3898150c3b 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -39,9 +39,7 @@ ERROR: no-method object generic ;
] [ ] make ;
: class-predicates ( assoc -- assoc )
- [
- >r >r picker r> "predicate" word-prop append r>
- ] assoc-map ;
+ [ >r "predicate" word-prop picker prepend r> ] assoc-map ;
: (simplify-alist) ( class i assoc -- default assoc )
2dup length 1- = [
From 7cb9be06e5c303d0c390a44e8e034b180bc93fcd Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 16:46:22 -0500
Subject: [PATCH 054/127] redo singletons
---
extra/singleton/singleton-docs.factor | 12 ------------
extra/singleton/singleton-tests.factor | 5 ++++-
extra/singleton/singleton.factor | 15 +++++++++++----
3 files changed, 15 insertions(+), 17 deletions(-)
diff --git a/extra/singleton/singleton-docs.factor b/extra/singleton/singleton-docs.factor
index 92ddcc494a..7acf97a436 100644
--- a/extra/singleton/singleton-docs.factor
+++ b/extra/singleton/singleton-docs.factor
@@ -12,15 +12,3 @@ HELP: SINGLETON:
} { $see-also
POSTPONE: PREDICATE:
} ;
-
-HELP: SINGLETONS:
-{ $syntax "SINGLETONS: classes... ;"
-} { $values
- { "classes" "new singletons to define" }
-} { $description
- "Defines a new singleton for each class in the list."
-} { $examples
- { $example "USE: singleton" "SINGLETONS: foo bar baz ;" "" }
-} { $see-also
- POSTPONE: SINGLETON:
-} ;
diff --git a/extra/singleton/singleton-tests.factor b/extra/singleton/singleton-tests.factor
index 1698181ed3..da2a74f8d1 100644
--- a/extra/singleton/singleton-tests.factor
+++ b/extra/singleton/singleton-tests.factor
@@ -1,4 +1,4 @@
-USING: kernel singleton tools.test ;
+USING: kernel singleton tools.test prettyprint io.streams.string ;
IN: singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
@@ -7,3 +7,6 @@ IN: singleton.tests
GENERIC: zammo ( obj -- )
[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
[ "yes!" ] [ bzzt zammo ] unit-test
+[ ] [ SINGLETON: omg ] unit-test
+[ t ] [ omg singleton? ] unit-test
+[ "USING: singleton ;\nIN: singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
diff --git a/extra/singleton/singleton.factor b/extra/singleton/singleton.factor
index 9ec9f2f4a3..99319fdfdb 100755
--- a/extra/singleton/singleton.factor
+++ b/extra/singleton/singleton.factor
@@ -1,16 +1,23 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.predicate kernel namespaces parser quotations
-sequences words ;
+sequences words prettyprint prettyprint.backend prettyprint.sections
+compiler.units classes ;
+USE: tools.walker
IN: singleton
+PREDICATE: singleton < predicate-class
+ [ "predicate-definition" word-prop ]
+ [ [ eq? ] curry ] bi sequence= ;
+
: define-singleton ( token -- )
create-class-in
- \ word
+ dup save-location
+ \ singleton
over [ eq? ] curry define-predicate-class ;
: SINGLETON:
scan define-singleton ; parsing
-: SINGLETONS:
- ";" parse-tokens [ define-singleton ] each ; parsing
+M: singleton see-class* ( class -- )
+ <colon \ SINGLETON: pprint-word pprint-word ;
From 9e32613f5ca6933c1d1016f8ae0e555c7d1b8b61 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 16:51:48 -0500
Subject: [PATCH 055/127] rename singletons
---
extra/{ => classes}/singleton/authors.txt | 0
extra/{ => classes}/singleton/singleton-docs.factor | 2 +-
extra/{ => classes}/singleton/singleton-tests.factor | 4 ++--
extra/{ => classes}/singleton/singleton.factor | 3 +--
4 files changed, 4 insertions(+), 5 deletions(-)
rename extra/{ => classes}/singleton/authors.txt (100%)
rename extra/{ => classes}/singleton/singleton-docs.factor (96%)
rename extra/{ => classes}/singleton/singleton-tests.factor (70%)
rename extra/{ => classes}/singleton/singleton.factor (95%)
diff --git a/extra/singleton/authors.txt b/extra/classes/singleton/authors.txt
similarity index 100%
rename from extra/singleton/authors.txt
rename to extra/classes/singleton/authors.txt
diff --git a/extra/singleton/singleton-docs.factor b/extra/classes/singleton/singleton-docs.factor
similarity index 96%
rename from extra/singleton/singleton-docs.factor
rename to extra/classes/singleton/singleton-docs.factor
index 7acf97a436..95b5b6af18 100644
--- a/extra/singleton/singleton-docs.factor
+++ b/extra/classes/singleton/singleton-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax kernel words ;
-IN: singleton
+IN: classes.singleton
HELP: SINGLETON:
{ $syntax "SINGLETON: class"
diff --git a/extra/singleton/singleton-tests.factor b/extra/classes/singleton/singleton-tests.factor
similarity index 70%
rename from extra/singleton/singleton-tests.factor
rename to extra/classes/singleton/singleton-tests.factor
index da2a74f8d1..453a2a0ea5 100644
--- a/extra/singleton/singleton-tests.factor
+++ b/extra/classes/singleton/singleton-tests.factor
@@ -1,5 +1,5 @@
USING: kernel singleton tools.test prettyprint io.streams.string ;
-IN: singleton.tests
+IN: classes.singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
[ t ] [ bzzt bzzt? ] unit-test
@@ -9,4 +9,4 @@ GENERIC: zammo ( obj -- )
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
[ t ] [ omg singleton? ] unit-test
-[ "USING: singleton ;\nIN: singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
+[ "USING: singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
diff --git a/extra/singleton/singleton.factor b/extra/classes/singleton/singleton.factor
similarity index 95%
rename from extra/singleton/singleton.factor
rename to extra/classes/singleton/singleton.factor
index 99319fdfdb..61a519679c 100755
--- a/extra/singleton/singleton.factor
+++ b/extra/classes/singleton/singleton.factor
@@ -3,8 +3,7 @@
USING: classes.predicate kernel namespaces parser quotations
sequences words prettyprint prettyprint.backend prettyprint.sections
compiler.units classes ;
-USE: tools.walker
-IN: singleton
+IN: classes.singleton
PREDICATE: singleton < predicate-class
[ "predicate-definition" word-prop ]
From b4adebb6910278f1ca140552510f5278abd7f25e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 16:53:32 -0500
Subject: [PATCH 056/127] update usages of singleton
---
extra/db/types/types.factor | 2 +-
extra/http/server/auth/providers/db/db.factor | 84 ++++++++---------
.../http/server/sessions/storage/db/db.factor | 92 +++++++++----------
3 files changed, 89 insertions(+), 89 deletions(-)
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index 9babfbcdb0..98bc451a6f 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -4,7 +4,7 @@ USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes
mirrors classes.tuple combinators calendar.format symbols
-singleton ;
+classes.singleton ;
IN: db.types
HOOK: modifier-table db ( -- hash )
diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor
index 1e84e544b8..deab40e8d4 100755
--- a/extra/http/server/auth/providers/db/db.factor
+++ b/extra/http/server/auth/providers/db/db.factor
@@ -1,42 +1,42 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: db db.tuples db.types accessors
-http.server.auth.providers kernel continuations
-singleton ;
-IN: http.server.auth.providers.db
-
-user "USERS"
-{
- { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ }
- { "realname" "REALNAME" { VARCHAR 256 } }
- { "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
- { "email" "EMAIL" { VARCHAR 256 } }
- { "ticket" "TICKET" { VARCHAR 256 } }
- { "profile" "PROFILE" FACTOR-BLOB }
-} define-persistent
-
-: init-users-table user ensure-table ;
-
-SINGLETON: users-in-db
-
-: find-user ( username -- user )
- <user>
- swap >>username
- select-tuple ;
-
-M: users-in-db get-user
- drop
- find-user ;
-
-M: users-in-db new-user
- drop
- [
- dup username>> find-user [
- drop f
- ] [
- dup insert-tuple
- ] if
- ] with-transaction ;
-
-M: users-in-db update-user
- drop update-tuple ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db db.tuples db.types accessors
+http.server.auth.providers kernel continuations
+classes.singleton ;
+IN: http.server.auth.providers.db
+
+user "USERS"
+{
+ { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ }
+ { "realname" "REALNAME" { VARCHAR 256 } }
+ { "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
+ { "email" "EMAIL" { VARCHAR 256 } }
+ { "ticket" "TICKET" { VARCHAR 256 } }
+ { "profile" "PROFILE" FACTOR-BLOB }
+} define-persistent
+
+: init-users-table user ensure-table ;
+
+SINGLETON: users-in-db
+
+: find-user ( username -- user )
+ <user>
+ swap >>username
+ select-tuple ;
+
+M: users-in-db get-user
+ drop
+ find-user ;
+
+M: users-in-db new-user
+ drop
+ [
+ dup username>> find-user [
+ drop f
+ ] [
+ dup insert-tuple
+ ] if
+ ] with-transaction ;
+
+M: users-in-db update-user
+ drop update-tuple ;
diff --git a/extra/http/server/sessions/storage/db/db.factor b/extra/http/server/sessions/storage/db/db.factor
index 471b7fa6df..e573b22ba1 100755
--- a/extra/http/server/sessions/storage/db/db.factor
+++ b/extra/http/server/sessions/storage/db/db.factor
@@ -1,46 +1,46 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors http.server.sessions.storage
-alarms kernel http.server db.tuples db.types singleton
-math.parser ;
-IN: http.server.sessions.storage.db
-
-SINGLETON: sessions-in-db
-
-TUPLE: session id namespace ;
-
-session "SESSIONS"
-{
- { "id" "ID" INTEGER +native-id+ }
- { "namespace" "NAMESPACE" FACTOR-BLOB }
-} define-persistent
-
-: init-sessions-table session ensure-table ;
-
-: <session> ( id -- session )
- session construct-empty
- swap dup [ string>number ] when >>id ;
-
-M: sessions-in-db get-session ( id storage -- namespace/f )
- drop
- dup [
- <session>
- select-tuple dup [ namespace>> ] when
- ] when ;
-
-M: sessions-in-db update-session ( namespace id storage -- )
- drop
- <session>
- swap >>namespace
- update-tuple ;
-
-M: sessions-in-db delete-session ( id storage -- )
- drop
- <session>
- delete-tuple ;
-
-M: sessions-in-db new-session ( namespace storage -- id )
- drop
- f <session>
- swap >>namespace
- [ insert-tuple ] [ id>> number>string ] bi ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs accessors http.server.sessions.storage
+alarms kernel http.server db.tuples db.types math.parser
+classes.singleton ;
+IN: http.server.sessions.storage.db
+
+SINGLETON: sessions-in-db
+
+TUPLE: session id namespace ;
+
+session "SESSIONS"
+{
+ { "id" "ID" INTEGER +native-id+ }
+ { "namespace" "NAMESPACE" FACTOR-BLOB }
+} define-persistent
+
+: init-sessions-table session ensure-table ;
+
+: <session> ( id -- session )
+ session construct-empty
+ swap dup [ string>number ] when >>id ;
+
+M: sessions-in-db get-session ( id storage -- namespace/f )
+ drop
+ dup [
+ <session>
+ select-tuple dup [ namespace>> ] when
+ ] when ;
+
+M: sessions-in-db update-session ( namespace id storage -- )
+ drop
+ <session>
+ swap >>namespace
+ update-tuple ;
+
+M: sessions-in-db delete-session ( id storage -- )
+ drop
+ <session>
+ delete-tuple ;
+
+M: sessions-in-db new-session ( namespace storage -- id )
+ drop
+ f <session>
+ swap >>namespace
+ [ insert-tuple ] [ id>> number>string ] bi ;
From 23768dd482037e93cc4764d3bbbfc9eb31e496a7 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 17:06:36 -0500
Subject: [PATCH 057/127] remove singleton? from sequences.lib fix bootstrap
error
---
extra/math/polynomials/polynomials.factor | 2 +-
extra/math/text/english/english.factor | 2 +-
extra/random/unix/unix.factor | 2 +-
extra/sequences/lib/lib-tests.factor | 3 ---
extra/sequences/lib/lib.factor | 3 ---
5 files changed, 3 insertions(+), 9 deletions(-)
diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor
index d6ac71e629..0b0d3520ef 100644
--- a/extra/math/polynomials/polynomials.factor
+++ b/extra/math/polynomials/polynomials.factor
@@ -22,7 +22,7 @@ PRIVATE>
: p= ( p p -- ? ) pextend = ;
: ptrim ( p -- p )
- dup singleton? [ [ zero? ] right-trim ] unless ;
+ dup length 1 = [ [ zero? ] right-trim ] unless ;
: 2ptrim ( p p -- p p ) [ ptrim ] bi@ ;
: p+ ( p p -- p ) pextend v+ ;
diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor
index b77ac725ab..cba8c28310 100755
--- a/extra/math/text/english/english.factor
+++ b/extra/math/text/english/english.factor
@@ -79,7 +79,7 @@ SYMBOL: and-needed?
] if ;
: recombine ( seq -- str )
- dup singleton? [
+ dup length 1 = [
first 3digits>text
] [
dup set-conjunction "" swap
diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor
index f3f55007f0..3be2697bdf 100644
--- a/extra/random/unix/unix.factor
+++ b/extra/random/unix/unix.factor
@@ -1,5 +1,5 @@
USING: alien.c-types io io.files io.nonblocking kernel
-namespaces random io.encodings.binary singleton init
+namespaces random io.encodings.binary init
accessors system ;
IN: random.unix
diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor
index 6e6a924382..99565e966c 100755
--- a/extra/sequences/lib/lib-tests.factor
+++ b/extra/sequences/lib/lib-tests.factor
@@ -46,9 +46,6 @@ IN: sequences.lib.tests
[ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test
[ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ]
[ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test
-[ f ] [ { } singleton? ] unit-test
-[ t ] [ { "asdf" } singleton? ] unit-test
-[ f ] [ { "asdf" "bsdf" } singleton? ] unit-test
[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test
[ V{ } [ delete-random drop ] keep length ] must-fail
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index d246b16b8d..945ba1a3b7 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -98,9 +98,6 @@ MACRO: firstn ( n -- )
v, [ pick ,, call [ v, ] unless ] curry 2each ,v
] { } make ;
-: singleton? ( seq -- ? )
- length 1 = ;
-
: delete-random ( seq -- value )
[ length random ] keep [ nth ] 2keep delete-nth ;
From d1c9082cd426c3e96980fc94d2c37323fd73e4fb Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 1 Apr 2008 16:22:14 -0600
Subject: [PATCH 058/127] combinators.cleave: Major insurgency assault
---
extra/combinators/cleave/cleave.factor | 19 ++++++++++++++++++-
1 file changed, 18 insertions(+), 1 deletion(-)
diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor
index d99fe7e1d2..8018adaaa4 100644
--- a/extra/combinators/cleave/cleave.factor
+++ b/extra/combinators/cleave/cleave.factor
@@ -1,5 +1,5 @@
-USING: kernel sequences macros combinators ;
+USING: kernel arrays sequences macros combinators ;
IN: combinators.cleave
@@ -21,6 +21,18 @@ MACRO: <2arr> ( seq -- )
[ >quots ] [ length ] bi
'[ , 2cleave , narray ] ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {1} ( x -- {x} ) 1array ; inline
+: {2} ( x y -- {x,y} ) 2array ; inline
+: {3} ( x y z -- {x,y,z} ) 3array ; inline
+
+: {n} narray ;
+
+: {bi} ( x p q -- {p(x),q(x)} ) bi {2} ; inline
+
+: {tri} ( x p q r -- {p(x),q(x),r(x)} ) tri {3} ; inline
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Spread into array
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -28,3 +40,8 @@ MACRO: <2arr> ( seq -- )
MACRO: <arr*> ( seq -- )
[ >quots ] [ length ] bi
'[ , spread , narray ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {bi*} ( x y p q -- {p(x),q(y)} ) bi* {2} ; inline
+: {tri*} ( x y z p q r -- {p(x),q(y),r(z)} ) tri* {3} ; inline
From a80e95ac2d65de8b96edfdbb638a06551cfbdf2b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 18:02:39 -0500
Subject: [PATCH 059/127] fix using
---
extra/classes/singleton/singleton-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/classes/singleton/singleton-tests.factor b/extra/classes/singleton/singleton-tests.factor
index 453a2a0ea5..08f4a77aad 100644
--- a/extra/classes/singleton/singleton-tests.factor
+++ b/extra/classes/singleton/singleton-tests.factor
@@ -1,4 +1,4 @@
-USING: kernel singleton tools.test prettyprint io.streams.string ;
+USING: kernel classes.singleton tools.test prettyprint io.streams.string ;
IN: classes.singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
From 5b65e02851207ae91bde1245562c79ade2eb10ed Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 1 Apr 2008 17:48:49 -0600
Subject: [PATCH 060/127] Project for a new American stack effect
---
extra/newfx/newfx.factor | 50 ++++++++++++++++++++++++++++++++++++++++
1 file changed, 50 insertions(+)
create mode 100644 extra/newfx/newfx.factor
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
new file mode 100644
index 0000000000..a5db87ca37
--- /dev/null
+++ b/extra/newfx/newfx.factor
@@ -0,0 +1,50 @@
+
+USING: kernel sequences assocs qualified ;
+
+QUALIFIED: sequences
+
+IN: newfx
+
+! Now, we can see a new world coming into view.
+! A world in which there is the very real prospect of a new world order.
+!
+! - George Herbert Walker Bush
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: nth-at ( seq i -- val ) swap nth ;
+: nth-of ( i seq -- val ) nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: nth-is ( seq i val -- seq ) swap pick set-nth ;
+
+: is-nth ( seq val i -- seq ) pick set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: at-key ( tbl key -- val ) swap at ;
+: key-of ( key tbl -- val ) at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: key-is ( tbl key val -- tbl ) swap pick set-at ;
+: is-key ( tbl val key -- tbl ) pick set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: push ( seq obj -- seq ) over sequences:push ;
+: push-on ( obj seq -- seq ) tuck sequences:push ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: member? ( seq obj -- ? ) swap sequences:member? ;
+: member-of? ( obj seq -- ? ) sequences:member? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delete-at-key ( tbl key -- tbl ) over delete-at ;
+: delete-key-of ( key tbl -- tbl ) tuck delete-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
From 6b454eed36490c35cd928e8b5b932f4e3ba2dc6d Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 2 Apr 2008 12:59:12 +1300
Subject: [PATCH 061/127] Various peg/ebnf fixes - Box parsers were broken when
involved in left recursion detection - ebnf no longer implicitly ignores
white space between terminates/non-terminals - ebnf now handles \t and \n in
grammars so productions to detect white space work - reset-delegates is now
reset-pegs
---
extra/peg/ebnf/ebnf-tests.factor | 53 ++++++++++++++++++++++++++++++--
extra/peg/ebnf/ebnf.factor | 13 +++++---
extra/peg/peg.factor | 24 +++++++++------
3 files changed, 74 insertions(+), 16 deletions(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 4f802c5207..84c492c55a 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -180,6 +180,55 @@ IN: peg.ebnf.tests
{ 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
] unit-test
+{ f } [
+ "ab" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call
+] unit-test
+
+{ V{ "a" " " "b" } } [
+ "a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "\t" "b" } } [
+ "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "\n" "b" } } [
+ "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" f "b" } } [
+ "ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" " " "b" } } [
+ "a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
+] unit-test
+
+
+{ V{ "a" "\t" "b" } } [
+ "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "\n" "b" } } [
+ "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "b" } } [
+ "ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "b" } } [
+ "a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "b" } } [
+ "a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ f } [
+ "axb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call
+] unit-test
+
{ V{ V{ 49 } "+" V{ 49 } } } [
#! Test direct left recursion.
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
@@ -200,7 +249,7 @@ IN: peg.ebnf.tests
EBNF: primary
Primary = PrimaryNoNewArray
-PrimaryNoNewArray = ClassInstanceCreationExpression
+PrimaryNoNewArray = ClassInstanceCreationExpression
| MethodInvocation
| FieldAccess
| ArrayAccess
@@ -211,7 +260,7 @@ MethodInvocation = Primary "." MethodName "(" ")"
| MethodName "(" ")"
FieldAccess = Primary "." Identifier
| "super" "." Identifier
-ArrayAccess = Primary "[" Expression "]"
+ArrayAccess = Primary "[" Expression "]"
| ExpressionName "[" Expression "]"
ClassOrInterfaceType = ClassName | InterfaceTypeName
ClassName = "C" | "D"
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index a6567ce8f3..a4e4fe387d 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -3,7 +3,7 @@
USING: kernel compiler.units parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
peg.parsers unicode.categories multiline combinators.lib
- splitting accessors effects sequences.deep ;
+ splitting accessors effects sequences.deep peg.search ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
@@ -308,7 +308,7 @@ M: ebnf-var (transform) ( ast -- parser )
dup vars get push [ dupd set ] curry action ;
M: ebnf-terminal (transform) ( ast -- parser )
- symbol>> token sp ;
+ symbol>> token ;
: parser-not-found ( name -- * )
[
@@ -317,7 +317,7 @@ M: ebnf-terminal (transform) ( ast -- parser )
M: ebnf-non-terminal (transform) ( ast -- parser )
symbol>> [
- , \ dup , parser get , \ at , [ parser-not-found ] , \ unless* , \ sp , \ nip ,
+ , \ dup , parser get , \ at , [ parser-not-found ] , \ unless* , \ nip ,
] [ ] make box ;
: transform-ebnf ( string -- object )
@@ -340,10 +340,13 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
parse-result-ast transform dup dup parser [ main swap at compile ] with-variable
[ compiled-parse ] curry [ with-scope ] curry ;
-: [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing
+: replace-escapes ( string -- string )
+ "\\t" token [ drop "\t" ] action "\\n" token [ drop "\n" ] action 2choice replace ;
+
+: [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing
: EBNF:
CREATE-WORD dup
- ";EBNF" parse-multiline-string
+ ";EBNF" parse-multiline-string replace-escapes
ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop ; parsing
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 9e35c5b9be..ad821635d7 100755
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -30,6 +30,14 @@ SYMBOL: fail
SYMBOL: lrstack
SYMBOL: heads
+: delegates ( -- cache )
+ \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ;
+
+: reset-pegs ( -- )
+ H{ } clone \ delegates set-global ;
+
+reset-pegs
+
TUPLE: memo-entry ans pos ;
C: <memo-entry> memo-entry
@@ -253,14 +261,6 @@ SYMBOL: id
1 id set-global 0
] if* ;
-: delegates ( -- cache )
- \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ;
-
-: reset-delegates ( -- )
- H{ } clone \ delegates set-global ;
-
-reset-delegates
-
: init-parser ( parser -- parser )
#! Set the delegate for the parser. Equivalent parsers
#! get a delegate with the same id.
@@ -590,7 +590,13 @@ PRIVATE>
#! not a cached one. This is because the same box,
#! compiled twice can have a different compiled word
#! due to running at compile time.
- box-parser construct-boa next-id f <parser> over set-delegate ;
+ #! Why the [ ] action at the end? Box parsers don't get
+ #! memoized during parsing due to all box parsers being
+ #! unique. This breaks left recursion detection during the
+ #! parse. The action adds an indirection with a parser type
+ #! that gets memoized and fixes this. Need to rethink how
+ #! to fix boxes so this isn't needed...
+ box-parser construct-boa next-id f <parser> over set-delegate [ ] action ;
: PEG:
(:) [
From ae623ff9249632872cc85c69ecf3ade2797a47d0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 19:00:20 -0500
Subject: [PATCH 062/127] normalize-pathname prepends unicode prefix,
(normalize-pathname) does not
---
core/io/backend/backend.factor | 2 +-
core/io/files/files-tests.factor | 6 -----
core/io/files/files.factor | 13 ++++++---
extra/editors/editors.factor | 2 +-
extra/io/unix/files/files-tests.factor | 6 +++++
extra/io/windows/launcher/launcher.factor | 2 +-
extra/io/windows/nt/files/files-tests.factor | 9 ++++---
extra/io/windows/nt/files/files.factor | 28 +++++---------------
8 files changed, 32 insertions(+), 36 deletions(-)
diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor
index 6bcd448385..935b007dd5 100755
--- a/core/io/backend/backend.factor
+++ b/core/io/backend/backend.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init kernel system namespaces io io.encodings
-io.encodings.utf8 init assocs ;
+io.encodings.utf8 init assocs splitting ;
IN: io.backend
SYMBOL: io-backend
diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor
index 9920d8d25c..b4a7d44433 100755
--- a/core/io/files/files-tests.factor
+++ b/core/io/files/files-tests.factor
@@ -220,8 +220,6 @@ io.encodings.utf8 ;
[ "/usr/lib" ] [ "/usr" "lib" append-path ] unit-test
[ "/usr/lib" ] [ "/usr/" "lib" append-path ] unit-test
-[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test
-[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test
[ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test
[ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test
[ "/lib" ] [ "/usr" "../lib" append-path ] unit-test
@@ -239,9 +237,6 @@ io.encodings.utf8 ;
[ "lib" ] [ "" "lib" append-path ] unit-test
[ "lib" ] [ "" "./lib" append-path ] unit-test
-[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
-[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
-
[ "foo/bar/." parent-directory ] must-fail
[ "foo/bar/./" parent-directory ] must-fail
[ "foo/bar/baz/.." parent-directory ] must-fail
@@ -263,5 +258,4 @@ io.encodings.utf8 ;
[ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test
[ t ] [ "resource:core" absolute-path? ] unit-test
-[ t ] [ "/foo" absolute-path? ] unit-test
[ f ] [ "" absolute-path? ] unit-test
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 099acb157e..d2142cc6f3 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -102,6 +102,7 @@ PRIVATE>
: windows-absolute-path? ( path -- path ? )
{
+ { [ dup "\\\\?\\" head? ] [ t ] }
{ [ dup length 2 < ] [ f ] }
{ [ dup second CHAR: : = ] [ t ] }
{ [ t ] [ f ] }
@@ -111,8 +112,8 @@ PRIVATE>
{
{ [ dup empty? ] [ f ] }
{ [ dup "resource:" head? ] [ t ] }
- { [ dup first path-separator? ] [ t ] }
{ [ windows? ] [ windows-absolute-path? ] }
+ { [ dup first path-separator? ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;
@@ -126,6 +127,9 @@ PRIVATE>
2 tail left-trim-separators
>r parent-directory r> append-path
] }
+ { [ over absolute-path? over first path-separator? and ] [
+ >r 2 head r> append
+ ] }
{ [ t ] [
>r right-trim-separators "/" r>
left-trim-separators 3append
@@ -296,14 +300,17 @@ DEFER: copy-tree-into
: temp-file ( name -- path )
temp-directory prepend-path ;
-M: object normalize-pathname ( path -- path' )
+: (normalize-pathname) ( path -- path' )
"resource:" ?head [
left-trim-separators resource-path
- normalize-pathname
+ (normalize-pathname)
] [
current-directory get prepend-path
] if ;
+M: object normalize-pathname ( path -- path' )
+ (normalize-pathname) ;
+
! Pathname presentations
TUPLE: pathname string ;
diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor
index c442dfaa94..00e20de5b5 100755
--- a/extra/editors/editors.factor
+++ b/extra/editors/editors.factor
@@ -26,7 +26,7 @@ SYMBOL: edit-hook
require ;
: edit-location ( file line -- )
- >r normalize-pathname "\\\\?\\" ?head drop r>
+ >r (normalize-pathname) "\\\\?\\" ?head drop r>
edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
: edit ( defspec -- )
diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor
index bb2039adfb..a0310a1cac 100755
--- a/extra/io/unix/files/files-tests.factor
+++ b/extra/io/unix/files/files-tests.factor
@@ -21,3 +21,9 @@ IN: io.unix.files.tests
[ "/lib/" ] [ "/" "../lib/" append-path ] unit-test
[ "/lib" ] [ "/" "../../lib" append-path ] unit-test
[ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test
+
+{ [ "/lib" ] [ "/usr/" "/lib" append-path ] }
+{ [ "/lib/" ] [ "/usr/" "/lib/" append-path ] }
+{ [ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] }
+{ [ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] }
+{ [ t ] [ "/foo" absolute-path? ] }
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index 31247e43c3..f3226bfbf0 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -28,7 +28,7 @@ TUPLE: CreateProcess-args
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
TRUE >>bInheritHandles
0 >>dwCreateFlags
- current-directory get normalize-pathname >>lpCurrentDirectory ;
+ current-directory get (normalize-pathname) >>lpCurrentDirectory ;
: call-CreateProcess ( CreateProcess-args -- )
{
diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor
index 73d6a0bf7f..431aced65d 100644
--- a/extra/io/windows/nt/files/files-tests.factor
+++ b/extra/io/windows/nt/files/files-tests.factor
@@ -1,9 +1,9 @@
USING: io.files kernel tools.test io.backend
-io.windows.nt.files splitting ;
+io.windows.nt.files splitting sequences ;
IN: io.windows.nt.files.tests
-[ t ] [ "\\foo" absolute-path? ] unit-test
-[ t ] [ "\\\\?\\foo" absolute-path? ] unit-test
+[ f ] [ "\\foo" absolute-path? ] unit-test
+[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test
[ t ] [ "c:\\foo" absolute-path? ] unit-test
[ t ] [ "c:" absolute-path? ] unit-test
@@ -45,3 +45,6 @@ IN: io.windows.nt.files.tests
"C:\\builds\\factor\\12345\\"
"..\\.." append-path normalize-pathname
] unit-test
+
+[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test
+[ t ] [ "" resource-path 2 tail exists? ] unit-test
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index 81112a89c0..bc676b8d0a 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -36,28 +36,14 @@ ERROR: not-absolute-path ;
} && [ 2 head ] [ not-absolute-path ] if ;
: prepend-prefix ( string -- string' )
- unicode-prefix prepend ;
+ dup unicode-prefix head? [
+ unicode-prefix prepend
+ ] unless ;
-ERROR: nonstring-pathname ;
-ERROR: empty-pathname ;
-
-M: windows-nt-io normalize-pathname ( string -- string )
- "resource:" ?head [
- left-trim-separators resource-path
- normalize-pathname
- ] [
- dup empty? [ empty-pathname ] when
- current-directory get prepend-path
- dup unicode-prefix head? [
- dup first path-separator? [
- left-trim-separators
- current-directory get 2 head
- prepend-path
- ] when
- unicode-prefix prepend
- ] unless
- { { CHAR: / CHAR: \\ } } substitute ! necessary
- ] if ;
+M: windows-nt-io normalize-pathname ( string -- string' )
+ (normalize-pathname)
+ { { CHAR: / CHAR: \\ } } substitute
+ prepend-prefix ;
M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
FILE_FLAG_OVERLAPPED bitor ;
From 5ecb754cc863eca4f52e2d8a19edb20c78a8b85f Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 1 Apr 2008 18:18:18 -0600
Subject: [PATCH 063/127] newfx: mutators
---
extra/newfx/newfx.factor | 22 ++++++++++++++++++++--
1 file changed, 20 insertions(+), 2 deletions(-)
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
index a5db87ca37..53cda66dfc 100644
--- a/extra/newfx/newfx.factor
+++ b/extra/newfx/newfx.factor
@@ -17,9 +17,16 @@ IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: nth-is ( seq i val -- seq ) swap pick set-nth ;
+: nth-is ( seq i val -- seq ) swap pick set-nth ;
+: is-nth ( seq val i -- seq ) pick set-nth ;
-: is-nth ( seq val i -- seq ) pick set-nth ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mutate-nth ( seq i val -- ) swap rot set-nth ;
+: mutate-at-nth ( seq val i -- ) rot set-nth ;
+
+: mutate-nth-of ( i val seq -- ) swapd set-nth ;
+: mutate-at-nth-of ( val i seq -- ) set-nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -33,6 +40,14 @@ IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: mutate-key ( tbl key val -- ) swap rot set-at ;
+: mutate-at-key ( tbl val key -- ) rot set-at ;
+
+: mutate-key-of ( key val tbl -- ) swapd set-at ;
+: mutate-at-key-of ( val key tbl -- ) set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: push ( seq obj -- seq ) over sequences:push ;
: push-on ( obj seq -- seq ) tuck sequences:push ;
@@ -48,3 +63,6 @@ IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! A note about the 'mutate' qualifier. Other words also technically mutate
+! their primary object. However, the 'mutate' qualifier is supposed to
+! indicate that this is the main objective of the word, as a side effect.
\ No newline at end of file
From 1b58ba404ec22cef9d8713369c6aa4fa47387864 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 2 Apr 2008 13:50:29 +1300
Subject: [PATCH 064/127] Fix peg.pl0 test failures
---
extra/peg/pl0/pl0-tests.factor | 47 +++++++++++++++++++++++++++++++++-
extra/peg/pl0/pl0.factor | 26 ++++++++++---------
2 files changed, 60 insertions(+), 13 deletions(-)
diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor
index b3d2135da7..1ed528d05d 100644
--- a/extra/peg/pl0/pl0-tests.factor
+++ b/extra/peg/pl0/pl0-tests.factor
@@ -1,9 +1,54 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg peg.pl0 multiline sequences ;
+USING: kernel tools.test peg peg.pl0 multiline sequences words assocs ;
IN: peg.pl0.tests
+{ f } [
+ "CONST foo = 1;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+] unit-test
+
+{ f } [
+ "VAR foo;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+] unit-test
+
+{ f } [
+ "VAR foo,bar , baz;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+] unit-test
+
+{ f } [
+ "foo := 5;" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+] unit-test
+
+{ f } [
+ "BEGIN foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+] unit-test
+
+{ f } [
+ "IF 1=1 THEN foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+] unit-test
+
+{ f } [
+ "WHILE 1=1 DO foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+] unit-test
+
+{ f } [
+ "WHILE ODD 1=1 DO foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+] unit-test
+
+{ f } [
+ "PROCEDURE square; BEGIN squ=x*x END" \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+] unit-test
+
+{ f } [
+ <"
+PROCEDURE square;
+BEGIN
+ squ := x * x
+END;
+"> \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+] unit-test
+
{ t } [
<"
VAR x, squ;
diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor
index f7eb3cad23..8025728285 100644
--- a/extra/peg/pl0/pl0.factor
+++ b/extra/peg/pl0/pl0.factor
@@ -7,18 +7,20 @@ IN: peg.pl0
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
EBNF: pl0
-block = ( "CONST" ident "=" number ( "," ident "=" number )* ";" )?
- ( "VAR" ident ( "," ident )* ";" )?
- ( "PROCEDURE" ident ";" ( block ";" )? )* statement
-statement = ( ident ":=" expression | "CALL" ident |
- "BEGIN" statement (";" statement )* "END" |
- "IF" condition "THEN" statement |
- "WHILE" condition "DO" statement )?
-condition = "ODD" expression |
- expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression
-expression = ("+" | "-")? term (("+" | "-") term )*
-term = factor (("*" | "/") factor )*
-factor = ident | number | "(" expression ")"
+- = (" " | "\t" | "\n")+ => [[ drop ignore ]]
+_ = (" " | "\t" | "\n")* => [[ drop ignore ]]
+block = ( _ "CONST" - ident _ "=" _ number ( _ "," _ ident _ "=" _ number )* _ ";" )?
+ ( _ "VAR" - ident ( _ "," _ ident )* _ ";" )?
+ ( _ "PROCEDURE" - ident _ ";" ( _ block _ ";" )? )* _ statement
+statement = ( ident _ ":=" _ expression | "CALL" - ident |
+ "BEGIN" - statement ( _ ";" _ statement )* _ "END" |
+ "IF" - condition _ "THEN" - statement |
+ "WHILE" - condition _ "DO" - statement )?
+condition = "ODD" - expression |
+ expression _ ("=" | "#" | "<=" | "<" | ">=" | ">") _ expression
+expression = ("+" | "-")? term ( _ ("+" | "-") _ term )*
+term = factor ( _ ("*" | "/") _ factor )*
+factor = ident | number | "(" _ expression _ ")"
ident = (([a-zA-Z])+) [[ >string ]]
digit = ([0-9]) [[ digit> ]]
number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]]
From 2bad7228a7df0496b240c2b4b5f7483b06b0d10e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 19:51:49 -0500
Subject: [PATCH 065/127] rename normalize-pathname to normalize-path fix
windows launcher issue
---
core/io/backend/backend-tests.factor | 8 ++--
core/io/backend/backend.factor | 4 +-
core/io/files/files-docs.factor | 2 +-
core/io/files/files.factor | 45 ++++++++++----------
extra/cairo/png/png.factor | 2 +-
extra/editors/editors.factor | 2 +-
extra/io/sockets/sockets.factor | 2 +-
extra/io/unix/files/files.factor | 20 ++++-----
extra/io/unix/launcher/launcher.factor | 2 +-
extra/io/windows/ce/files/files.factor | 2 +-
extra/io/windows/files/files.factor | 8 ++--
extra/io/windows/launcher/launcher.factor | 2 +-
extra/io/windows/nt/files/files-tests.factor | 8 ++--
extra/io/windows/nt/files/files.factor | 4 +-
extra/io/windows/nt/launcher/launcher.factor | 2 +-
extra/io/windows/windows.factor | 12 +++---
16 files changed, 63 insertions(+), 62 deletions(-)
mode change 100644 => 100755 core/io/backend/backend-tests.factor
mode change 100644 => 100755 extra/io/windows/nt/files/files-tests.factor
diff --git a/core/io/backend/backend-tests.factor b/core/io/backend/backend-tests.factor
old mode 100644
new mode 100755
index 04f34068eb..c3d7e8e89b
--- a/core/io/backend/backend-tests.factor
+++ b/core/io/backend/backend-tests.factor
@@ -1,4 +1,4 @@
-IN: io.backend.tests
-USING: tools.test io.backend kernel ;
-
-[ ] [ "a" normalize-pathname drop ] unit-test
+IN: io.backend.tests
+USING: tools.test io.backend kernel ;
+
+[ ] [ "a" normalize-path drop ] unit-test
diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor
index 935b007dd5..44b1eea349 100755
--- a/core/io/backend/backend.factor
+++ b/core/io/backend/backend.factor
@@ -18,9 +18,9 @@ HOOK: io-multiplex io-backend ( ms -- )
HOOK: normalize-directory io-backend ( str -- newstr )
-HOOK: normalize-pathname io-backend ( str -- newstr )
+HOOK: normalize-path io-backend ( str -- newstr )
-M: object normalize-directory normalize-pathname ;
+M: object normalize-directory normalize-path ;
: set-io-backend ( io-backend -- )
io-backend set-global init-io init-stdio
diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
index 1953569223..342967acfc 100755
--- a/core/io/files/files-docs.factor
+++ b/core/io/files/files-docs.factor
@@ -252,7 +252,7 @@ HELP: normalize-directory
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
{ $description "Called by the " { $link directory } " word to prepare a pathname before passing it to the " { $link (directory) } " primitive." } ;
-HELP: normalize-pathname
+HELP: normalize-path
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index d2142cc6f3..720894d489 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -13,13 +13,13 @@ HOOK: (file-writer) io-backend ( path -- stream )
HOOK: (file-appender) io-backend ( path -- stream )
: <file-reader> ( path encoding -- stream )
- swap normalize-pathname (file-reader) swap <decoder> ;
+ swap normalize-path (file-reader) swap <decoder> ;
: <file-writer> ( path encoding -- stream )
- swap normalize-pathname (file-writer) swap <encoder> ;
+ swap normalize-path (file-writer) swap <encoder> ;
: <file-appender> ( path encoding -- stream )
- swap normalize-pathname (file-appender) swap <encoder> ;
+ swap normalize-path (file-appender) swap <encoder> ;
: file-lines ( path encoding -- seq )
<file-reader> lines ;
@@ -171,7 +171,7 @@ SYMBOL: +unknown+
! File metadata
: exists? ( path -- ? )
- normalize-pathname (exists?) ;
+ normalize-path (exists?) ;
: directory? ( path -- ? )
file-info file-info-type +directory+ = ;
@@ -187,18 +187,33 @@ M: object cwd ( -- path ) "." ;
[ cwd current-directory set-global ] "io.files" add-init-hook
+: resource-path ( path -- newpath )
+ "resource-path" get [ image parent-directory ] unless*
+ prepend-path ;
+
+: (normalize-path) ( path -- path' )
+ "resource:" ?head [
+ left-trim-separators resource-path
+ (normalize-path)
+ ] [
+ current-directory get prepend-path
+ ] if ;
+
+M: object normalize-path ( path -- path' )
+ (normalize-path) ;
+
: with-directory ( path quot -- )
- >r normalize-pathname r>
+ >r (normalize-path) r>
current-directory swap with-variable ; inline
: set-current-directory ( path -- )
- normalize-pathname current-directory set ;
+ normalize-path current-directory set ;
! Creating directories
HOOK: make-directory io-backend ( path -- )
: make-directories ( path -- )
- normalize-pathname right-trim-separators {
+ normalize-path right-trim-separators {
{ [ dup "." = ] [ ] }
{ [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] }
@@ -271,7 +286,7 @@ M: object copy-file
DEFER: copy-tree-into
: copy-tree ( from to -- )
- normalize-pathname
+ normalize-path
over link-info type>>
{
{ +symbolic-link+ [ copy-link ] }
@@ -290,9 +305,6 @@ DEFER: copy-tree-into
[ copy-tree-into ] curry each ;
! Special paths
-: resource-path ( path -- newpath )
- "resource-path" get [ image parent-directory ] unless*
- prepend-path ;
: temp-directory ( -- path )
"temp" resource-path dup make-directories ;
@@ -300,17 +312,6 @@ DEFER: copy-tree-into
: temp-file ( name -- path )
temp-directory prepend-path ;
-: (normalize-pathname) ( path -- path' )
- "resource:" ?head [
- left-trim-separators resource-path
- (normalize-pathname)
- ] [
- current-directory get prepend-path
- ] if ;
-
-M: object normalize-pathname ( path -- path' )
- (normalize-pathname) ;
-
! Pathname presentations
TUPLE: pathname string ;
diff --git a/extra/cairo/png/png.factor b/extra/cairo/png/png.factor
index 774a1afe8e..f9908e4581 100755
--- a/extra/cairo/png/png.factor
+++ b/extra/cairo/png/png.factor
@@ -24,7 +24,7 @@ ERROR: cairo-error string ;
} cond ;
: <png> ( path -- png )
- normalize-pathname
+ normalize-path
cairo_image_surface_create_from_png
dup cairo_surface_status cairo-png-error
dup [ cairo_image_surface_get_width check-zero ]
diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor
index 00e20de5b5..e871d5f808 100755
--- a/extra/editors/editors.factor
+++ b/extra/editors/editors.factor
@@ -26,7 +26,7 @@ SYMBOL: edit-hook
require ;
: edit-location ( file line -- )
- >r (normalize-pathname) "\\\\?\\" ?head drop r>
+ >r (normalize-path) "\\\\?\\" ?head drop r>
edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
: edit ( defspec -- )
diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor
index e1cc36cd2e..17799227b8 100755
--- a/extra/io/sockets/sockets.factor
+++ b/extra/io/sockets/sockets.factor
@@ -7,7 +7,7 @@ IN: io.sockets
TUPLE: local path ;
: <local> ( path -- addrspec )
- normalize-pathname local construct-boa ;
+ normalize-path local construct-boa ;
TUPLE: inet4 host port ;
diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor
index c4e506d37f..7d0e7c4330 100755
--- a/extra/io/unix/files/files.factor
+++ b/extra/io/unix/files/files.factor
@@ -43,22 +43,22 @@ M: unix-io (file-appender) ( path -- stream )
{ O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
M: unix-io touch-file ( path -- )
- normalize-pathname
+ normalize-path
touch-mode file-mode open
dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when
close ;
M: unix-io move-file ( from to -- )
- [ normalize-pathname ] bi@ rename io-error ;
+ [ normalize-path ] bi@ rename io-error ;
M: unix-io delete-file ( path -- )
- normalize-pathname unlink io-error ;
+ normalize-path unlink io-error ;
M: unix-io make-directory ( path -- )
- normalize-pathname OCT: 777 mkdir io-error ;
+ normalize-path OCT: 777 mkdir io-error ;
M: unix-io delete-directory ( path -- )
- normalize-pathname rmdir io-error ;
+ normalize-path rmdir io-error ;
: (copy-file) ( from to -- )
dup parent-directory make-directories
@@ -69,7 +69,7 @@ M: unix-io delete-directory ( path -- )
] with-disposal ;
M: unix-io copy-file ( from to -- )
- [ normalize-pathname ] bi@
+ [ normalize-path ] bi@
[ (copy-file) ]
[ swap file-info file-info-permissions chmod io-error ]
2bi ;
@@ -96,15 +96,15 @@ M: unix-io copy-file ( from to -- )
\ file-info construct-boa ;
M: unix-io file-info ( path -- info )
- normalize-pathname stat* stat>file-info ;
+ normalize-path stat* stat>file-info ;
M: unix-io link-info ( path -- info )
- normalize-pathname lstat* stat>file-info ;
+ normalize-path lstat* stat>file-info ;
M: unix-io make-link ( path1 path2 -- )
- normalize-pathname symlink io-error ;
+ normalize-path symlink io-error ;
M: unix-io read-link ( path -- path' )
- normalize-pathname
+ normalize-path
PATH_MAX [ <byte-array> tuck ] [ ] bi readlink
dup io-error head-slice >string ;
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index f738bd42c2..4986024e78 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -37,7 +37,7 @@ USE: unix
2nip reset-fd ;
: redirect-file ( obj mode fd -- )
- >r >r normalize-pathname r> file-mode
+ >r >r normalize-path r> file-mode
open dup io-error r> redirect-fd ;
: redirect-closed ( obj mode fd -- )
diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor
index c4f5b2ef9e..1e5cedae57 100755
--- a/extra/io/windows/ce/files/files.factor
+++ b/extra/io/windows/ce/files/files.factor
@@ -4,7 +4,7 @@ prettyprint sequences strings threads threads.private
windows windows.kernel32 io.windows.ce.backend ;
IN: windows.ce.files
-! M: windows-ce-io normalize-pathname ( string -- string )
+! M: windows-ce-io normalize-path ( string -- string )
! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
M: windows-ce-io CreateFile-flags ( DWORD -- DWORD )
diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor
index 295b3ab006..a23a78b3da 100755
--- a/extra/io/windows/files/files.factor
+++ b/extra/io/windows/files/files.factor
@@ -89,14 +89,14 @@ SYMBOLS: +read-only+ +hidden+ +system+
] if ;
M: windows-nt-io file-info ( path -- info )
- normalize-pathname get-file-information-stat ;
+ normalize-path get-file-information-stat ;
M: windows-nt-io link-info ( path -- info )
file-info ;
: file-times ( path -- timestamp timestamp timestamp )
[
- normalize-pathname open-existing dup close-always
+ normalize-path open-existing dup close-always
"FILETIME" <c-object>
"FILETIME" <c-object>
"FILETIME" <c-object>
@@ -112,7 +112,7 @@ M: windows-nt-io link-info ( path -- info )
#! timestamp order: creation access write
[
>r >r >r
- normalize-pathname open-existing dup close-always
+ normalize-path open-existing dup close-always
r> r> r> (set-file-times)
] with-destructors ;
@@ -127,7 +127,7 @@ M: windows-nt-io link-info ( path -- info )
M: windows-nt-io touch-file ( path -- )
[
- normalize-pathname
+ normalize-path
maybe-create-file over close-always
[ drop ] [ f now dup (set-file-times) ] if
] with-destructors ;
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index f3226bfbf0..579745710e 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -28,7 +28,7 @@ TUPLE: CreateProcess-args
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
TRUE >>bInheritHandles
0 >>dwCreateFlags
- current-directory get (normalize-pathname) >>lpCurrentDirectory ;
+ current-directory get (normalize-path) >>lpCurrentDirectory ;
: call-CreateProcess ( CreateProcess-args -- )
{
diff --git a/extra/io/windows/nt/files/files-tests.factor b/extra/io/windows/nt/files/files-tests.factor
old mode 100644
new mode 100755
index 431aced65d..1e6268fbc0
--- a/extra/io/windows/nt/files/files-tests.factor
+++ b/extra/io/windows/nt/files/files-tests.factor
@@ -29,21 +29,21 @@ IN: io.windows.nt.files.tests
[ ] [ "" resource-path cd ] unit-test
-[ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test
+[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test
[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
"C:\\builds\\factor\\12345\\"
- "..\\log.txt" append-path normalize-pathname
+ "..\\log.txt" append-path normalize-path
] unit-test
[ "\\\\?\\C:\\builds\\" ] [
"C:\\builds\\factor\\12345\\"
- "..\\.." append-path normalize-pathname
+ "..\\.." append-path normalize-path
] unit-test
[ "\\\\?\\C:\\builds\\" ] [
"C:\\builds\\factor\\12345\\"
- "..\\.." append-path normalize-pathname
+ "..\\.." append-path normalize-path
] unit-test
[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index bc676b8d0a..91ad0139b2 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -40,8 +40,8 @@ ERROR: not-absolute-path ;
unicode-prefix prepend
] unless ;
-M: windows-nt-io normalize-pathname ( string -- string' )
- (normalize-pathname)
+M: windows-nt-io normalize-path ( string -- string' )
+ (normalize-path)
{ { CHAR: / CHAR: \\ } } substitute
prepend-prefix ;
diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor
index c342b2ee9a..895890e898 100755
--- a/extra/io/windows/nt/launcher/launcher.factor
+++ b/extra/io/windows/nt/launcher/launcher.factor
@@ -32,7 +32,7 @@ IN: io.windows.nt.launcher
drop 2nip null-pipe ;
:: redirect-file ( default path access-mode create-mode -- handle )
- path normalize-pathname
+ path normalize-path
access-mode
share-mode
security-attributes-inherit
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index 27917cedfa..45c1adaf50 100755
--- a/extra/io/windows/windows.factor
+++ b/extra/io/windows/windows.factor
@@ -25,7 +25,7 @@ HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- )
M: windows-io normalize-directory ( string -- string )
- normalize-pathname "\\" ?tail drop "\\*" append ;
+ normalize-path "\\" ?tail drop "\\*" append ;
: share-mode ( -- fixnum )
{
@@ -135,21 +135,21 @@ M: windows-io (file-appender) ( path -- stream )
open-append <win32-file> <writer> ;
M: windows-io move-file ( from to -- )
- [ normalize-pathname ] bi@ MoveFile win32-error=0/f ;
+ [ normalize-path ] bi@ MoveFile win32-error=0/f ;
M: windows-io delete-file ( path -- )
- normalize-pathname DeleteFile win32-error=0/f ;
+ normalize-path DeleteFile win32-error=0/f ;
M: windows-io copy-file ( from to -- )
dup parent-directory make-directories
- [ normalize-pathname ] bi@ 0 CopyFile win32-error=0/f ;
+ [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
M: windows-io make-directory ( path -- )
- normalize-pathname
+ normalize-path
f CreateDirectory win32-error=0/f ;
M: windows-io delete-directory ( path -- )
- normalize-pathname
+ normalize-path
RemoveDirectory win32-error=0/f ;
HOOK: WSASocket-flags io-backend ( -- DWORD )
From 8047115746ada0a5577e8e045140a8424441005b Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 1 Apr 2008 18:52:40 -0600
Subject: [PATCH 066/127] remove extra/new-effects
---
extra/new-effects/new-effects.factor | 17 -----------------
1 file changed, 17 deletions(-)
delete mode 100644 extra/new-effects/new-effects.factor
diff --git a/extra/new-effects/new-effects.factor b/extra/new-effects/new-effects.factor
deleted file mode 100644
index f073ccadd3..0000000000
--- a/extra/new-effects/new-effects.factor
+++ /dev/null
@@ -1,17 +0,0 @@
-USING: assocs kernel sequences ;
-IN: new-effects
-
-: new-nth ( seq n -- elt )
- swap nth ; inline
-
-: new-set-nth ( seq obj n -- seq )
- pick set-nth ; inline
-
-: new-at ( assoc key -- elt )
- swap at ; inline
-
-: new-at* ( assoc key -- elt ? )
- swap at* ; inline
-
-: new-set-at ( assoc value key -- assoc )
- pick set-at ; inline
From a94e5245a3b35d6062990729e16b8bf13d2a4cdd Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Tue, 1 Apr 2008 20:07:18 -0500
Subject: [PATCH 067/127] fix teh tests FOR GREAT JUSTICE
---
extra/io/unix/files/files-tests.factor | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor
index a0310a1cac..040b191d27 100755
--- a/extra/io/unix/files/files-tests.factor
+++ b/extra/io/unix/files/files-tests.factor
@@ -22,8 +22,8 @@ IN: io.unix.files.tests
[ "/lib" ] [ "/" "../../lib" append-path ] unit-test
[ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test
-{ [ "/lib" ] [ "/usr/" "/lib" append-path ] }
-{ [ "/lib/" ] [ "/usr/" "/lib/" append-path ] }
-{ [ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] }
-{ [ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] }
-{ [ t ] [ "/foo" absolute-path? ] }
+[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test
+[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test
+[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
+[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
+[ t ] [ "/foo" absolute-path? ] unit-test
From 6ac0d4692fee4a81fef062a9738f1030abee6ae6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 1 Apr 2008 20:20:13 -0500
Subject: [PATCH 068/127] remove wrap word, add circular to mersenne twister
---
extra/random/mersenne-twister/mersenne-twister.factor | 10 ++++------
1 file changed, 4 insertions(+), 6 deletions(-)
diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor
index 8ddbdac6f4..77054ea377 100755
--- a/extra/random/mersenne-twister/mersenne-twister.factor
+++ b/extra/random/mersenne-twister/mersenne-twister.factor
@@ -4,7 +4,7 @@
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
USING: arrays kernel math namespaces sequences system init
-accessors math.ranges random ;
+accessors math.ranges random circular ;
IN: random.mersenne-twister
<PRIVATE
@@ -16,8 +16,6 @@ TUPLE: mersenne-twister seq i ;
: mt-a HEX: 9908b0df ; inline
: mt-hi HEX: 80000000 bitand ; inline
: mt-lo HEX: 7fffffff bitand ; inline
-: wrap ( x n -- y ) 2dup >= [ - ] [ drop ] if ; inline
-: mt-wrap ( x -- y ) mt-n wrap ; inline
: set-generated ( y from-elt to seq -- )
>r >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi
@@ -27,8 +25,8 @@ TUPLE: mersenne-twister seq i ;
tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline
: (mt-generate) ( n mt-seq -- y to from-elt )
- [ >r dup 1+ mt-wrap r> calculate-y ]
- [ >r mt-m + mt-wrap r> nth ]
+ [ >r dup 1+ r> calculate-y ]
+ [ >r mt-m + r> nth ]
[ drop ] 2tri ;
: mt-generate ( mt -- )
@@ -36,7 +34,7 @@ TUPLE: mersenne-twister seq i ;
[ 0 >>i drop ] bi ;
: init-mt-first ( seed -- seq )
- >r mt-n 0 <array> r>
+ >r mt-n 0 <array> <circular> r>
HEX: ffffffff bitand 0 pick set-nth ;
: init-mt-formula ( seq i -- f(seq[i]) )
From bbcc84862f5e2ee038011886b330c3c655e754d4 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 2 Apr 2008 15:47:21 +1300
Subject: [PATCH 069/127] Tweak ast from sequences in ebnf
---
extra/peg/ebnf/ebnf.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index a4e4fe387d..7c5854cd7d 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -252,7 +252,7 @@ M: ebnf-rule (transform) ( ast -- parser )
] keep ;
M: ebnf-sequence (transform) ( ast -- parser )
- elements>> [ (transform) ] map seq ;
+ elements>> [ (transform) ] map seq [ dup length 1 = [ first ] when ] action ;
M: ebnf-choice (transform) ( ast -- parser )
options>> [ (transform) ] map choice ;
From 34a1505d95891fd516e4f5b176d937fe4641dd8a Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 2 Apr 2008 15:47:30 +1300
Subject: [PATCH 070/127] PL0 whitespace handling improvement
---
extra/peg/pl0/pl0-tests.factor | 36 +++++++++----------
extra/peg/pl0/pl0.factor | 64 +++++++++++++++++++++++++---------
2 files changed, 65 insertions(+), 35 deletions(-)
diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor
index 1ed528d05d..039f66637d 100644
--- a/extra/peg/pl0/pl0-tests.factor
+++ b/extra/peg/pl0/pl0-tests.factor
@@ -4,40 +4,40 @@
USING: kernel tools.test peg peg.pl0 multiline sequences words assocs ;
IN: peg.pl0.tests
-{ f } [
- "CONST foo = 1;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+{ t } [
+ "CONST foo = 1;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty?
] unit-test
-{ f } [
- "VAR foo;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+{ t } [
+ "VAR foo;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty?
] unit-test
-{ f } [
- "VAR foo,bar , baz;" \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+{ t } [
+ "VAR foo,bar , baz;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty?
] unit-test
-{ f } [
- "foo := 5;" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+{ t } [
+ "foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
] unit-test
-{ f } [
- "BEGIN foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+{ t } [
+ "BEGIN foo := 5 END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
] unit-test
-{ f } [
- "IF 1=1 THEN foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+{ t } [
+ "IF 1=1 THEN foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
] unit-test
-{ f } [
- "WHILE 1=1 DO foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+{ t } [
+ "WHILE 1=1 DO foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
] unit-test
-{ f } [
- "WHILE ODD 1=1 DO foo := 5; END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse not
+{ t } [
+ "WHILE ODD 1 DO foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
] unit-test
-{ f } [
- "PROCEDURE square; BEGIN squ=x*x END" \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+{ t } [
+ "PROCEDURE square; BEGIN squ:=x*x END" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty?
] unit-test
{ f } [
diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor
index 8025728285..1b97814ca7 100644
--- a/extra/peg/pl0/pl0.factor
+++ b/extra/peg/pl0/pl0.factor
@@ -7,22 +7,52 @@ IN: peg.pl0
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
EBNF: pl0
-- = (" " | "\t" | "\n")+ => [[ drop ignore ]]
_ = (" " | "\t" | "\n")* => [[ drop ignore ]]
-block = ( _ "CONST" - ident _ "=" _ number ( _ "," _ ident _ "=" _ number )* _ ";" )?
- ( _ "VAR" - ident ( _ "," _ ident )* _ ";" )?
- ( _ "PROCEDURE" - ident _ ";" ( _ block _ ";" )? )* _ statement
-statement = ( ident _ ":=" _ expression | "CALL" - ident |
- "BEGIN" - statement ( _ ";" _ statement )* _ "END" |
- "IF" - condition _ "THEN" - statement |
- "WHILE" - condition _ "DO" - statement )?
-condition = "ODD" - expression |
- expression _ ("=" | "#" | "<=" | "<" | ">=" | ">") _ expression
-expression = ("+" | "-")? term ( _ ("+" | "-") _ term )*
-term = factor ( _ ("*" | "/") _ factor )*
-factor = ident | number | "(" _ expression _ ")"
-ident = (([a-zA-Z])+) [[ >string ]]
-digit = ([0-9]) [[ digit> ]]
-number = ((digit)+) [[ unclip [ swap 10 * + ] reduce ]]
-program = block "."
+
+BEGIN = "BEGIN" _
+CALL = "CALL" _
+CONST = "CONST" _
+DO = "DO" _
+END = "END" _
+IF = "IF" _
+THEN = "THEN" _
+ODD = "ODD" _
+PROCEDURE = "PROCEDURE" _
+VAR = "VAR" _
+WHILE = "WHILE" _
+EQ = "=" _
+LTEQ = "<=" _
+LT = "<" _
+GT = ">" _
+GTEQ = ">=" _
+NEQ = "#" _
+COMMA = "," _
+SEMICOLON = ";" _
+ASSIGN = ":=" _
+
+ADD = "+" _
+SUBTRACT = "-" _
+MULTIPLY = "*" _
+DIVIDE = "/" _
+
+LPAREN = "(" _
+RPAREN = ")" _
+
+block = ( CONST ident EQ number ( COMMA ident EQ number )* SEMICOLON )?
+ ( VAR ident ( COMMA ident )* SEMICOLON )?
+ ( PROCEDURE ident SEMICOLON ( block SEMICOLON )? )* statement
+statement = ( ident ASSIGN expression
+ | CALL ident
+ | BEGIN statement ( SEMICOLON statement )* END
+ | IF condition THEN statement
+ | WHILE condition DO statement )?
+condition = ODD expression
+ | expression (EQ | NEQ | LTEQ | LT | GTEQ | GT) expression
+expression = (ADD | SUBTRACT)? term ( (ADD | SUBTRACT) term )* _
+term = factor ( (MULTIPLY | DIVIDE) factor )*
+factor = ident | number | LPAREN expression RPAREN
+ident = (([a-zA-Z])+) _ => [[ >string ]]
+digit = ([0-9]) => [[ digit> ]]
+number = ((digit)+) _ => [[ 10 digits>integer ]]
+program = _ block "."
;EBNF
From eac450bdcf28773813552170bd1091e13148202b Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Wed, 2 Apr 2008 15:55:18 +1300
Subject: [PATCH 071/127] Add ebnf rule word
---
extra/peg/ebnf/ebnf.factor | 3 +++
extra/peg/pl0/pl0-tests.factor | 29 ++++++++++-------------------
2 files changed, 13 insertions(+), 19 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 7c5854cd7d..b0dfaad5b3 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -350,3 +350,6 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
";EBNF" parse-multiline-string replace-escapes
ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop ; parsing
+: rule ( name word -- parser )
+ #! Given an EBNF word produced from EBNF: return the EBNF rule
+ "ebnf-parser" word-prop at ;
\ No newline at end of file
diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor
index 039f66637d..88993c354b 100644
--- a/extra/peg/pl0/pl0-tests.factor
+++ b/extra/peg/pl0/pl0-tests.factor
@@ -1,52 +1,43 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg peg.pl0 multiline sequences words assocs ;
+USING: kernel tools.test peg peg.ebnf peg.pl0 multiline sequences ;
IN: peg.pl0.tests
{ t } [
- "CONST foo = 1;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty?
+ "CONST foo = 1;" "block" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
- "VAR foo;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty?
+ "VAR foo;" "block" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
- "VAR foo,bar , baz;" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty?
+ "VAR foo,bar , baz;" "block" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
- "foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
+ "foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
- "BEGIN foo := 5 END" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
+ "BEGIN foo := 5 END" "statement" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
- "IF 1=1 THEN foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
+ "IF 1=1 THEN foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
- "WHILE 1=1 DO foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
+ "WHILE 1=1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
- "WHILE ODD 1 DO foo := 5" \ pl0 "ebnf-parser" word-prop "statement" swap at parse parse-result-remaining empty?
+ "WHILE ODD 1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
- "PROCEDURE square; BEGIN squ:=x*x END" \ pl0 "ebnf-parser" word-prop "block" swap at parse parse-result-remaining empty?
-] unit-test
-
-{ f } [
- <"
-PROCEDURE square;
-BEGIN
- squ := x * x
-END;
-"> \ pl0 "ebnf-parser" word-prop "block" swap at parse not
+ "PROCEDURE square; BEGIN squ:=x*x END" "block" \ pl0 rule parse parse-result-remaining empty?
] unit-test
{ t } [
From b085ce2f5ff236eeae7640fcd75c34a189648cab Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.gateway.2wire.net>
Date: Tue, 1 Apr 2008 22:24:00 -0500
Subject: [PATCH 072/127] fix unit test
---
extra/classes/singleton/singleton-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/classes/singleton/singleton-tests.factor b/extra/classes/singleton/singleton-tests.factor
index 08f4a77aad..586724ee3b 100644
--- a/extra/classes/singleton/singleton-tests.factor
+++ b/extra/classes/singleton/singleton-tests.factor
@@ -9,4 +9,4 @@ GENERIC: zammo ( obj -- )
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
[ t ] [ omg singleton? ] unit-test
-[ "USING: singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
+[ "USING: classes.singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
From a2971bd3bef5ed9fb3e1b6cf66141156aafd2c43 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 00:03:04 -0500
Subject: [PATCH 073/127] Improve walker: step into on an array recursively
sets breakpoint on each quotation nested in the array. Useful for cond, case,
cleave, ...
---
extra/tools/walker/walker.factor | 44 ++++++++++++++++++++------------
1 file changed, 28 insertions(+), 16 deletions(-)
diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor
index d548c0a4f5..6bd8ace877 100755
--- a/extra/tools/walker/walker.factor
+++ b/extra/tools/walker/walker.factor
@@ -3,7 +3,7 @@
USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
-sequences.private assocs models ;
+sequences.private assocs models arrays accessors ;
IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- )
@@ -51,9 +51,16 @@ DEFER: start-walker-thread
: walk ( quot -- quot' )
\ break prefix [ break rethrow ] recover ;
-: add-breakpoint ( quot -- quot' )
+GENERIC: add-breakpoint ( quot -- quot' )
+
+M: callable add-breakpoint
dup [ break ] head? [ \ break prefix ] unless ;
+M: array add-breakpoint
+ [ add-breakpoint ] map ;
+
+M: object add-breakpoint ;
+
: (step-into-quot) ( quot -- ) add-breakpoint call ;
: (step-into-if) ? (step-into-quot) ;
@@ -74,7 +81,7 @@ DEFER: start-walker-thread
\ (step-into-execute) t "step-into?" set-word-prop
: (step-into-continuation)
- continuation callstack over set-continuation-call break ;
+ continuation callstack >>call break ;
! Messages sent to walker thread
SYMBOL: step
@@ -94,15 +101,18 @@ SYMBOL: +stopped+
: change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the
#! continuation.
- >r clone r>
- over continuation-call clone
- [
- dup innermost-frame-scan 1+
- swap innermost-frame-quot
- rot call
- ] keep
- [ set-innermost-frame-quot ] keep
- over set-continuation-call ; inline
+ >r clone r> [
+ >r clone r>
+ [
+ >r
+ [ innermost-frame-scan 1+ ]
+ [ innermost-frame-quot ] bi
+ r> call
+ ]
+ [ drop set-innermost-frame-quot ]
+ [ drop ]
+ 2tri
+ ] curry change-call ; inline
: step-msg ( continuation -- continuation' )
[
@@ -143,6 +153,7 @@ SYMBOL: +stopped+
swap % unclip {
{ [ dup \ break eq? ] [ , ] }
{ [ dup quotation? ] [ add-breakpoint , \ break , ] }
+ { [ dup array? ] [ add-breakpoint , \ break , ] }
{ [ dup word? ] [ literalize , \ (step-into-execute) , ] }
{ [ t ] [ , \ break , ] }
} cond %
@@ -177,16 +188,17 @@ SYMBOL: +stopped+
{ step-back [ f ] }
{ f [ +stopped+ set-status f ] }
[
- dup walker-continuation tget set-model
- step-into-msg
+ [ walker-continuation tget set-model ]
+ [ step-into-msg ] bi
]
} case
] handle-synchronous
] [ ] while ;
: step-back-msg ( continuation -- continuation' )
- walker-history tget dup pop*
- empty? [ drop walker-history tget pop ] unless ;
+ walker-history tget
+ [ pop* ]
+ [ dup empty? [ drop ] [ nip pop ] if ] bi ;
: walker-suspended ( continuation -- continuation' )
+suspended+ set-status
From fa8b578370a8d23968225160c13634f9e95da8e3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 00:28:07 -0500
Subject: [PATCH 074/127] Rewriting method dispatch to support inheritance
---
core/bootstrap/layouts/layouts.factor | 4 +-
core/bootstrap/primitives.factor | 23 ++-
core/classes/classes.factor | 6 +-
core/combinators/combinators.factor | 8 +-
core/compiler/tests/intrinsics.factor | 8 -
core/compiler/tests/templates.factor | 4 -
core/cpu/x86/intrinsics/intrinsics.factor | 52 -------
core/generic/generic.factor | 8 +-
core/generic/standard/engines/engines.factor | 49 ++++++
.../engines/predicate/predicate.factor | 28 ++++
core/generic/standard/engines/tag/tag.factor | 48 ++++++
.../standard/engines/tuple/tuple.factor | 109 ++++++++++++++
core/generic/standard/new/new-tests.factor | 141 ++++++++++++++++++
core/generic/standard/new/new.factor | 139 +++++++++++++++++
core/generic/standard/standard.factor | 24 +--
core/inference/backend/backend.factor | 15 +-
core/inference/class/class-tests.factor | 2 +-
core/inference/known-words/known-words.factor | 3 -
core/kernel/kernel-docs.factor | 6 -
core/kernel/kernel.factor | 10 +-
core/layouts/layouts-docs.factor | 4 +-
core/optimizer/known-words/known-words.factor | 23 ---
22 files changed, 573 insertions(+), 141 deletions(-)
create mode 100644 core/generic/standard/engines/engines.factor
create mode 100644 core/generic/standard/engines/predicate/predicate.factor
create mode 100644 core/generic/standard/engines/tag/tag.factor
create mode 100644 core/generic/standard/engines/tuple/tuple.factor
create mode 100644 core/generic/standard/new/new-tests.factor
create mode 100644 core/generic/standard/new/new.factor
diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor
index 846cce153b..ceb011d52b 100755
--- a/core/bootstrap/layouts/layouts.factor
+++ b/core/bootstrap/layouts/layouts.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel alien byte-arrays
hashtables vectors strings sbufs arrays bit-arrays
-float-arrays quotations assocs layouts classes.tuple.private ;
+float-arrays quotations assocs layouts classes.tuple.private
+kernel.private ;
BIN: 111 tag-mask set
8 num-tags set
@@ -15,6 +16,7 @@ H{
{ bignum BIN: 001 }
{ tuple BIN: 010 }
{ object BIN: 011 }
+ { hi-tag BIN: 011 }
{ ratio BIN: 100 }
{ float BIN: 101 }
{ complex BIN: 110 }
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index bc876c2dec..48a1117574 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -101,17 +101,24 @@ num-types get f <array> builtins set
} [ create-vocab drop ] each
! Builtin classes
-: builtin-predicate-quot ( class -- quot )
+: lo-tag-eq-quot ( n -- quot )
+ [ \ tag , , \ eq? , ] [ ] make ;
+
+: hi-tag-eq-quot ( n -- quot )
[
- "type" word-prop
- [ tag-mask get < \ tag \ type ? , ] [ , ] bi
- \ eq? ,
+ [ dup tag ] % \ hi-tag tag-number , \ eq? ,
+ [ [ hi-tag ] % , \ eq? , ] [ ] make ,
+ [ drop f ] ,
+ \ if ,
] [ ] make ;
+: builtin-predicate-quot ( class -- quot )
+ "type" word-prop
+ dup tag-mask get <
+ [ lo-tag-eq-quot ] [ hi-tag-eq-quot ] if ;
+
: define-builtin-predicate ( class -- )
- [ dup builtin-predicate-quot define-predicate ]
- [ predicate-word make-inline ]
- bi ;
+ dup builtin-predicate-quot define-predicate ;
: lookup-type-number ( word -- n )
global [ target-word ] bind type-number ;
@@ -363,7 +370,7 @@ define-class
f builtins get [ ] subset union-class define-class
! Class of objects with object tag
-"hi-tag" "classes.private" create
+"hi-tag" "kernel.private" create
f builtins get num-tags get tail union-class define-class
! Null class with no instances.
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index d6d1a72121..d91b1bb217 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -124,6 +124,8 @@ GENERIC: update-methods ( assoc -- )
] bi
] 2tri ;
-GENERIC: class ( object -- class ) inline
+GENERIC: class ( object -- class )
-M: object class type type>class ;
+M: hi-tag class hi-tag type>class ;
+
+M: object class tag type>class ;
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index f9ed219d7b..139c6d8fdf 100755
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -9,24 +9,24 @@ hashtables sorting ;
[ call ] with each ;
: cleave>quot ( seq -- quot )
- [ [ keep ] curry ] map concat [ drop ] append ;
+ [ [ keep ] curry ] map concat [ drop ] append [ ] like ;
: 2cleave ( x seq -- )
[ 2keep ] each 2drop ;
: 2cleave>quot ( seq -- quot )
- [ [ 2keep ] curry ] map concat [ 2drop ] append ;
+ [ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
: 3cleave ( x seq -- )
[ 3keep ] each 3drop ;
: 3cleave>quot ( seq -- quot )
- [ [ 3keep ] curry ] map concat [ 3drop ] append ;
+ [ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
: spread>quot ( seq -- quot )
[ length [ >r ] <repetition> concat ]
[ [ [ r> ] prepend ] map concat ] bi
- append ;
+ append [ ] like ;
: spread ( objs... seq -- )
spread>quot call ;
diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor
index 7a8fe5d735..fadc57dc8d 100755
--- a/core/compiler/tests/intrinsics.factor
+++ b/core/compiler/tests/intrinsics.factor
@@ -174,11 +174,6 @@ sequences.private ;
[ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
[ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
-[ t ] [ 3 type 3 [ type ] compile-call eq? ] unit-test
-[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-call eq? ] unit-test
-[ t ] [ "hey" type "hey" [ type ] compile-call eq? ] unit-test
-[ t ] [ f type f [ type ] compile-call eq? ] unit-test
-
[ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
@@ -223,9 +218,6 @@ sequences.private ;
[ t ] [ f [ f eq? ] compile-call ] unit-test
-! regression
-[ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-call 2nip ] unit-test
-
! regression
[ 3 ] [
100001 f <array> 3 100000 pick set-nth
diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor
index 081a8fd47c..a82208e9b9 100755
--- a/core/compiler/tests/templates.factor
+++ b/core/compiler/tests/templates.factor
@@ -26,10 +26,6 @@ IN: compiler.tests
[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
unit-test
-[ { 1 2 3 } { 1 4 3 } 8 8 ]
-[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-call ]
-unit-test
-
! Test literals in either side of a shuffle
[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor
index 261ada025b..80a786c9fa 100755
--- a/core/cpu/x86/intrinsics/intrinsics.factor
+++ b/core/cpu/x86/intrinsics/intrinsics.factor
@@ -19,58 +19,6 @@ IN: cpu.x86.intrinsics
{ +output+ { "in" } }
} define-intrinsic
-\ type [
- "end" define-label
- ! Make a copy
- "x" operand "obj" operand MOV
- ! Get the tag
- "x" operand tag-mask get AND
- ! Tag the tag
- "x" operand %tag-fixnum
- ! Compare with object tag number (3).
- "x" operand object tag-number tag-fixnum CMP
- "end" get JNE
- ! If we have equality, load type from header
- "x" operand "obj" operand -3 [+] MOV
- "end" resolve-label
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "x" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
-\ class-hash [
- "end" define-label
- "tuple" define-label
- "object" define-label
- ! Make a copy
- "x" operand "obj" operand MOV
- ! Get the tag
- "x" operand tag-mask get AND
- ! Tag the tag
- "x" operand %tag-fixnum
- ! Compare with tuple tag number (2).
- "x" operand tuple tag-number tag-fixnum CMP
- "tuple" get JE
- ! Compare with object tag number (3).
- "x" operand object tag-number tag-fixnum CMP
- "object" get JE
- "end" get JMP
- "object" get resolve-label
- ! Load header type
- "x" operand "obj" operand header-offset [+] MOV
- "end" get JMP
- "tuple" get resolve-label
- ! Load class hash
- "x" operand "obj" operand tuple-class-offset [+] MOV
- "x" operand dup class-hash-offset [+] MOV
- "end" resolve-label
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "x" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
! Slots
: %slot-literal-known-tag
"obj" operand
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 7dba7eb709..dc98883654 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -37,10 +37,12 @@ PREDICATE: method-spec < pair
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
+: sort-methods ( assoc -- assoc' )
+ [ keys sort-classes ]
+ [ [ dupd at ] curry ] bi { } map>assoc ;
+
: methods ( word -- assoc )
- "methods" word-prop
- [ keys sort-classes ] keep
- [ dupd at ] curry { } map>assoc ;
+ "methods" word-prop sort-methods ;
TUPLE: check-method class generic ;
diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor
new file mode 100644
index 0000000000..bf8d4fb67a
--- /dev/null
+++ b/core/generic/standard/engines/engines.factor
@@ -0,0 +1,49 @@
+USING: assocs kernel namespaces quotations generic math
+sequences combinators words classes.algebra ;
+IN: generic.standard.engines
+
+SYMBOL: default
+SYMBOL: assumed
+
+GENERIC: engine>quot ( engine -- quot )
+
+M: quotation engine>quot ;
+
+M: method-body engine>quot 1quotation ;
+
+: engines>quots ( assoc -- assoc' )
+ [ engine>quot ] assoc-map ;
+
+: engines>quots* ( assoc -- assoc' )
+ [ over assumed [ engine>quot ] with-variable ] assoc-map ;
+
+: if-small? ( assoc true false -- )
+ >r >r dup assoc-size 4 <= r> r> if ; inline
+
+: linear-dispatch-quot ( alist -- quot )
+ default get [ drop ] prepend swap
+ [ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map
+ alist>quot ;
+
+: split-methods ( assoc class -- first second )
+ [ [ nip class< not ] curry assoc-subset ]
+ [ [ nip class< ] curry assoc-subset ] 2bi ;
+
+: convert-methods ( assoc class word -- assoc' )
+ over >r >r split-methods dup assoc-empty? [
+ r> r> 3drop
+ ] [
+ r> execute r> pick set-at
+ ] if ; inline
+
+SYMBOL: (dispatch#)
+
+: (picker) ( n -- quot )
+ {
+ { 0 [ [ dup ] ] }
+ { 1 [ [ over ] ] }
+ { 2 [ [ pick ] ] }
+ [ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
+ } case ;
+
+: picker ( -- quot ) \ (dispatch#) get (picker) ;
diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor
new file mode 100644
index 0000000000..2d43a313f0
--- /dev/null
+++ b/core/generic/standard/engines/predicate/predicate.factor
@@ -0,0 +1,28 @@
+USING: generic.standard.engines generic namespaces kernel
+sequences classes.algebra accessors words combinators
+assocs ;
+IN: generic.standard.engines.predicate
+
+TUPLE: predicate-dispatch-engine methods ;
+
+C: <predicate-dispatch-engine> predicate-dispatch-engine
+
+: class-predicates ( assoc -- assoc )
+ [ >r "predicate" word-prop picker prepend r> ] assoc-map ;
+
+: keep-going? ( assoc -- ? )
+ assumed get swap second first class< ;
+
+: prune-redundant-predicates ( assoc -- default assoc' )
+ {
+ { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
+ { [ dup length 1 = ] [ first second { } ] }
+ { [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
+ { [ t ] [ [ first second ] [ 1 tail-slice ] bi ] }
+ } cond ;
+
+M: predicate-dispatch-engine engine>quot
+ methods>> clone
+ default get object bootstrap-word pick set-at engines>quots
+ sort-methods prune-redundant-predicates
+ class-predicates alist>quot ;
diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
new file mode 100644
index 0000000000..fd40af0e50
--- /dev/null
+++ b/core/generic/standard/engines/tag/tag.factor
@@ -0,0 +1,48 @@
+USING: classes.private generic.standard.engines namespaces
+arrays mirrors assocs sequences.private quotations
+kernel.private layouts math slots.private math.private
+kernel accessors ;
+IN: generic.standard.engines.tag
+
+TUPLE: lo-tag-dispatch-engine methods ;
+
+C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
+
+TUPLE: hi-tag-dispatch-engine methods ;
+
+C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
+
+: convert-hi-tag-methods ( assoc -- assoc' )
+ hi-tag \ <hi-tag-dispatch-engine> convert-methods ;
+
+: direct-dispatch-quot ( alist n -- quot )
+ default get <array>
+ [ <enum> swap update ] keep
+ [ dispatch ] curry >quotation ;
+
+M: lo-tag-dispatch-engine engine>quot
+ methods>> engines>quots* [ >r tag-number r> ] assoc-map
+ [
+ picker % [ tag ] % [
+ linear-dispatch-quot
+ ] [
+ num-tags get direct-dispatch-quot
+ ] if-small? %
+ ] [ ] make ;
+
+: num-hi-tags num-types get num-tags get - ;
+
+: hi-tag-number type-number num-tags get - ;
+
+: hi-tag-quot ( -- quot )
+ [ 0 slot ] num-tags get [ fixnum- ] curry compose ;
+
+M: hi-tag-dispatch-engine engine>quot
+ methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
+ [
+ picker % hi-tag-quot % [
+ linear-dispatch-quot
+ ] [
+ num-hi-tags direct-dispatch-quot
+ ] if-small? %
+ ] [ ] make ;
diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
new file mode 100644
index 0000000000..ce0f50337d
--- /dev/null
+++ b/core/generic/standard/engines/tuple/tuple.factor
@@ -0,0 +1,109 @@
+IN: generic.standard.engines.tuple
+USING: kernel classes.tuple.private hashtables assocs sorting
+accessors combinators sequences slots.private math.parser words
+effects namespaces generic generic.standard.engines
+classes.algebra math math.private quotations ;
+
+TUPLE: echelon-dispatch-engine n methods ;
+
+C: <echelon-dispatch-engine> echelon-dispatch-engine
+
+TUPLE: trivial-tuple-dispatch-engine methods ;
+
+C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
+
+TUPLE: tuple-dispatch-engine echelons ;
+
+: push-echelon ( class method assoc -- )
+ >r swap dup tuple-layout layout-echelon r>
+ [ ?set-at ] change-at ;
+
+: echelon-sort ( assoc -- assoc' )
+ V{ } clone [
+ [
+ push-echelon
+ ] curry assoc-each
+ ] keep sort-keys ;
+
+: <tuple-dispatch-engine> ( methods -- engine )
+ echelon-sort
+ [ dupd <echelon-dispatch-engine> ] assoc-map
+ \ tuple-dispatch-engine construct-boa ;
+
+: convert-tuple-methods ( assoc -- assoc' )
+ tuple \ <tuple-dispatch-engine> convert-methods ;
+
+M: trivial-tuple-dispatch-engine engine>quot
+ methods>> engines>quots* linear-dispatch-quot ;
+
+: hash-methods ( methods -- buckets )
+ >alist V{ } clone [ class-hashes ] distribute-buckets
+ [ <trivial-tuple-dispatch-engine> ] map ;
+
+: class-hash-dispatch-quot ( methods -- quot )
+ #! 1 slot == word hashcode
+ [
+ [ dup 1 slot ] %
+ hash-methods [ engine>quot ] map hash-dispatch-quot %
+ ] [ ] make ;
+
+: tuple-dispatch-engine-word-name ( engine -- string )
+ [
+ generic get word-name %
+ "/tuple-dispatch-engine/" %
+ n>> #
+ ] "" make ;
+
+PREDICATE: tuple-dispatch-engine-word < word
+ "tuple-dispatch-engine" word-prop ;
+
+M: tuple-dispatch-engine-word stack-effect
+ "tuple-dispatch-generic" word-prop stack-effect ;
+
+: <tuple-dispatch-engine-word> ( engine -- word )
+ tuple-dispatch-engine-word-name f <word>
+ [ t "tuple-dispatch-engine" set-word-prop ]
+ [ generic get "tuple-dispatch-generic" set-word-prop ]
+ [ ]
+ tri ;
+
+: define-tuple-dispatch-engine-word ( engine quot -- word )
+ >r <tuple-dispatch-engine-word> dup r> define ;
+
+: tuple-dispatch-engine-body ( engine -- quot )
+ #! 1 slot == tuple-layout
+ #! 2 slot == 0 array-nth
+ #! 4 slot == layout-superclasses
+ [
+ picker %
+ [ 1 slot 4 slot ] %
+ [ n>> 2 + , [ slot ] % ]
+ [
+ methods>> [
+ <trivial-tuple-dispatch-engine> engine>quot
+ ] [
+ class-hash-dispatch-quot
+ ] if-small? %
+ ] bi
+ ] [ ] make ;
+
+M: echelon-dispatch-engine engine>quot
+ dup tuple-dispatch-engine-body
+ define-tuple-dispatch-engine-word
+ 1quotation ;
+
+: >=-case-quot ( alist -- quot )
+ default get [ drop ] prepend swap
+ [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
+ alist>quot ;
+
+M: tuple-dispatch-engine engine>quot
+ #! 1 slot == tuple-layout
+ #! 5 slot == layout-echelon
+ [
+ picker %
+ [ 1 slot 5 slot ] %
+ echelons>>
+ [ [ engine>quot dup default set ] assoc-map ] with-scope
+ >=-case-quot %
+ ] [ ] make ;
diff --git a/core/generic/standard/new/new-tests.factor b/core/generic/standard/new/new-tests.factor
new file mode 100644
index 0000000000..d372926f43
--- /dev/null
+++ b/core/generic/standard/new/new-tests.factor
@@ -0,0 +1,141 @@
+IN: generic.standard.new.tests
+USING: tools.test math math.functions math.constants
+generic.standard.new strings sequences arrays kernel accessors
+words float-arrays byte-arrays bit-arrays parser ;
+
+<< : GENERIC: CREATE-GENERIC define-simple-generic ; parsing >>
+
+GENERIC: lo-tag-test
+
+M: integer lo-tag-test 3 + ;
+
+M: float lo-tag-test 4 - ;
+
+M: rational lo-tag-test 2 - ;
+
+M: complex lo-tag-test sq ;
+
+[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
+[ 0.0 ] [ 4.0 lo-tag-test ] unit-test
+[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
+[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
+
+GENERIC: hi-tag-test
+
+M: string hi-tag-test ", in bed" append ;
+
+M: number hi-tag-test 3 + ;
+
+M: array hi-tag-test [ hi-tag-test ] map ;
+
+M: sequence hi-tag-test reverse ;
+
+[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
+
+[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
+
+[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
+
+TUPLE: shape ;
+
+TUPLE: abstract-rectangle < shape width height ;
+
+TUPLE: rectangle < abstract-rectangle ;
+
+C: <rectangle> rectangle
+
+TUPLE: parallelogram < abstract-rectangle skew ;
+
+C: <parallelogram> parallelogram
+
+TUPLE: circle < shape radius ;
+
+C: <circle> circle
+
+GENERIC: area
+
+M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
+
+M: circle area radius>> sq pi * ;
+
+[ 12 ] [ 4 3 <rectangle> area ] unit-test
+[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
+[ t ] [ 2 <circle> area 4 pi * = ] unit-test
+
+GENERIC: perimiter
+
+: rectangle-perimiter + 2 * ;
+
+M: rectangle perimiter
+ [ width>> ] [ height>> ] bi
+ rectangle-perimiter ;
+
+: hypotenuse [ sq ] bi@ + sqrt ;
+
+M: parallelogram perimiter
+ [ width>> ]
+ [ [ height>> ] [ skew>> ] bi hypotenuse ] bi
+ rectangle-perimiter ;
+
+M: circle perimiter 2 * pi * ;
+
+[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
+[ 30 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
+
+GENERIC: big-mix-test
+
+M: object big-mix-test drop "object" ;
+
+M: tuple big-mix-test drop "tuple" ;
+
+M: integer big-mix-test drop "integer" ;
+
+M: float big-mix-test drop "float" ;
+
+M: complex big-mix-test drop "complex" ;
+
+M: string big-mix-test drop "string" ;
+
+M: array big-mix-test drop "array" ;
+
+M: sequence big-mix-test drop "sequence" ;
+
+M: rectangle big-mix-test drop "rectangle" ;
+
+M: parallelogram big-mix-test drop "parallelogram" ;
+
+M: circle big-mix-test drop "circle" ;
+
+[ "integer" ] [ 3 big-mix-test ] unit-test
+[ "float" ] [ 5.0 big-mix-test ] unit-test
+[ "complex" ] [ -1 sqrt big-mix-test ] unit-test
+[ "sequence" ] [ F{ 1.0 2.0 3.0 } big-mix-test ] unit-test
+[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
+[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
+[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
+[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
+[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
+[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
+[ "sequence" ] [ FV{ -0.3 4.6 } big-mix-test ] unit-test
+[ "string" ] [ "hello" big-mix-test ] unit-test
+[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
+[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
+[ "circle" ] [ 100 <circle> big-mix-test ] unit-test
+[ "tuple" ] [ H{ } big-mix-test ] unit-test
+[ "object" ] [ \ + big-mix-test ] unit-test
+
+GENERIC: small-lo-tag
+
+M: fixnum small-lo-tag drop "fixnum" ;
+
+M: string small-lo-tag drop "string" ;
+
+M: array small-lo-tag drop "array" ;
+
+M: float-array small-lo-tag drop "float-array" ;
+
+M: byte-array small-lo-tag drop "byte-array" ;
+
+[ "fixnum" ] [ 3 small-lo-tag ] unit-test
+
+[ "float-array" ] [ F{ 1.0 } small-lo-tag ] unit-test
diff --git a/core/generic/standard/new/new.factor b/core/generic/standard/new/new.factor
new file mode 100644
index 0000000000..b2371cc4e5
--- /dev/null
+++ b/core/generic/standard/new/new.factor
@@ -0,0 +1,139 @@
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs kernel kernel.private slots.private math
+namespaces sequences vectors words quotations definitions
+hashtables layouts combinators sequences.private generic
+classes classes.algebra classes.private generic.standard.engines
+generic.standard.engines.tag generic.standard.engines.predicate
+generic.standard.engines.tuple accessors ;
+IN: generic.standard.new
+
+: unpickers
+ {
+ [ nip ]
+ [ >r nip r> swap ]
+ [ >r >r nip r> r> -rot ]
+ } ; inline
+
+: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
+
+ERROR: no-method object generic ;
+
+: error-method ( word -- quot )
+ picker swap [ no-method ] curry append ;
+
+: empty-method ( word -- quot )
+ [
+ picker % [ delegate dup ] %
+ unpicker over suffix ,
+ error-method \ drop prefix , \ if ,
+ ] [ ] make ;
+
+: default-method ( word -- pair )
+ "default-method" word-prop
+ object bootstrap-word swap 2array ;
+
+: push-method ( method specializer atomic assoc -- )
+ [
+ [ H{ } clone <predicate-dispatch-engine> ] unless*
+ [ methods>> set-at ] keep
+ ] change-at ;
+
+: flatten-method ( class method assoc -- )
+ >r >r dup flatten-class keys swap r> r> [
+ >r spin r> push-method
+ ] 3curry each ;
+
+: flatten-methods ( assoc -- assoc' )
+ H{ } clone [
+ [
+ flatten-method
+ ] curry assoc-each
+ ] keep ;
+
+: <big-dispatch-engine> ( assoc -- engine )
+ flatten-methods
+ convert-tuple-methods
+ convert-hi-tag-methods
+ <lo-tag-dispatch-engine> ;
+
+: find-default ( methods -- quot )
+ #! Side-effects methods.
+ object swap delete-at* [
+ drop generic get "default-method" word-prop
+ ] unless 1quotation ;
+
+GENERIC: mangle-method ( method generic -- quot )
+
+: single-combination ( words -- quot )
+ [
+ object bootstrap-word assumed set
+ [ generic set ]
+ [
+ "methods" word-prop
+ [ generic get mangle-method ] assoc-map
+ [ find-default default set ]
+ [
+ generic get "inline" word-prop [
+ <predicate-dispatch-engine>
+ ] [
+ <big-dispatch-engine>
+ ] if
+ ] bi
+ engine>quot
+ ] bi
+ ] with-scope ;
+
+TUPLE: standard-combination # ;
+
+C: <standard-combination> standard-combination
+
+PREDICATE: standard-generic < generic
+ "combination" word-prop standard-combination? ;
+
+PREDICATE: simple-generic < standard-generic
+ "combination" word-prop #>> zero? ;
+
+: define-simple-generic ( word -- )
+ T{ standard-combination f 0 } define-generic ;
+
+: with-standard ( combination quot -- quot' )
+ >r #>> (dispatch#) r> with-variable ;
+
+M: standard-combination make-default-method
+ [ empty-method ] with-standard ;
+
+M: standard-combination perform-combination
+ [ single-combination ] with-standard ;
+
+TUPLE: hook-combination var ;
+
+C: <hook-combination> hook-combination
+
+PREDICATE: hook-generic < generic
+ "combination" word-prop hook-combination? ;
+
+: with-hook ( combination quot -- quot' )
+ 0 (dispatch#) [
+ dip var>> [ get ] curry prepend
+ ] with-variable ; inline
+
+M: hook-combination make-default-method
+ [ error-method ] with-hook ;
+
+M: hook-combination perform-combination
+ [ single-combination ] with-hook ;
+
+GENERIC: dispatch# ( word -- n )
+
+M: word dispatch# "combination" word-prop dispatch# ;
+
+M: standard-combination dispatch# #>> ;
+
+M: hook-combination dispatch# drop 0 ;
+
+M: simple-generic definer drop \ GENERIC: f ;
+
+M: standard-generic definer drop \ GENERIC# f ;
+
+M: hook-generic definer drop \ HOOK: f ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 4ed883dad5..65b66e9538 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -41,23 +41,13 @@ ERROR: no-method object generic ;
: class-predicates ( assoc -- assoc )
[ >r "predicate" word-prop picker prepend r> ] assoc-map ;
-: (simplify-alist) ( class i assoc -- default assoc )
- 2dup length 1- = [
- nth second { } rot drop
- ] [
- 3dup >r 1+ r> nth first class< [
- >r 1+ r> (simplify-alist)
- ] [
- [ nth second ] 2keep swap 1+ tail rot drop
- ] if
- ] if ;
-
-: simplify-alist ( class assoc -- default assoc )
- dup empty? [
- 2drop [ "Unreachable" throw ] { }
- ] [
- 0 swap (simplify-alist)
- ] if ;
+: simplify-alist ( class assoc -- default assoc' )
+ {
+ { [ dup empty? ] [ 2drop [ "Unreachable" throw ] { } ] }
+ { [ dup length 1 = ] [ nip first second { } ] }
+ { [ 2dup second first class< ] [ 1 tail-slice simplify-alist ] }
+ { [ t ] [ nip [ first second ] [ 1 tail-slice ] bi ] }
+ } cond ;
: default-method ( word -- pair )
"default-method" word-prop
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index 5ca9b1b2e7..61412ccf9f 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -3,14 +3,23 @@
USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes
-continuations debugger assocs combinators compiler.errors ;
+continuations debugger assocs combinators compiler.errors
+generic.standard.engines.tuple ;
IN: inference.backend
: recursive-label ( word -- label/f )
recursive-state get at ;
-: inline? ( word -- ? )
- dup "method-generic" word-prop swap or "inline" word-prop ;
+GENERIC: inline? ( word -- ? )
+
+M: method-body inline?
+ "method-generic" word-prop inline? ;
+
+M: tuple-dispatch-engine-word inline?
+ "tuple-dispatch-generic" word-prop inline? ;
+
+M: word inline?
+ "inline" word-prop ;
: local-recursive-state ( -- assoc )
recursive-state get dup keys
diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor
index 67b8616c61..7d18aaa489 100755
--- a/core/inference/class/class-tests.factor
+++ b/core/inference/class/class-tests.factor
@@ -120,7 +120,7 @@ M: object xyz ;
[
[ no-cond ] 1
[ 1array dup quotation? [ >quotation ] unless ] times
- ] \ type inlined?
+ ] \ quotation? inlined?
] unit-test
[ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index 79e41c8ae4..3cc78831a3 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -383,9 +383,6 @@ set-primitive-effect
\ millis { } { integer } <effect> set-primitive-effect
\ millis make-flushable
-\ type { object } { fixnum } <effect> set-primitive-effect
-\ type make-foldable
-
\ tag { object } { fixnum } <effect> set-primitive-effect
\ tag make-foldable
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index b1120de8e6..2df5e69998 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -413,12 +413,6 @@ HELP: clone
{ $values { "obj" object } { "cloned" "a new object" } }
{ $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
-HELP: type ( object -- n )
-{ $values { "object" object } { "n" "a type number" } }
-{ $description "Outputs an object's type number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
-
-{ type tag type>class } related-words
-
HELP: ? ( ? true false -- true/false )
{ $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } }
{ $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index ab42a1b903..eed5b22e5f 100755
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel.private ;
+USING: kernel.private slots.private ;
IN: kernel
! Stack stuff
@@ -99,14 +99,14 @@ DEFER: if
! Appliers
: bi@ ( x y quot -- )
- tuck 2slip call ; inline
+ dup bi* ; inline
: tri@ ( x y z quot -- )
- tuck >r bi@ r> call ; inline
+ dup dup tri* ; inline
! Double appliers
: 2bi@ ( w x y z quot -- )
- dup -roll 3slip call ; inline
+ dup 2bi* ; inline
: while ( pred body tail -- )
>r >r dup slip r> r> roll
@@ -194,6 +194,8 @@ GENERIC: construct-boa ( ... class -- tuple )
<PRIVATE
+: hi-tag ( obj -- n ) 0 slot ;
+
: declare ( spec -- ) drop ;
: do-primitive ( number -- ) "Improper primitive call" throw ;
diff --git a/core/layouts/layouts-docs.factor b/core/layouts/layouts-docs.factor
index d4188dd3b6..089465177b 100755
--- a/core/layouts/layouts-docs.factor
+++ b/core/layouts/layouts-docs.factor
@@ -14,7 +14,7 @@ HELP: tag-mask
{ $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ;
HELP: num-types
-{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link type } " primitive." } ;
+{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link hi-tag } " primitive." } ;
HELP: tag-number
{ $values { "class" class } { "n" "an integer or " { $link f } } }
@@ -76,7 +76,7 @@ HELP: bootstrap-cell-bits
ARTICLE: "layouts-types" "Type numbers"
"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
-{ $subsection type }
+{ $subsection hi-tag }
"Built-in type numbers can be converted to classes, and vice versa:"
{ $subsection type>class }
{ $subsection type-number }
diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor
index 108c715ef0..a4782078ee 100755
--- a/core/optimizer/known-words/known-words.factor
+++ b/core/optimizer/known-words/known-words.factor
@@ -87,29 +87,6 @@ sequences.private combinators ;
{ { @ @ } [ 2drop t ] }
} define-identities
-! type applied to an object of a known type can be folded
-: known-type? ( node -- ? )
- node-class-first class-types length 1 number= ;
-
-: fold-known-type ( node -- node )
- dup node-class-first class-types inline-literals ;
-
-\ type [
- { [ dup known-type? ] [ fold-known-type ] }
-] define-optimizers
-
-! if the result of type is n, then the object has type n
-{ tag type } [
- [
- num-types get swap [
- [
- [ type>class object or 0 `input class, ] keep
- 0 `output literal,
- ] set-constraints
- ] curry each
- ] "constraints" set-word-prop
-] each
-
! Specializers
{ 1+ 1- sq neg recip sgn } [
{ number } "specializer" set-word-prop
From f96a43c42daaa07a4c63940f77552733e3309950 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 00:45:30 -0500
Subject: [PATCH 075/127] Getting ready to drop in new dispatch code
---
core/classes/algebra/algebra-tests.factor | 2 +-
core/generic/standard/engines/tag/tag.factor | 2 +-
core/generic/standard/new/new.factor | 6 ++++++
core/generic/standard/standard.factor | 2 +-
4 files changed, 9 insertions(+), 3 deletions(-)
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index cdf817e31d..dc65b09579 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -96,7 +96,7 @@ UNION: z1 b1 c1 ;
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
-[ f ] [ growable hi-tag classes-intersect? ] unit-test
+[ f ] [ growable \ hi-tag classes-intersect? ] unit-test
[ t ] [
growable tuple sequence class-and class<
diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
index fd40af0e50..1bcd007d0d 100644
--- a/core/generic/standard/engines/tag/tag.factor
+++ b/core/generic/standard/engines/tag/tag.factor
@@ -13,7 +13,7 @@ TUPLE: hi-tag-dispatch-engine methods ;
C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
: convert-hi-tag-methods ( assoc -- assoc' )
- hi-tag \ <hi-tag-dispatch-engine> convert-methods ;
+ \ hi-tag \ <hi-tag-dispatch-engine> convert-methods ;
: direct-dispatch-quot ( alist n -- quot )
default get <array>
diff --git a/core/generic/standard/new/new.factor b/core/generic/standard/new/new.factor
index b2371cc4e5..00c33e38fd 100644
--- a/core/generic/standard/new/new.factor
+++ b/core/generic/standard/new/new.factor
@@ -100,6 +100,9 @@ PREDICATE: simple-generic < standard-generic
: with-standard ( combination quot -- quot' )
>r #>> (dispatch#) r> with-variable ;
+M: standard-generic mangle-method
+ drop ;
+
M: standard-combination make-default-method
[ empty-method ] with-standard ;
@@ -118,6 +121,9 @@ PREDICATE: hook-generic < generic
dip var>> [ get ] curry prepend
] with-variable ; inline
+M: hook-generic mangle-method
+ drop [ drop ] prepend ;
+
M: hook-combination make-default-method
[ error-method ] with-hook ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 65b66e9538..b77c0ed9e5 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -77,7 +77,7 @@ ERROR: no-method object generic ;
[ small-generic ] picker class-hash-dispatch-quot ;
: vtable-class ( n -- class )
- bootstrap-type>class [ hi-tag bootstrap-word ] unless* ;
+ bootstrap-type>class [ \ hi-tag bootstrap-word ] unless* ;
: group-methods ( assoc -- vtable )
#! Input is a predicate -> method association.
From 7a596ce004972a0e8ddea4cc959ce3185f7feaa6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 02:44:10 -0500
Subject: [PATCH 076/127] Debugging inheritancE
---
core/assocs/assocs.factor | 26 ++-
core/classes/algebra/algebra-tests.factor | 2 +-
core/classes/classes.factor | 40 ++--
core/classes/predicate/predicate.factor | 11 +-
core/classes/tuple/tuple-tests.factor | 4 +-
core/classes/tuple/tuple.factor | 34 ++-
core/classes/union/union.factor | 28 +--
core/cpu/ppc/intrinsics/intrinsics.factor | 49 ----
core/generic/generic-docs.factor | 9 -
core/generic/standard/engines/tag/tag.factor | 5 +-
core/generic/standard/new/new.factor | 145 ------------
...new-tests.factor => standard-tests.factor} | 8 +-
core/generic/standard/standard.factor | 219 +++++++-----------
core/mirrors/mirrors.factor | 21 --
.../specializers/specializers.factor | 3 +-
15 files changed, 177 insertions(+), 427 deletions(-)
delete mode 100644 core/generic/standard/new/new.factor
rename core/generic/standard/{new/new-tests.factor => standard-tests.factor} (94%)
mode change 100755 => 100644 core/generic/standard/standard.factor
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index b911faf672..6b6bd3d51a 100755
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -1,6 +1,7 @@
-! Copyright (C) 2007 Daniel Ehrenberg
+! Copyright (C) 2007, 2008 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences arrays math sequences.private vectors ;
+USING: kernel sequences arrays math sequences.private vectors
+accessors ;
IN: assocs
MIXIN: assoc
@@ -189,3 +190,24 @@ M: f clear-assoc drop ;
M: f assoc-like drop dup assoc-empty? [ drop f ] when ;
INSTANCE: sequence assoc
+
+TUPLE: enum seq ;
+
+C: <enum> enum
+
+M: enum at*
+ seq>> 2dup bounds-check?
+ [ nth t ] [ 2drop f f ] if ;
+
+M: enum set-at seq>> set-nth ;
+
+M: enum delete-at enum-seq delete-nth ;
+
+M: enum >alist ( enum -- alist )
+ seq>> [ length ] keep 2array flip ;
+
+M: enum assoc-size seq>> length ;
+
+M: enum clear-assoc seq>> delete-all ;
+
+INSTANCE: enum assoc
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index dc65b09579..32664dc823 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
-random inference effects ;
+random inference effects kernel.private ;
: class= [ class< ] 2keep swap class< and ;
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index d91b1bb217..914e070e03 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -83,7 +83,7 @@ M: word reset-class drop ;
: update-map- ( class -- )
dup class-uses update-map get remove-vertex ;
-: define-class-props ( superclass members metaclass -- assoc )
+: make-class-props ( superclass members metaclass -- assoc )
[
[ dup [ bootstrap-word ] when "superclass" set ]
[ [ bootstrap-word ] map "members" set ]
@@ -92,12 +92,16 @@ M: word reset-class drop ;
] H{ } make-assoc ;
: (define-class) ( word props -- )
- over reset-class
- over deferred? [ over define-symbol ] when
- >r dup word-props r> union over set-word-props
- dup predicate-word 2dup 1quotation "predicate" set-word-prop
- over "predicating" set-word-prop
- t "class" set-word-prop ;
+ >r
+ dup reset-class
+ dup deferred? [ dup define-symbol ] when
+ dup word-props
+ r> union over set-word-props
+ dup predicate-word
+ [ 1quotation "predicate" set-word-prop ]
+ [ swap "predicating" set-word-prop ]
+ [ drop t "class" set-word-prop ]
+ 2tri ;
PRIVATE>
@@ -105,24 +109,22 @@ GENERIC: update-class ( class -- )
M: class update-class drop ;
-: update-classes ( assoc -- )
- [ drop update-class ] assoc-each ;
-
GENERIC: update-methods ( assoc -- )
+: update-classes ( class -- )
+ class-usages
+ [ [ drop update-class ] assoc-each ]
+ [ update-methods ]
+ bi ;
+
: define-class ( word superclass members metaclass -- )
#! If it was already a class, update methods after.
reset-caches
- define-class-props
+ make-class-props
[ drop update-map- ]
- [ (define-class) ] [
- drop
- [ update-map+ ] [
- class-usages
- [ update-classes ]
- [ update-methods ] bi
- ] bi
- ] 2tri ;
+ [ (define-class) ]
+ [ drop update-map+ ]
+ 2tri ;
GENERIC: class ( object -- class )
diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor
index b2a5a03bb4..0f98f1f5c4 100755
--- a/core/classes/predicate/predicate.factor
+++ b/core/classes/predicate/predicate.factor
@@ -14,9 +14,14 @@ PREDICATE: predicate-class < class
] [ ] make ;
: define-predicate-class ( class superclass definition -- )
- >r dupd f predicate-class define-class
- r> dupd "predicate-definition" set-word-prop
- dup predicate-quot define-predicate ;
+ [ drop f predicate-class define-class ]
+ [ nip "predicate-definition" set-word-prop ]
+ [
+ 2drop
+ [ dup predicate-quot define-predicate ]
+ [ update-classes ]
+ bi
+ ] 3tri ;
M: predicate-class reset-class
{
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index db0e25f091..228de8aabf 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -62,13 +62,13 @@ C: <point> point
[ 200 ] [ "p" get y>> ] unit-test
[ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
-"p" get 300 ">>z" "accessors" lookup execute drop
+[ ] [ "p" get 300 ">>z" "accessors" lookup execute drop ] unit-test
[ 4 ] [ "p" get tuple-size ] unit-test
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
-"IN: classes.tuple.tests TUPLE: point z y ;" eval
+[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test
[ 3 ] [ "p" get tuple-size ] unit-test
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 3cacef25a1..bbc221b85d 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -161,25 +161,23 @@ PRIVATE>
: update-tuples-after ( class -- )
outdated-tuples get [ all-slot-names ] cache drop ;
-: subclasses ( class -- classes )
- class-usages keys [ tuple-class? ] subset ;
-
-: each-subclass ( class quot -- )
- >r subclasses r> each ; inline
-
-: define-tuple-shape ( class -- )
- [ define-tuple-slots ]
+M: tuple-class update-class
[ define-tuple-layout ]
+ [ define-tuple-slots ]
[ define-tuple-predicate ]
tri ;
: define-new-tuple-class ( class superclass slots -- )
[ drop f tuple-class define-class ]
[ nip "slot-names" set-word-prop ]
- [
- 2drop
- [ define-tuple-shape ] each-subclass
- ] 3tri ;
+ [ 2drop update-classes ]
+ 3tri ;
+
+: subclasses ( class -- classes )
+ class-usages keys [ tuple-class? ] subset ;
+
+: each-subclass ( class quot -- )
+ >r subclasses r> each ; inline
: redefine-tuple-class ( class superclass slots -- )
[
@@ -214,6 +212,9 @@ M: tuple-class define-tuple-class
[ define-tuple-class ] [ 2drop ] 3bi
dup [ construct-boa throw ] curry define ;
+M: tuple-class reset-class
+ { "metaclass" "superclass" "slots" "layout" } reset-props ;
+
M: tuple clone
(clone) dup delegate clone over set-delegate ;
@@ -227,12 +228,6 @@ M: tuple hashcode*
] 2curry reduce
] recursive-hashcode ;
-M: tuple-class reset-class
- { "metaclass" "superclass" "slots" "layout" } reset-props ;
-
-M: object get-slots ( obj slots -- ... )
- [ execute ] with each ;
-
M: object construct-empty ( class -- tuple )
tuple-layout <tuple> ;
@@ -240,6 +235,9 @@ M: object construct-boa ( ... class -- tuple )
tuple-layout <tuple-boa> ;
! Deprecated
+M: object get-slots ( obj slots -- ... )
+ [ execute ] with each ;
+
M: object set-slots ( ... obj slots -- )
<reversed> get-slots ;
diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
index e9b98770dc..9079974a60 100755
--- a/core/classes/union/union.factor
+++ b/core/classes/union/union.factor
@@ -1,33 +1,21 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
-generic.standard namespaces arrays math quotations ;
+namespaces arrays math quotations ;
IN: classes.union
PREDICATE: union-class < class
"metaclass" word-prop union-class eq? ;
! Union classes for dispatch on multiple classes.
-: small-union-predicate-quot ( members -- quot )
+: union-predicate-quot ( members -- quot )
dup empty? [
drop [ drop f ]
] [
- unclip first "predicate" word-prop swap
- [ >r "predicate" word-prop [ dup ] prepend r> ]
- assoc-map alist>quot
- ] if ;
-
-: big-union-predicate-quot ( members -- quot )
- [ small-union-predicate-quot ] [ dup ]
- class-hash-dispatch-quot ;
-
-: union-predicate-quot ( members -- quot )
- [ [ drop t ] ] { } map>assoc
- dup length 4 <= [
- small-union-predicate-quot
- ] [
- flatten-methods
- big-union-predicate-quot
+ unclip "predicate" word-prop swap [
+ "predicate" word-prop [ dup ] prepend
+ [ drop t ]
+ ] { } map>assoc alist>quot
] if ;
: define-union-predicate ( class -- )
@@ -36,7 +24,9 @@ PREDICATE: union-class < class
M: union-class update-class define-union-predicate ;
: define-union-class ( class members -- )
- f swap union-class define-class ;
+ [ f swap union-class define-class ]
+ [ drop update-classes ]
+ 2bi ;
M: union-class reset-class
{ "metaclass" "members" } reset-props ;
diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index 07698eaa92..d092473960 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -402,55 +402,6 @@ IN: cpu.ppc.intrinsics
{ +output+ { "out" } }
} define-intrinsic
-\ type [
- "end" define-label
- ! Get the tag
- "y" operand "obj" operand tag-mask get ANDI
- ! Tag the tag
- "y" operand "x" operand %tag-fixnum
- ! Compare with object tag number (3).
- 0 "y" operand object tag-number CMPI
- ! Jump if the object doesn't store type info in its header
- "end" get BNE
- ! It does store type info in its header
- "x" operand "obj" operand header-offset LWZ
- "end" resolve-label
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "x" } { f "y" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
-\ class-hash [
- "end" define-label
- "tuple" define-label
- "object" define-label
- ! Get the tag
- "y" operand "obj" operand tag-mask get ANDI
- ! Compare with tuple tag number (2).
- 0 "y" operand tuple tag-number CMPI
- "tuple" get BEQ
- ! Compare with object tag number (3).
- 0 "y" operand object tag-number CMPI
- "object" get BEQ
- ! Tag the tag
- "y" operand "x" operand %tag-fixnum
- "end" get B
- "object" get resolve-label
- ! Load header type
- "x" operand "obj" operand header-offset LWZ
- "end" get B
- "tuple" get resolve-label
- ! Load class hash
- "x" operand "obj" operand tuple-class-offset LWZ
- "x" operand dup class-hash-offset LWZ
- "end" resolve-label
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "x" } { f "y" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
: userenv ( reg -- )
#! Load the userenv pointer in a register.
"userenv" f rot %load-dlsym ;
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 56de801e7a..100475455a 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -63,15 +63,6 @@ ARTICLE: "method-combination" "Custom method combination"
"Developing a custom method combination requires that a parsing word calling " { $link define-generic } " be defined; additionally, it is a good idea to implement the definition protocol words " { $link definer } " and " { $link synopsis* } " on the class of words having this method combination, to properly support developer tools."
$nl
"The combination quotation passed to " { $link define-generic } " has stack effect " { $snippet "( word -- quot )" } ". It's job is to call various introspection words, including at least obtaining the set of methods defined on the generic word, then combining these methods in some way to produce a quotation."
-$nl
-"Method combination utilities:"
-{ $subsection single-combination }
-{ $subsection class-predicates }
-{ $subsection simplify-alist }
-{ $subsection math-upgrade }
-{ $subsection object-method }
-{ $subsection error-method }
-"More quotation construction utilities can be found in " { $link "quotations" } " and " { $link "combinators-quot" } "."
{ $see-also "generic-introspection" } ;
ARTICLE: "generic" "Generic words and methods"
diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
index 1bcd007d0d..3dd8b83579 100644
--- a/core/generic/standard/engines/tag/tag.factor
+++ b/core/generic/standard/engines/tag/tag.factor
@@ -1,7 +1,6 @@
USING: classes.private generic.standard.engines namespaces
-arrays mirrors assocs sequences.private quotations
-kernel.private layouts math slots.private math.private
-kernel accessors ;
+arrays assocs sequences.private quotations kernel.private
+layouts math slots.private math.private kernel accessors ;
IN: generic.standard.engines.tag
TUPLE: lo-tag-dispatch-engine methods ;
diff --git a/core/generic/standard/new/new.factor b/core/generic/standard/new/new.factor
deleted file mode 100644
index 00c33e38fd..0000000000
--- a/core/generic/standard/new/new.factor
+++ /dev/null
@@ -1,145 +0,0 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel kernel.private slots.private math
-namespaces sequences vectors words quotations definitions
-hashtables layouts combinators sequences.private generic
-classes classes.algebra classes.private generic.standard.engines
-generic.standard.engines.tag generic.standard.engines.predicate
-generic.standard.engines.tuple accessors ;
-IN: generic.standard.new
-
-: unpickers
- {
- [ nip ]
- [ >r nip r> swap ]
- [ >r >r nip r> r> -rot ]
- } ; inline
-
-: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
-
-ERROR: no-method object generic ;
-
-: error-method ( word -- quot )
- picker swap [ no-method ] curry append ;
-
-: empty-method ( word -- quot )
- [
- picker % [ delegate dup ] %
- unpicker over suffix ,
- error-method \ drop prefix , \ if ,
- ] [ ] make ;
-
-: default-method ( word -- pair )
- "default-method" word-prop
- object bootstrap-word swap 2array ;
-
-: push-method ( method specializer atomic assoc -- )
- [
- [ H{ } clone <predicate-dispatch-engine> ] unless*
- [ methods>> set-at ] keep
- ] change-at ;
-
-: flatten-method ( class method assoc -- )
- >r >r dup flatten-class keys swap r> r> [
- >r spin r> push-method
- ] 3curry each ;
-
-: flatten-methods ( assoc -- assoc' )
- H{ } clone [
- [
- flatten-method
- ] curry assoc-each
- ] keep ;
-
-: <big-dispatch-engine> ( assoc -- engine )
- flatten-methods
- convert-tuple-methods
- convert-hi-tag-methods
- <lo-tag-dispatch-engine> ;
-
-: find-default ( methods -- quot )
- #! Side-effects methods.
- object swap delete-at* [
- drop generic get "default-method" word-prop
- ] unless 1quotation ;
-
-GENERIC: mangle-method ( method generic -- quot )
-
-: single-combination ( words -- quot )
- [
- object bootstrap-word assumed set
- [ generic set ]
- [
- "methods" word-prop
- [ generic get mangle-method ] assoc-map
- [ find-default default set ]
- [
- generic get "inline" word-prop [
- <predicate-dispatch-engine>
- ] [
- <big-dispatch-engine>
- ] if
- ] bi
- engine>quot
- ] bi
- ] with-scope ;
-
-TUPLE: standard-combination # ;
-
-C: <standard-combination> standard-combination
-
-PREDICATE: standard-generic < generic
- "combination" word-prop standard-combination? ;
-
-PREDICATE: simple-generic < standard-generic
- "combination" word-prop #>> zero? ;
-
-: define-simple-generic ( word -- )
- T{ standard-combination f 0 } define-generic ;
-
-: with-standard ( combination quot -- quot' )
- >r #>> (dispatch#) r> with-variable ;
-
-M: standard-generic mangle-method
- drop ;
-
-M: standard-combination make-default-method
- [ empty-method ] with-standard ;
-
-M: standard-combination perform-combination
- [ single-combination ] with-standard ;
-
-TUPLE: hook-combination var ;
-
-C: <hook-combination> hook-combination
-
-PREDICATE: hook-generic < generic
- "combination" word-prop hook-combination? ;
-
-: with-hook ( combination quot -- quot' )
- 0 (dispatch#) [
- dip var>> [ get ] curry prepend
- ] with-variable ; inline
-
-M: hook-generic mangle-method
- drop [ drop ] prepend ;
-
-M: hook-combination make-default-method
- [ error-method ] with-hook ;
-
-M: hook-combination perform-combination
- [ single-combination ] with-hook ;
-
-GENERIC: dispatch# ( word -- n )
-
-M: word dispatch# "combination" word-prop dispatch# ;
-
-M: standard-combination dispatch# #>> ;
-
-M: hook-combination dispatch# drop 0 ;
-
-M: simple-generic definer drop \ GENERIC: f ;
-
-M: standard-generic definer drop \ GENERIC# f ;
-
-M: hook-generic definer drop \ HOOK: f ;
diff --git a/core/generic/standard/new/new-tests.factor b/core/generic/standard/standard-tests.factor
similarity index 94%
rename from core/generic/standard/new/new-tests.factor
rename to core/generic/standard/standard-tests.factor
index d372926f43..fbca22471c 100644
--- a/core/generic/standard/new/new-tests.factor
+++ b/core/generic/standard/standard-tests.factor
@@ -1,10 +1,8 @@
-IN: generic.standard.new.tests
+IN: generic.standard.tests
USING: tools.test math math.functions math.constants
-generic.standard.new strings sequences arrays kernel accessors
+generic.standard strings sequences arrays kernel accessors
words float-arrays byte-arrays bit-arrays parser ;
-<< : GENERIC: CREATE-GENERIC define-simple-generic ; parsing >>
-
GENERIC: lo-tag-test
M: integer lo-tag-test 3 + ;
@@ -24,7 +22,7 @@ GENERIC: hi-tag-test
M: string hi-tag-test ", in bed" append ;
-M: number hi-tag-test 3 + ;
+M: integer hi-tag-test 3 + ;
M: array hi-tag-test [ hi-tag-test ] map ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
old mode 100755
new mode 100644
index b77c0ed9e5..1de41f24ed
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -3,32 +3,23 @@
USING: arrays assocs kernel kernel.private slots.private math
namespaces sequences vectors words quotations definitions
hashtables layouts combinators sequences.private generic
-classes classes.algebra classes.private ;
+classes classes.algebra classes.private generic.standard.engines
+generic.standard.engines.tag generic.standard.engines.predicate
+generic.standard.engines.tuple accessors ;
IN: generic.standard
-TUPLE: standard-combination # ;
-
-C: <standard-combination> standard-combination
-
-SYMBOL: (dispatch#)
-
-: (picker) ( n -- quot )
+: unpickers
{
- { 0 [ [ dup ] ] }
- { 1 [ [ over ] ] }
- { 2 [ [ pick ] ] }
- [ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
- } case ;
-
-: picker ( -- quot ) \ (dispatch#) get (picker) ;
-
-: unpickers { [ nip ] [ >r nip r> swap ] [ >r >r nip r> r> -rot ] } ; inline
+ [ nip ]
+ [ >r nip r> swap ]
+ [ >r >r nip r> r> -rot ]
+ } ; inline
: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
ERROR: no-method object generic ;
-: error-method ( word -- quot )
+: error-method ( word -- quot )
picker swap [ no-method ] curry append ;
: empty-method ( word -- quot )
@@ -38,144 +29,112 @@ ERROR: no-method object generic ;
error-method \ drop prefix , \ if ,
] [ ] make ;
-: class-predicates ( assoc -- assoc )
- [ >r "predicate" word-prop picker prepend r> ] assoc-map ;
-
-: simplify-alist ( class assoc -- default assoc' )
- {
- { [ dup empty? ] [ 2drop [ "Unreachable" throw ] { } ] }
- { [ dup length 1 = ] [ nip first second { } ] }
- { [ 2dup second first class< ] [ 1 tail-slice simplify-alist ] }
- { [ t ] [ nip [ first second ] [ 1 tail-slice ] bi ] }
- } cond ;
-
: default-method ( word -- pair )
"default-method" word-prop
object bootstrap-word swap 2array ;
-: method-alist>quot ( alist base-class -- quot )
- bootstrap-word swap simplify-alist
- class-predicates alist>quot ;
-
-: small-generic ( methods -- def )
- object method-alist>quot ;
-
-: hash-methods ( methods -- buckets )
- V{ } clone [
- tuple bootstrap-word over class< [
- drop t
- ] [
- class-hashes
- ] if
- ] distribute-buckets ;
-
-: class-hash-dispatch-quot ( methods quot picker -- quot )
- >r >r hash-methods r> map
- hash-dispatch-quot r> [ class-hash ] rot 3append ; inline
-
-: big-generic ( methods -- quot )
- [ small-generic ] picker class-hash-dispatch-quot ;
-
-: vtable-class ( n -- class )
- bootstrap-type>class [ \ hi-tag bootstrap-word ] unless* ;
-
-: group-methods ( assoc -- vtable )
- #! Input is a predicate -> method association.
- #! n is vtable size (either num-types or num-tags).
- num-tags get [
- vtable-class
- [ swap first classes-intersect? ] curry subset
- ] with map ;
-
-: build-type-vtable ( alist-seq -- alist-seq )
- dup length [
- vtable-class
- swap simplify-alist
- class-predicates alist>quot
- ] 2map ;
-
-: tag-generic ( methods -- quot )
+: push-method ( method specializer atomic assoc -- )
[
- picker %
- \ tag ,
- group-methods build-type-vtable ,
- \ dispatch ,
- ] [ ] make ;
+ [ H{ } clone <predicate-dispatch-engine> ] unless*
+ [ methods>> set-at ] keep
+ ] change-at ;
-: flatten-method ( class body -- )
- over members pick object bootstrap-word eq? not and [
- >r members r> [ flatten-method ] curry each
- ] [
- swap set
- ] if ;
+: flatten-method ( class method assoc -- )
+ >r >r dup flatten-class keys swap r> r> [
+ >r spin r> push-method
+ ] 3curry each ;
-: flatten-methods ( methods -- newmethods )
- [ [ flatten-method ] assoc-each ] V{ } make-assoc ;
+: flatten-methods ( assoc -- assoc' )
+ H{ } clone [
+ [
+ flatten-method
+ ] curry assoc-each
+ ] keep ;
-: dispatched-types ( methods -- seq )
- keys object bootstrap-word swap remove prune ;
+: <big-dispatch-engine> ( assoc -- engine )
+ flatten-methods
+ convert-tuple-methods
+ convert-hi-tag-methods
+ <lo-tag-dispatch-engine> ;
-: single-combination ( methods -- quot )
- dup length 4 <= [
- small-generic
- ] [
- flatten-methods
- dup dispatched-types [ number class< ] all?
- [ tag-generic ] [ big-generic ] if
- ] if ;
+: find-default ( methods -- quot )
+ #! Side-effects methods.
+ object swap delete-at* [
+ drop generic get "default-method" word-prop 1quotation
+ ] unless ;
-: standard-methods ( word -- alist )
- dup methods swap default-method prefix
- [ 1quotation ] assoc-map ;
+GENERIC: mangle-method ( method generic -- quot )
-M: standard-combination make-default-method
- standard-combination-# (dispatch#)
- [ empty-method ] with-variable ;
-
-M: standard-combination perform-combination
- standard-combination-# (dispatch#) [
- [ standard-methods ] keep "inline" word-prop
- [ small-generic ] [ single-combination ] if
- ] with-variable ;
-
-TUPLE: hook-combination var ;
-
-C: <hook-combination> hook-combination
-
-: with-hook ( combination quot -- quot' )
- 0 (dispatch#) [
- swap slip
- hook-combination-var [ get ] curry
- prepend
- ] with-variable ; inline
-
-M: hook-combination make-default-method
- [ error-method ] with-hook ;
-
-M: hook-combination perform-combination
+: single-combination ( words -- quot )
[
- standard-methods
- [ [ drop ] prepend ] assoc-map
- single-combination
- ] with-hook ;
+ object bootstrap-word assumed set
+ [ generic set ]
+ [
+ "methods" word-prop
+ [ generic get mangle-method ] assoc-map
+ [ find-default default set ]
+ [
+ generic get "inline" word-prop [
+ <predicate-dispatch-engine>
+ ] [
+ <big-dispatch-engine>
+ ] if
+ ] bi
+ engine>quot
+ ] bi
+ ] with-scope ;
-: define-simple-generic ( word -- )
- T{ standard-combination f 0 } define-generic ;
+TUPLE: standard-combination # ;
+
+C: <standard-combination> standard-combination
PREDICATE: standard-generic < generic
"combination" word-prop standard-combination? ;
PREDICATE: simple-generic < standard-generic
- "combination" word-prop standard-combination-# zero? ;
+ "combination" word-prop #>> zero? ;
+
+: define-simple-generic ( word -- )
+ T{ standard-combination f 0 } define-generic ;
+
+: with-standard ( combination quot -- quot' )
+ >r #>> (dispatch#) r> with-variable ;
+
+M: standard-generic mangle-method
+ drop 1quotation ;
+
+M: standard-combination make-default-method
+ [ empty-method ] with-standard ;
+
+M: standard-combination perform-combination
+ [ single-combination ] with-standard ;
+
+TUPLE: hook-combination var ;
+
+C: <hook-combination> hook-combination
PREDICATE: hook-generic < generic
"combination" word-prop hook-combination? ;
+: with-hook ( combination quot -- quot' )
+ 0 (dispatch#) [
+ dip var>> [ get ] curry prepend
+ ] with-variable ; inline
+
+M: hook-generic mangle-method
+ drop 1quotation [ drop ] prepend ;
+
+M: hook-combination make-default-method
+ [ error-method ] with-hook ;
+
+M: hook-combination perform-combination
+ [ single-combination ] with-hook ;
+
GENERIC: dispatch# ( word -- n )
M: word dispatch# "combination" word-prop dispatch# ;
-M: standard-combination dispatch# standard-combination-# ;
+M: standard-combination dispatch# #>> ;
M: hook-combination dispatch# drop 0 ;
diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor
index fde8728858..a13e1331fa 100755
--- a/core/mirrors/mirrors.factor
+++ b/core/mirrors/mirrors.factor
@@ -48,27 +48,6 @@ M: mirror assoc-size mirror-slots length ;
INSTANCE: mirror assoc
-TUPLE: enum seq ;
-
-C: <enum> enum
-
-M: enum at*
- enum-seq 2dup bounds-check?
- [ nth t ] [ 2drop f f ] if ;
-
-M: enum set-at enum-seq set-nth ;
-
-M: enum delete-at enum-seq delete-nth ;
-
-M: enum >alist ( enum -- alist )
- enum-seq dup length swap 2array flip ;
-
-M: enum assoc-size enum-seq length ;
-
-M: enum clear-assoc enum-seq delete-all ;
-
-INSTANCE: enum assoc
-
: sort-assoc ( assoc -- alist )
>alist
[ dup first unparse-short swap ] { } map>assoc
diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor
index cbdb1b9ec4..d115d0a1c6 100755
--- a/core/optimizer/specializers/specializers.factor
+++ b/core/optimizer/specializers/specializers.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math
namespaces sequences vectors words strings layouts combinators
-sequences.private classes generic.standard assocs ;
+sequences.private classes generic.standard
+generic.standard.engines assocs ;
IN: optimizer.specializers
: (make-specializer) ( class picker -- quot )
From 11feb563ebdb1ca453ac1d96e8391a9b07478bf1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 13:11:55 -0500
Subject: [PATCH 077/127] move singletons to core
---
core/bootstrap/syntax.factor | 1 +
{extra => core}/classes/singleton/authors.txt | 0
{extra => core}/classes/singleton/singleton-docs.factor | 0
{extra => core}/classes/singleton/singleton-tests.factor | 2 +-
{extra => core}/classes/singleton/singleton.factor | 3 ---
core/syntax/syntax.factor | 6 +++++-
6 files changed, 7 insertions(+), 5 deletions(-)
rename {extra => core}/classes/singleton/authors.txt (100%)
rename {extra => core}/classes/singleton/singleton-docs.factor (100%)
rename {extra => core}/classes/singleton/singleton-tests.factor (75%)
rename {extra => core}/classes/singleton/singleton.factor (92%)
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index e7e90d8dd0..e5a439c32b 100755
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -43,6 +43,7 @@ IN: bootstrap.syntax
"PRIMITIVE:"
"PRIVATE>"
"SBUF\""
+ "SINLETON:"
"SYMBOL:"
"TUPLE:"
"T{"
diff --git a/extra/classes/singleton/authors.txt b/core/classes/singleton/authors.txt
similarity index 100%
rename from extra/classes/singleton/authors.txt
rename to core/classes/singleton/authors.txt
diff --git a/extra/classes/singleton/singleton-docs.factor b/core/classes/singleton/singleton-docs.factor
similarity index 100%
rename from extra/classes/singleton/singleton-docs.factor
rename to core/classes/singleton/singleton-docs.factor
diff --git a/extra/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor
similarity index 75%
rename from extra/classes/singleton/singleton-tests.factor
rename to core/classes/singleton/singleton-tests.factor
index 586724ee3b..11a2a2d166 100644
--- a/extra/classes/singleton/singleton-tests.factor
+++ b/core/classes/singleton/singleton-tests.factor
@@ -9,4 +9,4 @@ GENERIC: zammo ( obj -- )
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
[ t ] [ omg singleton? ] unit-test
-[ "USING: classes.singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
+[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
diff --git a/extra/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor
similarity index 92%
rename from extra/classes/singleton/singleton.factor
rename to core/classes/singleton/singleton.factor
index 61a519679c..13fd242dad 100755
--- a/extra/classes/singleton/singleton.factor
+++ b/core/classes/singleton/singleton.factor
@@ -15,8 +15,5 @@ PREDICATE: singleton < predicate-class
\ singleton
over [ eq? ] curry define-predicate-class ;
-: SINGLETON:
- scan define-singleton ; parsing
-
M: singleton see-class* ( class -- )
<colon \ SINGLETON: pprint-word pprint-word ;
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 19fdf0e45f..1191752ed7 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -6,7 +6,7 @@ namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard
generic.math classes io.files vocabs float-arrays float-vectors
classes.union classes.mixin classes.predicate compiler.units
-combinators debugger ;
+combinators debugger classes.singleton ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@@ -154,6 +154,10 @@ IN: bootstrap.syntax
parse-definition define-predicate-class
] define-syntax
+ "SINGLETON:" [
+ scan define-singleton
+ ] define-syntax
+
"TUPLE:" [
parse-tuple-definition define-tuple-class
] define-syntax
From e62c3c323c99490e9e0aebfafaeabb1b9e3ed7d4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 13:13:56 -0500
Subject: [PATCH 078/127] fix unit test
---
core/classes/singleton/singleton-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor
index 11a2a2d166..92a9877477 100644
--- a/core/classes/singleton/singleton-tests.factor
+++ b/core/classes/singleton/singleton-tests.factor
@@ -4,7 +4,7 @@ IN: classes.singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
[ t ] [ bzzt bzzt? ] unit-test
[ t ] [ bzzt bzzt eq? ] unit-test
-GENERIC: zammo ( obj -- )
+GENERIC: zammo ( obj -- str )
[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
From c89ee5bfccfb8d6e19906841b3dd5fc06917b74c Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Wed, 2 Apr 2008 15:11:11 -0500
Subject: [PATCH 079/127] add textwrangler binding
---
extra/editors/textwrangler/authors.txt | 1 +
extra/editors/textwrangler/summary.txt | 1 +
extra/editors/textwrangler/textwrangler.factor | 13 +++++++++++++
3 files changed, 15 insertions(+)
create mode 100644 extra/editors/textwrangler/authors.txt
create mode 100644 extra/editors/textwrangler/summary.txt
create mode 100644 extra/editors/textwrangler/textwrangler.factor
diff --git a/extra/editors/textwrangler/authors.txt b/extra/editors/textwrangler/authors.txt
new file mode 100644
index 0000000000..b4a113da41
--- /dev/null
+++ b/extra/editors/textwrangler/authors.txt
@@ -0,0 +1 @@
+Ben Schlingelhof
diff --git a/extra/editors/textwrangler/summary.txt b/extra/editors/textwrangler/summary.txt
new file mode 100644
index 0000000000..cf502f96e5
--- /dev/null
+++ b/extra/editors/textwrangler/summary.txt
@@ -0,0 +1 @@
+Textwrangler editor integration
diff --git a/extra/editors/textwrangler/textwrangler.factor b/extra/editors/textwrangler/textwrangler.factor
new file mode 100644
index 0000000000..e97dadcdcb
--- /dev/null
+++ b/extra/editors/textwrangler/textwrangler.factor
@@ -0,0 +1,13 @@
+! Copyright (C) 2008 Ben Schlingelhof.
+! See http://factorcode.org/license.txt for BSD license.
+USING: definitions io.launcher kernel parser words sequences
+math math.parser namespaces editors ;
+IN: editors.textwrangler
+
+: tw ( file line -- )
+ [ "edit +" % # " " % % ] "" make run-process drop ;
+
+: tw-word ( word -- )
+ where first2 tw ;
+
+[ tw ] edit-hook set-global
From 47b54b13072b91c4b3bdf2ecfb7673bd77aedaea Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 15:41:29 -0500
Subject: [PATCH 080/127] add singletons to core
---
core/bootstrap/syntax.factor | 2 +-
core/classes/singleton/singleton-tests.factor | 2 +-
core/classes/singleton/singleton.factor | 16 ++++------------
core/prettyprint/prettyprint.factor | 5 ++++-
core/syntax/syntax.factor | 7 ++++---
5 files changed, 14 insertions(+), 18 deletions(-)
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index e5a439c32b..fb5923382e 100755
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -43,7 +43,7 @@ IN: bootstrap.syntax
"PRIMITIVE:"
"PRIVATE>"
"SBUF\""
- "SINLETON:"
+ "SINGLETON:"
"SYMBOL:"
"TUPLE:"
"T{"
diff --git a/core/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor
index 92a9877477..2ed51abb93 100644
--- a/core/classes/singleton/singleton-tests.factor
+++ b/core/classes/singleton/singleton-tests.factor
@@ -8,5 +8,5 @@ GENERIC: zammo ( obj -- str )
[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
-[ t ] [ omg singleton? ] unit-test
+[ t ] [ omg singleton-class? ] unit-test
[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
diff --git a/core/classes/singleton/singleton.factor b/core/classes/singleton/singleton.factor
index 13fd242dad..65d7422ed7 100755
--- a/core/classes/singleton/singleton.factor
+++ b/core/classes/singleton/singleton.factor
@@ -1,19 +1,11 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes.predicate kernel namespaces parser quotations
-sequences words prettyprint prettyprint.backend prettyprint.sections
-compiler.units classes ;
+USING: classes.predicate kernel sequences words ;
IN: classes.singleton
-PREDICATE: singleton < predicate-class
+PREDICATE: singleton-class < predicate-class
[ "predicate-definition" word-prop ]
[ [ eq? ] curry ] bi sequence= ;
-: define-singleton ( token -- )
- create-class-in
- dup save-location
- \ singleton
- over [ eq? ] curry define-predicate-class ;
-
-M: singleton see-class* ( class -- )
- <colon \ SINGLETON: pprint-word pprint-word ;
+: define-singleton-class ( word -- )
+ \ word over [ eq? ] curry define-predicate-class ;
diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor
index d294f95be6..fd7133053a 100755
--- a/core/prettyprint/prettyprint.factor
+++ b/core/prettyprint/prettyprint.factor
@@ -7,7 +7,7 @@ vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting math.parser vocabs
definitions effects classes.tuple io.files classes continuations
hashtables classes.mixin classes.union classes.predicate
-combinators quotations ;
+classes.singleton combinators quotations ;
: make-pprint ( obj quot -- block in use )
[
@@ -254,6 +254,9 @@ M: predicate-class see-class*
"predicate-definition" word-prop pprint-elements
pprint-; block> block> ;
+M: singleton-class see-class* ( class -- )
+ \ SINGLETON: pprint-word pprint-word ;
+
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
dup pprint-word
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 1191752ed7..90bb1f0a6d 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -5,8 +5,8 @@ byte-vectors definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard
generic.math classes io.files vocabs float-arrays float-vectors
-classes.union classes.mixin classes.predicate compiler.units
-combinators debugger classes.singleton ;
+classes.union classes.mixin classes.predicate classes.singleton
+compiler.units combinators debugger ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@@ -155,7 +155,8 @@ IN: bootstrap.syntax
] define-syntax
"SINGLETON:" [
- scan define-singleton
+ scan create-class-in
+ dup save-location define-singleton-class
] define-syntax
"TUPLE:" [
From 8b22f4436bcd57ae1c2384b3ce4b5b5056c7011a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 16:32:10 -0500
Subject: [PATCH 081/127] t is now a singleton
---
core/syntax/syntax.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 90bb1f0a6d..37df12e9a7 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -55,7 +55,7 @@ IN: bootstrap.syntax
"BIN:" [ 2 parse-base ] define-syntax
"f" [ f parsed ] define-syntax
- "t" "syntax" lookup define-symbol
+ "t" "syntax" lookup define-singleton-class
"CHAR:" [
scan {
From 7ec68e0aa7fce17bee0ea28fde27c0224c48ed8c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 16:32:34 -0500
Subject: [PATCH 082/127] singleton docs
---
core/classes/classes-docs.factor | 1 +
core/classes/singleton/singleton-docs.factor | 16 +++++++++++++++-
2 files changed, 16 insertions(+), 1 deletion(-)
diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor
index 9573de8949..5cc815fc36 100755
--- a/core/classes/classes-docs.factor
+++ b/core/classes/classes-docs.factor
@@ -47,6 +47,7 @@ $nl
"Other sorts of classes:"
{ $subsection "builtin-classes" }
{ $subsection "unions" }
+{ $subsection "singletons" }
{ $subsection "mixins" }
{ $subsection "predicates" }
"Classes can be inspected and operated upon:"
diff --git a/core/classes/singleton/singleton-docs.factor b/core/classes/singleton/singleton-docs.factor
index 95b5b6af18..8548f84a3a 100644
--- a/core/classes/singleton/singleton-docs.factor
+++ b/core/classes/singleton/singleton-docs.factor
@@ -1,6 +1,11 @@
USING: help.markup help.syntax kernel words ;
IN: classes.singleton
+ARTICLE: "singletons" "Singleton classes"
+"A singleton is a class with only one instance and with no state. Methods may dispatch off of singleton classes."
+{ $subsection POSTPONE: SINGLETON: }
+{ $subsection define-singleton-class } ;
+
HELP: SINGLETON:
{ $syntax "SINGLETON: class"
} { $values
@@ -8,7 +13,16 @@ HELP: SINGLETON:
} { $description
"Defines a new predicate class whose superclass is " { $link word } ". Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves. Methods may be defined on a singleton."
} { $examples
- { $example "USING: singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
+ { $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
} { $see-also
POSTPONE: PREDICATE:
} ;
+
+HELP: define-singleton-class
+{ $values { "word" "a new word" } }
+{ $description
+ "Defines a newly created word to be a singleton class." } ;
+
+{ POSTPONE: SINGLETON: define-singleton-class } related-words
+
+ABOUT: "singletons"
From d736a8660da45d0778d340f504f6c9cacc4cb6e2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 16:32:58 -0500
Subject: [PATCH 083/127] cpu is now a singleton
---
core/bootstrap/compiler/compiler.factor | 2 +-
core/bootstrap/image/image.factor | 3 ++-
core/system/system.factor | 32 +++++++++++++++++++++++--
3 files changed, 33 insertions(+), 4 deletions(-)
diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor
index 7d4db3c473..ab09279a7b 100755
--- a/core/bootstrap/compiler/compiler.factor
+++ b/core/bootstrap/compiler/compiler.factor
@@ -14,7 +14,7 @@ IN: bootstrap.compiler
"alien.remote-control" require
] unless
-"cpu." cpu append require
+"cpu." cpu word-name append require
: enable-compiler ( -- )
[ optimized-recompile-hook ] recompile-hook set-global ;
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index fc963683b6..e2fa5833eb 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -12,7 +12,8 @@ io.encodings.binary ;
IN: bootstrap.image
: my-arch ( -- arch )
- cpu dup "ppc" = [ >r os "-" r> 3append ] when ;
+ cpu word-name
+ dup "ppc" = [ >r os "-" r> 3append ] when ;
: boot-image-name ( arch -- string )
"boot." swap ".image" 3append ;
diff --git a/core/system/system.factor b/core/system/system.factor
index 87bbcfdc3f..5a0faeece9 100755
--- a/core/system/system.factor
+++ b/core/system/system.factor
@@ -2,12 +2,40 @@
! See http://factorcode.org/license.txt for BSD license.
IN: system
USING: kernel kernel.private sequences math namespaces
-splitting assocs system.private layouts ;
+init splitting assocs system.private layouts words ;
-: cpu ( -- cpu ) 8 getenv ; foldable
+! : cpu ( -- cpu ) 8 getenv ; foldable
: os ( -- os ) 9 getenv ; foldable
+SINGLETON: x86.32
+SINGLETON: x86.64
+SINGLETON: arm
+SINGLETON: ppc
+
+: cpu ( -- class ) \ cpu get ;
+
+! SINGLETON: winnt
+! SINGLETON: wince
+
+! MIXIN: windows
+! INSTANCE: winnt windows
+! INSTANCE: wince windows
+
+! SINGLETON: freebsd
+! SINGLETON: netbsd
+! SINGLETON: openbsd
+! SINGLETON: solaris
+! SINGLETON: macosx
+! SINGLETON: linux
+
+! : os ( -- class ) \ os get ;
+
+[
+ 8 getenv "system" lookup \ cpu set-global
+ ! 9 getenv "system" lookup \ os set-global
+] "system" add-init-hook
+
: image ( -- path ) 13 getenv ;
: vm ( -- path ) 14 getenv ;
From 7cb3fdcfec85f100a33f0a81b763a54aa75d19c1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 17:07:38 -0500
Subject: [PATCH 084/127] compiler backend now dispatches on the os
---
core/cpu/architecture/architecture.factor | 94 +++++++++----------
core/cpu/ppc/allot/allot.factor | 4 +-
core/cpu/ppc/architecture/architecture.factor | 86 +++++++++--------
core/cpu/ppc/ppc.factor | 2 -
core/cpu/x86/32/32.factor | 59 ++++++------
core/cpu/x86/64/64.factor | 63 ++++++-------
core/cpu/x86/allot/allot.factor | 4 +-
core/cpu/x86/architecture/architecture.factor | 72 +++++++-------
core/system/system.factor | 22 ++++-
9 files changed, 200 insertions(+), 206 deletions(-)
diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor
index 8d1e1f281f..4670cf86d2 100755
--- a/core/cpu/architecture/architecture.factor
+++ b/core/cpu/architecture/architecture.factor
@@ -5,8 +5,6 @@ namespaces sequences layouts system hashtables classes alien
byte-arrays bit-arrays float-arrays combinators words ;
IN: cpu.architecture
-SYMBOL: compiler-backend
-
! A pseudo-register class for parameters spilled on the stack
TUPLE: stack-params ;
@@ -26,122 +24,122 @@ GENERIC: vregs ( register-class -- regs )
! Load a literal (immediate or indirect)
GENERIC# load-literal 1 ( obj vreg -- )
-HOOK: load-indirect compiler-backend ( obj reg -- )
+HOOK: load-indirect cpu ( obj reg -- )
-HOOK: stack-frame compiler-backend ( frame-size -- n )
+HOOK: stack-frame cpu ( frame-size -- n )
: stack-frame* ( -- n )
\ stack-frame get stack-frame ;
! Set up caller stack frame
-HOOK: %prologue compiler-backend ( n -- )
+HOOK: %prologue cpu ( n -- )
: %prologue-later \ %prologue-later , ;
! Tear down stack frame
-HOOK: %epilogue compiler-backend ( n -- )
+HOOK: %epilogue cpu ( n -- )
: %epilogue-later \ %epilogue-later , ;
! Store word XT in stack frame
-HOOK: %save-word-xt compiler-backend ( -- )
+HOOK: %save-word-xt cpu ( -- )
! Store dispatch branch XT in stack frame
-HOOK: %save-dispatch-xt compiler-backend ( -- )
+HOOK: %save-dispatch-xt cpu ( -- )
M: object %save-dispatch-xt %save-word-xt ;
! Call another word
-HOOK: %call compiler-backend ( word -- )
+HOOK: %call cpu ( word -- )
! Local jump for branches
-HOOK: %jump-label compiler-backend ( label -- )
+HOOK: %jump-label cpu ( label -- )
! Test if vreg is 'f' or not
-HOOK: %jump-t compiler-backend ( label -- )
+HOOK: %jump-t cpu ( label -- )
-HOOK: %dispatch compiler-backend ( -- )
+HOOK: %dispatch cpu ( -- )
-HOOK: %dispatch-label compiler-backend ( word -- )
+HOOK: %dispatch-label cpu ( word -- )
! Return to caller
-HOOK: %return compiler-backend ( -- )
+HOOK: %return cpu ( -- )
! Change datastack height
-HOOK: %inc-d compiler-backend ( n -- )
+HOOK: %inc-d cpu ( n -- )
! Change callstack height
-HOOK: %inc-r compiler-backend ( n -- )
+HOOK: %inc-r cpu ( n -- )
! Load stack into vreg
-HOOK: %peek compiler-backend ( vreg loc -- )
+HOOK: %peek cpu ( vreg loc -- )
! Store vreg to stack
-HOOK: %replace compiler-backend ( vreg loc -- )
+HOOK: %replace cpu ( vreg loc -- )
! Box and unbox floats
-HOOK: %unbox-float compiler-backend ( dst src -- )
-HOOK: %box-float compiler-backend ( dst src -- )
+HOOK: %unbox-float cpu ( dst src -- )
+HOOK: %box-float cpu ( dst src -- )
! FFI stuff
! Is this integer small enough to appear in value template
! slots?
-HOOK: small-enough? compiler-backend ( n -- ? )
+HOOK: small-enough? cpu ( n -- ? )
! Is this structure small enough to be returned in registers?
-HOOK: struct-small-enough? compiler-backend ( size -- ? )
+HOOK: struct-small-enough? cpu ( size -- ? )
! Do we pass explode value structs?
-HOOK: value-structs? compiler-backend ( -- ? )
+HOOK: value-structs? cpu ( -- ? )
! If t, fp parameters are shadowed by dummy int parameters
-HOOK: fp-shadows-int? compiler-backend ( -- ? )
+HOOK: fp-shadows-int? cpu ( -- ? )
-HOOK: %prepare-unbox compiler-backend ( -- )
+HOOK: %prepare-unbox cpu ( -- )
-HOOK: %unbox compiler-backend ( n reg-class func -- )
+HOOK: %unbox cpu ( n reg-class func -- )
-HOOK: %unbox-long-long compiler-backend ( n func -- )
+HOOK: %unbox-long-long cpu ( n func -- )
-HOOK: %unbox-small-struct compiler-backend ( size -- )
+HOOK: %unbox-small-struct cpu ( size -- )
-HOOK: %unbox-large-struct compiler-backend ( n size -- )
+HOOK: %unbox-large-struct cpu ( n size -- )
-HOOK: %box compiler-backend ( n reg-class func -- )
+HOOK: %box cpu ( n reg-class func -- )
-HOOK: %box-long-long compiler-backend ( n func -- )
+HOOK: %box-long-long cpu ( n func -- )
-HOOK: %prepare-box-struct compiler-backend ( size -- )
+HOOK: %prepare-box-struct cpu ( size -- )
-HOOK: %box-small-struct compiler-backend ( size -- )
+HOOK: %box-small-struct cpu ( size -- )
-HOOK: %box-large-struct compiler-backend ( n size -- )
+HOOK: %box-large-struct cpu ( n size -- )
GENERIC: %save-param-reg ( stack reg reg-class -- )
GENERIC: %load-param-reg ( stack reg reg-class -- )
-HOOK: %prepare-alien-invoke compiler-backend ( -- )
+HOOK: %prepare-alien-invoke cpu ( -- )
-HOOK: %prepare-var-args compiler-backend ( -- )
+HOOK: %prepare-var-args cpu ( -- )
M: object %prepare-var-args ;
-HOOK: %alien-invoke compiler-backend ( function library -- )
+HOOK: %alien-invoke cpu ( function library -- )
-HOOK: %cleanup compiler-backend ( alien-node -- )
+HOOK: %cleanup cpu ( alien-node -- )
-HOOK: %alien-callback compiler-backend ( quot -- )
+HOOK: %alien-callback cpu ( quot -- )
-HOOK: %callback-value compiler-backend ( ctype -- )
+HOOK: %callback-value cpu ( ctype -- )
! Return to caller with stdcall unwinding (only for x86)
-HOOK: %unwind compiler-backend ( n -- )
+HOOK: %unwind cpu ( n -- )
-HOOK: %prepare-alien-indirect compiler-backend ( -- )
+HOOK: %prepare-alien-indirect cpu ( -- )
-HOOK: %alien-indirect compiler-backend ( -- )
+HOOK: %alien-indirect cpu ( -- )
M: stack-params param-reg drop ;
@@ -179,15 +177,15 @@ PREDICATE: inline-array < integer 32 < ;
] if-small-struct ;
! Alien accessors
-HOOK: %unbox-byte-array compiler-backend ( dst src -- )
+HOOK: %unbox-byte-array cpu ( dst src -- )
-HOOK: %unbox-alien compiler-backend ( dst src -- )
+HOOK: %unbox-alien cpu ( dst src -- )
-HOOK: %unbox-f compiler-backend ( dst src -- )
+HOOK: %unbox-f cpu ( dst src -- )
-HOOK: %unbox-any-c-ptr compiler-backend ( dst src -- )
+HOOK: %unbox-any-c-ptr cpu ( dst src -- )
-HOOK: %box-alien compiler-backend ( dst src -- )
+HOOK: %box-alien cpu ( dst src -- )
: operand ( var -- op ) get v>operand ; inline
diff --git a/core/cpu/ppc/allot/allot.factor b/core/cpu/ppc/allot/allot.factor
index 6c37fce4f1..34ea82dc4e 100755
--- a/core/cpu/ppc/allot/allot.factor
+++ b/core/cpu/ppc/allot/allot.factor
@@ -32,7 +32,7 @@ IN: cpu.ppc.allot
12 11 float tag-number ORI
f fresh-object ;
-M: ppc-backend %box-float ( dst src -- )
+M: ppc %box-float ( dst src -- )
[ v>operand ] bi@ %allot-float 12 MR ;
: %allot-bignum ( #digits -- )
@@ -78,7 +78,7 @@ M: ppc-backend %box-float ( dst src -- )
"end" resolve-label
] with-scope ;
-M: ppc-backend %box-alien ( dst src -- )
+M: ppc %box-alien ( dst src -- )
{ "end" "f" } [ define-label ] each
0 over v>operand 0 CMPI
"f" get BEQ
diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor
index 903ac32df9..8055e4ff6e 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/core/cpu/ppc/architecture/architecture.factor
@@ -7,8 +7,6 @@ layouts classes words.private alien combinators
compiler.constants ;
IN: cpu.ppc.architecture
-TUPLE: ppc-backend ;
-
! PowerPC register assignments
! r3-r10, r16-r31: integer vregs
! f0-f13: float vregs
@@ -44,7 +42,7 @@ TUPLE: ppc-backend ;
: xt-save ( n -- i ) 2 cells - ;
-M: ppc-backend stack-frame ( n -- i )
+M: ppc stack-frame ( n -- i )
local@ factor-area-size + 4 cells align ;
M: temp-reg v>operand drop 11 ;
@@ -73,14 +71,14 @@ M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ;
M: immediate load-literal
[ v>operand ] bi@ LOAD ;
-M: ppc-backend load-indirect ( obj reg -- )
+M: ppc load-indirect ( obj reg -- )
[ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
dup 0 LWZ ;
-M: ppc-backend %save-word-xt ( -- )
+M: ppc %save-word-xt ( -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
-M: ppc-backend %prologue ( n -- )
+M: ppc %prologue ( n -- )
0 MFLR
1 1 pick neg ADDI
11 1 pick xt-save STW
@@ -88,7 +86,7 @@ M: ppc-backend %prologue ( n -- )
11 1 pick next-save STW
0 1 rot lr-save + STW ;
-M: ppc-backend %epilogue ( n -- )
+M: ppc %epilogue ( n -- )
#! At the end of each word that calls a subroutine, we store
#! the previous link register value in r0 by popping it off
#! the stack, set the link register to the contents of r0,
@@ -104,14 +102,14 @@ M: ppc-backend %epilogue ( n -- )
: %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
-M: ppc-backend %call ( label -- ) BL ;
+M: ppc %call ( label -- ) BL ;
-M: ppc-backend %jump-label ( label -- ) B ;
+M: ppc %jump-label ( label -- ) B ;
-M: ppc-backend %jump-t ( label -- )
+M: ppc %jump-t ( label -- )
0 "flag" operand f v>operand CMPI BNE ;
-M: ppc-backend %dispatch ( -- )
+M: ppc %dispatch ( -- )
[
%epilogue-later
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
@@ -124,25 +122,25 @@ M: ppc-backend %dispatch ( -- )
{ +scratch+ { { f "offset" } } }
} with-template ;
-M: ppc-backend %dispatch-label ( word -- )
+M: ppc %dispatch-label ( word -- )
0 , rc-absolute-cell rel-word ;
-M: ppc-backend %return ( -- ) %epilogue-later BLR ;
+M: ppc %return ( -- ) %epilogue-later BLR ;
-M: ppc-backend %unwind drop %return ;
+M: ppc %unwind drop %return ;
-M: ppc-backend %peek ( vreg loc -- )
+M: ppc %peek ( vreg loc -- )
>r v>operand r> loc>operand LWZ ;
-M: ppc-backend %replace
+M: ppc %replace
>r v>operand r> loc>operand STW ;
-M: ppc-backend %unbox-float ( dst src -- )
+M: ppc %unbox-float ( dst src -- )
[ v>operand ] bi@ float-offset LFD ;
-M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
+M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
-M: ppc-backend %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
+M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
M: int-regs %save-param-reg drop 1 rot local@ STW ;
@@ -166,19 +164,19 @@ M: stack-params %save-param-reg ( stack reg reg-class -- )
0 1 rot param@ stack-frame* + LWZ
0 1 rot local@ STW ;
-M: ppc-backend %prepare-unbox ( -- )
+M: ppc %prepare-unbox ( -- )
! First parameter is top of stack
3 ds-reg 0 LWZ
ds-reg dup cell SUBI ;
-M: ppc-backend %unbox ( n reg-class func -- )
+M: ppc %unbox ( n reg-class func -- )
! Value must be in r3
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
-M: ppc-backend %unbox-long-long ( n func -- )
+M: ppc %unbox-long-long ( n func -- )
! Value must be in r3:r4
! Call the unboxer
f %alien-invoke
@@ -188,7 +186,7 @@ M: ppc-backend %unbox-long-long ( n func -- )
4 1 rot cell + local@ STW
] when* ;
-M: ppc-backend %unbox-large-struct ( n size -- )
+M: ppc %unbox-large-struct ( n size -- )
! Value must be in r3
! Compute destination address
4 1 roll local@ ADDI
@@ -197,7 +195,7 @@ M: ppc-backend %unbox-large-struct ( n size -- )
! Call the function
"to_value_struct" f %alien-invoke ;
-M: ppc-backend %box ( n reg-class func -- )
+M: ppc %box ( n reg-class func -- )
! If the source is a stack location, load it into freg #0.
! If the source is f, then we assume the value is already in
! freg #0.
@@ -205,7 +203,7 @@ M: ppc-backend %box ( n reg-class func -- )
over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
r> f %alien-invoke ;
-M: ppc-backend %box-long-long ( n func -- )
+M: ppc %box-long-long ( n func -- )
>r [
3 1 pick local@ LWZ
4 1 rot cell + local@ LWZ
@@ -215,12 +213,12 @@ M: ppc-backend %box-long-long ( n func -- )
: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
-M: ppc-backend %prepare-box-struct ( size -- )
+M: ppc %prepare-box-struct ( size -- )
#! Compute target address for value struct return
3 1 rot f struct-return@ ADDI
3 1 0 local@ STW ;
-M: ppc-backend %box-large-struct ( n size -- )
+M: ppc %box-large-struct ( n size -- )
#! If n = f, then we're boxing a returned struct
[ swap struct-return@ ] keep
! Compute destination address
@@ -230,7 +228,7 @@ M: ppc-backend %box-large-struct ( n size -- )
! Call the function
"box_value_struct" f %alien-invoke ;
-M: ppc-backend %prepare-alien-invoke
+M: ppc %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
@@ -240,20 +238,20 @@ M: ppc-backend %prepare-alien-invoke
ds-reg 11 8 STW
rs-reg 11 12 STW ;
-M: ppc-backend %alien-invoke ( symbol dll -- )
+M: ppc %alien-invoke ( symbol dll -- )
11 %load-dlsym (%call) ;
-M: ppc-backend %alien-callback ( quot -- )
+M: ppc %alien-callback ( quot -- )
3 load-indirect "c_to_factor" f %alien-invoke ;
-M: ppc-backend %prepare-alien-indirect ( -- )
+M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
3 1 cell temp@ STW ;
-M: ppc-backend %alien-indirect ( -- )
+M: ppc %alien-indirect ( -- )
11 1 cell temp@ LWZ (%call) ;
-M: ppc-backend %callback-value ( ctype -- )
+M: ppc %callback-value ( ctype -- )
! Save top of data stack
3 ds-reg 0 LWZ
3 1 0 local@ STW
@@ -264,7 +262,7 @@ M: ppc-backend %callback-value ( ctype -- )
! Unbox former top of data stack to return registers
unbox-return ;
-M: ppc-backend %cleanup ( alien-node -- ) drop ;
+M: ppc %cleanup ( alien-node -- ) drop ;
: %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
@@ -272,34 +270,34 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ;
: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
-M: ppc-backend value-structs?
+M: ppc value-structs?
#! On Linux/PPC, value structs are passed in the same way
#! as reference structs, we just have to make a copy first.
linux? not ;
-M: ppc-backend fp-shadows-int? ( -- ? ) macosx? ;
+M: ppc fp-shadows-int? ( -- ? ) macosx? ;
-M: ppc-backend small-enough? ( n -- ? ) -32768 32767 between? ;
+M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
-M: ppc-backend struct-small-enough? ( size -- ? ) drop f ;
+M: ppc struct-small-enough? ( size -- ? ) drop f ;
-M: ppc-backend %box-small-struct
+M: ppc %box-small-struct
drop "No small structs" throw ;
-M: ppc-backend %unbox-small-struct
+M: ppc %unbox-small-struct
drop "No small structs" throw ;
! Alien intrinsics
-M: ppc-backend %unbox-byte-array ( dst src -- )
+M: ppc %unbox-byte-array ( dst src -- )
[ v>operand ] bi@ byte-array-offset ADDI ;
-M: ppc-backend %unbox-alien ( dst src -- )
+M: ppc %unbox-alien ( dst src -- )
[ v>operand ] bi@ alien-offset LWZ ;
-M: ppc-backend %unbox-f ( dst src -- )
+M: ppc %unbox-f ( dst src -- )
drop 0 swap v>operand LI ;
-M: ppc-backend %unbox-any-c-ptr ( dst src -- )
+M: ppc %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in R12
0 12 LI
diff --git a/core/cpu/ppc/ppc.factor b/core/cpu/ppc/ppc.factor
index 75de49acda..da17da9185 100755
--- a/core/cpu/ppc/ppc.factor
+++ b/core/cpu/ppc/ppc.factor
@@ -12,8 +12,6 @@ namespaces alien.c-types kernel system combinators ;
] }
} cond
-T{ ppc-backend } compiler-backend set-global
-
macosx? [
4 "double" c-type set-c-type-align
] when
diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor
index f4af421cdd..3ebee73cbf 100755
--- a/core/cpu/x86/32/32.factor
+++ b/core/cpu/x86/32/32.factor
@@ -8,23 +8,20 @@ alien.compiler combinators command-line
compiler compiler.units io vocabs.loader accessors ;
IN: cpu.x86.32
-PREDICATE: x86-32-backend < x86-backend
- x86-backend-cell 4 = ;
-
! We implement the FFI for Linux, OS X and Windows all at once.
! OS X requires that the stack be 16-byte aligned, and we do
! this on all platforms, sacrificing some stack space for
! code simplicity.
-M: x86-32-backend ds-reg ESI ;
-M: x86-32-backend rs-reg EDI ;
-M: x86-32-backend stack-reg ESP ;
-M: x86-32-backend xt-reg ECX ;
-M: x86-32-backend stack-save-reg EDX ;
+M: x86.32 ds-reg ESI ;
+M: x86.32 rs-reg EDI ;
+M: x86.32 stack-reg ESP ;
+M: x86.32 xt-reg ECX ;
+M: x86.32 stack-save-reg EDX ;
M: temp-reg v>operand drop EBX ;
-M: x86-32-backend %alien-invoke ( symbol dll -- )
+M: x86.32 %alien-invoke ( symbol dll -- )
(CALL) rel-dlsym ;
! On x86, parameters are never passed in registers.
@@ -61,20 +58,20 @@ M: float-regs store-return-reg load/store-float-return FSTP ;
! On x86, we can always use an address as an operand
! directly.
-M: x86-32-backend address-operand ;
+M: x86.32 address-operand ;
-M: x86-32-backend fixnum>slot@ 1 SHR ;
+M: x86.32 fixnum>slot@ 1 SHR ;
-M: x86-32-backend prepare-division CDQ ;
+M: x86.32 prepare-division CDQ ;
-M: x86-32-backend load-indirect
+M: x86.32 load-indirect
0 [] MOV rc-absolute-cell rel-literal ;
M: object %load-param-reg 3drop ;
M: object %save-param-reg 3drop ;
-M: x86-32-backend %prepare-unbox ( -- )
+M: x86.32 %prepare-unbox ( -- )
#! Move top of data stack to EAX.
EAX ESI [] MOV
ESI 4 SUB ;
@@ -87,7 +84,7 @@ M: x86-32-backend %prepare-unbox ( -- )
f %alien-invoke
] with-aligned-stack ;
-M: x86-32-backend %unbox ( n reg-class func -- )
+M: x86.32 %unbox ( n reg-class func -- )
#! The value being unboxed must already be in EAX.
#! If n is f, we're unboxing a return value about to be
#! returned by the callback. Otherwise, we're unboxing
@@ -96,7 +93,7 @@ M: x86-32-backend %unbox ( n reg-class func -- )
! Store the return value on the C stack
over [ store-return-reg ] [ 2drop ] if ;
-M: x86-32-backend %unbox-long-long ( n func -- )
+M: x86.32 %unbox-long-long ( n func -- )
(%unbox)
! Store the return value on the C stack
[
@@ -104,7 +101,7 @@ M: x86-32-backend %unbox-long-long ( n func -- )
cell + stack@ EDX MOV
] when* ;
-M: x86-32-backend %unbox-struct-2
+M: x86.32 %unbox-struct-2
#! Alien must be in EAX.
4 [
EAX PUSH
@@ -115,7 +112,7 @@ M: x86-32-backend %unbox-struct-2
EAX EAX [] MOV
] with-aligned-stack ;
-M: x86-32-backend %unbox-large-struct ( n size -- )
+M: x86.32 %unbox-large-struct ( n size -- )
#! Alien must be in EAX.
! Compute destination address
ECX ESP roll [+] LEA
@@ -147,7 +144,7 @@ M: x86-32-backend %unbox-large-struct ( n size -- )
over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
push-return-reg ;
-M: x86-32-backend %box ( n reg-class func -- )
+M: x86.32 %box ( n reg-class func -- )
over reg-size [
>r (%box) r> f %alien-invoke
] with-aligned-stack ;
@@ -165,12 +162,12 @@ M: x86-32-backend %box ( n reg-class func -- )
EDX PUSH
EAX PUSH ;
-M: x86-32-backend %box-long-long ( n func -- )
+M: x86.32 %box-long-long ( n func -- )
8 [
>r (%box-long-long) r> f %alien-invoke
] with-aligned-stack ;
-M: x86-32-backend %box-large-struct ( n size -- )
+M: x86.32 %box-large-struct ( n size -- )
! Compute destination address
[ swap struct-return@ ] keep
ECX ESP roll [+] LEA
@@ -183,13 +180,13 @@ M: x86-32-backend %box-large-struct ( n size -- )
"box_value_struct" f %alien-invoke
] with-aligned-stack ;
-M: x86-32-backend %prepare-box-struct ( size -- )
+M: x86.32 %prepare-box-struct ( size -- )
! Compute target address for value struct return
EAX ESP rot f struct-return@ [+] LEA
! Store it as the first parameter
ESP [] EAX MOV ;
-M: x86-32-backend %unbox-struct-1
+M: x86.32 %unbox-struct-1
#! Alien must be in EAX.
4 [
EAX PUSH
@@ -198,7 +195,7 @@ M: x86-32-backend %unbox-struct-1
EAX EAX [] MOV
] with-aligned-stack ;
-M: x86-32-backend %box-small-struct ( size -- )
+M: x86.32 %box-small-struct ( size -- )
#! Box a <= 8-byte struct returned in EAX:DX. OS X only.
12 [
PUSH
@@ -207,21 +204,21 @@ M: x86-32-backend %box-small-struct ( size -- )
"box_small_struct" f %alien-invoke
] with-aligned-stack ;
-M: x86-32-backend %prepare-alien-indirect ( -- )
+M: x86.32 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
cell temp@ EAX MOV ;
-M: x86-32-backend %alien-indirect ( -- )
+M: x86.32 %alien-indirect ( -- )
cell temp@ CALL ;
-M: x86-32-backend %alien-callback ( quot -- )
+M: x86.32 %alien-callback ( quot -- )
4 [
EAX load-indirect
EAX PUSH
"c_to_factor" f %alien-invoke
] with-aligned-stack ;
-M: x86-32-backend %callback-value ( ctype -- )
+M: x86.32 %callback-value ( ctype -- )
! Align C stack
ESP 12 SUB
! Save top of data stack
@@ -236,7 +233,7 @@ M: x86-32-backend %callback-value ( ctype -- )
! Unbox EAX
unbox-return ;
-M: x86-32-backend %cleanup ( alien-node -- )
+M: x86.32 %cleanup ( alien-node -- )
#! a) If we just called an stdcall function in Windows, it
#! cleaned up the stack frame for us. But we don't want that
#! so we 'undo' the cleanup since we do that in %epilogue.
@@ -254,7 +251,7 @@ M: x86-32-backend %cleanup ( alien-node -- )
}
} cond ;
-M: x86-32-backend %unwind ( n -- ) %epilogue-later RET ;
+M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
windows? [
cell "longlong" c-type set-c-type-align
@@ -265,8 +262,6 @@ windows? [
4 "double" c-type set-c-type-align
] unless
-T{ x86-backend f 4 } compiler-backend set-global
-
: sse2? "Intrinsic" throw ;
\ sse2? [
diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor
index c2af60e983..d3ccffe00e 100755
--- a/core/cpu/x86/64/64.factor
+++ b/core/cpu/x86/64/64.factor
@@ -8,14 +8,11 @@ layouts alien alien.accessors alien.compiler alien.structs slots
splitting assocs ;
IN: cpu.x86.64
-PREDICATE: amd64-backend < x86-backend
- x86-backend-cell 8 = ;
-
-M: amd64-backend ds-reg R14 ;
-M: amd64-backend rs-reg R15 ;
-M: amd64-backend stack-reg RSP ;
-M: amd64-backend xt-reg RCX ;
-M: amd64-backend stack-save-reg RSI ;
+M: x86.64 ds-reg R14 ;
+M: x86.64 rs-reg R15 ;
+M: x86.64 stack-reg RSP ;
+M: x86.64 xt-reg RCX ;
+M: x86.64 stack-save-reg RSI ;
M: temp-reg v>operand drop RBX ;
@@ -34,18 +31,18 @@ M: float-regs vregs
M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-M: amd64-backend address-operand ( address -- operand )
+M: x86.64 address-operand ( address -- operand )
#! On AMD64, we have to load 64-bit addresses into a
#! scratch register first. The usage of R11 here is a hack.
#! This word can only be called right before a subroutine
#! call, where all vregs have been flushed anyway.
temp-reg v>operand [ swap MOV ] keep ;
-M: amd64-backend fixnum>slot@ drop ;
+M: x86.64 fixnum>slot@ drop ;
-M: amd64-backend prepare-division CQO ;
+M: x86.64 prepare-division CQO ;
-M: amd64-backend load-indirect ( literal reg -- )
+M: x86.64 load-indirect ( literal reg -- )
0 [] MOV rc-relative rel-literal ;
M: stack-params %load-param-reg
@@ -56,27 +53,27 @@ M: stack-params %load-param-reg
M: stack-params %save-param-reg
>r stack-frame* + cell + swap r> %load-param-reg ;
-M: amd64-backend %prepare-unbox ( -- )
+M: x86.64 %prepare-unbox ( -- )
! First parameter is top of stack
RDI R14 [] MOV
R14 cell SUB ;
-M: amd64-backend %unbox ( n reg-class func -- )
+M: x86.64 %unbox ( n reg-class func -- )
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
-M: amd64-backend %unbox-long-long ( n func -- )
+M: x86.64 %unbox-long-long ( n func -- )
T{ int-regs } swap %unbox ;
-M: amd64-backend %unbox-struct-1 ( -- )
+M: x86.64 %unbox-struct-1 ( -- )
#! Alien must be in RDI.
"alien_offset" f %alien-invoke
! Load first cell
RAX RAX [] MOV ;
-M: amd64-backend %unbox-struct-2 ( -- )
+M: x86.64 %unbox-struct-2 ( -- )
#! Alien must be in RDI.
"alien_offset" f %alien-invoke
! Load second cell
@@ -84,7 +81,7 @@ M: amd64-backend %unbox-struct-2 ( -- )
! Load first cell
RAX RAX [] MOV ;
-M: amd64-backend %unbox-large-struct ( n size -- )
+M: x86.64 %unbox-large-struct ( n size -- )
! Source is in RDI
! Load destination address
RSI RSP roll [+] LEA
@@ -97,7 +94,7 @@ M: amd64-backend %unbox-large-struct ( n size -- )
0 over param-reg swap return-reg
2dup eq? [ 2drop ] [ MOV ] if ;
-M: amd64-backend %box ( n reg-class func -- )
+M: x86.64 %box ( n reg-class func -- )
rot [
rot [ 0 swap param-reg ] keep %load-param-reg
] [
@@ -105,19 +102,19 @@ M: amd64-backend %box ( n reg-class func -- )
] if*
f %alien-invoke ;
-M: amd64-backend %box-long-long ( n func -- )
+M: x86.64 %box-long-long ( n func -- )
T{ int-regs } swap %box ;
-M: amd64-backend struct-small-enough? ( size -- ? ) 2 cells <= ;
+M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
-M: amd64-backend %box-small-struct ( size -- )
+M: x86.64 %box-small-struct ( size -- )
#! Box a <= 16-byte struct returned in RAX:RDX.
RDI RAX MOV
RSI RDX MOV
RDX swap MOV
"box_small_struct" f %alien-invoke ;
-M: amd64-backend %box-large-struct ( n size -- )
+M: x86.64 %box-large-struct ( n size -- )
! Struct size is parameter 2
RSI over MOV
! Compute destination address
@@ -125,27 +122,27 @@ M: amd64-backend %box-large-struct ( n size -- )
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke ;
-M: amd64-backend %prepare-box-struct ( size -- )
+M: x86.64 %prepare-box-struct ( size -- )
! Compute target address for value struct return
RAX RSP rot f struct-return@ [+] LEA
RSP 0 [+] RAX MOV ;
-M: amd64-backend %prepare-var-args RAX RAX XOR ;
+M: x86.64 %prepare-var-args RAX RAX XOR ;
-M: amd64-backend %alien-invoke ( symbol dll -- )
+M: x86.64 %alien-invoke ( symbol dll -- )
0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
-M: amd64-backend %prepare-alien-indirect ( -- )
+M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
cell temp@ RAX MOV ;
-M: amd64-backend %alien-indirect ( -- )
+M: x86.64 %alien-indirect ( -- )
cell temp@ CALL ;
-M: amd64-backend %alien-callback ( quot -- )
+M: x86.64 %alien-callback ( quot -- )
RDI load-indirect "c_to_factor" f %alien-invoke ;
-M: amd64-backend %callback-value ( ctype -- )
+M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
%prepare-unbox
! Put former top of data stack in RDI
@@ -157,9 +154,9 @@ M: amd64-backend %callback-value ( ctype -- )
! Unbox former top of data stack to return registers
unbox-return ;
-M: amd64-backend %cleanup ( alien-node -- ) drop ;
+M: x86.64 %cleanup ( alien-node -- ) drop ;
-M: amd64-backend %unwind ( n -- ) drop %epilogue-later 0 RET ;
+M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ;
USE: cpu.x86.intrinsics
@@ -171,8 +168,6 @@ USE: cpu.x86.intrinsics
\ alien-signed-4 small-reg-32 define-signed-getter
\ set-alien-signed-4 small-reg-32 define-setter
-T{ x86-backend f 8 } compiler-backend set-global
-
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
T{ stack-params } "__stack_value" c-type set-c-type-reg-class >>
diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor
index 5519a9a8d5..f236cdcfa6 100755
--- a/core/cpu/x86/allot/allot.factor
+++ b/core/cpu/x86/allot/allot.factor
@@ -46,7 +46,7 @@ IN: cpu.x86.allot
allot-reg swap tag-number OR
allot-reg MOV ;
-M: x86-backend %box-float ( dst src -- )
+M: x86 %box-float ( dst src -- )
#! Only called by pentium4 backend, uses SSE2 instruction
#! dest is a loc or a vreg
float 16 [
@@ -86,7 +86,7 @@ M: x86-backend %box-float ( dst src -- )
"end" resolve-label
] with-scope ;
-M: x86-backend %box-alien ( dst src -- )
+M: x86 %box-alien ( dst src -- )
[
{ "end" "f" } [ define-label ] each
dup v>operand 0 CMP
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 31fa4c8e4b..76c4f1691a 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -6,13 +6,11 @@ memory namespaces sequences words generator generator.registers
generator.fixup system layouts combinators compiler.constants ;
IN: cpu.x86.architecture
-TUPLE: x86-backend cell ;
-
-HOOK: ds-reg compiler-backend
-HOOK: rs-reg compiler-backend
-HOOK: stack-reg compiler-backend
-HOOK: xt-reg compiler-backend
-HOOK: stack-save-reg compiler-backend
+HOOK: ds-reg cpu
+HOOK: rs-reg cpu
+HOOK: stack-reg cpu
+HOOK: xt-reg cpu
+HOOK: stack-save-reg cpu
: stack@ stack-reg swap [+] ;
@@ -33,34 +31,34 @@ GENERIC: push-return-reg ( reg-class -- )
GENERIC: load-return-reg ( stack@ reg-class -- )
GENERIC: store-return-reg ( stack@ reg-class -- )
-HOOK: address-operand compiler-backend ( address -- operand )
+HOOK: address-operand cpu ( address -- operand )
-HOOK: fixnum>slot@ compiler-backend
+HOOK: fixnum>slot@ cpu
-HOOK: prepare-division compiler-backend
+HOOK: prepare-division cpu
M: immediate load-literal v>operand swap v>operand MOV ;
-M: x86-backend stack-frame ( n -- i )
+M: x86 stack-frame ( n -- i )
3 cells + 16 align cell - ;
-M: x86-backend %save-word-xt ( -- )
+M: x86 %save-word-xt ( -- )
xt-reg 0 MOV rc-absolute-cell rel-this ;
: factor-area-size 4 cells ;
-M: x86-backend %prologue ( n -- )
+M: x86 %prologue ( n -- )
dup cell + PUSH
xt-reg PUSH
stack-reg swap 2 cells - SUB ;
-M: x86-backend %epilogue ( n -- )
+M: x86 %epilogue ( n -- )
stack-reg swap ADD ;
: %alien-global ( symbol dll register -- )
[ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
-M: x86-backend %prepare-alien-invoke
+M: x86 %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
@@ -70,11 +68,11 @@ M: x86-backend %prepare-alien-invoke
temp-reg v>operand 2 cells [+] ds-reg MOV
temp-reg v>operand 3 cells [+] rs-reg MOV ;
-M: x86-backend %call ( label -- ) CALL ;
+M: x86 %call ( label -- ) CALL ;
-M: x86-backend %jump-label ( label -- ) JMP ;
+M: x86 %jump-label ( label -- ) JMP ;
-M: x86-backend %jump-t ( label -- )
+M: x86 %jump-t ( label -- )
"flag" operand f v>operand CMP JNE ;
: code-alignment ( -- n )
@@ -83,7 +81,7 @@ M: x86-backend %jump-t ( label -- )
: align-code ( n -- )
0 <repetition> % ;
-M: x86-backend %dispatch ( -- )
+M: x86 %dispatch ( -- )
[
%epilogue-later
! Load jump table base. We use a temporary register
@@ -105,27 +103,27 @@ M: x86-backend %dispatch ( -- )
{ +clobber+ { "n" } }
} with-template ;
-M: x86-backend %dispatch-label ( word -- )
+M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
-M: x86-backend %unbox-float ( dst src -- )
+M: x86 %unbox-float ( dst src -- )
[ v>operand ] bi@ float-offset [+] MOVSD ;
-M: x86-backend %peek [ v>operand ] bi@ MOV ;
+M: x86 %peek [ v>operand ] bi@ MOV ;
-M: x86-backend %replace swap %peek ;
+M: x86 %replace swap %peek ;
: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
-M: x86-backend %inc-d ( n -- ) ds-reg (%inc) ;
+M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
-M: x86-backend %inc-r ( n -- ) rs-reg (%inc) ;
+M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
-M: x86-backend fp-shadows-int? ( -- ? ) f ;
+M: x86 fp-shadows-int? ( -- ? ) f ;
-M: x86-backend value-structs? t ;
+M: x86 value-structs? t ;
-M: x86-backend small-enough? ( n -- ? )
+M: x86 small-enough? ( n -- ? )
HEX: -80000000 HEX: 7fffffff between? ;
: %untag ( reg -- ) tag-mask get bitnot AND ;
@@ -143,34 +141,34 @@ M: x86-backend small-enough? ( n -- ? )
\ stack-frame get swap -
] ?if ;
-HOOK: %unbox-struct-1 compiler-backend ( -- )
+HOOK: %unbox-struct-1 cpu ( -- )
-HOOK: %unbox-struct-2 compiler-backend ( -- )
+HOOK: %unbox-struct-2 cpu ( -- )
-M: x86-backend %unbox-small-struct ( size -- )
+M: x86 %unbox-small-struct ( size -- )
#! Alien must be in EAX.
cell align cell /i {
{ 1 [ %unbox-struct-1 ] }
{ 2 [ %unbox-struct-2 ] }
} case ;
-M: x86-backend struct-small-enough? ( size -- ? )
+M: x86 struct-small-enough? ( size -- ? )
{ 1 2 4 8 } member?
os { "linux" "netbsd" "solaris" } member? not and ;
-M: x86-backend %return ( -- ) 0 %unwind ;
+M: x86 %return ( -- ) 0 %unwind ;
! Alien intrinsics
-M: x86-backend %unbox-byte-array ( dst src -- )
+M: x86 %unbox-byte-array ( dst src -- )
[ v>operand ] bi@ byte-array-offset [+] LEA ;
-M: x86-backend %unbox-alien ( dst src -- )
+M: x86 %unbox-alien ( dst src -- )
[ v>operand ] bi@ alien-offset [+] MOV ;
-M: x86-backend %unbox-f ( dst src -- )
+M: x86 %unbox-f ( dst src -- )
drop v>operand 0 MOV ;
-M: x86-backend %unbox-any-c-ptr ( dst src -- )
+M: x86 %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in ds-reg
ds-reg PUSH
diff --git a/core/system/system.factor b/core/system/system.factor
index 5a0faeece9..459af28537 100755
--- a/core/system/system.factor
+++ b/core/system/system.factor
@@ -13,14 +13,14 @@ SINGLETON: x86.64
SINGLETON: arm
SINGLETON: ppc
+UNION: x86 x86.32 x86.64 ;
+
: cpu ( -- class ) \ cpu get ;
! SINGLETON: winnt
! SINGLETON: wince
-! MIXIN: windows
-! INSTANCE: winnt windows
-! INSTANCE: wince windows
+! UNION: windows winnt wince ;
! SINGLETON: freebsd
! SINGLETON: netbsd
@@ -29,11 +29,23 @@ SINGLETON: ppc
! SINGLETON: macosx
! SINGLETON: linux
+<PRIVATE
+
+: string>cpu ( str -- class )
+ H{
+ { "x86.32" x86.32 }
+ { "x86.64" x86.64 }
+ { "arm" arm }
+ { "ppc" ppc }
+ } at ;
+
+PRIVATE>
+
! : os ( -- class ) \ os get ;
[
- 8 getenv "system" lookup \ cpu set-global
- ! 9 getenv "system" lookup \ os set-global
+ 8 getenv string>cpu \ cpu set-global
+ ! 9 getenv string>os \ os set-global
] "system" add-init-hook
: image ( -- path ) 13 getenv ;
From 393f77715cafa447f6e9499ba61cd319c2620e28 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 18:25:33 -0500
Subject: [PATCH 085/127] update everything to use os singletons
---
core/alien/alien-docs.factor | 4 +-
core/alien/alien.factor | 2 +-
core/bootstrap/image/image.factor | 2 +-
core/bootstrap/stage2.factor | 6 +-
core/command-line/command-line.factor | 2 +-
core/cpu/ppc/architecture/architecture.factor | 16 ++--
core/cpu/ppc/ppc.factor | 9 +--
core/cpu/x86/32/32.factor | 5 +-
core/cpu/x86/architecture/architecture.factor | 2 +-
core/generator/fixup/fixup.factor | 2 +-
core/io/files/files.factor | 12 +--
core/system/system-docs.factor | 60 +++------------
core/system/system-tests.factor | 4 +-
core/system/system.factor | 75 ++++++++-----------
extra/bootstrap/io/io.factor | 6 +-
extra/bootstrap/random/random.factor | 4 +-
extra/bootstrap/ui/ui.factor | 6 +-
extra/builder/builder.factor | 2 +-
extra/cairo/ffi/ffi.factor | 8 +-
extra/calendar/calendar.factor | 4 +-
.../distributed/distributed-tests.factor | 66 ++++++++--------
extra/db/mysql/ffi/ffi.factor | 6 +-
extra/db/postgresql/ffi/ffi.factor | 6 +-
extra/db/sqlite/ffi/ffi.factor | 6 +-
extra/editors/gvim/gvim.factor | 4 +-
extra/freetype/freetype.factor | 4 +-
extra/hardware-info/hardware-info.factor | 6 +-
extra/io/files/unique/unique.factor | 4 +-
extra/io/sockets/impl/impl.factor | 4 +-
extra/io/unix/unix.factor | 2 +-
extra/io/windows/ce/backend/backend.factor | 2 +-
extra/io/windows/launcher/launcher.factor | 4 +-
extra/ogg/ogg.factor | 6 +-
extra/ogg/theora/theora.factor | 6 +-
extra/ogg/vorbis/vorbis.factor | 6 +-
extra/openal/openal.factor | 14 ++--
extra/opengl/gl/extensions/extensions.factor | 10 ++-
extra/openssl/libcrypto/libcrypto.factor | 6 +-
extra/openssl/libssl/libssl.factor | 6 +-
extra/oracle/liboci/liboci.factor | 6 +-
extra/tools/deploy/deploy.factor | 4 +-
extra/tools/disassembler/disassembler.factor | 2 +-
extra/ui/tools/deploy/deploy.factor | 2 +-
extra/unix/kqueue/kqueue.factor | 2 +-
extra/unix/stat/stat.factor | 10 +--
45 files changed, 186 insertions(+), 239 deletions(-)
diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index 7bba9d7332..fcafe3441c 100755
--- a/core/alien/alien-docs.factor
+++ b/core/alien/alien-docs.factor
@@ -76,8 +76,8 @@ $nl
{ $examples "Here is a typical usage of " { $link add-library } ":"
{ $code
"<< \"freetype\" {"
- " { [ macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
- " { [ windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
+ " { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
+ " { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
" { [ t ] [ drop ] }"
"} cond >>"
}
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index cfa9fb2e16..56be3e66a5 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -29,7 +29,7 @@ M: f expired? drop t ;
f <displaced-alien> { simple-c-ptr } declare ; inline
: alien>native-string ( alien -- string )
- windows? [ alien>u16-string ] [ alien>char-string ] if ;
+ os windows? [ alien>u16-string ] [ alien>char-string ] if ;
: dll-path ( dll -- string )
(dll-path) alien>native-string ;
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index e2fa5833eb..6e0f8e2970 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -13,7 +13,7 @@ IN: bootstrap.image
: my-arch ( -- arch )
cpu word-name
- dup "ppc" = [ >r os "-" r> 3append ] when ;
+ dup "ppc" = [ >r os word-name "-" r> 3append ] when ;
: boot-image-name ( arch -- string )
"boot." swap ".image" 3append ;
diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor
index bbb2e44843..c82ebbe9f8 100755
--- a/core/bootstrap/stage2.factor
+++ b/core/bootstrap/stage2.factor
@@ -11,7 +11,7 @@ IN: bootstrap.stage2
SYMBOL: bootstrap-time
: default-image-name ( -- string )
- vm file-name windows? [ "." split1 drop ] when
+ vm file-name os windows? [ "." split1 drop ] when
".image" append resource-path ;
: do-crossref ( -- )
@@ -65,8 +65,8 @@ parse-command-line
"-no-crossref" cli-args member? [ do-crossref ] unless
! Set dll paths
-wince? [ "windows.ce" require ] when
-winnt? [ "windows.nt" require ] when
+os wince? [ "windows.ce" require ] when
+os winnt? [ "windows.nt" require ] when
"deploy-vocab" get [
"stage2: deployment mode" print
diff --git a/core/command-line/command-line.factor b/core/command-line/command-line.factor
index 72c1e063e0..246bf2dabe 100644
--- a/core/command-line/command-line.factor
+++ b/core/command-line/command-line.factor
@@ -47,7 +47,7 @@ SYMBOL: main-vocab-hook
] bind ;
: ignore-cli-args? ( -- ? )
- macosx? "run" get "ui" = and ;
+ os macosx? "run" get "ui" = and ;
: script-mode ( -- )
t "quiet" set-global
diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor
index 8055e4ff6e..a1a4bd3809 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/core/cpu/ppc/architecture/architecture.factor
@@ -19,14 +19,14 @@ IN: cpu.ppc.architecture
: reserved-area-size
os {
- { "linux" [ 2 ] }
- { "macosx" [ 6 ] }
+ { linux [ 2 ] }
+ { macosx [ 6 ] }
} case cells ; foldable
: lr-save
os {
- { "linux" [ 1 ] }
- { "macosx" [ 2 ] }
+ { linux [ 1 ] }
+ { macosx [ 2 ] }
} case cells ; foldable
: param@ ( n -- x ) reserved-area-size + ; inline
@@ -58,8 +58,8 @@ M: int-regs vregs
M: float-regs return-reg drop 1 ;
M: float-regs param-regs
drop os H{
- { "macosx" { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
- { "linux" { 1 2 3 4 5 6 7 8 } }
+ { macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
+ { linux { 1 2 3 4 5 6 7 8 } }
} at ;
M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
@@ -273,9 +273,9 @@ M: ppc %cleanup ( alien-node -- ) drop ;
M: ppc value-structs?
#! On Linux/PPC, value structs are passed in the same way
#! as reference structs, we just have to make a copy first.
- linux? not ;
+ os linux? not ;
-M: ppc fp-shadows-int? ( -- ? ) macosx? ;
+M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
diff --git a/core/cpu/ppc/ppc.factor b/core/cpu/ppc/ppc.factor
index da17da9185..eede86085b 100755
--- a/core/cpu/ppc/ppc.factor
+++ b/core/cpu/ppc/ppc.factor
@@ -2,16 +2,13 @@ USING: cpu.ppc.architecture cpu.ppc.intrinsics cpu.architecture
namespaces alien.c-types kernel system combinators ;
{
- { [ macosx? ] [
+ { [ os macosx? ] [
4 "longlong" c-type set-c-type-align
4 "ulonglong" c-type set-c-type-align
+ 4 "double" c-type set-c-type-align
] }
- { [ linux? ] [
+ { [ os linux? ] [
t "longlong" c-type set-c-type-stack-align?
t "ulonglong" c-type set-c-type-stack-align?
] }
} cond
-
-macosx? [
- 4 "double" c-type set-c-type-align
-] when
diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor
index 3ebee73cbf..4d447b38fc 100755
--- a/core/cpu/x86/32/32.factor
+++ b/core/cpu/x86/32/32.factor
@@ -253,12 +253,9 @@ M: x86.32 %cleanup ( alien-node -- )
M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
-windows? [
+os windows? [
cell "longlong" c-type set-c-type-align
cell "ulonglong" c-type set-c-type-align
-] unless
-
-windows? [
4 "double" c-type set-c-type-align
] unless
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 76c4f1691a..6c9a4dc05f 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -154,7 +154,7 @@ M: x86 %unbox-small-struct ( size -- )
M: x86 struct-small-enough? ( size -- ? )
{ 1 2 4 8 } member?
- os { "linux" "netbsd" "solaris" } member? not and ;
+ os { linux netbsd solaris } member? not and ;
M: x86 %return ( -- ) 0 %unwind ;
diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor
index 7581377a6a..5cc0442464 100755
--- a/core/generator/fixup/fixup.factor
+++ b/core/generator/fixup/fixup.factor
@@ -111,7 +111,7 @@ SYMBOL: literal-table
: add-literal ( obj -- n ) literal-table get push-new* ;
: string>symbol ( str -- alien )
- [ wince? [ string>u16-alien ] [ string>char-alien ] if ]
+ [ os wince? [ string>u16-alien ] [ string>char-alien ] if ]
over string? [ call ] [ map ] if ;
: add-dlsym-literals ( symbol dll -- )
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 720894d489..45bf0602f2 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -43,9 +43,9 @@ HOOK: (file-appender) io-backend ( path -- stream )
>r <file-appender> r> with-stream ; inline
! Pathnames
-: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
+: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
-: path-separator ( -- string ) windows? "\\" "/" ? ;
+: path-separator ( -- string ) os windows? "\\" "/" ? ;
: right-trim-separators ( str -- newstr )
[ path-separator? ] right-trim ;
@@ -112,7 +112,7 @@ PRIVATE>
{
{ [ dup empty? ] [ f ] }
{ [ dup "resource:" head? ] [ t ] }
- { [ windows? ] [ windows-absolute-path? ] }
+ { [ os windows? ] [ windows-absolute-path? ] }
{ [ dup first path-separator? ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;
@@ -322,7 +322,7 @@ M: pathname <=> [ pathname-string ] compare ;
! Home directory
: home ( -- dir )
{
- { [ winnt? ] [ "USERPROFILE" os-env ] }
- { [ wince? ] [ "" resource-path ] }
- { [ unix? ] [ "HOME" os-env ] }
+ { [ os winnt? ] [ "USERPROFILE" os-env ] }
+ { [ os wince? ] [ "" resource-path ] }
+ { [ os unix? ] [ "HOME" os-env ] }
} cond ;
diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor
index 7e7a5ff215..9124efcb8c 100755
--- a/core/system/system-docs.factor
+++ b/core/system/system-docs.factor
@@ -5,14 +5,8 @@ IN: system
ARTICLE: "os" "System interface"
"Operating system detection:"
{ $subsection os }
-{ $subsection unix? }
-{ $subsection macosx? }
-{ $subsection solaris? }
-{ $subsection windows? }
-{ $subsection winnt? }
{ $subsection win32? }
{ $subsection win64? }
-{ $subsection wince? }
"Processor detection:"
{ $subsection cpu }
"Reading environment variables:"
@@ -32,23 +26,23 @@ ABOUT: "os"
HELP: cpu
{ $values { "cpu" string } }
{ $description
- "Outputs a string descriptor of the current CPU architecture. Currently, this set of descriptors is:"
- { $code "x86.32" "x86.64" "ppc" "arm" }
+ "Outputs a singleton class with the name of the current CPU architecture. Currently, this set of descriptors is:"
+ { $code x86.32 x86.64 ppc arm }
} ;
HELP: os
{ $values { "os" string } }
{ $description
- "Outputs a string descriptor of the current operating system family. Currently, this set of descriptors is:"
+ "Outputs a singleton class with the name of the current operating system family. Currently, this set of descriptors is:"
{ $code
- "freebsd"
- "linux"
- "macosx"
- "openbsd"
- "netbsd"
- "solaris"
- "wince"
- "winnt"
+ freebsd
+ linux
+ macosx
+ openbsd
+ netbsd
+ solaris
+ wince
+ winnt
}
} ;
@@ -56,34 +50,6 @@ HELP: embedded?
{ $values { "?" "a boolean" } }
{ $description "Tests if this Factor instance is embedded in another application." } ;
-HELP: windows?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Windows." } ;
-
-HELP: winnt?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Windows XP or Vista." } ;
-
-HELP: wince?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Windows CE." } ;
-
-HELP: macosx?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Mac OS X." } ;
-
-HELP: linux?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Linux." } ;
-
-HELP: solaris?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Solaris." } ;
-
-HELP: bsd?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on FreeBSD/OpenBSD/NetBSD." } ;
-
HELP: exit ( n -- )
{ $values { "n" "an integer exit code" } }
{ $description "Exits the Factor process." } ;
@@ -135,7 +101,3 @@ HELP: image
HELP: vm
{ $values { "path" "a pathname string" } }
{ $description "Outputs the pathname of the currently running Factor VM." } ;
-
-HELP: unix?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on a Unix-like system. While this is a rather vague notion, one can use it to make certain assumptions about system calls and file structure which are not valid on Windows." } ;
diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor
index 4b074ed7aa..14e34ccb17 100755
--- a/core/system/system-tests.factor
+++ b/core/system/system-tests.factor
@@ -1,11 +1,11 @@
USING: math tools.test system prettyprint namespaces kernel ;
IN: system.tests
-wince? [
+os wince? [
[ ] [ os-envs . ] unit-test
] unless
-unix? [
+os unix? [
[ ] [ os-envs "envs" set ] unit-test
[ ] [ { { "A" "B" } } set-os-envs ] unit-test
[ "B" ] [ "A" os-env ] unit-test
diff --git a/core/system/system.factor b/core/system/system.factor
index 459af28537..00b3f87e98 100755
--- a/core/system/system.factor
+++ b/core/system/system.factor
@@ -4,10 +4,6 @@ IN: system
USING: kernel kernel.private sequences math namespaces
init splitting assocs system.private layouts words ;
-! : cpu ( -- cpu ) 8 getenv ; foldable
-
-: os ( -- os ) 9 getenv ; foldable
-
SINGLETON: x86.32
SINGLETON: x86.64
SINGLETON: arm
@@ -17,17 +13,23 @@ UNION: x86 x86.32 x86.64 ;
: cpu ( -- class ) \ cpu get ;
-! SINGLETON: winnt
-! SINGLETON: wince
+SINGLETON: winnt
+SINGLETON: wince
-! UNION: windows winnt wince ;
+UNION: windows winnt wince ;
-! SINGLETON: freebsd
-! SINGLETON: netbsd
-! SINGLETON: openbsd
-! SINGLETON: solaris
-! SINGLETON: macosx
-! SINGLETON: linux
+SINGLETON: freebsd
+SINGLETON: netbsd
+SINGLETON: openbsd
+SINGLETON: solaris
+SINGLETON: macosx
+SINGLETON: linux
+
+UNION: bsd freebsd netbsd openbsd macosx ;
+
+UNION: unix bsd solaris linux ;
+
+: os ( -- class ) \ os get ;
<PRIVATE
@@ -39,52 +41,39 @@ UNION: x86 x86.32 x86.64 ;
{ "ppc" ppc }
} at ;
-PRIVATE>
+: string>os ( str -- class )
+ H{
+ { "winnt" winnt }
+ { "wince" wince }
+ { "freebsd" freebsd }
+ { "netbsd" netbsd }
+ { "openbsd" openbsd }
+ { "solaris" solaris }
+ { "macosx" macosx }
+ { "linux" linux }
+ } at ;
-! : os ( -- class ) \ os get ;
+PRIVATE>
[
8 getenv string>cpu \ cpu set-global
- ! 9 getenv string>os \ os set-global
+ 9 getenv string>os \ os set-global
] "system" add-init-hook
: image ( -- path ) 13 getenv ;
: vm ( -- path ) 14 getenv ;
-: wince? ( -- ? )
- os "wince" = ; foldable
-
-: winnt? ( -- ? )
- os "winnt" = ; foldable
-
-: windows? ( -- ? )
- wince? winnt? or ; foldable
-
: win32? ( -- ? )
- winnt? cell 4 = and ; foldable
+ os winnt?
+ cell 4 = and ; foldable
: win64? ( -- ? )
- winnt? cell 8 = and ; foldable
-
-: macosx? ( -- ? ) os "macosx" = ; foldable
+ os winnt?
+ cell 8 = and ; foldable
: embedded? ( -- ? ) 15 getenv ;
-: unix? ( -- ? )
- os {
- "freebsd" "openbsd" "netbsd" "linux" "macosx" "solaris"
- } member? ;
-
-: bsd? ( -- ? )
- os { "freebsd" "openbsd" "netbsd" "macosx" } member? ;
-
-: linux? ( -- ? )
- os "linux" = ;
-
-: solaris? ( -- ? )
- os "solaris" = ;
-
: os-envs ( -- assoc )
(os-envs) [ "=" split1 ] H{ } map>assoc ;
diff --git a/extra/bootstrap/io/io.factor b/extra/bootstrap/io/io.factor
index 065f7dd5c4..a38107fbab 100755
--- a/extra/bootstrap/io/io.factor
+++ b/extra/bootstrap/io/io.factor
@@ -5,8 +5,8 @@ IN: bootstrap.io
"bootstrap.compiler" vocab [
"io." {
{ [ "io-backend" get ] [ "io-backend" get ] }
- { [ unix? ] [ "unix" ] }
- { [ winnt? ] [ "windows.nt" ] }
- { [ wince? ] [ "windows.ce" ] }
+ { [ os unix? ] [ "unix" ] }
+ { [ os winnt? ] [ "windows.nt" ] }
+ { [ os wince? ] [ "windows.ce" ] }
} cond append require
] when
diff --git a/extra/bootstrap/random/random.factor b/extra/bootstrap/random/random.factor
index daf35b9c03..fa0c54d0c6 100755
--- a/extra/bootstrap/random/random.factor
+++ b/extra/bootstrap/random/random.factor
@@ -5,8 +5,8 @@ namespaces random ;
"random.mersenne-twister" require
{
- { [ windows? ] [ "random.windows" require ] }
- { [ unix? ] [ "random.unix" require ] }
+ { [ os windows? ] [ "random.windows" require ] }
+ { [ os unix? ] [ "random.unix" require ] }
} cond
! [ [ 32 random-bits ] with-secure-random <mersenne-twister> random-generator set-global ]
diff --git a/extra/bootstrap/ui/ui.factor b/extra/bootstrap/ui/ui.factor
index f8db831dbc..5aa7683efc 100644
--- a/extra/bootstrap/ui/ui.factor
+++ b/extra/bootstrap/ui/ui.factor
@@ -4,9 +4,9 @@ vocabs vocabs.loader ;
"bootstrap.compiler" vocab [
"ui-backend" get [
{
- { [ macosx? ] [ "cocoa" ] }
- { [ windows? ] [ "windows" ] }
- { [ unix? ] [ "x11" ] }
+ { [ os macosx? ] [ "cocoa" ] }
+ { [ os windows? ] [ "windows" ] }
+ { [ os unix? ] [ "x11" ] }
} cond
] unless* "ui." prepend require
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 75664ce5e5..ece6d64ed9 100644
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@@ -245,4 +245,4 @@ USE: bootstrap.image.download
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-MAIN: build-loop
\ No newline at end of file
+MAIN: build-loop
diff --git a/extra/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor
index c319ade93b..dd4faf9f96 100644
--- a/extra/cairo/ffi/ffi.factor
+++ b/extra/cairo/ffi/ffi.factor
@@ -13,10 +13,10 @@ USING: alien alien.syntax combinators system ;
IN: cairo.ffi
<< "cairo" {
- { [ win32? ] [ "libcairo-2.dll" ] }
- ! { [ macosx? ] [ "libcairo.dylib" ] }
- { [ macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
- { [ unix? ] [ "libcairo.so.2" ] }
+ { [ os win32? ] [ "libcairo-2.dll" ] }
+ ! { [ os macosx? ] [ "libcairo.dylib" ] }
+ { [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
+ { [ os unix? ] [ "libcairo.so.2" ] }
} cond "cdecl" add-library >>
LIBRARY: cairo
diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor
index 6c29c0d1ac..8dcb4af7f1 100755
--- a/extra/calendar/calendar.factor
+++ b/extra/calendar/calendar.factor
@@ -377,6 +377,6 @@ M: timestamp sleep-until timestamp>millis sleep-until ;
M: duration sleep from-now sleep-until ;
{
- { [ unix? ] [ "calendar.unix" ] }
- { [ windows? ] [ "calendar.windows" ] }
+ { [ os unix? ] [ "calendar.unix" ] }
+ { [ os windows? ] [ "calendar.windows" ] }
} cond require
diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor
index 856c37a6bc..e2abd6deb9 100755
--- a/extra/concurrency/distributed/distributed-tests.factor
+++ b/extra/concurrency/distributed/distributed-tests.factor
@@ -1,33 +1,33 @@
-IN: concurrency.distributed.tests
-USING: tools.test concurrency.distributed kernel io.files
-arrays io.sockets system combinators threads math sequences
-concurrency.messaging continuations ;
-
-: test-node
- {
- { [ unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
- { [ windows? ] [ "127.0.0.1" 1238 <inet4> ] }
- } cond ;
-
-[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
-
-[ ] [ test-node dup 1array swap (start-node) ] unit-test
-
-[ ] [ yield ] unit-test
-
-[ ] [
- [
- receive first2 >r 3 + r> send
- "thread-a" unregister-process
- ] "Thread A" spawn
- "thread-a" swap register-process
-] unit-test
-
-[ 8 ] [
- 5 self 2array
- "thread-a" test-node <remote-process> send
-
- receive
-] unit-test
-
-[ ] [ test-node stop-node ] unit-test
+IN: concurrency.distributed.tests
+USING: tools.test concurrency.distributed kernel io.files
+arrays io.sockets system combinators threads math sequences
+concurrency.messaging continuations ;
+
+: test-node
+ {
+ { [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
+ { [ os windows? ] [ "127.0.0.1" 1238 <inet4> ] }
+ } cond ;
+
+[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
+
+[ ] [ test-node dup 1array swap (start-node) ] unit-test
+
+[ ] [ yield ] unit-test
+
+[ ] [
+ [
+ receive first2 >r 3 + r> send
+ "thread-a" unregister-process
+ ] "Thread A" spawn
+ "thread-a" swap register-process
+] unit-test
+
+[ 8 ] [
+ 5 self 2array
+ "thread-a" test-node <remote-process> send
+
+ receive
+] unit-test
+
+[ ] [ test-node stop-node ] unit-test
diff --git a/extra/db/mysql/ffi/ffi.factor b/extra/db/mysql/ffi/ffi.factor
index 845381a23c..424cc7c754 100644
--- a/extra/db/mysql/ffi/ffi.factor
+++ b/extra/db/mysql/ffi/ffi.factor
@@ -6,9 +6,9 @@ USING: alien alien.syntax combinators kernel system ;
IN: db.mysql.ffi
<< "mysql" {
- { [ win32? ] [ "libmySQL.dll" "stdcall" ] }
- { [ macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] }
- { [ unix? ] [ "libmysqlclient.so.14" "cdecl" ] }
+ { [ os win32? ] [ "libmySQL.dll" "stdcall" ] }
+ { [ os macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] }
+ { [ os unix? ] [ "libmysqlclient.so.14" "cdecl" ] }
} cond add-library >>
LIBRARY: mysql
diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor
index be491b8c85..b6aee3dcce 100755
--- a/extra/db/postgresql/ffi/ffi.factor
+++ b/extra/db/postgresql/ffi/ffi.factor
@@ -5,9 +5,9 @@ USING: alien alien.syntax combinators system ;
IN: db.postgresql.ffi
<< "postgresql" {
- { [ win32? ] [ "libpq.dll" ] }
- { [ macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] }
- { [ unix? ] [ "libpq.so" ] }
+ { [ os win32? ] [ "libpq.dll" ] }
+ { [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] }
+ { [ os unix? ] [ "libpq.so" ] }
} cond "cdecl" add-library >>
! ConnSatusType
diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor
index 1d356b1592..c724025874 100755
--- a/extra/db/sqlite/ffi/ffi.factor
+++ b/extra/db/sqlite/ffi/ffi.factor
@@ -7,9 +7,9 @@ USING: alien compiler kernel math namespaces sequences strings alien.syntax
IN: db.sqlite.ffi
<< "sqlite" {
- { [ winnt? ] [ "sqlite3.dll" ] }
- { [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
- { [ unix? ] [ "libsqlite3.so" ] }
+ { [ os winnt? ] [ "sqlite3.dll" ] }
+ { [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
+ { [ os unix? ] [ "libsqlite3.so" ] }
} cond "cdecl" add-library >>
! Return values from sqlite functions
diff --git a/extra/editors/gvim/gvim.factor b/extra/editors/gvim/gvim.factor
index 775d008963..62150bdf49 100755
--- a/extra/editors/gvim/gvim.factor
+++ b/extra/editors/gvim/gvim.factor
@@ -13,6 +13,6 @@ t vim-detach set-global ! don't block the ui
T{ gvim } vim-editor set-global
{
- { [ unix? ] [ "editors.gvim.unix" ] }
- { [ windows? ] [ "editors.gvim.windows" ] }
+ { [ os unix? ] [ "editors.gvim.unix" ] }
+ { [ os windows? ] [ "editors.gvim.windows" ] }
} cond require
diff --git a/extra/freetype/freetype.factor b/extra/freetype/freetype.factor
index 00f7de1370..f34bdc9920 100755
--- a/extra/freetype/freetype.factor
+++ b/extra/freetype/freetype.factor
@@ -4,8 +4,8 @@ USING: alien alien.syntax kernel system combinators ;
IN: freetype
<< "freetype" {
- { [ macosx? ] [ "@executable_path/../Frameworks/libfreetype.6.dylib" "cdecl" add-library ] }
- { [ windows? ] [ "freetype6.dll" "cdecl" add-library ] }
+ { [ os macosx? ] [ "@executable_path/../Frameworks/libfreetype.6.dylib" "cdecl" add-library ] }
+ { [ os windows? ] [ "freetype6.dll" "cdecl" add-library ] }
{ [ t ] [ drop ] }
} cond >>
diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor
index 69b8678749..83e59b3123 100755
--- a/extra/hardware-info/hardware-info.factor
+++ b/extra/hardware-info/hardware-info.factor
@@ -8,9 +8,9 @@ IN: hardware-info
<<
{
- { [ windows? ] [ "hardware-info.windows" ] }
- { [ linux? ] [ "hardware-info.linux" ] }
- { [ macosx? ] [ "hardware-info.macosx" ] }
+ { [ os windows? ] [ "hardware-info.windows" ] }
+ { [ os linux? ] [ "hardware-info.linux" ] }
+ { [ os macosx? ] [ "hardware-info.macosx" ] }
{ [ t ] [ f ] }
} cond [ require ] when* >>
diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor
index a180a28f23..06a3ec8dd2 100644
--- a/extra/io/files/unique/unique.factor
+++ b/extra/io/files/unique/unique.factor
@@ -42,6 +42,6 @@ PRIVATE>
[ with-directory ] curry keep delete-tree ; inline
{
- { [ unix? ] [ "io.unix.files.unique" ] }
- { [ windows? ] [ "io.windows.files.unique" ] }
+ { [ os unix? ] [ "io.unix.files.unique" ] }
+ { [ os windows? ] [ "io.windows.files.unique" ] }
} cond require
diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor
index 8480fcd856..45130c0ab6 100755
--- a/extra/io/sockets/impl/impl.factor
+++ b/extra/io/sockets/impl/impl.factor
@@ -6,8 +6,8 @@ alien.c-types combinators namespaces alien parser ;
IN: io.sockets.impl
<< {
- { [ windows? ] [ "windows.winsock" ] }
- { [ unix? ] [ "unix" ] }
+ { [ os windows? ] [ "windows.winsock" ] }
+ { [ os unix? ] [ "unix" ] }
} cond use+ >>
GENERIC: protocol-family ( addrspec -- af )
diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor
index 0a7fc72662..f6607d98f9 100755
--- a/extra/io/unix/unix.factor
+++ b/extra/io/unix/unix.factor
@@ -2,4 +2,4 @@ USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
io.unix.launcher io.unix.mmap io.backend combinators namespaces
system vocabs.loader sequences ;
-"io.unix." os append require
+"io.unix." os word-name append require
diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor
index 152e76a6c7..b8b024d710 100755
--- a/extra/io/windows/ce/backend/backend.factor
+++ b/extra/io/windows/ce/backend/backend.factor
@@ -37,7 +37,7 @@ M: windows-ce-io (init-stdio) ( -- )
#! We support Windows NT too, to make this I/O backend
#! easier to debug.
512 default-buffer-size [
- winnt? [
+ os winnt? [
STD_INPUT_HANDLE GetStdHandle
STD_OUTPUT_HANDLE GetStdHandle
STD_ERROR_HANDLE GetStdHandle
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index 579745710e..3f230a4ac0 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -82,7 +82,7 @@ TUPLE: CreateProcess-args
: fill-dwCreateFlags ( process args -- process args )
0
pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
- pick detached>> winnt? and [ DETACHED_PROCESS bitor ] when
+ pick detached>> os winnt? and [ DETACHED_PROCESS bitor ] when
pick lookup-priority [ bitor ] when*
>>dwCreateFlags ;
@@ -105,7 +105,7 @@ M: windows-ce-io fill-redirection 2drop ;
: make-CreateProcess-args ( process -- args )
default-CreateProcess-args
- wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
+ os wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
fill-dwCreateFlags
fill-lpEnvironment
fill-startup-info
diff --git a/extra/ogg/ogg.factor b/extra/ogg/ogg.factor
index 830249a3df..9a6997ce29 100644
--- a/extra/ogg/ogg.factor
+++ b/extra/ogg/ogg.factor
@@ -6,9 +6,9 @@ IN: ogg
<<
"ogg" {
- { [ win32? ] [ "ogg.dll" ] }
- { [ macosx? ] [ "libogg.0.dylib" ] }
- { [ unix? ] [ "libogg.so" ] }
+ { [ os win32? ] [ "ogg.dll" ] }
+ { [ os macosx? ] [ "libogg.0.dylib" ] }
+ { [ os unix? ] [ "libogg.so" ] }
} cond "cdecl" add-library
>>
diff --git a/extra/ogg/theora/theora.factor b/extra/ogg/theora/theora.factor
index 48b61b41a3..12d2aa4efb 100644
--- a/extra/ogg/theora/theora.factor
+++ b/extra/ogg/theora/theora.factor
@@ -6,9 +6,9 @@ IN: ogg.theora
<<
"theora" {
- { [ win32? ] [ "theora.dll" ] }
- { [ macosx? ] [ "libtheora.0.dylib" ] }
- { [ unix? ] [ "libtheora.so" ] }
+ { [ os win32? ] [ "theora.dll" ] }
+ { [ os macosx? ] [ "libtheora.0.dylib" ] }
+ { [ os unix? ] [ "libtheora.so" ] }
} cond "cdecl" add-library
>>
diff --git a/extra/ogg/vorbis/vorbis.factor b/extra/ogg/vorbis/vorbis.factor
index 170d0ea6ef..6dbea7869a 100644
--- a/extra/ogg/vorbis/vorbis.factor
+++ b/extra/ogg/vorbis/vorbis.factor
@@ -6,9 +6,9 @@ IN: ogg.vorbis
<<
"vorbis" {
- { [ win32? ] [ "vorbis.dll" ] }
- { [ macosx? ] [ "libvorbis.0.dylib" ] }
- { [ unix? ] [ "libvorbis.so" ] }
+ { [ os win32? ] [ "vorbis.dll" ] }
+ { [ os macosx? ] [ "libvorbis.0.dylib" ] }
+ { [ os unix? ] [ "libvorbis.so" ] }
} cond "cdecl" add-library
>>
diff --git a/extra/openal/openal.factor b/extra/openal/openal.factor
index f7b97d2bf5..e37988a8ce 100644
--- a/extra/openal/openal.factor
+++ b/extra/openal/openal.factor
@@ -7,15 +7,15 @@ USING: kernel alien system combinators alien.syntax namespaces
openal.backend ;
<< "alut" {
- { [ win32? ] [ "alut.dll" ] }
- { [ macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] }
- { [ unix? ] [ "libalut.so" ] }
+ { [ os win32? ] [ "alut.dll" ] }
+ { [ os macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] }
+ { [ os unix? ] [ "libalut.so" ] }
} cond "cdecl" add-library >>
<< "openal" {
- { [ win32? ] [ "OpenAL32.dll" ] }
- { [ macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] }
- { [ unix? ] [ "libopenal.so" ] }
+ { [ os win32? ] [ "OpenAL32.dll" ] }
+ { [ os macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] }
+ { [ os unix? ] [ "libopenal.so" ] }
} cond "cdecl" add-library >>
LIBRARY: openal
@@ -257,7 +257,7 @@ SYMBOL: init
"create-buffer-from-file failed" throw
] when ;
-macosx? "openal.macosx" "openal.other" ? require
+os macosx? "openal.macosx" "openal.other" ? require
: create-buffer-from-wav ( filename -- buffer )
gen-buffer dup rot load-wav-file
diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor
index fd9be4eb12..b0a683dac6 100644
--- a/extra/opengl/gl/extensions/extensions.factor
+++ b/extra/opengl/gl/extensions/extensions.factor
@@ -1,11 +1,13 @@
USING: alien alien.syntax combinators kernel parser sequences
system words namespaces hashtables init math arrays assocs
sequences.lib continuations ;
+
+ERROR: unknown-gl-platform ;
<< {
- { [ windows? ] [ "opengl.gl.windows" ] }
- { [ macosx? ] [ "opengl.gl.macosx" ] }
- { [ unix? ] [ "opengl.gl.unix" ] }
- { [ t ] [ "Unknown OpenGL platform" throw ] }
+ { [ os windows? ] [ "opengl.gl.windows" ] }
+ { [ os macosx? ] [ "opengl.gl.macosx" ] }
+ { [ os unix? ] [ "opengl.gl.unix" ] }
+ { [ t ] [ unknown-gl-platform ] }
} cond use+ >>
IN: opengl.gl.extensions
diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor
index d06afdc5ea..a68cda34ea 100755
--- a/extra/openssl/libcrypto/libcrypto.factor
+++ b/extra/openssl/libcrypto/libcrypto.factor
@@ -11,9 +11,9 @@ IN: openssl.libcrypto
<<
"libcrypto" {
- { [ win32? ] [ "libeay32.dll" "cdecl" ] }
- { [ macosx? ] [ "libcrypto.dylib" "cdecl" ] }
- { [ unix? ] [ "libcrypto.so" "cdecl" ] }
+ { [ os win32? ] [ "libeay32.dll" "cdecl" ] }
+ { [ os macosx? ] [ "libcrypto.dylib" "cdecl" ] }
+ { [ os unix? ] [ "libcrypto.so" "cdecl" ] }
} cond add-library
>>
diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor
index 11dcee31f6..098e1f9382 100755
--- a/extra/openssl/libssl/libssl.factor
+++ b/extra/openssl/libssl/libssl.factor
@@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ;
IN: openssl.libssl
<< "libssl" {
- { [ win32? ] [ "ssleay32.dll" "cdecl" ] }
- { [ macosx? ] [ "libssl.dylib" "cdecl" ] }
- { [ unix? ] [ "libssl.so" "cdecl" ] }
+ { [ os win32? ] [ "ssleay32.dll" "cdecl" ] }
+ { [ os macosx? ] [ "libssl.dylib" "cdecl" ] }
+ { [ os unix? ] [ "libssl.so" "cdecl" ] }
} cond add-library >>
: X509_FILETYPE_PEM 1 ; inline
diff --git a/extra/oracle/liboci/liboci.factor b/extra/oracle/liboci/liboci.factor
index e5313d5b77..6a482b9f56 100644
--- a/extra/oracle/liboci/liboci.factor
+++ b/extra/oracle/liboci/liboci.factor
@@ -12,9 +12,9 @@ USING: alien alien.syntax combinators kernel system ;
IN: oracle.liboci
"oci" {
- { [ win32? ] [ "oci.dll" "stdcall" ] }
- { [ macosx? ] [ "$DYLD_LIBRARY_PATH/libclntsh.dylib" "cdecl" ] }
- { [ unix? ] [ "$DYLD_LIBRARY_PATH/libclntsh.so.10.1" "cdecl" ] }
+ { [ os win32? ] [ "oci.dll" "stdcall" ] }
+ { [ os macosx? ] [ "$DYLD_LIBRARY_PATH/libclntsh.dylib" "cdecl" ] }
+ { [ os unix? ] [ "$DYLD_LIBRARY_PATH/libclntsh.so.10.1" "cdecl" ] }
} cond add-library
! ===============================================
diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor
index f12512f510..893b43844a 100755
--- a/extra/tools/deploy/deploy.factor
+++ b/extra/tools/deploy/deploy.factor
@@ -5,5 +5,5 @@ IN: tools.deploy
: deploy ( vocab -- ) deploy* ;
-macosx? [ "tools.deploy.macosx" require ] when
-winnt? [ "tools.deploy.windows" require ] when
+os macosx? [ "tools.deploy.macosx" require ] when
+os winnt? [ "tools.deploy.windows" require ] when
diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor
index 927f7111fa..5b835cd52f 100755
--- a/extra/tools/disassembler/disassembler.factor
+++ b/extra/tools/disassembler/disassembler.factor
@@ -27,7 +27,7 @@ M: method-spec make-disassemble-cmd
first2 method make-disassemble-cmd ;
: gdb-binary ( -- string )
- os "freebsd" = "gdb66" "gdb" ? ;
+ os freebsd? "gdb66" "gdb" ? ;
: run-gdb ( -- lines )
<process>
diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor
index eca5740bbc..522c26e92e 100755
--- a/extra/ui/tools/deploy/deploy.factor
+++ b/extra/ui/tools/deploy/deploy.factor
@@ -49,7 +49,7 @@ TUPLE: deploy-gadget vocab settings ;
[
bundle-name
deploy-ui
- macosx? [ exit-when-windows-closed ] when
+ os macosx? [ exit-when-windows-closed ] when
io-settings
reflection-settings
advanced-settings
diff --git a/extra/unix/kqueue/kqueue.factor b/extra/unix/kqueue/kqueue.factor
index 55b53bd6d0..50020072c5 100644
--- a/extra/unix/kqueue/kqueue.factor
+++ b/extra/unix/kqueue/kqueue.factor
@@ -3,7 +3,7 @@
USING: alien.syntax system sequences vocabs.loader ;
IN: unix.kqueue
-<< "unix.kqueue." os append require >>
+<< "unix.kqueue." os word-name append require >>
FUNCTION: int kqueue ( ) ;
diff --git a/extra/unix/stat/stat.factor b/extra/unix/stat/stat.factor
index f7432332b9..342047d9af 100644
--- a/extra/unix/stat/stat.factor
+++ b/extra/unix/stat/stat.factor
@@ -60,11 +60,11 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ;
<<
os
{
- { "linux" [ "unix.stat.linux" require ] }
- { "macosx" [ "unix.stat.macosx" require ] }
- { "freebsd" [ "unix.stat.freebsd" require ] }
- { "netbsd" [ "unix.stat.netbsd" require ] }
- { "openbsd" [ "unix.stat.openbsd" require ] }
+ { linux [ "unix.stat.linux" require ] }
+ { macosx [ "unix.stat.macosx" require ] }
+ { freebsd [ "unix.stat.freebsd" require ] }
+ { netbsd [ "unix.stat.netbsd" require ] }
+ { openbsd [ "unix.stat.openbsd" require ] }
}
case
>>
From 28d804d2c4916692b4f2589f0f6223929cda46b9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 18:28:55 -0500
Subject: [PATCH 086/127] remove calendar-backend and use os
---
extra/calendar/backend/backend.factor | 5 ++---
extra/calendar/unix/unix.factor | 9 ++-------
extra/calendar/windows/windows.factor | 8 ++------
3 files changed, 6 insertions(+), 16 deletions(-)
diff --git a/extra/calendar/backend/backend.factor b/extra/calendar/backend/backend.factor
index 01c36c65ae..56ccf9e6cc 100644
--- a/extra/calendar/backend/backend.factor
+++ b/extra/calendar/backend/backend.factor
@@ -1,5 +1,4 @@
-USING: kernel ;
+USING: kernel system ;
IN: calendar.backend
-SYMBOL: calendar-backend
-HOOK: gmt-offset calendar-backend ( -- hours minutes seconds )
+HOOK: gmt-offset os ( -- hours minutes seconds )
diff --git a/extra/calendar/unix/unix.factor b/extra/calendar/unix/unix.factor
index 2877fa07b5..6383d4ec42 100644
--- a/extra/calendar/unix/unix.factor
+++ b/extra/calendar/unix/unix.factor
@@ -1,17 +1,12 @@
USING: alien alien.c-types arrays calendar.backend
-kernel structs math unix.time namespaces ;
-
+kernel structs math unix.time namespaces system ;
IN: calendar.unix
-TUPLE: unix-calendar ;
-
-T{ unix-calendar } calendar-backend set-global
-
: get-time ( -- alien )
f time <uint> localtime ;
: timezone-name ( -- string )
get-time tm-zone ;
-M: unix-calendar gmt-offset ( -- hours minutes seconds )
+M: unix gmt-offset ( -- hours minutes seconds )
get-time tm-gmtoff 3600 /mod 60 /mod ;
diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor
index 8548e4ee52..2986422155 100755
--- a/extra/calendar/windows/windows.factor
+++ b/extra/calendar/windows/windows.factor
@@ -1,12 +1,8 @@
-USING: calendar.backend namespaces alien.c-types
+USING: calendar.backend namespaces alien.c-types system
windows windows.kernel32 kernel math combinators ;
IN: calendar.windows
-TUPLE: windows-calendar ;
-
-T{ windows-calendar } calendar-backend set-global
-
-M: windows-calendar gmt-offset ( -- hours minutes seconds )
+M: windows gmt-offset ( -- hours minutes seconds )
"TIME_ZONE_INFORMATION" <c-object>
dup GetTimeZoneInformation {
{ [ dup TIME_ZONE_ID_INVALID = ] [ win32-error-string throw ] }
From 5db2e8570aef4582a1d62aa3a42e2b3c9b61ff5b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 18:30:52 -0500
Subject: [PATCH 087/127] change editors.gvim to use the os singletons
---
extra/editors/gvim/unix/unix.factor | 5 +++--
extra/editors/gvim/windows/windows.factor | 4 ++--
2 files changed, 5 insertions(+), 4 deletions(-)
diff --git a/extra/editors/gvim/unix/unix.factor b/extra/editors/gvim/unix/unix.factor
index a7de09c013..3b8f7454c1 100644
--- a/extra/editors/gvim/unix/unix.factor
+++ b/extra/editors/gvim/unix/unix.factor
@@ -1,7 +1,8 @@
-USING: io.unix.backend kernel namespaces editors.gvim.backend ;
+USING: io.unix.backend kernel namespaces editors.gvim.backend
+system ;
IN: editors.gvim.unix
-M: unix-io gvim-path
+M: unix gvim-path
\ gvim-path get-global [
"gvim"
] unless* ;
diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor
index 489000498e..daf5409c94 100755
--- a/extra/editors/gvim/windows/windows.factor
+++ b/extra/editors/gvim/windows/windows.factor
@@ -1,8 +1,8 @@
USING: editors.gvim.backend io.files io.windows kernel namespaces
-sequences windows.shell32 io.paths ;
+sequences windows.shell32 io.paths system ;
IN: editors.gvim.windows
-M: windows-io gvim-path
+M: windows gvim-path
\ gvim-path get-global [
program-files "vim" append-path
t [ "gvim.exe" tail? ] find-file
From 8fde3fb914f178fbe6c2e48077a947640e98a6dc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 18:50:21 -0500
Subject: [PATCH 088/127] More inheritance debugging
---
core/bootstrap/image/image.factor | 1 +
core/bootstrap/primitives.factor | 100 ++++++++++--------
core/bootstrap/stage1.factor | 1 -
core/classes/algebra/algebra.factor | 10 +-
core/classes/classes.factor | 10 +-
core/classes/tuple/tuple-tests.factor | 4 +-
core/generic/generic-docs.factor | 7 +-
core/generic/generic-tests.factor | 31 ------
core/generic/generic.factor | 43 ++++----
core/generic/math/math.factor | 4 +-
.../engines/predicate/predicate.factor | 4 +
core/generic/standard/engines/tag/tag.factor | 32 ++++--
.../standard/engines/tuple/tuple.factor | 37 +++++--
core/generic/standard/standard.factor | 39 +++----
core/kernel/kernel.factor | 2 +-
core/words/words.factor | 5 +-
16 files changed, 174 insertions(+), 156 deletions(-)
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index fc963683b6..f0d9b77981 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -444,6 +444,7 @@ PRIVATE>
"resource:/core/bootstrap/stage1.factor" run-file
build-image
write-image
+ \ word-props target-word
] with-scope ;
: make-images ( -- )
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 48a1117574..6c4462ed98 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -31,6 +31,7 @@ crossref off
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
H{ } clone changed-words set
+H{ } clone forgotten-definitions set
H{ } clone root-cache set
H{ } clone source-files set
H{ } clone update-map set
@@ -126,27 +127,49 @@ num-types get f <array> builtins set
: register-builtin ( class -- )
[ dup lookup-type-number "type" set-word-prop ]
[ dup "type" word-prop builtins get set-nth ]
- bi ;
+ [ f f builtin-class define-class ]
+ tri ;
: define-builtin-slots ( symbol slotspec -- )
[ drop ] [ 1 simple-slots ] 2bi
[ "slots" set-word-prop ] [ define-slots ] 2bi ;
: define-builtin ( symbol slotspec -- )
- >r
- {
- [ register-builtin ]
- [ f f builtin-class define-class ]
- [ define-builtin-predicate ]
- [ ]
- } cleave
+ >r [ define-builtin-predicate ] keep
r> define-builtin-slots ;
-! Forward definitions
-"object" "kernel" create t "class" set-word-prop
-"object" "kernel" create union-class "metaclass" set-word-prop
+"fixnum" "math" create register-builtin
+"bignum" "math" create register-builtin
+"tuple" "kernel" create register-builtin
+"ratio" "math" create register-builtin
+"float" "math" create register-builtin
+"complex" "math" create register-builtin
+"f" "syntax" lookup register-builtin
+"array" "arrays" create register-builtin
+"wrapper" "kernel" create register-builtin
+"float-array" "float-arrays" create register-builtin
+"callstack" "kernel" create register-builtin
+"string" "strings" create register-builtin
+"bit-array" "bit-arrays" create register-builtin
+"quotation" "quotations" create register-builtin
+"dll" "alien" create register-builtin
+"alien" "alien" create register-builtin
+"word" "words" create register-builtin
+"byte-array" "byte-arrays" create register-builtin
+"tuple-layout" "classes.tuple.private" create register-builtin
-"null" "kernel" create drop
+! Catch-all class for providing a default method.
+"object" "kernel" create [ drop t ] "predicate" set-word-prop
+"object" "kernel" create
+f builtins get [ ] subset union-class define-class
+
+! Class of objects with object tag
+"hi-tag" "kernel.private" create
+f builtins get num-tags get tail union-class define-class
+
+! Empty class with no instances
+"null" "kernel" create [ drop f ] "predicate" set-word-prop
+"null" "kernel" create f { } union-class define-class
"fixnum" "math" create { } define-builtin
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
@@ -335,23 +358,25 @@ define-builtin
}
} define-builtin
-"tuple" "kernel" create { } define-builtin
-
-"tuple" "kernel" lookup
-{
- {
- { "object" "kernel" }
- "delegate"
- { "delegate" "kernel" }
- { "set-delegate" "kernel" }
- }
-}
-[ drop ] [ generate-tuple-slots ] 2bi
-[ [ name>> ] map "slot-names" set-word-prop ]
-[ "slots" set-word-prop ]
-[ define-slots ] 2tri
-
-"tuple" "kernel" lookup define-tuple-layout
+"tuple" "kernel" create {
+ [ { } define-builtin ]
+ [ { "delegate" } "slot-names" set-word-prop ]
+ [ define-tuple-layout ]
+ [
+ {
+ {
+ { "object" "kernel" }
+ "delegate"
+ { "delegate" "kernel" }
+ { "set-delegate" "kernel" }
+ }
+ }
+ [ drop ] [ generate-tuple-slots ] 2bi
+ [ "slots" set-word-prop ]
+ [ define-slots ]
+ 2bi
+ ]
+} cleave
! Define general-t type, which is any object that is not f.
"general-t" "kernel" create
@@ -359,23 +384,10 @@ f "f" "syntax" lookup builtins get remove [ ] subset union-class
define-class
"f" "syntax" create [ not ] "predicate" set-word-prop
-"f?" "syntax" create "syntax" vocab-words delete-at
+"f?" "syntax" vocab-words delete-at
"general-t" "kernel" create [ ] "predicate" set-word-prop
-"general-t?" "kernel" create "syntax" vocab-words delete-at
-
-! Catch-all class for providing a default method.
-"object" "kernel" create [ drop t ] "predicate" set-word-prop
-"object" "kernel" create
-f builtins get [ ] subset union-class define-class
-
-! Class of objects with object tag
-"hi-tag" "kernel.private" create
-f builtins get num-tags get tail union-class define-class
-
-! Null class with no instances.
-"null" "kernel" create [ drop f ] "predicate" set-word-prop
-"null" "kernel" create f { } union-class define-class
+"general-t?" "kernel" vocab-words delete-at
! Create special tombstone values
"tombstone" "hashtables.private" create
diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor
index 34f758c9df..f99c8eb82f 100755
--- a/core/bootstrap/stage1.factor
+++ b/core/bootstrap/stage1.factor
@@ -19,7 +19,6 @@ vocabs.loader system debugger continuations ;
! Rehash hashtables, since bootstrap.image creates them
! using the host image's hashing algorithms
[ hashtable? ] instances [ rehash ] each
-
boot
] %
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index 5d7c114cbc..97309dbea2 100755
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables
-;
+kernel.private ;
IN: classes.algebra
: 2cache ( key1 key2 assoc quot -- value )
@@ -211,12 +211,6 @@ C: <anonymous-complement> anonymous-complement
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
-: class-hashes ( class -- seq )
- flatten-class keys [
- dup builtin-class?
- [ "type" word-prop ] [ hashcode ] if
- ] map ;
-
: flatten-builtin-class ( class -- assoc )
flatten-class [
dup tuple class< [ 2drop tuple tuple ] when
@@ -229,5 +223,5 @@ C: <anonymous-complement> anonymous-complement
: class-tags ( class -- tag/f )
class-types [
dup num-tags get >=
- [ drop object tag-number ] when
+ [ drop \ hi-tag tag-number ] when
] map prune ;
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 914e070e03..0baf235edb 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -25,9 +25,11 @@ SYMBOL: class-or-cache
class-and-cache get clear-assoc
class-or-cache get clear-assoc ;
-PREDICATE: class < word ( obj -- ? ) "class" word-prop ;
-
SYMBOL: update-map
+
+PREDICATE: class < word
+ "class" word-prop ;
+
SYMBOL: builtins
PREDICATE: builtin-class < class
@@ -58,7 +60,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
dup class? [ "superclass" word-prop ] [ drop f ] if ;
: superclasses ( class -- supers )
- [ dup ] [ dup superclass swap ] [ ] unfold reverse nip ;
+ [ dup ] [ [ superclass ] keep ] [ ] unfold nip reverse ;
: members ( class -- seq )
#! Output f for non-classes to work with algebra code
@@ -72,7 +74,7 @@ M: word reset-class drop ;
! update-map
: class-uses ( class -- seq )
- dup members swap superclass [ suffix ] when* ;
+ [ members ] [ superclass ] bi [ suffix ] when* ;
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 228de8aabf..ff34c25416 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -394,7 +394,9 @@ test-server-slot-values
! Reshape crash
TUPLE: test1 a ; TUPLE: test2 < test1 b ;
-T{ test2 f "a" "b" } "test" set
+C: <test2> test2
+
+"a" "b" <test2> "test" set
: test-a/b
[ "a" ] [ "test" get a>> ] unit-test
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 100475455a..04252b6b3b 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -37,7 +37,6 @@ $nl
{ $subsection create-method }
"Method definitions can be looked up:"
{ $subsection method }
-{ $subsection methods }
"A generic word contains methods; the list of methods specializing on a class can also be obtained:"
{ $subsection implementors }
"Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
@@ -120,10 +119,6 @@ HELP: <method>
{ $values { "class" class } { "generic" generic } { "method" "a new method definition" } }
{ $description "Creates a new method." } ;
-HELP: methods
-{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
-{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
-
HELP: order
{ $values { "generic" generic } { "seq" "a sequence of classes" } }
{ $description "Outputs a sequence of classes for which methods have been defined on this generic word. The sequence is sorted in method dispatch order." } ;
@@ -151,4 +146,4 @@ HELP: forget-methods
{ $values { "class" class } }
{ $description "Remove all method definitions which specialize on the class." } ;
-{ sort-classes methods order } related-words
+{ sort-classes order } related-words
diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor
index 6a7f8f29fc..fd313d8165 100755
--- a/core/generic/generic-tests.factor
+++ b/core/generic/generic-tests.factor
@@ -171,37 +171,6 @@ M: f tag-and-f 4 ;
[ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
-! define-class hashing issue
-TUPLE: debug-combination ;
-
-M: debug-combination make-default-method
- 2drop [ "Oops" throw ] ;
-
-M: debug-combination perform-combination
- drop
- order [ dup class-hashes ] { } map>assoc sort-keys
- 1quotation ;
-
-SYMBOL: redefinition-test-generic
-
-[
- redefinition-test-generic
- T{ debug-combination }
- define-generic
-] with-compilation-unit
-
-TUPLE: redefinition-test-tuple ;
-
-"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval
-
-[ t ] [
- [
- redefinition-test-generic ,
- "IN: generic.tests TUPLE: redefinition-test-tuple ;" eval
- redefinition-test-generic ,
- ] { } make all-equal?
-] unit-test
-
! Issues with forget
GENERIC: generic-forget-test-1
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index dc98883654..2ec285146e 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -25,8 +25,9 @@ PREDICATE: generic < word
M: generic definition drop f ;
: make-generic ( word -- )
- dup { "unannotated-def" } reset-props
- dup dup "combination" word-prop perform-combination define ;
+ [ { "unannotated-def" } reset-props ]
+ [ dup "combination" word-prop perform-combination ]
+ bi ;
: method ( class generic -- method/f )
"methods" word-prop at ;
@@ -37,13 +38,6 @@ PREDICATE: method-spec < pair
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
-: sort-methods ( assoc -- assoc' )
- [ keys sort-classes ]
- [ [ dupd at ] curry ] bi { } map>assoc ;
-
-: methods ( word -- assoc )
- "methods" word-prop sort-methods ;
-
TUPLE: check-method class generic ;
: check-method ( class generic -- class generic )
@@ -64,6 +58,9 @@ PREDICATE: method-body < word
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
+M: method-body crossref?
+ drop t ;
+
: method-word-props ( class generic -- assoc )
[
"method-generic" set
@@ -122,9 +119,12 @@ M: method-body definer
M: method-body forget*
dup "forgotten" word-prop [ drop ] [
- dup "method-class" word-prop
- over "method-generic" word-prop forget-method
- t "forgotten" set-word-prop
+ [
+ [ "method-class" word-prop ]
+ [ "method-generic" word-prop ] bi
+ forget-method
+ ]
+ [ t "forgotten" set-word-prop ] bi
] if ;
: implementors* ( classes -- words )
@@ -137,12 +137,13 @@ M: method-body forget*
dup associate implementors* ;
: forget-methods ( class -- )
- [ implementors ] keep [ swap 2array ] curry map forget-all ;
+ [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
M: class forget* ( class -- )
- dup forget-methods
- dup update-map-
- forget-word ;
+ [ forget-methods ]
+ [ update-map- ]
+ [ forget-word ]
+ tri ;
M: assoc update-methods ( assoc -- )
implementors* [ make-generic ] each ;
@@ -158,11 +159,15 @@ M: assoc update-methods ( assoc -- )
] if ;
M: generic subwords
- dup "methods" word-prop values
- swap "default-method" word-prop suffix ;
+ [
+ [ "default-method" word-prop , ]
+ [ "methods" word-prop values % ]
+ [ "engines" word-prop % ]
+ tri
+ ] { } make ;
M: generic forget-word
- dup subwords [ forget ] each (forget-word) ;
+ [ subwords forget-all ] [ (forget-word) ] bi ;
: xref-generics ( -- )
all-words [ subwords [ xref ] each ] each ;
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 85bd736139..2fda2c9621 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -71,13 +71,15 @@ M: math-combination make-default-method
M: math-combination perform-combination
drop
+ dup
\ over [
dup math-class? [
\ dup [ >r 2dup r> math-method ] math-vtable
] [
over object-method
] if nip
- ] math-vtable nip ;
+ ] math-vtable nip
+ define ;
PREDICATE: math-generic < generic ( word -- ? )
"combination" word-prop math-combination? ;
diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor
index 2d43a313f0..ce7d5c6c21 100644
--- a/core/generic/standard/engines/predicate/predicate.factor
+++ b/core/generic/standard/engines/predicate/predicate.factor
@@ -21,6 +21,10 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
{ [ t ] [ [ first second ] [ 1 tail-slice ] bi ] }
} cond ;
+: sort-methods ( assoc -- assoc' )
+ [ keys sort-classes ]
+ [ [ dupd at ] curry ] bi { } map>assoc ;
+
M: predicate-dispatch-engine engine>quot
methods>> clone
default get object bootstrap-word pick set-at engines>quots
diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
index 3dd8b83579..6344bec536 100644
--- a/core/generic/standard/engines/tag/tag.factor
+++ b/core/generic/standard/engines/tag/tag.factor
@@ -1,26 +1,27 @@
USING: classes.private generic.standard.engines namespaces
arrays assocs sequences.private quotations kernel.private
-layouts math slots.private math.private kernel accessors ;
+math slots.private math.private kernel accessors words
+layouts ;
IN: generic.standard.engines.tag
TUPLE: lo-tag-dispatch-engine methods ;
C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
-TUPLE: hi-tag-dispatch-engine methods ;
-
-C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
-
-: convert-hi-tag-methods ( assoc -- assoc' )
- \ hi-tag \ <hi-tag-dispatch-engine> convert-methods ;
-
: direct-dispatch-quot ( alist n -- quot )
default get <array>
[ <enum> swap update ] keep
[ dispatch ] curry >quotation ;
+: lo-tag-number ( class -- n )
+ dup \ hi-tag bootstrap-word eq? [
+ drop \ hi-tag tag-number
+ ] [
+ "type" word-prop
+ ] if ;
+
M: lo-tag-dispatch-engine engine>quot
- methods>> engines>quots* [ >r tag-number r> ] assoc-map
+ methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map
[
picker % [ tag ] % [
linear-dispatch-quot
@@ -29,12 +30,21 @@ M: lo-tag-dispatch-engine engine>quot
] if-small? %
] [ ] make ;
+TUPLE: hi-tag-dispatch-engine methods ;
+
+C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
+
+: convert-hi-tag-methods ( assoc -- assoc' )
+ \ hi-tag bootstrap-word
+ \ <hi-tag-dispatch-engine> convert-methods ;
+
: num-hi-tags num-types get num-tags get - ;
-: hi-tag-number type-number num-tags get - ;
+: hi-tag-number ( class -- n )
+ "type" word-prop num-tags get - ;
: hi-tag-quot ( -- quot )
- [ 0 slot ] num-tags get [ fixnum- ] curry compose ;
+ [ hi-tag ] num-tags get [ fixnum-fast ] curry compose ;
M: hi-tag-dispatch-engine engine>quot
methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
index ce0f50337d..510d5ef732 100644
--- a/core/generic/standard/engines/tuple/tuple.factor
+++ b/core/generic/standard/engines/tuple/tuple.factor
@@ -2,7 +2,7 @@ IN: generic.standard.engines.tuple
USING: kernel classes.tuple.private hashtables assocs sorting
accessors combinators sequences slots.private math.parser words
effects namespaces generic generic.standard.engines
-classes.algebra math math.private quotations ;
+classes.algebra math math.private quotations arrays ;
TUPLE: echelon-dispatch-engine n methods ;
@@ -27,17 +27,25 @@ TUPLE: tuple-dispatch-engine echelons ;
: <tuple-dispatch-engine> ( methods -- engine )
echelon-sort
- [ dupd <echelon-dispatch-engine> ] assoc-map
+ [
+ over zero? [
+ dup assoc-empty?
+ [ drop f ] [ values first ] if
+ ] [
+ dupd <echelon-dispatch-engine>
+ ] if
+ ] assoc-map [ nip ] assoc-subset
\ tuple-dispatch-engine construct-boa ;
: convert-tuple-methods ( assoc -- assoc' )
- tuple \ <tuple-dispatch-engine> convert-methods ;
+ tuple bootstrap-word
+ \ <tuple-dispatch-engine> convert-methods ;
M: trivial-tuple-dispatch-engine engine>quot
methods>> engines>quots* linear-dispatch-quot ;
: hash-methods ( methods -- buckets )
- >alist V{ } clone [ class-hashes ] distribute-buckets
+ >alist V{ } clone [ hashcode 1array ] distribute-buckets
[ <trivial-tuple-dispatch-engine> ] map ;
: class-hash-dispatch-quot ( methods -- quot )
@@ -60,12 +68,20 @@ PREDICATE: tuple-dispatch-engine-word < word
M: tuple-dispatch-engine-word stack-effect
"tuple-dispatch-generic" word-prop stack-effect ;
+M: tuple-dispatch-engine-word crossref?
+ drop t ;
+
+: remember-engine ( word -- )
+ generic get "engines" word-prop push ;
+
: <tuple-dispatch-engine-word> ( engine -- word )
tuple-dispatch-engine-word-name f <word>
- [ t "tuple-dispatch-engine" set-word-prop ]
- [ generic get "tuple-dispatch-generic" set-word-prop ]
- [ ]
- tri ;
+ {
+ [ t "tuple-dispatch-engine" set-word-prop ]
+ [ generic get "tuple-dispatch-generic" set-word-prop ]
+ [ remember-engine ]
+ [ ]
+ } cleave ;
: define-tuple-dispatch-engine-word ( engine quot -- word )
>r <tuple-dispatch-engine-word> dup r> define ;
@@ -104,6 +120,9 @@ M: tuple-dispatch-engine engine>quot
picker %
[ 1 slot 5 slot ] %
echelons>>
- [ [ engine>quot dup default set ] assoc-map ] with-scope
+ [
+ tuple assumed set
+ [ engine>quot dup default set ] assoc-map
+ ] with-scope
>=-case-quot %
] [ ] make ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 1de41f24ed..0d29bdecd5 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -59,29 +59,32 @@ ERROR: no-method object generic ;
: find-default ( methods -- quot )
#! Side-effects methods.
- object swap delete-at* [
+ object bootstrap-word swap delete-at* [
drop generic get "default-method" word-prop 1quotation
] unless ;
GENERIC: mangle-method ( method generic -- quot )
-: single-combination ( words -- quot )
+: single-combination ( word -- quot )
[
- object bootstrap-word assumed set
- [ generic set ]
- [
- "methods" word-prop
- [ generic get mangle-method ] assoc-map
- [ find-default default set ]
+ object bootstrap-word assumed set {
+ [ generic set ]
+ [ "engines" word-prop forget-all ]
+ [ V{ } clone "engines" set-word-prop ]
[
- generic get "inline" word-prop [
- <predicate-dispatch-engine>
- ] [
- <big-dispatch-engine>
- ] if
- ] bi
- engine>quot
- ] bi
+ "methods" word-prop
+ [ generic get mangle-method ] assoc-map
+ [ find-default default set ]
+ [
+ generic get "inline" word-prop [
+ <predicate-dispatch-engine>
+ ] [
+ <big-dispatch-engine>
+ ] if
+ ] bi
+ engine>quot
+ ]
+ } cleave
] with-scope ;
TUPLE: standard-combination # ;
@@ -107,7 +110,7 @@ M: standard-combination make-default-method
[ empty-method ] with-standard ;
M: standard-combination perform-combination
- [ single-combination ] with-standard ;
+ [ drop ] [ [ single-combination ] with-standard ] 2bi define ;
TUPLE: hook-combination var ;
@@ -128,7 +131,7 @@ M: hook-combination make-default-method
[ error-method ] with-hook ;
M: hook-combination perform-combination
- [ single-combination ] with-hook ;
+ [ drop ] [ [ single-combination ] with-hook ] 2bi define ;
GENERIC: dispatch# ( word -- n )
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index eed5b22e5f..ae775ec116 100755
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -194,7 +194,7 @@ GENERIC: construct-boa ( ... class -- tuple )
<PRIVATE
-: hi-tag ( obj -- n ) 0 slot ;
+: hi-tag ( obj -- n ) 0 slot ; inline
: declare ( spec -- ) drop ;
diff --git a/core/words/words.factor b/core/words/words.factor
index 5c0d84d4cc..a45e1627e9 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -63,10 +63,11 @@ SYMBOL: bootstrapping?
: bootstrap-word ( word -- target )
[ target-word ] [ ] if-bootstrapping ;
-: crossref? ( word -- ? )
+GENERIC: crossref? ( word -- ? )
+
+M: word crossref?
{
{ [ dup "forgotten" word-prop ] [ f ] }
- { [ dup "method-generic" word-prop ] [ t ] }
{ [ dup word-vocabulary ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;
From 7cd21081af327a06b267278806e245cc68f9ff52 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 18:50:35 -0500
Subject: [PATCH 089/127] Don't JIT inside heap scan loop, too fragile
---
vm/data_gc.c | 1 -
vm/factor.c | 24 +++++++++++++++++++-----
vm/run.c | 7 +++++--
3 files changed, 24 insertions(+), 8 deletions(-)
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 0a1fad575a..24f7cfecb9 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -730,7 +730,6 @@ void garbage_collection(CELL gen,
/* collect objects referenced from stacks and environment */
collect_roots();
-
/* collect objects referenced from older generations */
collect_cards();
diff --git a/vm/factor.c b/vm/factor.c
index 20667a23f5..5825f97bdd 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -36,22 +36,36 @@ void do_stage1_init(void)
fprintf(stderr,"*** Stage 2 early init... ");
fflush(stderr);
+ GROWABLE_ARRAY(words);
+
begin_scan();
CELL obj;
while((obj = next_object()) != F)
{
if(type_of(obj) == WORD_TYPE)
- {
- F_WORD *word = untag_object(obj);
- default_word_code(word,false);
- update_word_xt(word);
- }
+ GROWABLE_ADD(words,obj);
}
/* End heap scan */
gc_off = false;
+ GROWABLE_TRIM(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);
userenv[STAGE2_ENV] = T;
diff --git a/vm/run.c b/vm/run.c
index d03d999ffd..cec19b5445 100755
--- a/vm/run.c
+++ b/vm/run.c
@@ -22,8 +22,11 @@ void fix_stacks(void)
be stored in registers, so callbacks must save and restore the correct values */
void save_stacks(void)
{
- stack_chain->datastack = ds;
- stack_chain->retainstack = rs;
+ if(stack_chain)
+ {
+ stack_chain->datastack = ds;
+ stack_chain->retainstack = rs;
+ }
}
/* called on entry into a compiled callback */
From 93ebbfb7e4e39835d06daf2582044d73facda692 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 18:50:42 -0500
Subject: [PATCH 090/127] Try to fix inotify again
---
extra/io/unix/linux/linux.factor | 17 +++++++++++------
1 file changed, 11 insertions(+), 6 deletions(-)
diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor
index 2ae4065fb6..0c79ce970d 100755
--- a/extra/io/unix/linux/linux.factor
+++ b/extra/io/unix/linux/linux.factor
@@ -24,8 +24,10 @@ TUPLE: inotify watches ;
: <inotify> ( -- port/f )
H{ } clone
- inotify_init [ io-error ] [ inotify <buffered-port> ] bi
- { set-inotify-watches set-delegate } inotify construct ;
+ inotify_init dup 0 < [ 2drop f ] [
+ inotify <buffered-port>
+ { set-inotify-watches set-delegate } inotify construct
+ ] if ;
: inotify-fd inotify get-global handle>> ;
@@ -109,9 +111,12 @@ TUPLE: inotify-task ;
f inotify-task <input-task> ;
: init-inotify ( mx -- )
- <inotify>
- dup inotify set-global
- <inotify-task> swap register-io-task ;
+ <inotify> dup [
+ dup inotify set-global
+ <inotify-task> swap register-io-task
+ ] [
+ 2drop
+ ] if ;
M: inotify-task do-io-task ( task -- )
io-task-port read-notifications f ;
@@ -119,7 +124,7 @@ M: inotify-task do-io-task ( task -- )
M: linux-io init-io ( -- )
<select-mx>
[ mx set-global ]
- [ [ init-inotify ] curry ignore-errors ] bi ;
+ [ init-inotify ] bi ;
T{ linux-io } set-io-backend
From a9cd31704daa40b2d5a013613f2f39d9de59d7a9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 18:53:24 -0500
Subject: [PATCH 091/127] remove win32? and win64? words
---
core/alien/c-types/c-types.factor | 2 +-
core/system/system-docs.factor | 10 --------
core/system/system.factor | 8 ------
extra/cairo/ffi/ffi.factor | 4 +--
extra/db/mysql/ffi/ffi.factor | 2 +-
extra/db/postgresql/ffi/ffi.factor | 2 +-
extra/ogg/ogg.factor | 2 +-
extra/ogg/theora/theora.factor | 2 +-
extra/ogg/vorbis/vorbis.factor | 2 +-
extra/openal/backend/backend.factor | 8 ++----
extra/openal/macosx/macosx.factor | 32 +++++++++++-------------
extra/openal/openal.factor | 16 ++++++------
extra/openal/other/other.factor | 28 ++++++++++-----------
extra/openssl/libcrypto/libcrypto.factor | 2 +-
extra/openssl/libssl/libssl.factor | 2 +-
extra/oracle/liboci/liboci.factor | 2 +-
16 files changed, 49 insertions(+), 75 deletions(-)
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index ae99f9e6bf..ca1a89b4ae 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -388,6 +388,6 @@ M: long-long-type box-return ( type -- )
[ string>u16-alien ] "ushort*" c-type set-c-type-prep
- win64? "longlong" "long" ? "ptrdiff_t" typedef
+ os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
] with-compilation-unit
diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor
index 9124efcb8c..9d25ee1138 100755
--- a/core/system/system-docs.factor
+++ b/core/system/system-docs.factor
@@ -5,8 +5,6 @@ IN: system
ARTICLE: "os" "System interface"
"Operating system detection:"
{ $subsection os }
-{ $subsection win32? }
-{ $subsection win64? }
"Processor detection:"
{ $subsection cpu }
"Reading environment variables:"
@@ -86,14 +84,6 @@ HELP: set-os-envs
{ os-env os-envs set-os-envs } related-words
-HELP: win32?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on 32-bit Windows." } ;
-
-HELP: win64?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on 64-bit Windows." } ;
-
HELP: image
{ $values { "path" "a pathname string" } }
{ $description "Outputs the pathname of the currently running Factor image." } ;
diff --git a/core/system/system.factor b/core/system/system.factor
index 00b3f87e98..98dc605acc 100755
--- a/core/system/system.factor
+++ b/core/system/system.factor
@@ -64,14 +64,6 @@ PRIVATE>
: vm ( -- path ) 14 getenv ;
-: win32? ( -- ? )
- os winnt?
- cell 4 = and ; foldable
-
-: win64? ( -- ? )
- os winnt?
- cell 8 = and ; foldable
-
: embedded? ( -- ? ) 15 getenv ;
: os-envs ( -- assoc )
diff --git a/extra/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor
index dd4faf9f96..200c85c929 100644
--- a/extra/cairo/ffi/ffi.factor
+++ b/extra/cairo/ffi/ffi.factor
@@ -7,13 +7,11 @@
! - most of the matrix stuff
! - most of the query functions
-
USING: alien alien.syntax combinators system ;
-
IN: cairo.ffi
<< "cairo" {
- { [ os win32? ] [ "libcairo-2.dll" ] }
+ { [ os winnt? ] [ "libcairo-2.dll" ] }
! { [ os macosx? ] [ "libcairo.dylib" ] }
{ [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
{ [ os unix? ] [ "libcairo.so.2" ] }
diff --git a/extra/db/mysql/ffi/ffi.factor b/extra/db/mysql/ffi/ffi.factor
index 424cc7c754..c047393c99 100644
--- a/extra/db/mysql/ffi/ffi.factor
+++ b/extra/db/mysql/ffi/ffi.factor
@@ -6,7 +6,7 @@ USING: alien alien.syntax combinators kernel system ;
IN: db.mysql.ffi
<< "mysql" {
- { [ os win32? ] [ "libmySQL.dll" "stdcall" ] }
+ { [ os winnt? ] [ "libmySQL.dll" "stdcall" ] }
{ [ os macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] }
{ [ os unix? ] [ "libmysqlclient.so.14" "cdecl" ] }
} cond add-library >>
diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor
index b6aee3dcce..7925989bf5 100755
--- a/extra/db/postgresql/ffi/ffi.factor
+++ b/extra/db/postgresql/ffi/ffi.factor
@@ -5,7 +5,7 @@ USING: alien alien.syntax combinators system ;
IN: db.postgresql.ffi
<< "postgresql" {
- { [ os win32? ] [ "libpq.dll" ] }
+ { [ os winnt? ] [ "libpq.dll" ] }
{ [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] }
{ [ os unix? ] [ "libpq.so" ] }
} cond "cdecl" add-library >>
diff --git a/extra/ogg/ogg.factor b/extra/ogg/ogg.factor
index 9a6997ce29..37dd30f7fd 100644
--- a/extra/ogg/ogg.factor
+++ b/extra/ogg/ogg.factor
@@ -6,7 +6,7 @@ IN: ogg
<<
"ogg" {
- { [ os win32? ] [ "ogg.dll" ] }
+ { [ os winnt? ] [ "ogg.dll" ] }
{ [ os macosx? ] [ "libogg.0.dylib" ] }
{ [ os unix? ] [ "libogg.so" ] }
} cond "cdecl" add-library
diff --git a/extra/ogg/theora/theora.factor b/extra/ogg/theora/theora.factor
index 12d2aa4efb..3d73fb8820 100644
--- a/extra/ogg/theora/theora.factor
+++ b/extra/ogg/theora/theora.factor
@@ -6,7 +6,7 @@ IN: ogg.theora
<<
"theora" {
- { [ os win32? ] [ "theora.dll" ] }
+ { [ os winnt? ] [ "theora.dll" ] }
{ [ os macosx? ] [ "libtheora.0.dylib" ] }
{ [ os unix? ] [ "libtheora.so" ] }
} cond "cdecl" add-library
diff --git a/extra/ogg/vorbis/vorbis.factor b/extra/ogg/vorbis/vorbis.factor
index 6dbea7869a..5712272ebc 100644
--- a/extra/ogg/vorbis/vorbis.factor
+++ b/extra/ogg/vorbis/vorbis.factor
@@ -6,7 +6,7 @@ IN: ogg.vorbis
<<
"vorbis" {
- { [ os win32? ] [ "vorbis.dll" ] }
+ { [ os winnt? ] [ "vorbis.dll" ] }
{ [ os macosx? ] [ "libvorbis.0.dylib" ] }
{ [ os unix? ] [ "libvorbis.so" ] }
} cond "cdecl" add-library
diff --git a/extra/openal/backend/backend.factor b/extra/openal/backend/backend.factor
index edbb227fcc..41069dcddf 100644
--- a/extra/openal/backend/backend.factor
+++ b/extra/openal/backend/backend.factor
@@ -1,8 +1,4 @@
-USING: namespaces ;
+USING: namespaces system ;
IN: openal.backend
-SYMBOL: openal-backend
-HOOK: load-wav-file openal-backend ( filename -- format data size frequency )
-
-TUPLE: other-openal-backend ;
-T{ other-openal-backend } openal-backend set-global
+HOOK: load-wav-file os ( filename -- format data size frequency )
diff --git a/extra/openal/macosx/macosx.factor b/extra/openal/macosx/macosx.factor
index 7828021f53..c03ad5693c 100644
--- a/extra/openal/macosx/macosx.factor
+++ b/extra/openal/macosx/macosx.factor
@@ -1,18 +1,14 @@
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-IN: openal.macosx
-USING: alien.c-types kernel alien alien.syntax shuffle
-combinators.lib openal.backend namespaces ;
-
-TUPLE: macosx-openal-backend ;
-LIBRARY: alut
-
-T{ macosx-openal-backend } openal-backend set-global
-
-FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
-
-M: macosx-openal-backend load-wav-file ( path -- format data size frequency )
- 0 <int> f <void*> 0 <int> 0 <int>
- [ alutLoadWAVFile ] 4keep
- >r >r >r *int r> *void* r> *int r> *int ;
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types kernel alien alien.syntax shuffle
+combinators.lib openal.backend namespaces ;
+IN: openal.macosx
+
+LIBRARY: alut
+
+FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
+
+M: macosx load-wav-file ( path -- format data size frequency )
+ 0 <int> f <void*> 0 <int> 0 <int>
+ [ alutLoadWAVFile ] 4keep
+ >r >r >r *int r> *void* r> *int r> *int ;
diff --git a/extra/openal/openal.factor b/extra/openal/openal.factor
index e37988a8ce..ff67a30ea3 100644
--- a/extra/openal/openal.factor
+++ b/extra/openal/openal.factor
@@ -1,20 +1,23 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-!
-IN: openal
USING: kernel alien system combinators alien.syntax namespaces
alien.c-types sequences vocabs.loader shuffle combinators.lib
openal.backend ;
+IN: openal
<< "alut" {
- { [ os win32? ] [ "alut.dll" ] }
- { [ os macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] }
+ { [ os windows? ] [ "alut.dll" ] }
+ { [ os macosx? ] [
+ "/System/Library/Frameworks/OpenAL.framework/OpenAL"
+ ] }
{ [ os unix? ] [ "libalut.so" ] }
} cond "cdecl" add-library >>
<< "openal" {
- { [ os win32? ] [ "OpenAL32.dll" ] }
- { [ os macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] }
+ { [ os windows? ] [ "OpenAL32.dll" ] }
+ { [ os macosx? ] [
+ "/System/Library/Frameworks/OpenAL.framework/OpenAL"
+ ] }
{ [ os unix? ] [ "libopenal.so" ] }
} cond "cdecl" add-library >>
@@ -290,4 +293,3 @@ os macosx? "openal.macosx" "openal.other" ? require
: source-playing? ( source -- bool )
AL_SOURCE_STATE get-source-param AL_PLAYING = ;
-
diff --git a/extra/openal/other/other.factor b/extra/openal/other/other.factor
index e32b007973..d0429fb3c3 100644
--- a/extra/openal/other/other.factor
+++ b/extra/openal/other/other.factor
@@ -1,14 +1,14 @@
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-IN: openal.other
-USING: openal.backend alien.c-types kernel alien alien.syntax shuffle combinators.lib ;
-
-LIBRARY: alut
-
-FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
-
-M: other-openal-backend load-wav-file ( filename -- format data size frequency )
- 0 <int> f <void*> 0 <int> 0 <int>
- [ 0 <char> alutLoadWAVFile ] 4keep
- >r >r >r *int r> *void* r> *int r> *int ;
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: openal.backend alien.c-types kernel alien alien.syntax
+shuffle combinators.lib ;
+IN: openal.other
+
+LIBRARY: alut
+
+FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
+
+M: object load-wav-file ( filename -- format data size frequency )
+ 0 <int> f <void*> 0 <int> 0 <int>
+ [ 0 <char> alutLoadWAVFile ] 4keep
+ >r >r >r *int r> *void* r> *int r> *int ;
diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor
index a68cda34ea..312c7b04b3 100755
--- a/extra/openssl/libcrypto/libcrypto.factor
+++ b/extra/openssl/libcrypto/libcrypto.factor
@@ -11,7 +11,7 @@ IN: openssl.libcrypto
<<
"libcrypto" {
- { [ os win32? ] [ "libeay32.dll" "cdecl" ] }
+ { [ os winnt? ] [ "libeay32.dll" "cdecl" ] }
{ [ os macosx? ] [ "libcrypto.dylib" "cdecl" ] }
{ [ os unix? ] [ "libcrypto.so" "cdecl" ] }
} cond add-library
diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor
index 098e1f9382..0f2e7b3184 100755
--- a/extra/openssl/libssl/libssl.factor
+++ b/extra/openssl/libssl/libssl.factor
@@ -10,7 +10,7 @@ USING: alien alien.syntax combinators kernel system ;
IN: openssl.libssl
<< "libssl" {
- { [ os win32? ] [ "ssleay32.dll" "cdecl" ] }
+ { [ os winnt? ] [ "ssleay32.dll" "cdecl" ] }
{ [ os macosx? ] [ "libssl.dylib" "cdecl" ] }
{ [ os unix? ] [ "libssl.so" "cdecl" ] }
} cond add-library >>
diff --git a/extra/oracle/liboci/liboci.factor b/extra/oracle/liboci/liboci.factor
index 6a482b9f56..7af69a97bb 100644
--- a/extra/oracle/liboci/liboci.factor
+++ b/extra/oracle/liboci/liboci.factor
@@ -12,7 +12,7 @@ USING: alien alien.syntax combinators kernel system ;
IN: oracle.liboci
"oci" {
- { [ os win32? ] [ "oci.dll" "stdcall" ] }
+ { [ os winnt? ] [ "oci.dll" "stdcall" ] }
{ [ os macosx? ] [ "$DYLD_LIBRARY_PATH/libclntsh.dylib" "cdecl" ] }
{ [ os unix? ] [ "$DYLD_LIBRARY_PATH/libclntsh.so.10.1" "cdecl" ] }
} cond add-library
From 0d8a27e5e43f9d45b84bc0f3baeaf77495a26a55 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 19:23:26 -0500
Subject: [PATCH 092/127] update docs
---
core/system/system-docs.factor | 60 ++++++++++++++++++-----------
extra/help/handbook/handbook.factor | 2 +-
2 files changed, 39 insertions(+), 23 deletions(-)
diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor
index 9d25ee1138..df112bd786 100755
--- a/core/system/system-docs.factor
+++ b/core/system/system-docs.factor
@@ -1,12 +1,12 @@
USING: generic help.markup help.syntax kernel math memory
-namespaces sequences kernel.private strings ;
+namespaces sequences kernel.private strings classes.singleton ;
IN: system
-ARTICLE: "os" "System interface"
-"Operating system detection:"
-{ $subsection os }
-"Processor detection:"
-{ $subsection cpu }
+ABOUT: "system"
+
+ARTICLE: "system" "System interface"
+{ $subsection "cpu" }
+{ $subsection "os" }
"Reading environment variables:"
{ $subsection os-env }
{ $subsection os-envs }
@@ -19,29 +19,45 @@ ARTICLE: "os" "System interface"
{ $subsection exit }
{ $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ;
-ABOUT: "os"
+ARTICLE: "cpu" "Processor Detection"
+"Processor detection:"
+{ $subsection cpu }
+"Supported processors:"
+{ $subsection x86.32 }
+{ $subsection x86.64 }
+{ $subsection ppc }
+{ $subsection arm }
+"Processor families:"
+{ $subsection x86 } ;
+
+ARTICLE: "os" "Operating System Detection"
+"Operating system detection:"
+{ $subsection os }
+"Supported operating systems:"
+{ $subsection freebsd }
+{ $subsection linux }
+{ $subsection macosx }
+{ $subsection openbsd }
+{ $subsection netbsd }
+{ $subsection solaris }
+{ $subsection wince }
+{ $subsection winnt }
+"Operating system families:"
+{ $subsection bsd }
+{ $subsection unix }
+{ $subsection windows } ;
+
HELP: cpu
-{ $values { "cpu" string } }
+{ $values { "class" singleton-class } }
{ $description
- "Outputs a singleton class with the name of the current CPU architecture. Currently, this set of descriptors is:"
- { $code x86.32 x86.64 ppc arm }
+ "Outputs a singleton class with the name of the current CPU architecture."
} ;
HELP: os
-{ $values { "os" string } }
+{ $values { "class" singleton-class } }
{ $description
- "Outputs a singleton class with the name of the current operating system family. Currently, this set of descriptors is:"
- { $code
- freebsd
- linux
- macosx
- openbsd
- netbsd
- solaris
- wince
- winnt
- }
+ "Outputs a singleton class with the name of the current operating system family."
} ;
HELP: embedded?
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index 1c2dfde85c..e45c49aa25 100755
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -261,7 +261,7 @@ ARTICLE: "handbook" "Factor documentation"
{ $subsection "collections" }
{ $subsection "io" }
{ $subsection "concurrency" }
-{ $subsection "os" }
+{ $subsection "system" }
{ $subsection "alien" }
{ $heading "Environment reference" }
{ $subsection "cli" }
From de30882cb1b74ac77df1188f0103f5cb0593cf7f Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 19:23:37 -0500
Subject: [PATCH 093/127] fix load error
---
extra/hardware-info/hardware-info.factor | 4 +---
extra/hardware-info/windows/windows.factor | 4 ++--
2 files changed, 3 insertions(+), 5 deletions(-)
diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor
index 83e59b3123..ecdcc42cb5 100755
--- a/extra/hardware-info/hardware-info.factor
+++ b/extra/hardware-info/hardware-info.factor
@@ -6,11 +6,9 @@ IN: hardware-info
: megs. ( x -- ) 20 2^ /f . ;
: gigs. ( x -- ) 30 2^ /f . ;
-<<
-{
+<< {
{ [ os windows? ] [ "hardware-info.windows" ] }
{ [ os linux? ] [ "hardware-info.linux" ] }
{ [ os macosx? ] [ "hardware-info.macosx" ] }
{ [ t ] [ f ] }
} cond [ require ] when* >>
-
diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor
index f3a1eb33f5..807fd158ba 100755
--- a/extra/hardware-info/windows/windows.factor
+++ b/extra/hardware-info/windows/windows.factor
@@ -65,6 +65,6 @@ IN: hardware-info.windows
<<
{
- { [ wince? ] [ "hardware-info.windows.ce" ] }
- { [ winnt? ] [ "hardware-info.windows.nt" ] }
+ { [ os wince? ] [ "hardware-info.windows.ce" ] }
+ { [ os winnt? ] [ "hardware-info.windows.nt" ] }
} cond [ require ] when* >>
From 83d9b936b2ca8bbb17b972ec9db444aed0ec69bc Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 19:44:01 -0500
Subject: [PATCH 094/127] change ui backends to singletons
---
extra/ui/cocoa/cocoa.factor | 4 ++--
extra/ui/windows/windows.factor | 4 ++--
extra/ui/x11/x11.factor | 4 ++--
3 files changed, 6 insertions(+), 6 deletions(-)
diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor
index 79b7041dcb..59adcf9af1 100755
--- a/extra/ui/cocoa/cocoa.factor
+++ b/extra/ui/cocoa/cocoa.factor
@@ -12,7 +12,7 @@ TUPLE: handle view window ;
C: <handle> handle
-TUPLE: cocoa-ui-backend ;
+SINGLETON: cocoa-ui-backend
SYMBOL: stop-after-last-window?
@@ -119,6 +119,6 @@ M: cocoa-ui-backend ui
] ui-running
] with-cocoa ;
-T{ cocoa-ui-backend } ui-backend set-global
+cocoa-ui-backend ui-backend set-global
[ running.app? "ui" "listener" ? ] main-vocab-hook set-global
diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor
index f47a82275b..e0c9f24122 100755
--- a/extra/ui/windows/windows.factor
+++ b/extra/ui/windows/windows.factor
@@ -10,7 +10,7 @@ shuffle opengl ui.render unicode.case ascii math.bitfields
locals symbols ;
IN: ui.windows
-TUPLE: windows-ui-backend ;
+SINGLETON: windows-ui-backend
: crlf>lf CHAR: \r swap remove ;
: lf>crlf [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
@@ -496,6 +496,6 @@ M: windows-ui-backend ui
] [ cleanup-win32-ui ] [ ] cleanup
] ui-running ;
-T{ windows-ui-backend } ui-backend set-global
+windows-ui-backend ui-backend set-global
[ "ui" ] main-vocab-hook set-global
diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor
index eaf87acace..9445486656 100755
--- a/extra/ui/x11/x11.factor
+++ b/extra/ui/x11/x11.factor
@@ -8,7 +8,7 @@ io.encodings.utf8 combinators debugger system command-line
ui.render math.vectors classes.tuple opengl.gl threads ;
IN: ui.x11
-TUPLE: x11-ui-backend ;
+SINGLETON: x11-ui-backend
: XA_NET_WM_NAME "_NET_WM_NAME" x-atom ;
@@ -259,7 +259,7 @@ M: x11-ui-backend ui ( -- )
] with-x
] ui-running ;
-T{ x11-ui-backend } ui-backend set-global
+x11-ui-backend ui-backend set-global
[ "DISPLAY" os-env "ui" "listener" ? ]
main-vocab-hook set-global
From 72c06fc028e56dd39f657b6c1f31494dd631a88a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 19:46:37 -0500
Subject: [PATCH 095/127] use OS symbol in deploy
---
extra/tools/deploy/backend/backend.factor | 4 +---
extra/tools/deploy/macosx/macosx.factor | 6 +-----
extra/tools/deploy/windows/windows.factor | 6 +-----
3 files changed, 3 insertions(+), 13 deletions(-)
diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor
index 395c4ff924..e11d16c4ec 100755
--- a/extra/tools/deploy/backend/backend.factor
+++ b/extra/tools/deploy/backend/backend.factor
@@ -107,6 +107,4 @@ DEFER: ?make-staging-image
make-boot-image
deploy-command-line run-factor ;
-SYMBOL: deploy-implementation
-
-HOOK: deploy* deploy-implementation ( vocab -- )
+HOOK: deploy* os ( vocab -- )
diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor
index 6d9c8e9d8a..3a7f8e5d03 100755
--- a/extra/tools/deploy/macosx/macosx.factor
+++ b/extra/tools/deploy/macosx/macosx.factor
@@ -50,17 +50,13 @@ IN: tools.deploy.macosx
: bundle-name ( -- string )
deploy-name get ".app" append ;
-TUPLE: macosx-deploy-implementation ;
-
-T{ macosx-deploy-implementation } deploy-implementation set-global
-
: show-in-finder ( path -- )
NSWorkspace
-> sharedWorkspace
over <NSString> rot parent-directory <NSString>
-> selectFile:inFileViewerRootedAtPath: drop ;
-M: macosx-deploy-implementation deploy* ( vocab -- )
+M: macosx deploy* ( vocab -- )
".app deploy tool" assert.app
"resource:" [
dup deploy-config [
diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor
index 1c9a8195c5..33ab877ee1 100755
--- a/extra/tools/deploy/windows/windows.factor
+++ b/extra/tools/deploy/windows/windows.factor
@@ -25,11 +25,7 @@ IN: tools.deploy.windows
: image-name ( vocab bundle-name -- str )
prepend-path ".image" append ;
-TUPLE: windows-deploy-implementation ;
-
-T{ windows-deploy-implementation } deploy-implementation set-global
-
-M: windows-deploy-implementation deploy*
+M: winnt deploy*
"." resource-path [
dup deploy-config [
[ deploy-name get create-exe-dir ] keep
From c53e75ef0f54f52a86659eb3ec39f18bdcc2bf43 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 20:09:56 -0500
Subject: [PATCH 096/127] io backend now uses OS singletons
---
extra/io/unix/backend/backend.factor | 8 ++---
extra/io/unix/bsd/bsd.factor | 10 ++----
extra/io/unix/files/files.factor | 32 ++++++++++----------
extra/io/unix/files/unique/unique.factor | 6 ++--
extra/io/unix/freebsd/freebsd.factor | 9 ++----
extra/io/unix/launcher/launcher.factor | 8 ++---
extra/io/unix/linux/linux.factor | 10 ++----
extra/io/unix/macosx/macosx.factor | 12 +++-----
extra/io/unix/netbsd/netbsd.factor | 9 ++----
extra/io/unix/openbsd/openbsd.factor | 9 ++----
extra/io/windows/ce/backend/backend.factor | 8 ++---
extra/io/windows/ce/ce.factor | 16 ++++++----
extra/io/windows/ce/files/files.factor | 8 ++---
extra/io/windows/ce/sockets/sockets.factor | 16 +++++-----
extra/io/windows/files/files.factor | 8 ++---
extra/io/windows/files/unique/unique.factor | 4 +--
extra/io/windows/launcher/launcher.factor | 10 +++---
extra/io/windows/mmap/mmap.factor | 10 +++---
extra/io/windows/nt/backend/backend.factor | 10 +++---
extra/io/windows/nt/files/files.factor | 14 ++++-----
extra/io/windows/nt/launcher/launcher.factor | 4 +--
extra/io/windows/nt/monitors/monitors.factor | 4 +--
extra/io/windows/nt/nt.factor | 3 +-
extra/io/windows/nt/sockets/sockets.factor | 16 +++++-----
extra/io/windows/windows.factor | 30 ++++++++----------
25 files changed, 123 insertions(+), 151 deletions(-)
diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor
index 63d2adbdf7..865490b0ce 100755
--- a/extra/io/unix/backend/backend.factor
+++ b/extra/io/unix/backend/backend.factor
@@ -8,8 +8,6 @@ qualified namespaces io.timeouts io.encodings.utf8 accessors ;
QUALIFIED: io
IN: io.unix.backend
-MIXIN: unix-io
-
! I/O tasks
TUPLE: io-task port callbacks ;
@@ -120,7 +118,7 @@ M: integer close-handle ( fd -- )
[ dup reads>> handle-timeout ]
[ dup writes>> handle-timeout ] 2bi ;
-M: unix-io cancel-io ( port -- )
+M: unix cancel-io ( port -- )
mx get-global cancel-io-tasks ;
! Readers
@@ -180,10 +178,10 @@ M: write-task do-io-task
M: port port-flush ( port -- )
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
-M: unix-io io-multiplex ( ms/f -- )
+M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ;
-M: unix-io (init-stdio) ( -- )
+M: unix (init-stdio) ( -- )
0 <reader>
1 <writer>
2 <writer> ;
diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor
index 89b0757da5..6f6517868e 100755
--- a/extra/io/unix/bsd/bsd.factor
+++ b/extra/io/unix/bsd/bsd.factor
@@ -3,7 +3,7 @@
IN: io.unix.bsd
USING: io.backend io.unix.backend io.unix.kqueue io.unix.select
io.launcher io.unix.launcher namespaces kernel assocs
-threads continuations ;
+threads continuations system ;
! On Mac OS X, we use select() for the top-level
! multiplexer, and we hang a kqueue off of it for process exit
@@ -12,16 +12,12 @@ threads continuations ;
! kqueue is buggy with files and ptys so we can't use it as the
! main multiplexer.
-MIXIN: bsd-io
-
-INSTANCE: bsd-io unix-io
-
-M: bsd-io init-io ( -- )
+M: bsd init-io ( -- )
<select-mx> mx set-global
<kqueue-mx> kqueue-mx set-global
kqueue-mx get-global <mx-port> <mx-task> dup io-task-fd
2dup mx get-global mx-reads set-at
mx get-global mx-writes set-at ;
-M: bsd-io register-process ( process -- )
+M: bsd register-process ( process -- )
process-handle kqueue-mx get-global add-pid-task ;
diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor
index 7d0e7c4330..f6bb3edcde 100755
--- a/extra/io/unix/files/files.factor
+++ b/extra/io/unix/files/files.factor
@@ -3,15 +3,15 @@
USING: io.backend io.nonblocking io.unix.backend io.files io
unix unix.stat unix.time kernel math continuations
math.bitfields byte-arrays alien combinators calendar
-io.encodings.binary accessors sequences strings ;
+io.encodings.binary accessors sequences strings system ;
IN: io.unix.files
-M: unix-io cwd ( -- path )
+M: unix cwd ( -- path )
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
[ (io-error) ] unless* ;
-M: unix-io cd ( path -- )
+M: unix cd ( path -- )
chdir io-error ;
: read-flags O_RDONLY ; inline
@@ -19,7 +19,7 @@ M: unix-io cd ( path -- )
: open-read ( path -- fd )
O_RDONLY file-mode open dup io-error ;
-M: unix-io (file-reader) ( path -- stream )
+M: unix (file-reader) ( path -- stream )
open-read <reader> ;
: write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline
@@ -27,7 +27,7 @@ M: unix-io (file-reader) ( path -- stream )
: open-write ( path -- fd )
write-flags file-mode open dup io-error ;
-M: unix-io (file-writer) ( path -- stream )
+M: unix (file-writer) ( path -- stream )
open-write <writer> ;
: append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline
@@ -36,28 +36,28 @@ M: unix-io (file-writer) ( path -- stream )
append-flags file-mode open dup io-error
[ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ;
-M: unix-io (file-appender) ( path -- stream )
+M: unix (file-appender) ( path -- stream )
open-append <writer> ;
: touch-mode ( -- n )
{ O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
-M: unix-io touch-file ( path -- )
+M: unix touch-file ( path -- )
normalize-path
touch-mode file-mode open
dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when
close ;
-M: unix-io move-file ( from to -- )
+M: unix move-file ( from to -- )
[ normalize-path ] bi@ rename io-error ;
-M: unix-io delete-file ( path -- )
+M: unix delete-file ( path -- )
normalize-path unlink io-error ;
-M: unix-io make-directory ( path -- )
+M: unix make-directory ( path -- )
normalize-path OCT: 777 mkdir io-error ;
-M: unix-io delete-directory ( path -- )
+M: unix delete-directory ( path -- )
normalize-path rmdir io-error ;
: (copy-file) ( from to -- )
@@ -68,7 +68,7 @@ M: unix-io delete-directory ( path -- )
] with-disposal
] with-disposal ;
-M: unix-io copy-file ( from to -- )
+M: unix copy-file ( from to -- )
[ normalize-path ] bi@
[ (copy-file) ]
[ swap file-info file-info-permissions chmod io-error ]
@@ -95,16 +95,16 @@ M: unix-io copy-file ( from to -- )
} cleave
\ file-info construct-boa ;
-M: unix-io file-info ( path -- info )
+M: unix file-info ( path -- info )
normalize-path stat* stat>file-info ;
-M: unix-io link-info ( path -- info )
+M: unix link-info ( path -- info )
normalize-path lstat* stat>file-info ;
-M: unix-io make-link ( path1 path2 -- )
+M: unix make-link ( path1 path2 -- )
normalize-path symlink io-error ;
-M: unix-io read-link ( path -- path' )
+M: unix read-link ( path -- path' )
normalize-path
PATH_MAX [ <byte-array> tuck ] [ ] bi readlink
dup io-error head-slice >string ;
diff --git a/extra/io/unix/files/unique/unique.factor b/extra/io/unix/files/unique/unique.factor
index c5365d8d5c..035e6398ee 100644
--- a/extra/io/unix/files/unique/unique.factor
+++ b/extra/io/unix/files/unique/unique.factor
@@ -1,11 +1,11 @@
USING: kernel io.nonblocking io.unix.backend math.bitfields
-unix io.files.unique.backend ;
+unix io.files.unique.backend system ;
IN: io.unix.files.unique
: open-unique-flags ( -- flags )
{ O_RDWR O_CREAT O_EXCL } flags ;
-M: unix-io (make-unique-file) ( path -- )
+M: unix (make-unique-file) ( path -- )
open-unique-flags file-mode open dup io-error close ;
-M: unix-io temporary-path ( -- path ) "/tmp" ;
+M: unix temporary-path ( -- path ) "/tmp" ;
diff --git a/extra/io/unix/freebsd/freebsd.factor b/extra/io/unix/freebsd/freebsd.factor
index 65b4a6f0f7..49fbc9af7e 100644
--- a/extra/io/unix/freebsd/freebsd.factor
+++ b/extra/io/unix/freebsd/freebsd.factor
@@ -1,8 +1,3 @@
-IN: io.unix.freebsd
-USING: io.unix.bsd io.backend ;
+USING: io.unix.bsd io.backend system ;
-TUPLE: freebsd-io ;
-
-INSTANCE: freebsd-io bsd-io
-
-T{ freebsd-io } set-io-backend
+freebsd set-io-backend
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index 4986024e78..8e5531a40c 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -79,12 +79,12 @@ USE: unix
(io-error)
] [ 255 exit ] recover ;
-M: unix-io current-process-handle ( -- handle ) getpid ;
+M: unix current-process-handle ( -- handle ) getpid ;
-M: unix-io run-process* ( process -- pid )
+M: unix run-process* ( process -- pid )
[ spawn-process ] curry [ ] with-fork ;
-M: unix-io kill-process* ( pid -- )
+M: unix kill-process* ( pid -- )
SIGTERM kill io-error ;
: open-pipe ( -- pair )
@@ -95,7 +95,7 @@ M: unix-io kill-process* ( pid -- )
2dup first close second close
>r first 0 dup2 drop r> second 1 dup2 drop ;
-M: unix-io (process-stream)
+M: unix (process-stream)
>r open-pipe open-pipe r>
[ >r setup-stdio-pipe r> spawn-process ] curry
[ -rot 2dup second close first close ]
diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor
index 2ae4065fb6..9f135f2958 100755
--- a/extra/io/unix/linux/linux.factor
+++ b/extra/io/unix/linux/linux.factor
@@ -7,10 +7,6 @@ namespaces threads continuations init math alien.c-types alien
vocabs.loader accessors ;
IN: io.unix.linux
-TUPLE: linux-io ;
-
-INSTANCE: linux-io unix-io
-
TUPLE: linux-monitor ;
: <linux-monitor> ( wd -- monitor )
@@ -50,7 +46,7 @@ TUPLE: inotify watches ;
"inotify is not supported by this Linux release" throw
] unless ;
-M: linux-io <monitor> ( path recursive? -- monitor )
+M: linux <monitor> ( path recursive? -- monitor )
check-inotify
drop IN_CHANGE_EVENTS add-watch ;
@@ -116,11 +112,11 @@ TUPLE: inotify-task ;
M: inotify-task do-io-task ( task -- )
io-task-port read-notifications f ;
-M: linux-io init-io ( -- )
+M: linux init-io ( -- )
<select-mx>
[ mx set-global ]
[ [ init-inotify ] curry ignore-errors ] bi ;
-T{ linux-io } set-io-backend
+linux set-io-backend
[ start-wait-thread ] "io.unix.linux" add-init-hook
diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor
index bd48fbc9b5..c1c73ea018 100644
--- a/extra/io/unix/macosx/macosx.factor
+++ b/extra/io/unix/macosx/macosx.factor
@@ -1,13 +1,9 @@
-IN: io.unix.macosx
USING: io.unix.bsd io.backend io.monitors io.monitors.private
continuations kernel core-foundation.fsevents sequences
-namespaces arrays ;
+namespaces arrays system ;
+IN: io.unix.macosx
-TUPLE: macosx-io ;
-
-INSTANCE: macosx-io bsd-io
-
-T{ macosx-io } set-io-backend
+macosx set-io-backend
TUPLE: macosx-monitor ;
@@ -16,7 +12,7 @@ TUPLE: macosx-monitor ;
[ [ first { +modify-file+ } swap changed-file ] each ] bind
notify-callback ;
-M: macosx-io <monitor>
+M: macosx <monitor>
drop
f macosx-monitor construct-simple-monitor
dup [ enqueue-notifications ] curry
diff --git a/extra/io/unix/netbsd/netbsd.factor b/extra/io/unix/netbsd/netbsd.factor
index 3aa8678702..c5771c8ffc 100644
--- a/extra/io/unix/netbsd/netbsd.factor
+++ b/extra/io/unix/netbsd/netbsd.factor
@@ -1,8 +1,3 @@
-IN: io.unix.netbsd
-USING: io.unix.bsd io.backend ;
+USING: io.backend system ;
-TUPLE: netbsd-io ;
-
-INSTANCE: netbsd-io bsd-io
-
-T{ netbsd-io } set-io-backend
+netbsd set-io-backend
diff --git a/extra/io/unix/openbsd/openbsd.factor b/extra/io/unix/openbsd/openbsd.factor
index 767861ec75..9b3021646d 100644
--- a/extra/io/unix/openbsd/openbsd.factor
+++ b/extra/io/unix/openbsd/openbsd.factor
@@ -1,8 +1,3 @@
-IN: io.unix.openbsd
-USING: io.unix.bsd io.backend core-foundation.fsevents ;
+USING: io.unix.bsd io.backend core-foundation.fsevents system ;
-TUPLE: openbsd-io ;
-
-INSTANCE: openbsd-io bsd-io
-
-T{ openbsd-io } set-io-backend
+openbsd set-io-backend
diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor
index b8b024d710..a8ff4c14e3 100755
--- a/extra/io/windows/ce/backend/backend.factor
+++ b/extra/io/windows/ce/backend/backend.factor
@@ -7,10 +7,10 @@ IN: io.windows.ce.backend
: port-errored ( port -- )
win32-error-string swap set-port-error ;
-M: windows-ce-io io-multiplex ( ms -- )
+M: wince io-multiplex ( ms -- )
60 60 * 1000 * or (sleep) ;
-M: windows-ce-io add-completion ( handle -- ) drop ;
+M: wince add-completion ( handle -- ) drop ;
GENERIC: wince-read ( port port-handle -- )
@@ -26,14 +26,14 @@ M: port port-flush
dup dup port-handle wince-write port-flush
] if ;
-M: windows-ce-io init-io ( -- )
+M: wince init-io ( -- )
init-winsock ;
LIBRARY: libc
FUNCTION: void* _getstdfilex int fd ;
FUNCTION: void* _fileno void* file ;
-M: windows-ce-io (init-stdio) ( -- )
+M: wince (init-stdio) ( -- )
#! We support Windows NT too, to make this I/O backend
#! easier to debug.
512 default-buffer-size [
diff --git a/extra/io/windows/ce/ce.factor b/extra/io/windows/ce/ce.factor
index 878f5899f6..a0a8de8513 100755
--- a/extra/io/windows/ce/ce.factor
+++ b/extra/io/windows/ce/ce.factor
@@ -1,7 +1,11 @@
-USING: io.backend io.windows io.windows.ce.backend
-io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher
-namespaces io.windows.mmap ;
-IN: io.windows.ce
-
+USE: io.backend
+USE: io.windows
+USE: io.windows.ce.backend
+USE: io.windows.ce.files
+USE: io.windows.ce.sockets
+USE: io.windows.ce.launcher
+USE: io.windows.mmap system
USE: io.windows.files
-T{ windows-ce-io } set-io-backend
+USE: system
+
+wince set-io-backend
diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor
index 1e5cedae57..8f7390aa7c 100755
--- a/extra/io/windows/ce/files/files.factor
+++ b/extra/io/windows/ce/files/files.factor
@@ -1,15 +1,15 @@
USING: alien alien.c-types combinators io io.backend io.buffers
io.files io.nonblocking io.windows kernel libc math namespaces
prettyprint sequences strings threads threads.private
-windows windows.kernel32 io.windows.ce.backend ;
+windows windows.kernel32 io.windows.ce.backend system ;
IN: windows.ce.files
-! M: windows-ce-io normalize-path ( string -- string )
+! M: wince normalize-path ( string -- string )
! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
-M: windows-ce-io CreateFile-flags ( DWORD -- DWORD )
+M: wince CreateFile-flags ( DWORD -- DWORD )
FILE_ATTRIBUTE_NORMAL bitor ;
-M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ;
+M: wince FileArgs-overlapped ( port -- f ) drop f ;
: finish-read ( port status bytes-ret -- )
swap [ drop port-errored ] [ swap n>buffer ] if ;
diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor
index 9bc583a3d8..0001bb5142 100755
--- a/extra/io/windows/ce/sockets/sockets.factor
+++ b/extra/io/windows/ce/sockets/sockets.factor
@@ -2,11 +2,11 @@ USING: alien alien.c-types combinators io io.backend io.buffers
io.nonblocking io.sockets io.sockets.impl io.windows kernel libc
math namespaces prettyprint qualified sequences strings threads
threads.private windows windows.kernel32 io.windows.ce.backend
-byte-arrays ;
+byte-arrays system ;
QUALIFIED: windows.winsock
IN: io.windows.ce
-M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ;
+M: wince WSASocket-flags ( -- DWORD ) 0 ;
M: win32-socket wince-read ( port port-handle -- )
win32-file-handle over buffer-end pick buffer-capacity 0
@@ -31,15 +31,15 @@ M: win32-socket wince-write ( port port-handle -- )
windows.winsock:WSAConnect
windows.winsock:winsock-error!=0/f ;
-M: windows-ce-io (client) ( addrspec -- reader writer )
+M: wince (client) ( addrspec -- reader writer )
do-connect <win32-socket> dup <reader&writer> ;
-M: windows-ce-io (server) ( addrspec -- handle )
+M: wince (server) ( addrspec -- handle )
windows.winsock:SOCK_STREAM server-fd
dup listen-on-socket
<win32-socket> ;
-M: windows-ce-io (accept) ( server -- client )
+M: wince (accept) ( server -- client )
[
dup check-server-port
[
@@ -55,7 +55,7 @@ M: windows-ce-io (accept) ( server -- client )
<win32-socket> <reader&writer>
] with-timeout ;
-M: windows-ce-io <datagram> ( addrspec -- datagram )
+M: wince <datagram> ( addrspec -- datagram )
[
windows.winsock:SOCK_DGRAM server-fd <win32-socket>
] keep <datagram-port> ;
@@ -81,7 +81,7 @@ M: windows-ce-io <datagram> ( addrspec -- datagram )
packet-size <byte-array> receive-buffer set-global
-M: windows-ce-io receive ( datagram -- packet addrspec )
+M: wince receive ( datagram -- packet addrspec )
dup check-datagram-port
[
port-handle win32-file-handle
@@ -104,7 +104,7 @@ M: windows-ce-io receive ( datagram -- packet addrspec )
dup length receive-buffer rot pick memcpy
receive-buffer make-WSABUF ;
-M: windows-ce-io send ( packet addrspec datagram -- )
+M: wince send ( packet addrspec datagram -- )
3dup check-datagram-send
port-handle win32-file-handle
rot send-WSABUF
diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor
index a23a78b3da..4f31d2dfce 100755
--- a/extra/io/windows/files/files.factor
+++ b/extra/io/windows/files/files.factor
@@ -3,7 +3,7 @@
USING: alien.c-types io.backend io.files io.windows kernel math
windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces words symbols
-combinators.lib io.nonblocking destructors ;
+combinators.lib io.nonblocking destructors system ;
IN: io.windows.files
SYMBOLS: +read-only+ +hidden+ +system+
@@ -88,10 +88,10 @@ SYMBOLS: +read-only+ +hidden+ +system+
get-file-information BY_HANDLE_FILE_INFORMATION>file-info
] if ;
-M: windows-nt-io file-info ( path -- info )
+M: winnt file-info ( path -- info )
normalize-path get-file-information-stat ;
-M: windows-nt-io link-info ( path -- info )
+M: winnt link-info ( path -- info )
file-info ;
: file-times ( path -- timestamp timestamp timestamp )
@@ -125,7 +125,7 @@ M: windows-nt-io link-info ( path -- info )
: set-file-write-time ( path timestamp -- )
>r f f r> set-file-times ;
-M: windows-nt-io touch-file ( path -- )
+M: winnt touch-file ( path -- )
[
normalize-path
maybe-create-file over close-always
diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor
index 7e7610eb72..0449980286 100644
--- a/extra/io/windows/files/unique/unique.factor
+++ b/extra/io/windows/files/unique/unique.factor
@@ -2,9 +2,9 @@ USING: kernel system io.files.unique.backend
windows.kernel32 io.windows io.nonblocking windows ;
IN: io.windows.files.unique
-M: windows-io (make-unique-file) ( path -- )
+M: windows (make-unique-file) ( path -- )
GENERIC_WRITE CREATE_NEW 0 open-file
CloseHandle win32-error=0/f ;
-M: windows-io temporary-path ( -- path )
+M: windows temporary-path ( -- path )
"TEMP" os-env ;
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index 3f230a4ac0..2724966a8f 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -101,7 +101,7 @@ TUPLE: CreateProcess-args
HOOK: fill-redirection io-backend ( process args -- )
-M: windows-ce-io fill-redirection 2drop ;
+M: wince fill-redirection 2drop ;
: make-CreateProcess-args ( process -- args )
default-CreateProcess-args
@@ -111,10 +111,10 @@ M: windows-ce-io fill-redirection 2drop ;
fill-startup-info
nip ;
-M: windows-io current-process-handle ( -- handle )
+M: windows current-process-handle ( -- handle )
GetCurrentProcessId ;
-M: windows-io run-process* ( process -- handle )
+M: windows run-process* ( process -- handle )
[
dup make-CreateProcess-args
tuck fill-redirection
@@ -122,7 +122,7 @@ M: windows-io run-process* ( process -- handle )
lpProcessInformation>>
] with-destructors ;
-M: windows-io kill-process* ( handle -- )
+M: windows kill-process* ( handle -- )
PROCESS_INFORMATION-hProcess
255 TerminateProcess win32-error=0/f ;
@@ -161,7 +161,7 @@ SYMBOL: wait-flag
<flag> wait-flag set-global
[ wait-loop t ] "Process wait" spawn-server drop ;
-M: windows-io register-process
+M: windows register-process
drop wait-flag get-global raise-flag ;
[ start-wait-thread ] "io.windows.launcher" add-init-hook
diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor
index d1cafa4c0f..8d3690bbb5 100755
--- a/extra/io/windows/mmap/mmap.factor
+++ b/extra/io/windows/mmap/mmap.factor
@@ -1,7 +1,7 @@
USING: alien alien.c-types alien.syntax arrays continuations
destructors generic io.mmap io.nonblocking io.windows
kernel libc math namespaces quotations sequences windows
-windows.advapi32 windows.kernel32 io.backend ;
+windows.advapi32 windows.kernel32 io.backend system ;
IN: io.windows.mmap
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
@@ -53,11 +53,11 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
HOOK: with-privileges io-backend ( seq quot -- ) inline
-M: windows-nt-io with-privileges
+M: winnt with-privileges
over [ [ t set-privilege ] each ] curry compose
swap [ [ f set-privilege ] each ] curry [ ] cleanup ;
-M: windows-ce-io with-privileges
+M: wince with-privileges
nip call ;
: mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
@@ -70,7 +70,7 @@ M: windows-ce-io with-privileges
dup close-later
] with-privileges ;
-M: windows-io <mapped-file> ( path length -- mmap )
+M: windows <mapped-file> ( path length -- mmap )
[
swap
GENERIC_WRITE GENERIC_READ bitor
@@ -81,7 +81,7 @@ M: windows-io <mapped-file> ( path length -- mmap )
f \ mapped-file construct-boa
] with-destructors ;
-M: windows-io close-mapped-file ( mapped-file -- )
+M: windows close-mapped-file ( mapped-file -- )
[
dup mapped-file-handle [ close-always ] each
mapped-file-address UnmapViewOfFile win32-error=0/f
diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor
index dcd13895b2..822973b85b 100755
--- a/extra/io/windows/nt/backend/backend.factor
+++ b/extra/io/windows/nt/backend/backend.factor
@@ -3,7 +3,7 @@ continuations destructors io io.backend io.nonblocking
io.windows libc kernel math namespaces sequences
threads classes.tuple.lib windows windows.errors
windows.kernel32 strings splitting io.files qualified ascii
-combinators.lib ;
+combinators.lib system ;
QUALIFIED: windows.winsock
IN: io.windows.nt.backend
@@ -28,7 +28,7 @@ SYMBOL: master-completion-port
: <master-completion-port> ( -- handle )
INVALID_HANDLE_VALUE f <completion-port> ;
-M: windows-nt-io add-completion ( handle -- )
+M: winnt add-completion ( handle -- )
master-completion-port get-global <completion-port> drop ;
: eof? ( error -- ? )
@@ -89,13 +89,13 @@ M: windows-nt-io add-completion ( handle -- )
: drain-overlapped ( timeout -- )
handle-overlapped [ 0 drain-overlapped ] unless ;
-M: windows-nt-io cancel-io
+M: winnt cancel-io
port-handle win32-file-handle CancelIo drop ;
-M: windows-nt-io io-multiplex ( ms -- )
+M: winnt io-multiplex ( ms -- )
drain-overlapped ;
-M: windows-nt-io init-io ( -- )
+M: winnt init-io ( -- )
<master-completion-port> master-completion-port set-global
H{ } clone io-hash set-global
windows.winsock:init-winsock ;
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index 91ad0139b2..7bac540ddc 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -1,22 +1,22 @@
USING: continuations destructors io.buffers io.files io.backend
io.timeouts io.nonblocking io.windows io.windows.nt.backend
-kernel libc math threads windows windows.kernel32
+kernel libc math threads windows windows.kernel32 system
alien.c-types alien.arrays sequences combinators combinators.lib
sequences.lib ascii splitting alien strings assocs namespaces ;
IN: io.windows.nt.files
-M: windows-nt-io cwd
+M: winnt cwd
MAX_UNICODE_PATH dup "ushort" <c-array>
[ GetCurrentDirectory win32-error=0/f ] keep
alien>u16-string ;
-M: windows-nt-io cd
+M: winnt cd
SetCurrentDirectory win32-error=0/f ;
: unicode-prefix ( -- seq )
"\\\\?\\" ; inline
-M: windows-nt-io root-directory? ( path -- ? )
+M: winnt root-directory? ( path -- ? )
{
{ [ dup empty? ] [ f ] }
{ [ dup [ path-separator? ] all? ] [ t ] }
@@ -40,15 +40,15 @@ ERROR: not-absolute-path ;
unicode-prefix prepend
] unless ;
-M: windows-nt-io normalize-path ( string -- string' )
+M: winnt normalize-path ( string -- string' )
(normalize-path)
{ { CHAR: / CHAR: \\ } } substitute
prepend-prefix ;
-M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
+M: winnt CreateFile-flags ( DWORD -- DWORD )
FILE_FLAG_OVERLAPPED bitor ;
-M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
+M: winnt FileArgs-overlapped ( port -- overlapped )
make-overlapped ;
: update-file-ptr ( n port -- )
diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor
index 895890e898..4bbf7c8e32 100755
--- a/extra/io/windows/nt/launcher/launcher.factor
+++ b/extra/io/windows/nt/launcher/launcher.factor
@@ -112,13 +112,13 @@ IN: io.windows.nt.launcher
dup pipe-out f set-inherit
>>stdin-pipe ;
-M: windows-nt-io fill-redirection ( process args -- )
+M: winnt fill-redirection ( process args -- )
[ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
[ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError
[ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput
2drop ;
-M: windows-nt-io (process-stream)
+M: winnt (process-stream)
[
dup make-CreateProcess-args
diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor
index 83e062c3a9..164b529b61 100755
--- a/extra/io/windows/nt/monitors/monitors.factor
+++ b/extra/io/windows/nt/monitors/monitors.factor
@@ -5,7 +5,7 @@ io.windows.nt.backend kernel math windows windows.kernel32
windows.types libc assocs alien namespaces continuations
io.monitors io.monitors.private io.nonblocking io.buffers
io.files io.timeouts io sequences hashtables sorting arrays
-combinators math.bitfields strings ;
+combinators math.bitfields strings system ;
IN: io.windows.nt.monitors
: open-directory ( path -- handle )
@@ -30,7 +30,7 @@ TUPLE: win32-monitor path recursive? ;
set-delegate
} win32-monitor construct ;
-M: windows-nt-io <monitor> ( path recursive? -- monitor )
+M: winnt <monitor> ( path recursive? -- monitor )
[
over open-directory win32-monitor <buffered-port>
<win32-monitor>
diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor
index 1baec5658f..33bb3a88b9 100755
--- a/extra/io/windows/nt/nt.factor
+++ b/extra/io/windows/nt/nt.factor
@@ -11,5 +11,6 @@ USE: io.windows.nt.sockets
USE: io.windows.mmap
USE: io.windows.files
USE: io.backend
+USE: system
-T{ windows-nt-io } set-io-backend
+winnt set-io-backend
diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor
index 85bb34b225..36acaac992 100755
--- a/extra/io/windows/nt/sockets/sockets.factor
+++ b/extra/io/windows/nt/sockets/sockets.factor
@@ -2,13 +2,13 @@ USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.nonblocking io.timeouts io.sockets
io.sockets.impl io namespaces io.streams.duplex io.windows
io.windows.nt.backend windows.winsock kernel libc math sequences
-threads classes.tuple.lib ;
+threads classes.tuple.lib system ;
IN: io.windows.nt.sockets
: malloc-int ( object -- object )
"int" heap-size malloc tuck 0 set-alien-signed-4 ; inline
-M: windows-nt-io WSASocket-flags ( -- DWORD )
+M: winnt WSASocket-flags ( -- DWORD )
WSA_FLAG_OVERLAPPED ;
: get-ConnectEx-ptr ( socket -- void* )
@@ -50,7 +50,7 @@ TUPLE: ConnectEx-args port
2dup save-callback
get-overlapped-result drop ;
-M: windows-nt-io (client) ( addrspec -- client-in client-out )
+M: winnt (client) ( addrspec -- client-in client-out )
[
\ ConnectEx-args construct-empty
over make-sockaddr/size pick init-connect
@@ -119,7 +119,7 @@ TUPLE: AcceptEx-args port
[ AcceptEx-args-sAcceptSocket* add-completion ] keep
AcceptEx-args-sAcceptSocket* <win32-socket> ;
-M: windows-nt-io (accept) ( server -- addrspec handle )
+M: winnt (accept) ( server -- addrspec handle )
[
[
dup check-server-port
@@ -131,14 +131,14 @@ M: windows-nt-io (accept) ( server -- addrspec handle )
] with-timeout
] with-destructors ;
-M: windows-nt-io (server) ( addrspec -- handle )
+M: winnt (server) ( addrspec -- handle )
[
SOCK_STREAM server-fd dup listen-on-socket
dup add-completion
<win32-socket>
] with-destructors ;
-M: windows-nt-io <datagram> ( addrspec -- datagram )
+M: winnt <datagram> ( addrspec -- datagram )
[
[
SOCK_DGRAM server-fd
@@ -190,7 +190,7 @@ TUPLE: WSARecvFrom-args port
[ WSARecvFrom-args-lpFrom* ] keep
WSARecvFrom-args-port datagram-port-addr parse-sockaddr ;
-M: windows-nt-io receive ( datagram -- packet addrspec )
+M: winnt receive ( datagram -- packet addrspec )
[
dup check-datagram-port
\ WSARecvFrom-args construct-empty
@@ -242,7 +242,7 @@ TUPLE: WSASendTo-args port
USE: io.sockets
-M: windows-nt-io send ( packet addrspec datagram -- )
+M: winnt send ( packet addrspec datagram -- )
[
3dup check-datagram-send
\ WSASendTo-args construct-empty
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index 45c1adaf50..7755f111c6 100755
--- a/extra/io/windows/windows.factor
+++ b/extra/io/windows/windows.factor
@@ -5,16 +5,12 @@ io.buffers io.files io.nonblocking io.sockets io.binary
io.sockets.impl windows.errors strings io.streams.duplex
kernel math namespaces sequences windows windows.kernel32
windows.shell32 windows.types windows.winsock splitting
-continuations math.bitfields ;
+continuations math.bitfields system ;
IN: io.windows
-TUPLE: windows-nt-io ;
-TUPLE: windows-ce-io ;
-UNION: windows-io windows-nt-io windows-ce-io ;
+M: windows destruct-handle CloseHandle drop ;
-M: windows-io destruct-handle CloseHandle drop ;
-
-M: windows-io destruct-socket closesocket drop ;
+M: windows destruct-socket closesocket drop ;
TUPLE: win32-file handle ptr ;
@@ -24,7 +20,7 @@ HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- )
-M: windows-io normalize-directory ( string -- string )
+M: windows normalize-directory ( string -- string )
normalize-path "\\" ?tail drop "\\*" append ;
: share-mode ( -- fixnum )
@@ -125,30 +121,30 @@ C: <FileArgs> FileArgs
[ FileArgs-lpNumberOfBytesRet ] keep
FileArgs-lpOverlapped ;
-M: windows-io (file-reader) ( path -- stream )
+M: windows (file-reader) ( path -- stream )
open-read <win32-file> <reader> ;
-M: windows-io (file-writer) ( path -- stream )
+M: windows (file-writer) ( path -- stream )
open-write <win32-file> <writer> ;
-M: windows-io (file-appender) ( path -- stream )
+M: windows (file-appender) ( path -- stream )
open-append <win32-file> <writer> ;
-M: windows-io move-file ( from to -- )
+M: windows move-file ( from to -- )
[ normalize-path ] bi@ MoveFile win32-error=0/f ;
-M: windows-io delete-file ( path -- )
+M: windows delete-file ( path -- )
normalize-path DeleteFile win32-error=0/f ;
-M: windows-io copy-file ( from to -- )
+M: windows copy-file ( from to -- )
dup parent-directory make-directories
[ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
-M: windows-io make-directory ( path -- )
+M: windows make-directory ( path -- )
normalize-path
f CreateDirectory win32-error=0/f ;
-M: windows-io delete-directory ( path -- )
+M: windows delete-directory ( path -- )
normalize-path
RemoveDirectory win32-error=0/f ;
@@ -194,7 +190,7 @@ USE: namespaces
M: win32-socket dispose ( stream -- )
win32-file-handle closesocket drop ;
-M: windows-io addrinfo-error ( n -- )
+M: windows addrinfo-error ( n -- )
winsock-return-check ;
: tcp-socket ( addrspec -- socket )
From 5de68cd30f3bcf16177aab4344feeeebaa4c5c1e Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Wed, 2 Apr 2008 20:33:36 -0500
Subject: [PATCH 097/127] fix bootstrap on intel mac
---
extra/io/unix/mmap/mmap.factor | 4 ++--
extra/io/unix/sockets/sockets.factor | 16 ++++++++--------
extra/io/unix/unix.factor | 2 +-
extra/unix/bsd/bsd.factor | 8 ++++----
extra/unix/kqueue/kqueue.factor | 2 +-
extra/unix/types/types.factor | 23 ++++++++++-------------
extra/unix/unix.factor | 6 +++---
7 files changed, 29 insertions(+), 32 deletions(-)
diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor
index 71c55f2303..f042366b13 100755
--- a/extra/io/unix/mmap/mmap.factor
+++ b/extra/io/unix/mmap/mmap.factor
@@ -10,12 +10,12 @@ IN: io.unix.mmap
>r f -roll r> open-r/w [ 0 mmap ] keep
over MAP_FAILED = [ close (io-error) ] when ;
-M: unix-io <mapped-file> ( path length -- obj )
+M: unix <mapped-file> ( path length -- obj )
swap >r
dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
r> mmap-open f mapped-file construct-boa ;
-M: unix-io close-mapped-file ( mmap -- )
+M: unix close-mapped-file ( mmap -- )
[ mapped-file-address ] keep
[ mapped-file-length munmap ] keep
mapped-file-handle close
diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor
index 69ce6a3069..477757e0ed 100755
--- a/extra/io/unix/sockets/sockets.factor
+++ b/extra/io/unix/sockets/sockets.factor
@@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces
io.nonblocking parser threads unix sequences
byte-arrays io.sockets io.binary io.unix.backend
io.streams.duplex io.sockets.impl math.parser continuations libc
-combinators io.backend io.files ;
+combinators io.backend io.files system ;
IN: io.unix.sockets
: pending-init-error ( port -- )
@@ -23,7 +23,7 @@ IN: io.unix.sockets
: sockopt ( fd level opt -- )
1 <int> "int" heap-size setsockopt io-error ;
-M: unix-io addrinfo-error ( n -- )
+M: unix addrinfo-error ( n -- )
dup zero? [ drop ] [ gai_strerror throw ] if ;
! Client sockets - TCP and Unix domain
@@ -42,7 +42,7 @@ M: connect-task do-io-task
: wait-to-connect ( port -- )
[ <connect-task> add-io-task ] with-port-continuation drop ;
-M: unix-io (client) ( addrspec -- client-in client-out )
+M: unix (client) ( addrspec -- client-in client-out )
dup make-sockaddr/size >r >r
protocol-family SOCK_STREAM socket-fd
dup r> r> connect
@@ -91,11 +91,11 @@ USE: io.sockets
dup rot make-sockaddr/size bind
zero? [ dup close (io-error) ] unless ;
-M: unix-io (server) ( addrspec -- handle )
+M: unix (server) ( addrspec -- handle )
SOCK_STREAM server-fd
dup 10 listen zero? [ dup close (io-error) ] unless ;
-M: unix-io (accept) ( server -- addrspec handle )
+M: unix (accept) ( server -- addrspec handle )
#! Wait for a client connection.
dup check-server-port
dup wait-to-accept
@@ -104,7 +104,7 @@ M: unix-io (accept) ( server -- addrspec handle )
swap server-port-client ;
! Datagram sockets - UDP and Unix domain
-M: unix-io <datagram>
+M: unix <datagram>
[ SOCK_DGRAM server-fd ] keep <datagram-port> ;
SYMBOL: receive-buffer
@@ -147,7 +147,7 @@ M: receive-task do-io-task
: wait-receive ( stream -- )
[ <receive-task> add-io-task ] with-port-continuation drop ;
-M: unix-io receive ( datagram -- packet addrspec )
+M: unix receive ( datagram -- packet addrspec )
dup check-datagram-port
dup wait-receive
dup pending-error
@@ -179,7 +179,7 @@ M: send-task do-io-task
[ <send-task> add-io-task ] with-port-continuation
2drop 2drop ;
-M: unix-io send ( packet addrspec datagram -- )
+M: unix send ( packet addrspec datagram -- )
3dup check-datagram-send
[ >r make-sockaddr/size r> wait-send ] keep
pending-error ;
diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor
index f6607d98f9..b4328f31b3 100755
--- a/extra/io/unix/unix.factor
+++ b/extra/io/unix/unix.factor
@@ -1,5 +1,5 @@
USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
io.unix.launcher io.unix.mmap io.backend combinators namespaces
-system vocabs.loader sequences ;
+system vocabs.loader sequences words ;
"io.unix." os word-name append require
diff --git a/extra/unix/bsd/bsd.factor b/extra/unix/bsd/bsd.factor
index 6cb5d6385b..d80db44348 100755
--- a/extra/unix/bsd/bsd.factor
+++ b/extra/unix/bsd/bsd.factor
@@ -73,8 +73,8 @@ C-STRUCT: sockaddr-un
: SEEK_END 2 ; inline
os {
- { "macosx" [ "unix.bsd.macosx" require ] }
- { "freebsd" [ "unix.bsd.freebsd" require ] }
- { "openbsd" [ "unix.bsd.openbsd" require ] }
- { "netbsd" [ "unix.bsd.netbsd" require ] }
+ { macosx [ "unix.bsd.macosx" require ] }
+ { freebsd [ "unix.bsd.freebsd" require ] }
+ { openbsd [ "unix.bsd.openbsd" require ] }
+ { netbsd [ "unix.bsd.netbsd" require ] }
} case
diff --git a/extra/unix/kqueue/kqueue.factor b/extra/unix/kqueue/kqueue.factor
index 50020072c5..080820ebd0 100644
--- a/extra/unix/kqueue/kqueue.factor
+++ b/extra/unix/kqueue/kqueue.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax system sequences vocabs.loader ;
+USING: alien.syntax system sequences vocabs.loader words ;
IN: unix.kqueue
<< "unix.kqueue." os word-name append require >>
diff --git a/extra/unix/types/types.factor b/extra/unix/types/types.factor
index 983d5d677d..0ac2fa608e 100644
--- a/extra/unix/types/types.factor
+++ b/extra/unix/types/types.factor
@@ -1,17 +1,14 @@
-
-USING: kernel system alien.syntax combinators vocabs.loader ;
-
+USING: kernel system alien.syntax combinators vocabs.loader
+system ;
IN: unix.types
TYPEDEF: void* caddr_t
-os
- {
- { "linux" [ "unix.types.linux" require ] }
- { "macosx" [ "unix.types.macosx" require ] }
- { "freebsd" [ "unix.types.freebsd" require ] }
- { "openbsd" [ "unix.types.openbsd" require ] }
- { "netbsd" [ "unix.types.netbsd" require ] }
- { "winnt" [ ] }
- }
-case
+os {
+ { linux [ "unix.types.linux" require ] }
+ { macosx [ "unix.types.macosx" require ] }
+ { freebsd [ "unix.types.freebsd" require ] }
+ { openbsd [ "unix.types.openbsd" require ] }
+ { netbsd [ "unix.types.netbsd" require ] }
+ { winnt [ ] }
+} case
diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index ffd102901c..e911a5c039 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -161,8 +161,8 @@ FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
{
- { [ linux? ] [ "unix.linux" require ] }
- { [ bsd? ] [ "unix.bsd" require ] }
- { [ solaris? ] [ "unix.solaris" require ] }
+ { [ os linux? ] [ "unix.linux" require ] }
+ { [ os bsd? ] [ "unix.bsd" require ] }
+ { [ os solaris? ] [ "unix.solaris" require ] }
} cond
From f10f601e3f17fe2a437f1badfe5638946084a225 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 2 Apr 2008 20:50:20 -0500
Subject: [PATCH 098/127] fix teh bootstrap
---
extra/io/unix/linux/linux.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor
index 9f135f2958..a452878a43 100755
--- a/extra/io/unix/linux/linux.factor
+++ b/extra/io/unix/linux/linux.factor
@@ -4,7 +4,7 @@ USING: kernel io.backend io.monitors io.monitors.private
io.files io.buffers io.nonblocking io.timeouts io.unix.backend
io.unix.select io.unix.launcher unix.linux.inotify assocs
namespaces threads continuations init math alien.c-types alien
-vocabs.loader accessors ;
+vocabs.loader accessors system ;
IN: io.unix.linux
TUPLE: linux-monitor ;
From 5346e1899f2fea2bccdad4ed55adbb6cfd471160 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 21:27:49 -0500
Subject: [PATCH 099/127] Working on call-next-method, and identity-tuple
---
core/bootstrap/compiler/compiler.factor | 6 ---
core/bootstrap/image/image.factor | 1 -
core/bootstrap/primitives.factor | 25 +++++------
core/bootstrap/syntax.factor | 1 +
core/classes/algebra/algebra-tests.factor | 4 +-
core/classes/classes-docs.factor | 1 -
core/classes/classes-tests.factor | 9 +++-
core/classes/classes.factor | 5 ++-
core/classes/tuple/tuple-docs.factor | 8 ----
core/classes/tuple/tuple-tests.factor | 31 +++++++++++++
core/classes/tuple/tuple.factor | 44 ++++++++-----------
core/compiler/compiler-docs.factor | 15 +++++--
core/compiler/compiler.factor | 6 +++
core/definitions/definitions-tests.factor | 2 +-
core/generic/generic-tests.factor | 23 ----------
core/generic/generic.factor | 23 +++++-----
core/generic/math/math.factor | 4 +-
.../standard/engines/tuple/tuple.factor | 2 +-
core/generic/standard/standard.factor | 37 ++++++++++++----
core/inference/class/class-tests.factor | 14 +++++-
core/inference/class/class.factor | 17 +++++--
core/inference/dataflow/dataflow.factor | 9 ++--
.../transforms/transforms-tests.factor | 5 ++-
core/inference/transforms/transforms.factor | 10 ++++-
core/kernel/kernel-docs.factor | 40 ++++++++++-------
core/kernel/kernel.factor | 44 +++++++++++--------
core/optimizer/control/control.factor | 2 +-
core/optimizer/inlining/inlining.factor | 12 ++++-
core/optimizer/known-words/known-words.factor | 2 +-
core/optimizer/math/math.factor | 2 +-
core/parser/parser.factor | 12 ++++-
core/prettyprint/prettyprint-tests.factor | 2 -
core/sequences/sequences.factor | 3 ++
core/syntax/syntax-docs.factor | 2 +-
core/syntax/syntax.factor | 6 +++
core/vocabs/vocabs.factor | 8 +---
core/words/words.factor | 2 +-
extra/io/launcher/launcher.factor | 4 +-
extra/io/sockets/impl/impl.factor | 9 ++--
extra/models/models.factor | 5 +--
extra/ui/freetype/freetype.factor | 5 +--
extra/ui/gadgets/gadgets.factor | 8 ++--
extra/ui/gadgets/worlds/worlds.factor | 4 +-
43 files changed, 279 insertions(+), 195 deletions(-)
diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor
index 7d4db3c473..035d95d3ab 100755
--- a/core/bootstrap/compiler/compiler.factor
+++ b/core/bootstrap/compiler/compiler.factor
@@ -16,12 +16,6 @@ IN: bootstrap.compiler
"cpu." cpu append require
-: enable-compiler ( -- )
- [ optimized-recompile-hook ] recompile-hook set-global ;
-
-: disable-compiler ( -- )
- [ default-recompile-hook ] recompile-hook set-global ;
-
enable-compiler
nl
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index f0d9b77981..fc963683b6 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -444,7 +444,6 @@ PRIVATE>
"resource:/core/bootstrap/stage1.factor" run-file
build-image
write-image
- \ word-props target-word
] with-scope ;
: make-images ( -- )
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 6c4462ed98..f3846de5b1 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -159,17 +159,24 @@ num-types get f <array> builtins set
"tuple-layout" "classes.tuple.private" create register-builtin
! Catch-all class for providing a default method.
-"object" "kernel" create [ drop t ] "predicate" set-word-prop
"object" "kernel" create
-f builtins get [ ] subset union-class define-class
+[ f builtins get [ ] subset union-class define-class ]
+[ [ drop t ] "predicate" set-word-prop ]
+bi
+
+"object?" "kernel" vocab-words delete-at
! Class of objects with object tag
"hi-tag" "kernel.private" create
-f builtins get num-tags get tail union-class define-class
+builtins get num-tags get tail define-union-class
! Empty class with no instances
-"null" "kernel" create [ drop f ] "predicate" set-word-prop
-"null" "kernel" create f { } union-class define-class
+"null" "kernel" create
+[ f { } union-class define-class ]
+[ [ drop f ] "predicate" set-word-prop ]
+bi
+
+"null?" "kernel" vocab-words delete-at
"fixnum" "math" create { } define-builtin
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
@@ -378,17 +385,9 @@ define-builtin
]
} cleave
-! Define general-t type, which is any object that is not f.
-"general-t" "kernel" create
-f "f" "syntax" lookup builtins get remove [ ] subset union-class
-define-class
-
"f" "syntax" create [ not ] "predicate" set-word-prop
"f?" "syntax" vocab-words delete-at
-"general-t" "kernel" create [ ] "predicate" set-word-prop
-"general-t?" "kernel" vocab-words delete-at
-
! Create special tombstone values
"tombstone" "hashtables.private" create
"tuple" "kernel" lookup
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index e7e90d8dd0..b3e5cb0120 100755
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -66,6 +66,7 @@ IN: bootstrap.syntax
"CS{"
"<<"
">>"
+ "call-next-method"
} [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index 32664dc823..0f468908a9 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -23,8 +23,8 @@ random inference effects kernel.private ;
[ t ] [ number object number class-and* ] unit-test
[ t ] [ object number number class-and* ] unit-test
[ t ] [ slice reversed null class-and* ] unit-test
-[ t ] [ general-t \ f null class-and* ] unit-test
-[ t ] [ general-t \ f object class-or* ] unit-test
+[ t ] [ \ f class-not \ f null class-and* ] unit-test
+[ t ] [ \ f class-not \ f object class-or* ] unit-test
TUPLE: first-one ;
TUPLE: second-one ;
diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor
index 9573de8949..0560a0e755 100755
--- a/core/classes/classes-docs.factor
+++ b/core/classes/classes-docs.factor
@@ -21,7 +21,6 @@ $nl
{ { $link f } { $snippet "[ not ]" } { "The conventional name for a word which outputs true when given false is " { $link not } "; " { $snippet "f?" } " would be confusing." } }
{ { $link object } { $snippet "[ drop t ]" } { "All objects are instances of " { $link object } } }
{ { $link null } { $snippet "[ drop f ]" } { "No object is an instance of " { $link null } } }
- { { $link general-t } { $snippet "[ ]" } { "All objects with a true value are instances of " { $link general-t } } }
}
"The set of class predicate words is a class:"
{ $subsection predicate }
diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index ae9e6ec154..ae19f38d14 100755
--- a/core/classes/classes-tests.factor
+++ b/core/classes/classes-tests.factor
@@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files
-compiler.units ;
+compiler.units kernel.private ;
IN: classes.tests
! DEFER: bah
@@ -153,3 +153,10 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
! Test generic see and parsing
[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
[ [ \ bah see ] with-string-writer ] unit-test
+
+[ t ] [ 3 object instance? ] unit-test
+[ t ] [ 3 fixnum instance? ] unit-test
+[ f ] [ 3 float instance? ] unit-test
+[ t ] [ 3 number instance? ] unit-test
+[ f ] [ 3 null instance? ] unit-test
+[ t ] [ "hi" \ hi-tag instance? ] unit-test
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 0baf235edb..c45fd7360b 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -60,7 +60,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
dup class? [ "superclass" word-prop ] [ drop f ] if ;
: superclasses ( class -- supers )
- [ dup ] [ [ superclass ] keep ] [ ] unfold nip reverse ;
+ [ superclass ] follow reverse ;
: members ( class -- seq )
#! Output f for non-classes to work with algebra code
@@ -133,3 +133,6 @@ GENERIC: class ( object -- class )
M: hi-tag class hi-tag type>class ;
M: object class tag type>class ;
+
+: instance? ( obj class -- ? )
+ "predicate" word-prop call ;
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 18c8143654..664f0545fa 100755
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -153,14 +153,6 @@ HELP: tuple=
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
{ $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
-HELP: removed-slots
-{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } }
-{ $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ;
-
-HELP: forget-removed-slots
-{ $values { "class" tuple-class } { "slots" "a sequence of strings" } }
-{ $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ;
-
HELP: tuple
{ $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."
$nl
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index ff34c25416..735f328a67 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -511,3 +511,34 @@ USE: vocabs
define-tuple-class
] with-compilation-unit
] unit-test
+
+[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] must-fail-with
+
+! Accessors not being forgotten...
+[ [ ] ] [
+ "IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;"
+ <string-reader>
+ "forget-accessors-test" parse-stream
+] unit-test
+
+[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
+
+: accessor-exists? ( class name -- ? )
+ >r "forget-accessors-test" "classes.tuple.tests" lookup r>
+ ">>" append "accessors" lookup method >boolean ;
+
+[ t ] [ "x" accessor-exists? ] unit-test
+[ t ] [ "y" accessor-exists? ] unit-test
+[ t ] [ "z" accessor-exists? ] unit-test
+
+[ [ ] ] [
+ "IN: classes.tuple.tests GENERIC: forget-accessors-test"
+ <string-reader>
+ "forget-accessors-test" parse-stream
+] unit-test
+
+[ f ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
+
+[ f ] [ "x" accessor-exists? ] unit-test
+[ f ] [ "y" accessor-exists? ] unit-test
+[ f ] [ "z" accessor-exists? ] unit-test
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index bbc221b85d..ac1a7b8849 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -19,7 +19,7 @@ ERROR: no-tuple-class class ;
GENERIC: tuple-layout ( object -- layout )
-M: class tuple-layout "layout" word-prop ;
+M: tuple-class tuple-layout "layout" word-prop ;
M: tuple tuple-layout 1 slot ;
@@ -40,7 +40,9 @@ PRIVATE>
[ drop ] [ no-tuple-class ] if ;
: tuple>array ( tuple -- array )
- prepare-tuple>array >r copy-tuple-slots r> layout-class prefix ;
+ prepare-tuple>array
+ >r copy-tuple-slots r>
+ layout-class prefix ;
: tuple-slots ( tuple -- array )
prepare-tuple>array drop copy-tuple-slots ;
@@ -120,15 +122,6 @@ PRIVATE>
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
-: removed-slots ( class newslots -- seq )
- swap slot-names seq-diff ;
-
-: forget-removed-slots ( class slots -- )
- dupd removed-slots [
- [ reader-word forget-method ]
- [ writer-word forget-method ] 2bi
- ] with each ;
-
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class prefix ;
@@ -189,9 +182,8 @@ M: tuple-class update-class
tri
] each-subclass
]
- [ nip forget-removed-slots ]
[ define-new-tuple-class ]
- 3tri ;
+ 3bi ;
: tuple-class-unchanged? ( class superclass slots -- ? )
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
@@ -213,7 +205,19 @@ M: tuple-class define-tuple-class
dup [ construct-boa throw ] curry define ;
M: tuple-class reset-class
- { "metaclass" "superclass" "slots" "layout" } reset-props ;
+ [
+ dup "slot-names" word-prop [
+ [ reader-word forget-method ]
+ [ writer-word forget-method ] 2bi
+ ] with each
+ ] [
+ {
+ "metaclass"
+ "superclass"
+ "layout"
+ "slots"
+ } reset-props
+ ] bi ;
M: tuple clone
(clone) dup delegate clone over set-delegate ;
@@ -228,12 +232,6 @@ M: tuple hashcode*
] 2curry reduce
] recursive-hashcode ;
-M: object construct-empty ( class -- tuple )
- tuple-layout <tuple> ;
-
-M: object construct-boa ( ... class -- tuple )
- tuple-layout <tuple-boa> ;
-
! Deprecated
M: object get-slots ( obj slots -- ... )
[ execute ] with each ;
@@ -241,10 +239,6 @@ M: object get-slots ( obj slots -- ... )
M: object set-slots ( ... obj slots -- )
<reversed> get-slots ;
-M: object construct ( ... slots class -- tuple )
- construct-empty [ swap set-slots ] keep ;
-
-: delegates ( obj -- seq )
- [ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
+: delegates ( obj -- seq ) [ delegate ] follow ;
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor
index 3520104e1f..341d56f1d5 100755
--- a/core/compiler/compiler-docs.factor
+++ b/core/compiler/compiler-docs.factor
@@ -2,14 +2,21 @@ USING: generator help.markup help.syntax words io parser
assocs words.private sequences compiler.units ;
IN: compiler
+HELP: enable-compiler
+{ $description "Enables the optimizing compiler." } ;
+
+HELP: disable-compiler
+{ $description "Enables the optimizing compiler." } ;
+
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
-"Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly."
-$nl
-"The main entry point to the optimizing compiler:"
+"Normally, new word definitions are recompiled automatically. This can be changed:"
+{ $subsection disable-compiler }
+{ $subsection enable-compiler }
+"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:"
{ $subsection optimized-recompile-hook }
"Removing a word's optimized definition:"
{ $subsection decompile }
-"These words are not usually used directly. Instead, use " { $link "compilation-units" } "." ;
+"Higher-level words can be found in " { $link "compilation-units" } "." ;
ARTICLE: "compiler" "Optimizing compiler"
"Factor is a fully compiled language implementation with two distinct compilers:"
diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor
index 111d84cde0..a0599f79a1 100755
--- a/core/compiler/compiler.factor
+++ b/core/compiler/compiler.factor
@@ -56,5 +56,11 @@ IN: compiler
compiled get >alist
] with-scope ;
+: enable-compiler ( -- )
+ [ optimized-recompile-hook ] recompile-hook set-global ;
+
+: disable-compiler ( -- )
+ [ default-recompile-hook ] recompile-hook set-global ;
+
: recompile-all ( -- )
forget-errors all-words compile ;
diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor
index ebbce4d7e2..3dc28139ea 100755
--- a/core/definitions/definitions-tests.factor
+++ b/core/definitions/definitions-tests.factor
@@ -4,7 +4,7 @@ compiler.units words ;
TUPLE: combination-1 ;
-M: combination-1 perform-combination 2drop [ ] ;
+M: combination-1 perform-combination drop [ ] define ;
M: combination-1 make-default-method 2drop [ "No method" throw ] ;
diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor
index fd313d8165..524835f461 100755
--- a/core/generic/generic-tests.factor
+++ b/core/generic/generic-tests.factor
@@ -21,19 +21,6 @@ M: word class-of drop "word" ;
[ "Hello world" ] [ 4 foobar foobar ] unit-test
[ "Goodbye cruel world" ] [ 4 foobar ] unit-test
-GENERIC: bool>str ( x -- y )
-M: general-t bool>str drop "true" ;
-M: f bool>str drop "false" ;
-
-: str>bool
- H{
- { "true" t }
- { "false" f }
- } at ;
-
-[ t ] [ t bool>str str>bool ] unit-test
-[ f ] [ f bool>str str>bool ] unit-test
-
! Testing unions
UNION: funnies quotation float complex ;
@@ -51,16 +38,6 @@ M: very-funny gooey sq ;
[ 0.25 ] [ 0.5 gooey ] unit-test
-DEFER: complement-test
-FORGET: complement-test
-GENERIC: complement-test ( x -- y )
-
-M: f complement-test drop "f" ;
-M: general-t complement-test drop "general-t" ;
-
-[ "general-t" ] [ 5 complement-test ] unit-test
-[ "f" ] [ f complement-test ] unit-test
-
GENERIC: empty-method-test ( x -- y )
M: object empty-method-test ;
TUPLE: for-arguments-sake ;
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 2ec285146e..b0099f770c 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -6,16 +6,7 @@ classes.algebra quotations arrays vocabs effects ;
IN: generic
! Method combination protocol
-GENERIC: perform-combination ( word combination -- quot )
-
-M: object perform-combination
- #! We delay the invalid method combination error for a
- #! reason. If we call forget-vocab on a vocabulary which
- #! defines a method combination, a generic using this
- #! method combination, and a method on the generic, and the
- #! method combination is forgotten first, then forgetting
- #! the method will throw an error. We don't want that.
- nip [ "Invalid method combination" throw ] curry [ ] like ;
+GENERIC: perform-combination ( word combination -- )
GENERIC: make-default-method ( generic combination -- method )
@@ -38,6 +29,18 @@ PREDICATE: method-spec < pair
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
+: next-method-class ( class generic -- class/f )
+ order [ class< ] with subset reverse dup length 1 =
+ [ drop f ] [ second ] if ;
+
+: next-method ( class generic -- class/f )
+ [ next-method-class ] keep method ;
+
+GENERIC: next-method-quot ( class generic -- quot )
+
+: (call-next-method) ( class generic -- )
+ next-method-quot call ;
+
TUPLE: check-method class generic ;
: check-method ( class generic -- class generic )
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 2fda2c9621..46208744f0 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -12,9 +12,9 @@ PREDICATE: math-class < class
number bootstrap-word class<
] if ;
-: last/first ( seq -- pair ) dup peek swap first 2array ;
+: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
-: math-precedence ( class -- n )
+: math-precedence ( class -- pair )
{
{ [ dup null class< ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ class-types last/first ] }
diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
index 510d5ef732..40e749f473 100644
--- a/core/generic/standard/engines/tuple/tuple.factor
+++ b/core/generic/standard/engines/tuple/tuple.factor
@@ -15,7 +15,7 @@ C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
TUPLE: tuple-dispatch-engine echelons ;
: push-echelon ( class method assoc -- )
- >r swap dup tuple-layout layout-echelon r>
+ >r swap dup "layout" word-prop layout-echelon r>
[ ?set-at ] change-at ;
: echelon-sort ( assoc -- assoc' )
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 0d29bdecd5..2b2dbd2b2d 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -8,6 +8,10 @@ generic.standard.engines.tag generic.standard.engines.predicate
generic.standard.engines.tuple accessors ;
IN: generic.standard
+GENERIC: dispatch# ( word -- n )
+
+M: word dispatch# "combination" word-prop dispatch# ;
+
: unpickers
{
[ nip ]
@@ -101,7 +105,7 @@ PREDICATE: simple-generic < standard-generic
T{ standard-combination f 0 } define-generic ;
: with-standard ( combination quot -- quot' )
- >r #>> (dispatch#) r> with-variable ;
+ >r #>> (dispatch#) r> with-variable ; inline
M: standard-generic mangle-method
drop 1quotation ;
@@ -112,6 +116,27 @@ M: standard-combination make-default-method
M: standard-combination perform-combination
[ drop ] [ [ single-combination ] with-standard ] 2bi define ;
+M: standard-combination dispatch# #>> ;
+
+ERROR: inconsistent-next-method object class generic ;
+
+ERROR: no-next-method class generic ;
+
+M: standard-generic next-method-quot
+ [
+ [
+ [ [ instance? ] curry ]
+ [ dispatch# (picker) ] bi* prepend %
+ ]
+ [
+ 2dup next-method
+ [ 2nip 1quotation ]
+ [ [ no-next-method ] 2curry ] if* ,
+ ]
+ [ [ inconsistent-next-method ] 2curry , ]
+ 2tri
+ ] [ ] make ;
+
TUPLE: hook-combination var ;
C: <hook-combination> hook-combination
@@ -124,6 +149,8 @@ PREDICATE: hook-generic < generic
dip var>> [ get ] curry prepend
] with-variable ; inline
+M: hook-combination dispatch# drop 0 ;
+
M: hook-generic mangle-method
drop 1quotation [ drop ] prepend ;
@@ -133,14 +160,6 @@ M: hook-combination make-default-method
M: hook-combination perform-combination
[ drop ] [ [ single-combination ] with-hook ] 2bi define ;
-GENERIC: dispatch# ( word -- n )
-
-M: word dispatch# "combination" word-prop dispatch# ;
-
-M: standard-combination dispatch# #>> ;
-
-M: hook-combination dispatch# drop 0 ;
-
M: simple-generic definer drop \ GENERIC: f ;
M: standard-generic definer drop \ GENERIC# f ;
diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor
index 7d18aaa489..b54dbe256a 100755
--- a/core/inference/class/class-tests.factor
+++ b/core/inference/class/class-tests.factor
@@ -21,7 +21,7 @@ GENERIC: mynot ( x -- y )
M: f mynot drop t ;
-M: general-t mynot drop f ;
+M: object mynot drop f ;
GENERIC: detect-f ( x -- y )
@@ -297,3 +297,15 @@ cell-bits 32 = [
[ t ] [
[ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
] unit-test
+
+[ t ] [
+ [
+ dup integer? [
+ dup fixnum? [
+ 1 +
+ ] [
+ 2 +
+ ] if
+ ] when
+ ] \ + inlined?
+] unit-test
diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor
index 4aac98ce41..8269952409 100755
--- a/core/inference/class/class.factor
+++ b/core/inference/class/class.factor
@@ -176,9 +176,18 @@ M: pair constraint-satisfied?
: predicate-constraints ( class #call -- )
[
- 0 `input class,
- general-t 0 `output class,
- ] set-constraints ;
+ ! If word outputs true, input is an instance of class
+ [
+ 0 `input class,
+ \ f class-not 0 `output class,
+ ] set-constraints
+ ] [
+ ! If word outputs false, input is not an instance of class
+ [
+ class-not 0 `input class,
+ \ f 0 `output class,
+ ] set-constraints
+ ] 2bi ;
: compute-constraints ( #call -- )
dup node-param "constraints" word-prop [
@@ -209,7 +218,7 @@ M: #push infer-classes-before
M: #if child-constraints
[
- general-t 0 `input class,
+ \ f class-not 0 `input class,
f 0 `input literal,
] make-constraints ;
diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor
index 7fa2fbbcd3..01c0a9c5f4 100755
--- a/core/inference/dataflow/dataflow.factor
+++ b/core/inference/dataflow/dataflow.factor
@@ -9,15 +9,13 @@ IN: inference.dataflow
: <computed> \ <computed> counter ;
! Literal value
-TUPLE: value literal uid recursion ;
+TUPLE: value < identity-tuple literal uid recursion ;
: <value> ( obj -- value )
<computed> recursive-state get value construct-boa ;
M: value hashcode* nip value-uid ;
-M: value equal? 2drop f ;
-
! Result of curry
TUPLE: curried obj quot ;
@@ -30,13 +28,12 @@ C: <composed> composed
UNION: special curried composed ;
-TUPLE: node param
+TUPLE: node < identity-tuple
+param
in-d out-d in-r out-r
classes literals intervals
history successor children ;
-M: node equal? 2drop f ;
-
M: node hashcode* drop node hashcode* ;
GENERIC: flatten-curry ( value -- )
diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor
index cb8024d3c5..3fc8f37b4f 100755
--- a/core/inference/transforms/transforms-tests.factor
+++ b/core/inference/transforms/transforms-tests.factor
@@ -1,6 +1,7 @@
IN: inference.transforms.tests
USING: sequences inference.transforms tools.test math kernel
-quotations inference accessors combinators words arrays ;
+quotations inference accessors combinators words arrays
+classes ;
: compose-n-quot <repetition> >quotation ;
: compose-n compose-n-quot call ;
@@ -56,3 +57,5 @@ C: <color> color
[ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test
[ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test
+
+[ fixnum instance? ] must-infer
diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor
index 06c2a8f476..d95ff9c3bc 100755
--- a/core/inference/transforms/transforms.factor
+++ b/core/inference/transforms/transforms.factor
@@ -3,7 +3,7 @@
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
inference.dataflow inference.state classes.tuple.private effects
-inspector hashtables ;
+inspector hashtables classes generic ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )
@@ -98,3 +98,11 @@ M: duplicated-slots-error summary
\ construct-empty 1 1 <effect> make-call-node
] if
] "infer" set-word-prop
+
+\ instance? [
+ [ +inlined+ depends-on ] [ "predicate" word-prop ] bi
+] 1 define-transform
+
+\ (call-next-method) [
+ [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
+] 2 define-transform
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 2df5e69998..53618d4628 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -250,8 +250,9 @@ $nl
{ $subsection eq? }
"Value comparison:"
{ $subsection = }
-"Generic words for custom value comparison methods:"
+"Custom value comparison methods:"
{ $subsection equal? }
+{ $subsection identity-tuple }
"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
{ $subsection <=> }
{ $subsection compare }
@@ -377,10 +378,13 @@ HELP: equal?
}
$nl
"If a class defines a custom equality comparison test, it should also define a compatible method for the " { $link hashcode* } " generic word."
-}
+} ;
+
+HELP: identity-tuple
+{ $class-description "A class defining an " { $link equal? } " method which always returns f." }
{ $examples
- "To define a tuple class such that two instances are only equal if they are both the same instance, we can add a method to " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
- { $code "TUPLE: foo ;" "M: foo equal? 2drop f ;" }
+ "To define a tuple class such that two instances are only equal if they are both the same instance, inherit from the " { $link identity-tuple } " class. This class defines a method on " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
+ { $code "TUPLE: foo < identity-tuple ;" }
"By calling " { $link = } " on instances of " { $snippet "foo" } " we get the results we expect:"
{ $unchecked-example "T{ foo } dup = ." "t" }
{ $unchecked-example "T{ foo } dup clone = ." "f" }
@@ -665,6 +669,11 @@ HELP: bi@
"[ p ] bi@"
">r p r> p"
}
+ "The following two lines are also equivalent:"
+ { $code
+ "[ p ] bi@"
+ "[ p ] [ p ] bi*"
+ }
} ;
HELP: 2bi@
@@ -676,6 +685,11 @@ HELP: 2bi@
"[ p ] 2bi@"
">r >r p r> r> p"
}
+ "The following two lines are also equivalent:"
+ { $code
+ "[ p ] 2bi@"
+ "[ p ] [ p ] 2bi*"
+ }
} ;
HELP: tri@
@@ -687,6 +701,11 @@ HELP: tri@
"[ p ] tri@"
">r >r p r> p r> p"
}
+ "The following two lines are also equivalent:"
+ { $code
+ "[ p ] tri@"
+ "[ p ] [ p ] [ p ] tri*"
+ }
} ;
HELP: if ( cond true false -- )
@@ -785,19 +804,6 @@ HELP: null
"The canonical empty class with no instances."
} ;
-HELP: general-t
-{ $class-description
- "The class of all objects not equal to " { $link f } "."
-}
-{ $examples
- "Here is an implementation of " { $link if } " using generic words:"
- { $code
- "GENERIC# my-if 2 ( ? true false -- )"
- "M: f my-if 2nip call ;"
- "M: general-t my-if drop nip call ;"
- }
-} ;
-
HELP: most
{ $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } }
{ $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ;
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index ae775ec116..1935c89431 100755
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel.private slots.private ;
+USING: kernel.private slots.private classes.tuple.private ;
IN: kernel
! Stack stuff
@@ -114,12 +114,6 @@ DEFER: if
[ 2nip call ] if ; inline
! Object protocol
-GENERIC: delegate ( obj -- delegate )
-
-M: object delegate drop f ;
-
-GENERIC: set-delegate ( delegate tuple -- )
-
GENERIC: hashcode* ( depth obj -- code )
M: object hashcode* 2drop 0 ;
@@ -130,6 +124,10 @@ GENERIC: equal? ( obj1 obj2 -- ? )
M: object equal? 2drop f ;
+TUPLE: identity-tuple ;
+
+M: identity-tuple equal? 2drop f ;
+
: = ( obj1 obj2 -- ? )
2dup eq? [ 2drop t ] [ equal? ] if ; inline
@@ -142,18 +140,11 @@ M: object clone ;
M: callstack clone (clone) ;
! Tuple construction
-GENERIC# get-slots 1 ( tuple slots -- ... )
+: construct-empty ( class -- tuple )
+ tuple-layout <tuple> ;
-GENERIC# set-slots 1 ( ... tuple slots -- )
-
-GENERIC: construct-empty ( class -- tuple )
-
-GENERIC: construct ( ... slots class -- tuple ) inline
-
-GENERIC: construct-boa ( ... class -- tuple )
-
-: construct-delegate ( delegate class -- tuple )
- >r { set-delegate } r> construct ; inline
+: construct-boa ( ... class -- tuple )
+ tuple-layout <tuple-boa> ;
! Quotation building
: 2curry ( obj1 obj2 quot -- curry )
@@ -201,3 +192,20 @@ GENERIC: construct-boa ( ... class -- tuple )
: do-primitive ( number -- ) "Improper primitive call" throw ;
PRIVATE>
+
+! Deprecated
+GENERIC: delegate ( obj -- delegate )
+
+M: object delegate drop f ;
+
+GENERIC: set-delegate ( delegate tuple -- )
+
+GENERIC# get-slots 1 ( tuple slots -- ... )
+
+GENERIC# set-slots 1 ( ... tuple slots -- )
+
+: construct ( ... slots class -- tuple )
+ construct-empty [ swap set-slots ] keep ; inline
+
+: construct-delegate ( delegate class -- tuple )
+ >r { set-delegate } r> construct ; inline
diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor
index c108e3b1a7..11228c879a 100755
--- a/core/optimizer/control/control.factor
+++ b/core/optimizer/control/control.factor
@@ -154,7 +154,7 @@ SYMBOL: potential-loops
] [
node-class {
{ [ dup null class< ] [ drop f f ] }
- { [ dup general-t class< ] [ drop t t ] }
+ { [ dup \ f class-not class< ] [ drop t t ] }
{ [ dup \ f class< ] [ drop f t ] }
{ [ t ] [ drop f f ] }
} cond
diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor
index 1f3df92421..81f53b5ace 100755
--- a/core/optimizer/inlining/inlining.factor
+++ b/core/optimizer/inlining/inlining.factor
@@ -70,12 +70,20 @@ DEFER: (flat-length)
] if ;
! Partial dispatch of math-generic words
+: normalize-math-class ( class -- class' )
+ { fixnum bignum ratio float complex }
+ [ class< ] with find nip object or ;
+
: math-both-known? ( word left right -- ? )
math-class-max swap specific-method ;
: inline-math-method ( #call word -- node )
- over node-input-classes first2 3dup math-both-known?
- [ math-method f splice-quot ] [ 2drop 2drop t ] if ;
+ over node-input-classes
+ [ first normalize-math-class ]
+ [ second normalize-math-class ] bi
+ 3dup math-both-known?
+ [ math-method f splice-quot ]
+ [ 2drop 2drop t ] if ;
: inline-method ( #call -- node )
dup node-param {
diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor
index a4782078ee..2bce2dc94c 100755
--- a/core/optimizer/known-words/known-words.factor
+++ b/core/optimizer/known-words/known-words.factor
@@ -75,7 +75,7 @@ sequences.private combinators ;
dup node-in-d second dup value? [
swap [
value-literal 0 `input literal,
- general-t 0 `output class,
+ \ f class-not 0 `output class,
] set-constraints
] [
2drop
diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor
index abe48ec272..4ec4bfeb36 100755
--- a/core/optimizer/math/math.factor
+++ b/core/optimizer/math/math.factor
@@ -269,7 +269,7 @@ generic.standard system ;
: comparison-constraints ( node true false -- )
>r >r dup node set intervals dup [
2dup
- r> general-t (comparison-constraints)
+ r> \ f class-not (comparison-constraints)
r> \ f (comparison-constraints)
] [
r> r> 2drop 2drop
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 58c68a3614..2a481d413d 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -365,7 +365,17 @@ ERROR: bad-number ;
: (:) CREATE-WORD parse-definition ;
-: (M:) CREATE-METHOD parse-definition ;
+SYMBOL: current-class
+SYMBOL: current-generic
+
+: (M:)
+ CREATE-METHOD
+ [
+ [ "method-class" word-prop current-class set ]
+ [ "method-generic" word-prop current-generic set ]
+ [ ] tri
+ parse-definition
+ ] with-scope ;
: scan-object ( -- object )
scan-word dup parsing?
diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor
index 27b63ec26f..0f384b159d 100755
--- a/core/prettyprint/prettyprint-tests.factor
+++ b/core/prettyprint/prettyprint-tests.factor
@@ -57,8 +57,6 @@ unit-test
[ ] [ \ integer see ] unit-test
-[ ] [ \ general-t see ] unit-test
-
[ ] [ \ generic see ] unit-test
[ ] [ \ duplex-stream see ] unit-test
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index ca46066861..01a1cb9b6a 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -416,6 +416,9 @@ PRIVATE>
swap >r [ push ] curry compose r> while
] keep { } like ; inline
+: follow ( obj quot -- seq )
+ >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline
+
: index ( obj seq -- n )
[ = ] with find drop ;
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index bd349953df..b242e65de5 100755
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -243,7 +243,7 @@ HELP: flushable
HELP: t
{ $syntax "t" }
{ $values { "t" "the canonical truth value" } }
-{ $description "The canonical instance of " { $link general-t } ". It is just a symbol." } ;
+{ $class-description "The canonical truth value, which is an instance of itself." } ;
HELP: f
{ $syntax "f" }
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 19fdf0e45f..df135d0c1c 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -185,4 +185,10 @@ IN: bootstrap.syntax
[ \ >> parse-until >quotation ] with-compilation-unit
call
] define-syntax
+
+ "call-next-method" [
+ current-class get literalize parsed
+ current-generic get literalize parsed
+ \ (call-next-method) parsed
+ ] define-syntax
] with-compilation-unit
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index a6a5a014a7..8ef5f6f508 100755
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -6,13 +6,11 @@ IN: vocabs
SYMBOL: dictionary
-TUPLE: vocab
+TUPLE: vocab < identity-tuple
name words
main help
source-loaded? docs-loaded? ;
-M: vocab equal? 2drop f ;
-
: <vocab> ( name -- vocab )
H{ } clone
{ set-vocab-name set-vocab-words }
@@ -92,10 +90,6 @@ TUPLE: vocab-link name ;
: <vocab-link> ( name -- vocab-link )
vocab-link construct-boa ;
-M: vocab-link equal?
- over vocab-link?
- [ [ vocab-link-name ] bi@ = ] [ 2drop f ] if ;
-
M: vocab-link hashcode*
vocab-link-name hashcode* ;
diff --git a/core/words/words.factor b/core/words/words.factor
index a45e1627e9..1232a97ddc 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -173,7 +173,7 @@ GENERIC: subwords ( word -- seq )
M: word subwords drop f ;
: reset-generic ( word -- )
- dup subwords [ forget ] each
+ dup subwords forget-all
dup reset-word
{ "methods" "combination" "default-method" } reset-props ;
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index 79382091ab..20c5bb92c9 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -6,7 +6,7 @@ init threads continuations math io.encodings io.streams.duplex
io.nonblocking accessors ;
IN: io.launcher
-TUPLE: process
+TUPLE: process < identity-tuple
command
detached
@@ -65,8 +65,6 @@ M: object register-process drop ;
V{ } clone over processes get set-at
register-process ;
-M: process equal? 2drop f ;
-
M: process hashcode* process-handle hashcode* ;
: pass-environment? ( process -- ? )
diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor
index 8480fcd856..74a84c48ff 100755
--- a/extra/io/sockets/impl/impl.factor
+++ b/extra/io/sockets/impl/impl.factor
@@ -96,14 +96,13 @@ M: inet6 parse-sockaddr
M: f parse-sockaddr nip ;
: addrinfo>addrspec ( addrinfo -- addrspec )
- dup addrinfo-addr
- swap addrinfo-family addrspec-of-family
+ [ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi
parse-sockaddr ;
: parse-addrinfo-list ( addrinfo -- seq )
- [ dup ]
- [ dup addrinfo-next swap addrinfo>addrspec ]
- [ ] unfold nip [ ] subset ;
+ [ addrinfo-next ] follow
+ [ addrinfo>addrspec ] map
+ [ ] subset ;
: prepare-resolve-host ( host serv passive? -- host' serv' flags )
#! If the port is a number, we resolve for 'http' then
diff --git a/extra/models/models.factor b/extra/models/models.factor
index fd84dd248f..ffb9b1127a 100755
--- a/extra/models/models.factor
+++ b/extra/models/models.factor
@@ -4,13 +4,12 @@ USING: generic kernel math sequences arrays assocs alarms
calendar ;
IN: models
-TUPLE: model value connections dependencies ref locked? ;
+TUPLE: model < identity-tuple
+value connections dependencies ref locked? ;
: <model> ( value -- model )
V{ } clone V{ } clone 0 f model construct-boa ;
-M: model equal? 2drop f ;
-
M: model hashcode* drop model hashcode* ;
: add-dependency ( dep model -- )
diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor
index 1963f5670a..1c83bc9713 100755
--- a/extra/ui/freetype/freetype.factor
+++ b/extra/ui/freetype/freetype.factor
@@ -27,9 +27,8 @@ DEFER: freetype
\ freetype get-global expired? [ init-freetype ] when
\ freetype get-global ;
-TUPLE: font ascent descent height handle widths ;
-
-M: font equal? 2drop f ;
+TUPLE: font < identity-tuple
+ascent descent height handle widths ;
M: font hashcode* drop font hashcode* ;
diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor
index ddcaa4b979..c4f11f2e87 100755
--- a/extra/ui/gadgets/gadgets.factor
+++ b/extra/ui/gadgets/gadgets.factor
@@ -44,14 +44,12 @@ M: array rect-dim drop { 0 0 } ;
: rect-union ( rect1 rect2 -- newrect )
(rect-union) <extent-rect> ;
-TUPLE: gadget
+TUPLE: gadget < identity-tuple
pref-dim parent children orientation focus
visible? root? clipped? layout-state graft-state graft-node
interior boundary
model ;
-M: gadget equal? 2drop f ;
-
M: gadget hashcode* drop gadget hashcode* ;
M: gadget model-changed 2drop ;
@@ -354,7 +352,7 @@ SYMBOL: in-layout?
swap [ over (add-gadget) ] each relayout ;
: parents ( gadget -- seq )
- [ dup ] [ [ gadget-parent ] keep ] [ ] unfold nip ;
+ [ gadget-parent ] follow ;
: each-parent ( gadget quot -- ? )
>r parents r> all? ; inline
@@ -401,7 +399,7 @@ M: f request-focus-on 2drop ;
dup focusable-child swap request-focus-on ;
: focus-path ( world -- seq )
- [ dup ] [ [ gadget-focus ] keep ] [ ] unfold nip ;
+ [ gadget-parent ] follow ;
: make-gadget ( quot gadget -- gadget )
[ \ make-gadget rot with-variable ] keep ; inline
diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor
index a44b553858..8ee64b58be 100755
--- a/extra/ui/gadgets/worlds/worlds.factor
+++ b/extra/ui/gadgets/worlds/worlds.factor
@@ -5,7 +5,7 @@ namespaces opengl sequences io combinators math.vectors
ui.gadgets ui.gestures ui.render ui.backend inspector ;
IN: ui.gadgets.worlds
-TUPLE: world
+TUPLE: world < identity-tuple
active? focused?
glass
title status
@@ -46,8 +46,6 @@ M: world request-focus-on ( child gadget -- )
t over set-gadget-root?
dup request-focus ;
-M: world equal? 2drop f ;
-
M: world hashcode* drop world hashcode* ;
M: world pref-dim*
From 337d582a811ee6c3276942acf668eb0c5be15733 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 21:31:41 -0500
Subject: [PATCH 100/127] Fix call-next-method
---
core/generic/standard/standard.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 2b2dbd2b2d..c36e5f1921 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -135,6 +135,7 @@ M: standard-generic next-method-quot
]
[ [ inconsistent-next-method ] 2curry , ]
2tri
+ \ if ,
] [ ] make ;
TUPLE: hook-combination var ;
From a27fa2909875b302191d8c48a073b1ead0875ccc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 2 Apr 2008 21:37:26 -0500
Subject: [PATCH 101/127] Remove type, class-hash primitives
---
core/bootstrap/primitives.factor | 2 --
core/inference/known-words/known-words.factor | 3 ---
vm/primitives.c | 2 --
vm/run.c | 21 -------------------
vm/run.h | 2 --
5 files changed, 30 deletions(-)
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index f3846de5b1..6c87730278 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -656,7 +656,6 @@ define-builtin
{ "code-room" "memory" }
{ "os-env" "system" }
{ "millis" "system" }
- { "type" "kernel.private" }
{ "tag" "kernel.private" }
{ "modify-code-heap" "compiler.units" }
{ "dlopen" "alien" }
@@ -728,7 +727,6 @@ define-builtin
{ "(sleep)" "threads.private" }
{ "<float-array>" "float-arrays" }
{ "<tuple-boa>" "classes.tuple.private" }
- { "class-hash" "kernel.private" }
{ "callstack>array" "kernel" }
{ "innermost-frame-quot" "kernel.private" }
{ "innermost-frame-scan" "kernel.private" }
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index 3cc78831a3..5092b86a4d 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -386,9 +386,6 @@ set-primitive-effect
\ tag { object } { fixnum } <effect> set-primitive-effect
\ tag make-foldable
-\ class-hash { object } { fixnum } <effect> set-primitive-effect
-\ class-hash make-foldable
-
\ cwd { } { string } <effect> set-primitive-effect
\ cd { string } { } <effect> set-primitive-effect
diff --git a/vm/primitives.c b/vm/primitives.c
index 203ebb7f6b..6a6aeb9d46 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -106,7 +106,6 @@ void *primitives[] = {
primitive_code_room,
primitive_os_env,
primitive_millis,
- primitive_type,
primitive_tag,
primitive_modify_code_heap,
primitive_dlopen,
@@ -178,7 +177,6 @@ void *primitives[] = {
primitive_sleep,
primitive_float_array,
primitive_tuple_boa,
- primitive_class_hash,
primitive_callstack_to_array,
primitive_innermost_stack_frame_quot,
primitive_innermost_stack_frame_scan,
diff --git a/vm/run.c b/vm/run.c
index cec19b5445..282be0a447 100755
--- a/vm/run.c
+++ b/vm/run.c
@@ -307,32 +307,11 @@ DEFINE_PRIMITIVE(sleep)
sleep_millis(to_cell(dpop()));
}
-DEFINE_PRIMITIVE(type)
-{
- drepl(tag_fixnum(type_of(dpeek())));
-}
-
DEFINE_PRIMITIVE(tag)
{
drepl(tag_fixnum(TAG(dpeek())));
}
-DEFINE_PRIMITIVE(class_hash)
-{
- CELL obj = dpeek();
- CELL tag = TAG(obj);
- if(tag == TUPLE_TYPE)
- {
- F_TUPLE *tuple = untag_object(obj);
- F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
- drepl(layout->hashcode);
- }
- else if(tag == OBJECT_TYPE)
- drepl(get(UNTAG(obj)));
- else
- drepl(tag_fixnum(tag));
-}
-
DEFINE_PRIMITIVE(slot)
{
F_FIXNUM slot = untag_fixnum_fast(dpop());
diff --git a/vm/run.h b/vm/run.h
index 216a00b27d..c112c5f587 100755
--- a/vm/run.h
+++ b/vm/run.h
@@ -253,9 +253,7 @@ DECLARE_PRIMITIVE(set_os_envs);
DECLARE_PRIMITIVE(eq);
DECLARE_PRIMITIVE(millis);
DECLARE_PRIMITIVE(sleep);
-DECLARE_PRIMITIVE(type);
DECLARE_PRIMITIVE(tag);
-DECLARE_PRIMITIVE(class_hash);
DECLARE_PRIMITIVE(slot);
DECLARE_PRIMITIVE(set_slot);
From 50d8b351de04895ed22b5b2ff4720b9f5bfe28b0 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Wed, 2 Apr 2008 21:43:17 -0500
Subject: [PATCH 102/127] fix using
---
extra/openal/macosx/macosx.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/openal/macosx/macosx.factor b/extra/openal/macosx/macosx.factor
index c03ad5693c..d2a0422d8d 100644
--- a/extra/openal/macosx/macosx.factor
+++ b/extra/openal/macosx/macosx.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel alien alien.syntax shuffle
-combinators.lib openal.backend namespaces ;
+combinators.lib openal.backend namespaces system ;
IN: openal.macosx
LIBRARY: alut
From 27f2992dc5eca644fb077017746243b5f34e4cf2 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 3 Apr 2008 16:09:03 +1300
Subject: [PATCH 103/127] Add failing ebnf test
---
extra/peg/ebnf/ebnf-tests.factor | 6 +++++-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor
index 84c492c55a..0879ecda49 100644
--- a/extra/peg/ebnf/ebnf-tests.factor
+++ b/extra/peg/ebnf/ebnf-tests.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg peg.ebnf words math math.parser ;
+USING: kernel tools.test peg peg.ebnf words math math.parser sequences ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
@@ -247,6 +247,10 @@ IN: peg.ebnf.tests
"1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call parse-result-ast
] unit-test
+{ t } [
+ "abcd='9' | ('8'):x => [[ drop x ]]" 'ebnf' parse parse-result-remaining empty?
+] unit-test
+
EBNF: primary
Primary = PrimaryNoNewArray
PrimaryNoNewArray = ClassInstanceCreationExpression
From cc7d945a80273d4ce966d307424a4f66e72e32ae Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 3 Apr 2008 17:28:09 +1300
Subject: [PATCH 104/127] Change ebnf variables to not use namespaces
---
extra/peg/ebnf/ebnf.factor | 55 +++++++++++++++++++++++++-------------
1 file changed, 37 insertions(+), 18 deletions(-)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index b0dfaad5b3..49c2d5a8dd 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -237,17 +237,16 @@ GENERIC: (transform) ( ast -- parser )
SYMBOL: parser
SYMBOL: main
-SYMBOL: vars
: transform ( ast -- object )
- H{ } clone dup dup [ parser set V{ } vars set swap (transform) main set ] bind ;
+ H{ } clone dup dup [ parser set swap (transform) main set ] bind ;
M: ebnf (transform) ( ast -- parser )
rules>> [ (transform) ] map peek ;
M: ebnf-rule (transform) ( ast -- parser )
dup elements>>
- vars get clone vars [ (transform) ] with-variable [
+ (transform) [
swap symbol>> set
] keep ;
@@ -282,30 +281,50 @@ M: ebnf-repeat1 (transform) ( ast -- parser )
M: ebnf-optional (transform) ( ast -- parser )
transform-group optional ;
-: build-locals ( string vars -- string )
- dup empty? [
- drop
- ] [
+GENERIC: build-locals ( code ast -- code )
+
+M: ebnf-sequence build-locals ( code ast -- code )
+ elements>> dup [ ebnf-var? ] subset empty? [
+ drop
+ ] [
[
- "USING: locals namespaces ; [let* | " %
- [ dup % " [ \"" % % "\" get ] " % ] each
- " | " %
- %
- " ] with-locals" %
+ "USING: locals sequences ; [let* | " %
+ dup length swap [
+ dup ebnf-var? [
+ name>> %
+ " [ " % # " over nth ] " %
+ ] [
+ 2drop
+ ] if
+ ] 2each
+ " | " %
+ %
+ " ] with-locals" %
] "" make
] if ;
+M: ebnf-var build-locals ( code ast -- )
+ [
+ "USING: locals kernel ; [let* | " %
+ name>> % " [ dup ] " %
+ " | " %
+ %
+ " ] with-locals" %
+ ] "" make ;
+
+M: object build-locals ( code ast -- )
+ drop ;
+
M: ebnf-action (transform) ( ast -- parser )
- [ parser>> (transform) ] keep
- code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit action ;
+ [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals
+ string-lines [ parse-lines ] with-compilation-unit action ;
M: ebnf-semantic (transform) ( ast -- parser )
- [ parser>> (transform) ] keep
- code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit semantic ;
+ [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals
+ string-lines [ parse-lines ] with-compilation-unit semantic ;
M: ebnf-var (transform) ( ast -- parser )
- [ parser>> (transform) ] [ name>> ] bi
- dup vars get push [ dupd set ] curry action ;
+ parser>> (transform) ;
M: ebnf-terminal (transform) ( ast -- parser )
symbol>> token ;
From 970f0055c266ab813c177b4c4f545e51ea203479 Mon Sep 17 00:00:00 2001
From: Chris Double <chris@bethia.(none)>
Date: Thu, 3 Apr 2008 17:33:37 +1300
Subject: [PATCH 105/127] Fix failing ebnf unit test
---
extra/peg/ebnf/ebnf.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor
index 49c2d5a8dd..e5787e6cf8 100644
--- a/extra/peg/ebnf/ebnf.factor
+++ b/extra/peg/ebnf/ebnf.factor
@@ -213,6 +213,7 @@ DEFER: 'choice'
: 'actioned-sequence' ( -- parser )
[
[ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 <ebnf-action> ] action ,
+ [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , "=>" syntax , 'action' , ] seq* [ first3 >r <ebnf-var> r> <ebnf-action> ] action ,
[ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
'sequence' ,
] choice* ;
From 93d9722a6bb3bc9c956f10475febcbe85ddf61fd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 00:21:53 -0500
Subject: [PATCH 106/127] Fix class resetting
---
core/classes/mixin/mixin.factor | 2 +-
core/classes/predicate/predicate.factor | 5 ++++-
core/classes/tuple/tuple.factor | 1 +
core/classes/union/union.factor | 2 +-
core/parser/parser.factor | 13 ++++++++-----
5 files changed, 15 insertions(+), 8 deletions(-)
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index b771aa8920..aefd522269 100755
--- a/core/classes/mixin/mixin.factor
+++ b/core/classes/mixin/mixin.factor
@@ -7,7 +7,7 @@ IN: classes.mixin
PREDICATE: mixin-class < union-class "mixin" word-prop ;
M: mixin-class reset-class
- { "metaclass" "members" "mixin" } reset-props ;
+ { "class" "metaclass" "members" "mixin" } reset-props ;
: redefine-mixin-class ( class members -- )
dupd define-union-class
diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor
index 0f98f1f5c4..4729a6dd5e 100755
--- a/core/classes/predicate/predicate.factor
+++ b/core/classes/predicate/predicate.factor
@@ -25,5 +25,8 @@ PREDICATE: predicate-class < class
M: predicate-class reset-class
{
- "metaclass" "predicate-definition" "superclass"
+ "class"
+ "metaclass"
+ "predicate-definition"
+ "superclass"
} reset-props ;
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index ac1a7b8849..58c6f2c581 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -212,6 +212,7 @@ M: tuple-class reset-class
] with each
] [
{
+ "class"
"metaclass"
"superclass"
"layout"
diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
index 9079974a60..09f8f88ced 100755
--- a/core/classes/union/union.factor
+++ b/core/classes/union/union.factor
@@ -29,4 +29,4 @@ M: union-class update-class define-union-predicate ;
2bi ;
M: union-class reset-class
- { "metaclass" "members" } reset-props ;
+ { "class" "metaclass" "members" } reset-props ;
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 2a481d413d..5551ac8af0 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -505,8 +505,10 @@ SYMBOL: interactive-vocabs
: fix-class-words ( -- )
#! If a class word had a compound definition which was
#! removed, it must go back to being a symbol.
- new-definitions get first2 diff
- [ nip dup reset-generic define-symbol ] assoc-each ;
+ new-definitions get first2
+ [ diff values [ [ reset-generic ] [ define-symbol ] bi ] each ]
+ [ swap diff values [ class? ] subset [ reset-class ] each ]
+ 2bi ;
: forget-smudged ( -- )
smudged-usage forget-all
@@ -515,9 +517,10 @@ SYMBOL: interactive-vocabs
: finish-parsing ( lines quot -- )
file get
- [ record-form ] keep
- [ record-definitions ] keep
- record-checksum ;
+ [ record-form ]
+ [ record-definitions ]
+ [ record-checksum ]
+ tri ;
: parse-stream ( stream name -- quot )
[
From cfe1c5d39e95f111f98a72faa2936fa577219fda Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 00:22:10 -0500
Subject: [PATCH 107/127] Update unit test for word removal
---
core/compiler/tests/templates.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor
index a82208e9b9..565c045e2a 100755
--- a/core/compiler/tests/templates.factor
+++ b/core/compiler/tests/templates.factor
@@ -172,14 +172,14 @@ TUPLE: my-tuple ;
[ 1 t ] [
B{ 1 2 3 4 } [
{ c-ptr } declare
- [ 0 alien-unsigned-1 ] keep type
+ [ 0 alien-unsigned-1 ] keep hi-tag
] compile-call byte-array type-number =
] unit-test
[ t ] [
B{ 1 2 3 4 } [
{ c-ptr } declare
- 0 alien-cell type
+ 0 alien-cell hi-tag
] compile-call alien type-number =
] unit-test
From 0cf667859af5a6cb823127539303d3e56e5c371c Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.gateway.2wire.net>
Date: Thu, 3 Apr 2008 00:59:20 -0500
Subject: [PATCH 108/127] fix random on openbsd
---
extra/random/unix/unix.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor
index 3be2697bdf..6a72baa21b 100644
--- a/extra/random/unix/unix.factor
+++ b/extra/random/unix/unix.factor
@@ -15,7 +15,7 @@ C: <unix-random> unix-random
M: unix-random random-bytes* ( n tuple -- byte-array )
path>> file-read-unbuffered ;
-os "openbsd" = [
+os openbsd? [
[
"/dev/srandom" <unix-random> secure-random-generator set-global
"/dev/prandom" <unix-random> insecure-random-generator set-global
From e490e9b636dc045d53935c1ac86346af68650ae8 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.gateway.2wire.net>
Date: Thu, 3 Apr 2008 01:48:29 -0500
Subject: [PATCH 109/127] refactor hardware-info a bit
---
extra/hardware-info/backend/backend.factor | 3 +--
extra/hardware-info/hardware-info.factor | 15 ++++++++----
extra/hardware-info/macosx/macosx.factor | 28 ++++++++++++----------
extra/hardware-info/windows/ce/ce.factor | 19 +++++++--------
extra/hardware-info/windows/nt/nt.factor | 21 +++++++---------
5 files changed, 44 insertions(+), 42 deletions(-)
diff --git a/extra/hardware-info/backend/backend.factor b/extra/hardware-info/backend/backend.factor
index 17794c196d..95a56da2d2 100644
--- a/extra/hardware-info/backend/backend.factor
+++ b/extra/hardware-info/backend/backend.factor
@@ -1,8 +1,7 @@
+USING: system ;
IN: hardware-info.backend
-SYMBOL: os
HOOK: cpus os ( -- n )
-
HOOK: memory-load os ( -- n )
HOOK: physical-mem os ( -- n )
HOOK: available-mem os ( -- n )
diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor
index ecdcc42cb5..6d27cf5252 100755
--- a/extra/hardware-info/hardware-info.factor
+++ b/extra/hardware-info/hardware-info.factor
@@ -1,10 +1,13 @@
-USING: alien.syntax kernel math prettyprint
+USING: alien.syntax kernel math prettyprint io math.parser
combinators vocabs.loader hardware-info.backend system ;
IN: hardware-info
-: kb. ( x -- ) 10 2^ /f . ;
-: megs. ( x -- ) 20 2^ /f . ;
-: gigs. ( x -- ) 30 2^ /f . ;
+: write-unit ( x n str -- )
+ [ 2^ /i number>string write bl ] [ write ] bi* ;
+
+: kb ( x -- ) 10 "kB" write-unit ;
+: megs ( x -- ) 20 "MB" write-unit ;
+: gigs ( x -- ) 30 "GB" write-unit ;
<< {
{ [ os windows? ] [ "hardware-info.windows" ] }
@@ -12,3 +15,7 @@ IN: hardware-info
{ [ os macosx? ] [ "hardware-info.macosx" ] }
{ [ t ] [ f ] }
} cond [ require ] when* >>
+
+: hardware-report. ( -- )
+ "CPUs: " write cpus number>string write nl
+ "Physical RAM: " write physical-mem megs nl ;
diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/hardware-info/macosx/macosx.factor
index c246a95186..dac052a1de 100644
--- a/extra/hardware-info/macosx/macosx.factor
+++ b/extra/hardware-info/macosx/macosx.factor
@@ -1,10 +1,8 @@
USING: alien alien.c-types alien.syntax byte-arrays kernel
-namespaces sequences unix hardware-info.backend ;
+namespaces sequences unix hardware-info.backend system
+io.unix.backend ;
IN: hardware-info.macosx
-TUPLE: macosx ;
-T{ macosx } os set-global
-
! See /usr/include/sys/sysctl.h for constants
LIBRARY: libc
@@ -14,14 +12,11 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi
[ <int> ] map concat ;
: (sysctl-query) ( name namelen oldp oldlenp -- oldp error/f )
- over >r
- f 0 sysctl -1 = [ err_no strerror ] [ f ] if
- r> swap ;
+ over >r f 0 sysctl io-error r> ;
: sysctl-query ( seq n -- byte-array )
- >r [ make-int-array ] keep length r>
- [ <byte-array> ] keep <uint>
- (sysctl-query) [ throw ] when* ;
+ >r [ make-int-array ] [ length ] bi r>
+ [ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
: sysctl-query-string ( seq -- n )
4096 sysctl-query alien>char-string ;
@@ -36,8 +31,15 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi
: model ( -- str ) { 6 2 } sysctl-query-string ;
M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ;
: byte-order ( -- n ) { 6 4 } sysctl-query-uint ;
-: user-mem ( -- 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 ;
: cpu-frequency ( -- n ) { 6 15 } sysctl-query-uint ;
: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
@@ -47,7 +49,7 @@ M: macosx cpus ( -- n ) { 6 3 } 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 ;
-: bus-frequency2 ( -- n ) { 6 23 } sysctl-query-uint ;
-M: macosx physical-mem ( -- n ) { 6 24 } sysctl-query-ulonglong ;
+: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ;
+: mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ;
: available-cpus ( -- n ) { 6 25 } sysctl-query-uint ;
diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor
index f671ea9426..55c2ac6c0d 100755
--- a/extra/hardware-info/windows/ce/ce.factor
+++ b/extra/hardware-info/windows/ce/ce.factor
@@ -2,33 +2,30 @@ USING: alien.c-types hardware-info kernel math namespaces
windows windows.kernel32 hardware-info.backend ;
IN: hardware-info.windows.ce
-TUPLE: wince-os ;
-T{ wince-os } os set-global
-
: memory-status ( -- MEMORYSTATUS )
"MEMORYSTATUS" <c-object>
"MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
[ GlobalMemoryStatus ] keep ;
-M: wince-os cpus ( -- n ) 1 ;
+M: wince cpus ( -- n ) 1 ;
-M: wince-os memory-load ( -- n )
+M: wince memory-load ( -- n )
memory-status MEMORYSTATUS-dwMemoryLoad ;
-M: wince-os physical-mem ( -- n )
+M: wince physical-mem ( -- n )
memory-status MEMORYSTATUS-dwTotalPhys ;
-M: wince-os available-mem ( -- n )
+M: wince available-mem ( -- n )
memory-status MEMORYSTATUS-dwAvailPhys ;
-M: wince-os total-page-file ( -- n )
+M: wince total-page-file ( -- n )
memory-status MEMORYSTATUS-dwTotalPageFile ;
-M: wince-os available-page-file ( -- n )
+M: wince available-page-file ( -- n )
memory-status MEMORYSTATUS-dwAvailPageFile ;
-M: wince-os total-virtual-mem ( -- n )
+M: wince total-virtual-mem ( -- n )
memory-status MEMORYSTATUS-dwTotalVirtual ;
-M: wince-os available-virtual-mem ( -- n )
+M: wince available-virtual-mem ( -- n )
memory-status MEMORYSTATUS-dwAvailVirtual ;
diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor
index 8bdb75fe6a..ba9c1d74b5 100755
--- a/extra/hardware-info/windows/nt/nt.factor
+++ b/extra/hardware-info/windows/nt/nt.factor
@@ -1,15 +1,12 @@
USING: alien alien.c-types
kernel libc math namespaces hardware-info.backend
-windows windows.advapi32 windows.kernel32 ;
+windows windows.advapi32 windows.kernel32 system ;
IN: hardware-info.windows.nt
-TUPLE: winnt-os ;
-T{ winnt-os } os set-global
-
: system-info ( -- SYSTEM_INFO )
"SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
-M: winnt-os cpus ( -- n )
+M: winnt cpus ( -- n )
system-info SYSTEM_INFO-dwNumberOfProcessors ;
: memory-status ( -- MEMORYSTATUSEX )
@@ -17,25 +14,25 @@ M: winnt-os cpus ( -- n )
"MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength
[ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ;
-M: winnt-os memory-load ( -- n )
+M: winnt memory-load ( -- n )
memory-status MEMORYSTATUSEX-dwMemoryLoad ;
-M: winnt-os physical-mem ( -- n )
+M: winnt physical-mem ( -- n )
memory-status MEMORYSTATUSEX-ullTotalPhys ;
-M: winnt-os available-mem ( -- n )
+M: winnt available-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailPhys ;
-M: winnt-os total-page-file ( -- n )
+M: winnt total-page-file ( -- n )
memory-status MEMORYSTATUSEX-ullTotalPageFile ;
-M: winnt-os available-page-file ( -- n )
+M: winnt available-page-file ( -- n )
memory-status MEMORYSTATUSEX-ullAvailPageFile ;
-M: winnt-os total-virtual-mem ( -- n )
+M: winnt total-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullTotalVirtual ;
-M: winnt-os available-virtual-mem ( -- n )
+M: winnt available-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailVirtual ;
: computer-name ( -- string )
From 54265a9f4c33d2f60cf87320fe4ec530dc9a0255 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 04:58:37 -0500
Subject: [PATCH 110/127] Final inheritance fixes
---
core/classes/tuple/tuple-tests.factor | 11 +++
core/generic/standard/standard-tests.factor | 98 ++++++++++++++++++++-
core/inference/class/class-tests.factor | 14 +++
core/inference/class/class.factor | 31 ++++---
core/optimizer/inlining/inlining.factor | 9 +-
core/parser/parser.factor | 22 +++--
6 files changed, 159 insertions(+), 26 deletions(-)
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 735f328a67..a8e9066f56 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -542,3 +542,14 @@ USE: vocabs
[ f ] [ "x" accessor-exists? ] unit-test
[ f ] [ "y" accessor-exists? ] unit-test
[ f ] [ "z" accessor-exists? ] unit-test
+
+TUPLE: another-forget-accessors-test ;
+
+
+[ [ ] ] [
+ "IN: classes.tuple.tests GENERIC: another-forget-accessors-test"
+ <string-reader>
+ "another-forget-accessors-test" parse-stream
+] unit-test
+
+[ t ] [ \ another-forget-accessors-test class? ] unit-test
diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor
index fbca22471c..2f58770b1a 100644
--- a/core/generic/standard/standard-tests.factor
+++ b/core/generic/standard/standard-tests.factor
@@ -1,7 +1,7 @@
IN: generic.standard.tests
USING: tools.test math math.functions math.constants
generic.standard strings sequences arrays kernel accessors
-words float-arrays byte-arrays bit-arrays parser ;
+words float-arrays byte-arrays bit-arrays parser namespaces ;
GENERIC: lo-tag-test
@@ -137,3 +137,99 @@ M: byte-array small-lo-tag drop "byte-array" ;
[ "fixnum" ] [ 3 small-lo-tag ] unit-test
[ "float-array" ] [ F{ 1.0 } small-lo-tag ] unit-test
+
+! Testing next-method
+TUPLE: person ;
+
+TUPLE: intern < person ;
+
+TUPLE: employee < person ;
+
+TUPLE: tape-monkey < employee ;
+
+TUPLE: manager < employee ;
+
+TUPLE: junior-manager < manager ;
+
+TUPLE: middle-manager < manager ;
+
+TUPLE: senior-manager < manager ;
+
+TUPLE: executive < senior-manager ;
+
+TUPLE: ceo < executive ;
+
+GENERIC: salary ( person -- n )
+
+M: intern salary
+ #! Intentional mistake.
+ call-next-method ;
+
+M: employee salary drop 24000 ;
+
+M: manager salary call-next-method 12000 + ;
+
+M: middle-manager salary call-next-method 5000 + ;
+
+M: senior-manager salary call-next-method 15000 + ;
+
+M: executive salary call-next-method 2 * ;
+
+M: ceo salary
+ #! Intentional error.
+ drop 5 call-next-method 3 * ;
+
+[ salary ] must-infer
+
+[ 24000 ] [ employee construct-boa salary ] unit-test
+
+[ 24000 ] [ tape-monkey construct-boa salary ] unit-test
+
+[ 36000 ] [ junior-manager construct-boa salary ] unit-test
+
+[ 41000 ] [ middle-manager construct-boa salary ] unit-test
+
+[ 51000 ] [ senior-manager construct-boa salary ] unit-test
+
+[ 102000 ] [ executive construct-boa salary ] unit-test
+
+[ ceo construct-boa salary ]
+[ T{ inconsistent-next-method f 5 ceo salary } = ] must-fail-with
+
+[ intern construct-boa salary ]
+[ T{ no-next-method f intern salary } = ] must-fail-with
+
+! Weird shit
+TUPLE: a ;
+TUPLE: b ;
+TUPLE: c ;
+
+UNION: x a b ;
+UNION: y a c ;
+
+UNION: z x y ;
+
+GENERIC: funky* ( obj -- )
+
+M: z funky* "z" , drop ;
+
+M: x funky* "x" , call-next-method ;
+
+M: y funky* "y" , call-next-method ;
+
+M: a funky* "a" , call-next-method ;
+
+M: b funky* "b" , call-next-method ;
+
+M: c funky* "c" , call-next-method ;
+
+: funky [ funky* ] { } make ;
+
+[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
+
+[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test
+
+[ t ] [
+ T{ a } funky
+ { { "a" "x" "z" } { "a" "y" "z" } } member?
+] unit-test
diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor
index b54dbe256a..038ab1d230 100755
--- a/core/inference/class/class-tests.factor
+++ b/core/inference/class/class-tests.factor
@@ -233,6 +233,20 @@ M: fixnum annotate-entry-test-1 drop ;
\ >float inlined?
] unit-test
+GENERIC: detect-float ( a -- b )
+
+M: float detect-float ;
+
+[ t ] [
+ [ { real float } declare + detect-float ]
+ \ detect-float inlined?
+] unit-test
+
+[ t ] [
+ [ { float real } declare + detect-float ]
+ \ detect-float inlined?
+] unit-test
+
[ t ] [
[ 3 + = ] \ equal? inlined?
] unit-test
diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor
index 8269952409..033d2cce7a 100755
--- a/core/inference/class/class.factor
+++ b/core/inference/class/class.factor
@@ -274,7 +274,7 @@ DEFER: (infer-classes)
(merge-intervals) r> set-intervals ;
: annotate-merge ( nodes #merge/#entry -- )
- 2dup merge-classes merge-intervals ;
+ [ merge-classes ] [ merge-intervals ] 2bi ;
: merge-children ( node -- )
dup node-successor dup #merge? [
@@ -290,28 +290,31 @@ DEFER: (infer-classes)
M: #label infer-classes-before ( #label -- )
#! First, infer types under the hypothesis which hold on
#! entry to the recursive label.
- dup 1array swap annotate-entry ;
+ [ 1array ] keep annotate-entry ;
M: #label infer-classes-around ( #label -- )
#! Now merge the types at every recursion point with the
#! entry types.
- dup annotate-node
- dup infer-classes-before
- dup infer-children
- dup collect-recursion over suffix
- pick annotate-entry
- node-child (infer-classes) ;
+ {
+ [ annotate-node ]
+ [ infer-classes-before ]
+ [ infer-children ]
+ [ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ]
+ [ node-child (infer-classes) ]
+ } cleave ;
M: object infer-classes-around
- dup infer-classes-before
- dup annotate-node
- dup infer-children
- merge-children ;
+ {
+ [ infer-classes-before ]
+ [ annotate-node ]
+ [ infer-children ]
+ [ merge-children ]
+ } cleave ;
: (infer-classes) ( node -- )
[
- dup infer-classes-around
- node-successor (infer-classes)
+ [ infer-classes-around ]
+ [ node-successor (infer-classes) ] bi
] when* ;
: infer-classes-with ( node classes literals intervals -- )
diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor
index 81f53b5ace..9d41d6eae1 100755
--- a/core/optimizer/inlining/inlining.factor
+++ b/core/optimizer/inlining/inlining.factor
@@ -71,8 +71,13 @@ DEFER: (flat-length)
! Partial dispatch of math-generic words
: normalize-math-class ( class -- class' )
- { fixnum bignum ratio float complex }
- [ class< ] with find nip object or ;
+ {
+ fixnum bignum integer
+ ratio rational
+ float real
+ complex number
+ object
+ } [ class< ] with find nip ;
: math-both-known? ( word left right -- ? )
math-class-max swap specific-method ;
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 5551ac8af0..902bae29b5 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -477,18 +477,22 @@ SYMBOL: interactive-vocabs
nl
] when 2drop ;
-: filter-moved ( assoc -- newassoc )
- [
+: filter-moved ( assoc1 assoc2 -- seq )
+ diff [
drop where dup [ first ] when
file get source-file-path =
- ] assoc-subset ;
+ ] assoc-subset keys ;
-: removed-definitions ( -- definitions )
+: removed-definitions ( -- assoc1 assoc2 )
new-definitions old-definitions
- [ get first2 union ] bi@ diff ;
+ [ get first2 union ] bi@ ;
+
+: removed-classes ( -- assoc1 assoc2 )
+ new-definitions old-definitions
+ [ get second ] bi@ ;
: smudged-usage ( -- usages referenced removed )
- removed-definitions filter-moved keys [
+ removed-definitions filter-moved [
outside-usages
[
empty? [ drop f ] [
@@ -506,9 +510,9 @@ SYMBOL: interactive-vocabs
#! If a class word had a compound definition which was
#! removed, it must go back to being a symbol.
new-definitions get first2
- [ diff values [ [ reset-generic ] [ define-symbol ] bi ] each ]
- [ swap diff values [ class? ] subset [ reset-class ] each ]
- 2bi ;
+ filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each
+ removed-classes
+ filter-moved [ class? ] subset [ reset-class ] each ;
: forget-smudged ( -- )
smudged-usage forget-all
From 45cf030cbd6ed1075e626028849457969c955ef7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 05:21:45 -0500
Subject: [PATCH 111/127] Use call-next-method
---
extra/smtp/smtp-tests.factor | 6 ++++++
extra/smtp/smtp.factor | 2 +-
2 files changed, 7 insertions(+), 1 deletion(-)
diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor
index a705a9609e..1d22ed731a 100755
--- a/extra/smtp/smtp-tests.factor
+++ b/extra/smtp/smtp-tests.factor
@@ -3,6 +3,12 @@ smtp.server kernel sequences namespaces logging accessors
assocs sorting ;
IN: smtp.tests
+[ t ] [
+ <email>
+ dup clone "a" "b" set-header drop
+ headers>> assoc-empty?
+] unit-test
+
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
[ "hello\nworld" validate-address ] must-fail
diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor
index 13db422621..ee2b021329 100755
--- a/extra/smtp/smtp.factor
+++ b/extra/smtp/smtp.factor
@@ -106,7 +106,7 @@ LOG: smtp-response DEBUG
TUPLE: email from to subject headers body ;
M: email clone
- (clone) [ clone ] change-headers ;
+ call-next-method [ clone ] change-headers ;
: (send) ( email -- )
[
From 1ff2eaf09c9da714cd4699cddf07fba863934abf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 05:24:04 -0500
Subject: [PATCH 112/127] Move enum docs
---
core/assocs/assocs-docs.factor | 14 ++++++++++++++
core/mirrors/mirrors-docs.factor | 8 --------
extra/help/handbook/handbook.factor | 1 +
3 files changed, 15 insertions(+), 8 deletions(-)
diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
index b6326e1c10..9b0922d096 100755
--- a/core/assocs/assocs-docs.factor
+++ b/core/assocs/assocs-docs.factor
@@ -16,6 +16,20 @@ $nl
"To make an assoc into an alist:"
{ $subsection >alist } ;
+ARTICLE: "enums" "Enumerations"
+"An enumeration provides a view of a sequence as an assoc mapping integer indices to elements:"
+{ $subsection enum }
+{ $subsection <enum> } ;
+
+HELP: enum
+{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
+$nl
+"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ;
+
+HELP: <enum>
+{ $values { "seq" sequence } { "enum" enum } }
+{ $description "Creates a new enumeration." } ;
+
ARTICLE: "assocs-protocol" "Associative mapping protocol"
"All associative mappings must be instances of a mixin class:"
{ $subsection assoc }
diff --git a/core/mirrors/mirrors-docs.factor b/core/mirrors/mirrors-docs.factor
index 725a757e61..dc4315fb39 100755
--- a/core/mirrors/mirrors-docs.factor
+++ b/core/mirrors/mirrors-docs.factor
@@ -7,9 +7,6 @@ $nl
"A mirror provides such a view of a tuple:"
{ $subsection mirror }
{ $subsection <mirror> }
-"An enum provides such a view of a sequence:"
-{ $subsection enum }
-{ $subsection <enum> }
"Utility word used by developer tools which inspect objects:"
{ $subsection make-mirror }
{ $see-also "slots" } ;
@@ -44,11 +41,6 @@ HELP: >mirror<
{ $values { "mirror" mirror } { "obj" object } { "slots" "a sequence of " { $link slot-spec } " instances" } }
{ $description "Pushes the object being viewed in the mirror together with its slots." } ;
-HELP: enum
-{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
-$nl
-"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ;
-
HELP: make-mirror
{ $values { "obj" object } { "assoc" assoc } }
{ $description "Creates an assoc which reflects the internal structure of the object." } ;
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index e45c49aa25..847a5952af 100755
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -152,6 +152,7 @@ ARTICLE: "collections" "Collections"
"Implementations:"
{ $subsection "hashtables" }
{ $subsection "alists" }
+{ $subsection "enums" }
{ $heading "Other collections" }
{ $subsection "boxes" }
{ $subsection "dlists" }
From 88092f2c2ae7c86c3c831f8aaaea98e31933fa8a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 05:27:38 -0500
Subject: [PATCH 113/127] Documentation update
---
core/assocs/assocs-docs.factor | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
index 9b0922d096..e85789a4f2 100755
--- a/core/assocs/assocs-docs.factor
+++ b/core/assocs/assocs-docs.factor
@@ -19,7 +19,9 @@ $nl
ARTICLE: "enums" "Enumerations"
"An enumeration provides a view of a sequence as an assoc mapping integer indices to elements:"
{ $subsection enum }
-{ $subsection <enum> } ;
+{ $subsection <enum> }
+"Inverting a permutation using enumerations:"
+{ $example "USING: assocs sorting prettyprint ;" ": invert <enum> >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ;
HELP: enum
{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
From 16377be935bcfb1a9346d8d78c22f486baeac2a1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 05:57:20 -0500
Subject: [PATCH 114/127] Use call-next-method
---
core/classes/tuple/tuple.factor | 4 ++--
core/generic/generic.factor | 21 ++++++++-------------
core/words/words-docs.factor | 6 +-----
core/words/words.factor | 8 +-------
4 files changed, 12 insertions(+), 27 deletions(-)
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 58c6f2c581..b1cb3f8a66 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -207,8 +207,8 @@ M: tuple-class define-tuple-class
M: tuple-class reset-class
[
dup "slot-names" word-prop [
- [ reader-word forget-method ]
- [ writer-word forget-method ] 2bi
+ [ reader-word method forget ]
+ [ writer-word method forget ] 2bi
] with each
] [
{
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index b0099f770c..72948c5473 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -106,14 +106,6 @@ M: method-spec definer
M: method-spec definition
first2 method definition ;
-: forget-method ( class generic -- )
- dup generic? [
- [ delete-at* ] with-methods
- [ forget-word ] [ drop ] if
- ] [
- 2drop
- ] if ;
-
M: method-spec forget*
first2 method forget* ;
@@ -123,9 +115,12 @@ M: method-body definer
M: method-body forget*
dup "forgotten" word-prop [ drop ] [
[
- [ "method-class" word-prop ]
+ [ "method-class" word-prop ]
[ "method-generic" word-prop ] bi
- forget-method
+ dup generic? [
+ [ delete-at* ] with-methods
+ [ call-next-method ] [ drop ] if
+ ] [ 2drop ] if
]
[ t "forgotten" set-word-prop ] bi
] if ;
@@ -145,7 +140,7 @@ M: method-body forget*
M: class forget* ( class -- )
[ forget-methods ]
[ update-map- ]
- [ forget-word ]
+ [ call-next-method ]
tri ;
M: assoc update-methods ( assoc -- )
@@ -169,8 +164,8 @@ M: generic subwords
tri
] { } make ;
-M: generic forget-word
- [ subwords forget-all ] [ (forget-word) ] bi ;
+M: generic forget*
+ [ subwords forget-all ] [ call-next-method ] bi ;
: xref-generics ( -- )
all-words [ subwords [ xref ] each ] each ;
diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor
index eb1bd0908a..a715aab64f 100755
--- a/core/words/words-docs.factor
+++ b/core/words/words-docs.factor
@@ -324,11 +324,7 @@ HELP: constructor-word
{ $description "Creates a new word, surrounding " { $snippet "name" } " in angle brackets." }
{ $examples { $example "USING: prettyprint words ;" "\"salmon\" \"scratchpad\" constructor-word ." "<salmon>" } } ;
-HELP: forget-word
-{ $values { "word" word } }
-{ $description "Removes a word from its vocabulary. User code should call " { $link forget } " instead, since it also does the right thing when forgetting class words." } ;
-
-{ POSTPONE: FORGET: forget forget-word forget-vocab } related-words
+{ POSTPONE: FORGET: forget forget* forget-vocab } related-words
HELP: target-word
{ $values { "word" word } { "target" word } }
diff --git a/core/words/words.factor b/core/words/words.factor
index 1232a97ddc..059815e952 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -212,9 +212,7 @@ M: word where "loc" word-prop ;
M: word set-where swap "loc" set-word-prop ;
-GENERIC: forget-word ( word -- )
-
-: (forget-word) ( word -- )
+M: word forget*
dup "forgotten" word-prop [
dup delete-xref
dup delete-compiled-xref
@@ -222,10 +220,6 @@ GENERIC: forget-word ( word -- )
dup t "forgotten" set-word-prop
] unless drop ;
-M: word forget-word (forget-word) ;
-
-M: word forget* forget-word ;
-
M: word hashcode*
nip 1 slot { fixnum } declare ;
From b096395e6c1486a8de01b2d9f8a92dca32e00501 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 3 Apr 2008 06:11:18 -0500
Subject: [PATCH 115/127] Fix reports.noise load error
---
extra/reports/noise/noise.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor
index 7e9496c90d..6921d1223a 100755
--- a/extra/reports/noise/noise.factor
+++ b/extra/reports/noise/noise.factor
@@ -136,7 +136,7 @@ M: lambda-word word-noise-factor
: flatten-generics ( words -- words' )
[
- dup generic? [ methods values ] [ 1array ] if
+ dup generic? [ "methods" word-prop values ] [ 1array ] if
] map concat ;
: noisy-words ( -- alist )
From d642347f341e3820a3167e1c9c7e489d42928858 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 11:55:08 -0500
Subject: [PATCH 116/127] move bit twiddling words to math.bitfields.lib use
32-bit in mersenne-twister
---
extra/crypto/common/common-docs.factor | 17 -------------
extra/crypto/common/common.factor | 24 ++-----------------
extra/crypto/sha1/sha1.factor | 4 ++--
extra/crypto/sha2/sha2.factor | 20 ++++++++--------
extra/math/functions/functions.factor | 9 -------
.../mersenne-twister/mersenne-twister.factor | 13 ++++------
6 files changed, 19 insertions(+), 68 deletions(-)
diff --git a/extra/crypto/common/common-docs.factor b/extra/crypto/common/common-docs.factor
index b53ecaac3c..559c7934d0 100644
--- a/extra/crypto/common/common-docs.factor
+++ b/extra/crypto/common/common-docs.factor
@@ -2,23 +2,6 @@ USING: help.markup help.syntax kernel math sequences quotations
math.private ;
IN: crypto.common
-HELP: >32-bit
-{ $values { "x" integer } { "y" integer } }
-{ $description "Used to implement 32-bit integer overflow." } ;
-
-HELP: >64-bit
-{ $values { "x" integer } { "y" integer } }
-{ $description "Used to implement 64-bit integer overflow." } ;
-
-HELP: bitroll
-{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } }
-{ $description "Roll n by s bits to the left, wrapping around after w bits." }
-{ $examples
- { $example "USING: crypto.common prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
- { $example "USING: crypto.common prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
-} ;
-
-
HELP: hex-string
{ $values { "seq" "a sequence" } { "str" "a string" } }
{ $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." }
diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor
index 3ac551d114..f0129772b0 100644
--- a/extra/crypto/common/common.factor
+++ b/extra/crypto/common/common.factor
@@ -1,11 +1,8 @@
USING: arrays kernel io io.binary sbufs splitting strings sequences
-namespaces math math.parser parser hints ;
+namespaces math math.parser parser hints math.bitfields.lib ;
IN: crypto.common
-: >32-bit ( x -- y ) HEX: ffffffff bitand ; inline
-: >64-bit ( x -- y ) HEX: ffffffffffffffff bitand ; inline
-
-: w+ ( int int -- int ) + >32-bit ; inline
+: w+ ( int int -- int ) + 32-bit ; inline
: (nth-int) ( string n -- int )
2 shift dup 4 + rot <slice> ; inline
@@ -39,26 +36,9 @@ SYMBOL: big-endian?
3 shift 8 rot [ >be ] [ >le ] if %
] "" make 64 group ;
-: shift-mod ( n s w -- n )
- >r shift r> 2^ 1- bitand ; inline
-
: update-old-new ( old new -- )
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
-: bitroll ( x s w -- y )
- [ 1 - bitand ] keep
- over 0 < [ [ + ] keep ] when
- [ shift-mod ] 3keep
- [ - ] keep shift-mod bitor ; inline
-
-: bitroll-32 ( n s -- n' ) 32 bitroll ;
-
-HINTS: bitroll-32 bignum fixnum ;
-
-: bitroll-64 ( n s -- n' ) 64 bitroll ;
-
-HINTS: bitroll-64 bignum fixnum ;
-
: hex-string ( seq -- str )
[ [ >hex 2 48 pad-left % ] each ] "" make ;
diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor
index 8f3d3e6ecc..7e8677a117 100755
--- a/extra/crypto/sha1/sha1.factor
+++ b/extra/crypto/sha1/sha1.factor
@@ -1,7 +1,7 @@
USING: arrays combinators crypto.common kernel io
io.encodings.binary io.files io.streams.byte-array math.vectors
strings sequences namespaces math parser sequences vectors
-io.binary hashtables symbols ;
+io.binary hashtables symbols math.bitfields.lib ;
IN: crypto.sha1
! Implemented according to RFC 3174.
@@ -66,7 +66,7 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
K get nth ,
A get 5 bitroll-32 ,
E get ,
- ] { } make sum >32-bit ; inline
+ ] { } make sum 32-bit ; inline
: set-vars ( temp -- )
! E = D; D = C; C = S^30(B); B = A; A = TEMP;
diff --git a/extra/crypto/sha2/sha2.factor b/extra/crypto/sha2/sha2.factor
index daba6d29ff..f555de8b08 100755
--- a/extra/crypto/sha2/sha2.factor
+++ b/extra/crypto/sha2/sha2.factor
@@ -1,19 +1,19 @@
USING: crypto.common kernel splitting math sequences namespaces
-io.binary symbols ;
+io.binary symbols math.bitfields.lib ;
IN: crypto.sha2
<PRIVATE
SYMBOLS: vars M K H S0 S1 process-M word-size block-size >word ;
-: a 0 ;
-: b 1 ;
-: c 2 ;
-: d 3 ;
-: e 4 ;
-: f 5 ;
-: g 6 ;
-: h 7 ;
+: a 0 ; inline
+: b 1 ; inline
+: c 2 ; inline
+: d 3 ; inline
+: e 4 ; inline
+: f 5 ; inline
+: g 6 ; inline
+: h 7 ; inline
: initial-H-256 ( -- seq )
{
@@ -124,7 +124,7 @@ PRIVATE>
initial-H-256 H set
4 word-size set
64 block-size set
- \ >32-bit >word set
+ \ 32-bit >word set
byte-array>sha2
] with-scope ;
diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor
index dcbccb4316..77c7d9247d 100755
--- a/extra/math/functions/functions.factor
+++ b/extra/math/functions/functions.factor
@@ -30,15 +30,6 @@ M: real sqrt
2dup >r >r >r odd? r> call r> 2/ r> each-bit
] if ; inline
-: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
-: set-bit ( x n -- y ) 2^ bitor ; foldable
-: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
-: bit-set? ( x n -- ? ) bit-clear? not ; foldable
-: unmask ( x n -- ? ) bitnot bitand ; foldable
-: unmask? ( x n -- ? ) unmask 0 > ; foldable
-: mask ( x n -- ? ) bitand ; foldable
-: mask? ( x n -- ? ) mask 0 > ; foldable
-
GENERIC: (^) ( x y -- z ) foldable
: ^n ( z w -- z^w )
diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor
index 77054ea377..2aa6f45897 100755
--- a/extra/random/mersenne-twister/mersenne-twister.factor
+++ b/extra/random/mersenne-twister/mersenne-twister.factor
@@ -4,7 +4,7 @@
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
USING: arrays kernel math namespaces sequences system init
-accessors math.ranges random circular ;
+accessors math.ranges random circular math.bitfields.lib ;
IN: random.mersenne-twister
<PRIVATE
@@ -33,21 +33,18 @@ TUPLE: mersenne-twister seq i ;
[ >r mt-n r> seq>> [ [ (mt-generate) ] keep set-generated ] curry each ]
[ 0 >>i drop ] bi ;
-: init-mt-first ( seed -- seq )
- >r mt-n 0 <array> <circular> r>
- HEX: ffffffff bitand 0 pick set-nth ;
-
: init-mt-formula ( seq i -- f(seq[i]) )
tuck swap nth dup -30 shift bitxor 1812433253 * +
- 1+ HEX: ffffffff bitand ;
+ 1+ 32-bit ;
: init-mt-rest ( seq -- )
- mt-n 1- [0,b) [
+ mt-n 1- [
dupd [ init-mt-formula ] keep 1+ rot set-nth
] with each ;
: init-mt-seq ( seed -- seq )
- init-mt-first dup init-mt-rest ;
+ 32-bit mt-n 0 <array> <circular>
+ [ set-first ] [ init-mt-rest ] [ ] tri ;
: mt-temper ( y -- yt )
dup -11 shift bitxor
From 5c2b2b024e1c0b6a4332d752d68f119048b56d4a Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 13:04:24 -0500
Subject: [PATCH 117/127] more cleanup of mersenne-twister -- you can actually
understand it now :)
---
.../mersenne-twister/mersenne-twister.factor | 55 ++++++++++---------
1 file changed, 29 insertions(+), 26 deletions(-)
diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor
index 2aa6f45897..d3a5fad4ca 100755
--- a/extra/random/mersenne-twister/mersenne-twister.factor
+++ b/extra/random/mersenne-twister/mersenne-twister.factor
@@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
! mersenne twister based on
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
-
USING: arrays kernel math namespaces sequences system init
-accessors math.ranges random circular math.bitfields.lib ;
+accessors math.ranges random circular math.bitfields.lib
+combinators ;
IN: random.mersenne-twister
<PRIVATE
@@ -14,36 +14,37 @@ TUPLE: mersenne-twister seq i ;
: mt-n 624 ; inline
: mt-m 397 ; inline
: mt-a HEX: 9908b0df ; inline
-: mt-hi HEX: 80000000 bitand ; inline
-: mt-lo HEX: 7fffffff bitand ; inline
-
-: set-generated ( y from-elt to seq -- )
- >r >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi
- r> bitxor bitxor r> r> set-nth ; inline
: calculate-y ( y1 y2 mt -- y )
- tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline
+ tuck
+ [ nth 32 mask-bit ]
+ [ nth 31 bits ] 2bi* bitor ; inline
-: (mt-generate) ( n mt-seq -- y to from-elt )
- [ >r dup 1+ r> calculate-y ]
- [ >r mt-m + r> nth ]
- [ drop ] 2tri ;
+: (mt-generate) ( n mt-seq -- next-mt )
+ [
+ [ dup 1+ ] [ calculate-y ] bi*
+ [ 2/ ] [ odd? mt-a 0 ? ] bi bitxor
+ ] [
+ [ mt-m + ] [ nth ] bi*
+ ] 2bi bitxor ;
: mt-generate ( mt -- )
- [ >r mt-n r> seq>> [ [ (mt-generate) ] keep set-generated ] curry each ]
- [ 0 >>i drop ] bi ;
+ [
+ mt-n swap seq>> [
+ [ (mt-generate) ] [ set-nth ] 2bi
+ ] curry each
+ ] [ 0 >>i drop ] bi ;
-: init-mt-formula ( seq i -- f(seq[i]) )
- tuck swap nth dup -30 shift bitxor 1812433253 * +
- 1+ 32-bit ;
+: init-mt-formula ( i seq -- f(seq[i]) )
+ dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ;
: init-mt-rest ( seq -- )
- mt-n 1- [
- dupd [ init-mt-formula ] keep 1+ rot set-nth
- ] with each ;
+ mt-n 1- swap [
+ [ init-mt-formula ] [ >r 1+ r> set-nth ] 2bi
+ ] curry each ;
: init-mt-seq ( seed -- seq )
- 32-bit mt-n 0 <array> <circular>
+ 32 bits mt-n 0 <array> <circular>
[ set-first ] [ init-mt-rest ] [ ] tri ;
: mt-temper ( y -- yt )
@@ -52,6 +53,9 @@ TUPLE: mersenne-twister seq i ;
dup 15 shift HEX: efc60000 bitand bitxor
dup -18 shift bitxor ; inline
+: next-index ( mt -- i )
+ dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ;
+
PRIVATE>
: <mersenne-twister> ( seed -- obj )
@@ -62,7 +66,6 @@ M: mersenne-twister seed-random ( mt seed -- )
init-mt-seq >>seq drop ;
M: mersenne-twister random-32* ( mt -- r )
- dup [ i>> ] [ seq>> ] bi
- over mt-n < [ nip >r dup mt-generate 0 r> ] unless
- nth mt-temper
- swap [ 1+ ] change-i drop ;
+ [ next-index ]
+ [ seq>> nth mt-temper ]
+ [ [ 1+ ] change-i drop ] tri ;
From 0b90458cca9e82e2e1174edc81324f6e6e29c519 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 13:27:10 -0500
Subject: [PATCH 118/127] simplify bitroll
---
extra/crypto/common/common.factor | 2 +-
extra/crypto/sha1/sha1.factor | 2 +-
extra/crypto/sha2/sha2.factor | 3 +--
extra/math/bitfields/lib/lib-docs.factor | 16 ++++++++++++
extra/math/bitfields/lib/lib-tests.factor | 14 ++++++++++
extra/math/bitfields/lib/lib.factor | 31 +++++++++++++++++++++++
6 files changed, 64 insertions(+), 4 deletions(-)
create mode 100644 extra/math/bitfields/lib/lib-docs.factor
create mode 100644 extra/math/bitfields/lib/lib-tests.factor
create mode 100644 extra/math/bitfields/lib/lib.factor
diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor
index f0129772b0..b9f1d43784 100644
--- a/extra/crypto/common/common.factor
+++ b/extra/crypto/common/common.factor
@@ -2,7 +2,7 @@ USING: arrays kernel io io.binary sbufs splitting strings sequences
namespaces math math.parser parser hints math.bitfields.lib ;
IN: crypto.common
-: w+ ( int int -- int ) + 32-bit ; inline
+: w+ ( int int -- int ) + 32 bits ; inline
: (nth-int) ( string n -- int )
2 shift dup 4 + rot <slice> ; inline
diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor
index 7e8677a117..d054eda31b 100755
--- a/extra/crypto/sha1/sha1.factor
+++ b/extra/crypto/sha1/sha1.factor
@@ -66,7 +66,7 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
K get nth ,
A get 5 bitroll-32 ,
E get ,
- ] { } make sum 32-bit ; inline
+ ] { } make sum 32 bits ; inline
: set-vars ( temp -- )
! E = D; D = C; C = S^30(B); B = A; A = TEMP;
diff --git a/extra/crypto/sha2/sha2.factor b/extra/crypto/sha2/sha2.factor
index f555de8b08..0acc5c1388 100755
--- a/extra/crypto/sha2/sha2.factor
+++ b/extra/crypto/sha2/sha2.factor
@@ -4,7 +4,7 @@ IN: crypto.sha2
<PRIVATE
-SYMBOLS: vars M K H S0 S1 process-M word-size block-size >word ;
+SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
: a 0 ; inline
: b 1 ; inline
@@ -124,7 +124,6 @@ PRIVATE>
initial-H-256 H set
4 word-size set
64 block-size set
- \ 32-bit >word set
byte-array>sha2
] with-scope ;
diff --git a/extra/math/bitfields/lib/lib-docs.factor b/extra/math/bitfields/lib/lib-docs.factor
new file mode 100644
index 0000000000..bfbe9eaded
--- /dev/null
+++ b/extra/math/bitfields/lib/lib-docs.factor
@@ -0,0 +1,16 @@
+USING: help.markup help.syntax kernel math sequences ;
+IN: math.bitfields.lib
+
+HELP: bits
+{ $values { "m" integer } { "n" integer } { "m'" integer } }
+{ $description "Keep only n bits from the integer m." }
+{ $example "USING: math.bitfields.lib prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ;
+
+HELP: bitroll
+{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } }
+{ $description "Roll n by s bits to the left, wrapping around after w bits." }
+{ $examples
+ { $example "USING: math.bitfields.lib prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
+ { $example "USING: math.bitfields.lib prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
+} ;
+
diff --git a/extra/math/bitfields/lib/lib-tests.factor b/extra/math/bitfields/lib/lib-tests.factor
new file mode 100644
index 0000000000..c002240e69
--- /dev/null
+++ b/extra/math/bitfields/lib/lib-tests.factor
@@ -0,0 +1,14 @@
+USING: math.bitfields.lib tools.test ;
+IN: math.bitfields.lib.test
+
+[ 0 ] [ 1 0 0 bitroll ] unit-test
+[ 1 ] [ 1 0 1 bitroll ] unit-test
+[ 1 ] [ 1 1 1 bitroll ] unit-test
+[ 1 ] [ 1 0 2 bitroll ] unit-test
+[ 1 ] [ 1 0 1 bitroll ] unit-test
+[ 1 ] [ 1 20 2 bitroll ] unit-test
+[ 1 ] [ 1 8 8 bitroll ] unit-test
+[ 1 ] [ 1 -8 8 bitroll ] unit-test
+[ 1 ] [ 1 -32 8 bitroll ] unit-test
+[ 128 ] [ 1 -1 8 bitroll ] unit-test
+[ 8 ] [ 1 3 32 bitroll ] unit-test
diff --git a/extra/math/bitfields/lib/lib.factor b/extra/math/bitfields/lib/lib.factor
new file mode 100644
index 0000000000..4a8f3835ca
--- /dev/null
+++ b/extra/math/bitfields/lib/lib.factor
@@ -0,0 +1,31 @@
+USING: hints kernel math ;
+IN: math.bitfields.lib
+
+: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
+: set-bit ( x n -- y ) 2^ bitor ; foldable
+: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
+: bit-set? ( x n -- ? ) bit-clear? not ; foldable
+: unmask ( x n -- ? ) bitnot bitand ; foldable
+: unmask? ( x n -- ? ) unmask 0 > ; foldable
+: mask ( x n -- ? ) bitand ; foldable
+: mask? ( x n -- ? ) mask 0 > ; foldable
+: wrap ( m n -- m' ) 1- bitand ; foldable
+: bits ( m n -- m' ) 2^ wrap ; inline
+: mask-bit ( m n -- m' ) 1- 2^ mask ; inline
+
+: shift-mod ( n s w -- n )
+ >r shift r> 2^ wrap ; inline
+
+: bitroll ( x s w -- y )
+ [ wrap ] keep
+ [ shift-mod ] 3keep
+ [ - ] keep shift-mod bitor ; inline
+
+: bitroll-32 ( n s -- n' ) 32 bitroll ;
+
+HINTS: bitroll-32 bignum fixnum ;
+
+: bitroll-64 ( n s -- n' ) 64 bitroll ;
+
+HINTS: bitroll-64 bignum fixnum ;
+
From 53d21c6c7a8c69351147b4ce73ba4a869b086ed0 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 13:57:33 -0500
Subject: [PATCH 119/127] cleanup in aisle crypto
---
extra/crypto/barrett/barrett.factor | 8 +++++++-
extra/crypto/common/common.factor | 3 +--
extra/crypto/hmac/hmac-tests.factor | 1 -
extra/crypto/hmac/hmac.factor | 1 -
extra/crypto/md5/md5.factor | 6 +++---
extra/crypto/rsa/rsa.factor | 6 +++---
extra/crypto/test/common.factor | 15 ---------------
extra/crypto/timing/timing.factor | 5 ++---
extra/crypto/xor/xor.factor | 6 +++---
9 files changed, 19 insertions(+), 32 deletions(-)
delete mode 100644 extra/crypto/test/common.factor
diff --git a/extra/crypto/barrett/barrett.factor b/extra/crypto/barrett/barrett.factor
index 55da97202f..4a070190e3 100644
--- a/extra/crypto/barrett/barrett.factor
+++ b/extra/crypto/barrett/barrett.factor
@@ -4,5 +4,11 @@ IN: crypto.barrett
: barrett-mu ( n size -- mu )
#! Calculates Barrett's reduction parameter mu
#! size = word size in bits (8, 16, 32, 64, ...)
- over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ;
+ ! over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ;
+ [
+ [ log2 1+ ] [ / 2 * ] bi*
+ ] [
+ 2^ rot ^ swap /i
+ ] 2bi ;
+
diff --git a/extra/crypto/common/common.factor b/extra/crypto/common/common.factor
index b9f1d43784..a714727ad9 100644
--- a/extra/crypto/common/common.factor
+++ b/extra/crypto/common/common.factor
@@ -50,9 +50,8 @@ SYMBOL: big-endian?
: 2seq>seq ( seq1 seq2 -- seq )
#! { aceg } { bdfh } -> { abcdefgh }
- swap ! error?
[ 2array flip concat ] keep like ;
: mod-nth ( n seq -- elt )
#! 5 "abcd" -> b
- [ length mod ] keep nth ;
+ [ length mod ] [ nth ] bi ;
diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor
index fa0cbef4c7..eff95bbcd6 100755
--- a/extra/crypto/hmac/hmac-tests.factor
+++ b/extra/crypto/hmac/hmac-tests.factor
@@ -9,4 +9,3 @@ IN: crypto.hmac.tests
[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 <string> "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test
[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test
[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>sha1-hmac >string ] unit-test
-
diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor
index 3dad01fe3a..91d404aead 100755
--- a/extra/crypto/hmac/hmac.factor
+++ b/extra/crypto/hmac/hmac.factor
@@ -37,7 +37,6 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
: byte-array>sha1-hmac ( K string -- hmac )
binary <byte-reader> stream>sha1-hmac ;
-
: stream>md5-hmac ( K stream -- hmac )
[ init-hmac md5-hmac ] with-stream ;
diff --git a/extra/crypto/md5/md5.factor b/extra/crypto/md5/md5.factor
index 7ecbd767b9..45e10da74d 100755
--- a/extra/crypto/md5/md5.factor
+++ b/extra/crypto/md5/md5.factor
@@ -3,7 +3,7 @@
USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting strings
sequences crypto.common byte-arrays locals sequences.private
-io.encodings.binary symbols ;
+io.encodings.binary symbols math.bitfields.lib ;
IN: crypto.md5
<PRIVATE
@@ -43,11 +43,11 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
: F ( X Y Z -- FXYZ )
#! F(X,Y,Z) = XY v not(X) Z
- pick bitnot bitand >r bitand r> bitor ;
+ pick bitnot bitand [ bitand ] [ bitor ] bi* ;
: G ( X Y Z -- GXYZ )
#! G(X,Y,Z) = XZ v Y not(Z)
- dup bitnot rot bitand >r bitand r> bitor ;
+ dup bitnot rot bitand [ bitand ] [ bitor ] bi* ;
: H ( X Y Z -- HXYZ )
#! H(X,Y,Z) = X xor Y xor Z
diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor
index ccf17da4e8..5d3228db10 100644
--- a/extra/crypto/rsa/rsa.factor
+++ b/extra/crypto/rsa/rsa.factor
@@ -1,5 +1,5 @@
USING: math.miller-rabin kernel math math.functions namespaces
-sequences ;
+sequences accessors ;
IN: crypto.rsa
! The private key is the only secret.
@@ -39,7 +39,7 @@ PRIVATE>
public-key <rsa> ;
: rsa-encrypt ( message rsa -- encrypted )
- [ rsa-public-key ] keep rsa-modulus ^mod ;
+ [ public-key>> ] [ modulus>> ] bi ^mod ;
: rsa-decrypt ( encrypted rsa -- message )
- [ rsa-private-key ] keep rsa-modulus ^mod ;
\ No newline at end of file
+ [ private-key>> ] [ modulus>> ] bi ^mod ;
diff --git a/extra/crypto/test/common.factor b/extra/crypto/test/common.factor
deleted file mode 100644
index 6050454402..0000000000
--- a/extra/crypto/test/common.factor
+++ /dev/null
@@ -1,15 +0,0 @@
-USING: kernel math test namespaces crypto ;
-
-[ 0 ] [ 1 0 0 bitroll ] unit-test
-[ 1 ] [ 1 0 1 bitroll ] unit-test
-[ 1 ] [ 1 1 1 bitroll ] unit-test
-[ 1 ] [ 1 0 2 bitroll ] unit-test
-[ 1 ] [ 1 0 1 bitroll ] unit-test
-[ 1 ] [ 1 20 2 bitroll ] unit-test
-[ 1 ] [ 1 8 8 bitroll ] unit-test
-[ 1 ] [ 1 -8 8 bitroll ] unit-test
-[ 1 ] [ 1 -32 8 bitroll ] unit-test
-[ 128 ] [ 1 -1 8 bitroll ] unit-test
-[ 8 ] [ 1 3 32 bitroll ] unit-test
-
-
diff --git a/extra/crypto/timing/timing.factor b/extra/crypto/timing/timing.factor
index da2603d92c..a17d65d90b 100644
--- a/extra/crypto/timing/timing.factor
+++ b/extra/crypto/timing/timing.factor
@@ -1,7 +1,6 @@
USING: kernel math threads system ;
IN: crypto.timing
-: with-timing ( ... quot n -- )
+: with-timing ( quot n -- )
#! force the quotation to execute in, at minimum, n milliseconds
- millis 2slip millis - + sleep ;
-
+ millis 2slip millis - + sleep ; inline
diff --git a/extra/crypto/xor/xor.factor b/extra/crypto/xor/xor.factor
index 0713e19843..247387ebdf 100644
--- a/extra/crypto/xor/xor.factor
+++ b/extra/crypto/xor/xor.factor
@@ -1,8 +1,8 @@
USING: crypto.common kernel math sequences ;
IN: crypto.xor
-TUPLE: no-xor-key ;
+ERROR: no-xor-key ;
-: xor-crypt ( key seq -- seq )
- over empty? [ no-xor-key construct-empty throw ] when
+: xor-crypt ( key seq -- seq' )
+ over empty? [ no-xor-key ] when
dup length rot [ mod-nth bitxor ] curry 2map ;
From d27252e2321e2ef3f9d218df773592caa32c6b09 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 16:02:37 -0500
Subject: [PATCH 120/127] minor cleanup
---
extra/random/mersenne-twister/mersenne-twister.factor | 9 ++++-----
1 file changed, 4 insertions(+), 5 deletions(-)
diff --git a/extra/random/mersenne-twister/mersenne-twister.factor b/extra/random/mersenne-twister/mersenne-twister.factor
index d3a5fad4ca..46f2088440 100755
--- a/extra/random/mersenne-twister/mersenne-twister.factor
+++ b/extra/random/mersenne-twister/mersenne-twister.factor
@@ -15,14 +15,13 @@ TUPLE: mersenne-twister seq i ;
: mt-m 397 ; inline
: mt-a HEX: 9908b0df ; inline
-: calculate-y ( y1 y2 mt -- y )
- tuck
+: calculate-y ( n seq -- y )
[ nth 32 mask-bit ]
- [ nth 31 bits ] 2bi* bitor ; inline
+ [ [ 1+ ] [ nth ] bi* 31 bits ] 2bi bitor ; inline
-: (mt-generate) ( n mt-seq -- next-mt )
+: (mt-generate) ( n seq -- next-mt )
[
- [ dup 1+ ] [ calculate-y ] bi*
+ calculate-y
[ 2/ ] [ odd? mt-a 0 ? ] bi bitxor
] [
[ mt-m + ] [ nth ] bi*
From 9f085cc10a76febc7b77c314b42f7dcad49dfa4a Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 18:11:22 -0500
Subject: [PATCH 121/127] add using
---
extra/io/windows/files/files.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor
index 4f31d2dfce..8bfbff2ba0 100755
--- a/extra/io/windows/files/files.factor
+++ b/extra/io/windows/files/files.factor
@@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.backend io.files io.windows kernel math
windows windows.kernel32 windows.time calendar combinators
-math.functions sequences namespaces words symbols
-combinators.lib io.nonblocking destructors system ;
+math.functions sequences namespaces words symbols system
+combinators.lib io.nonblocking destructors math.bitfields.lib ;
IN: io.windows.files
SYMBOLS: +read-only+ +hidden+ +system+
From 4acd587629093d156fe0c20b2822cc3b59ac889f Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 18:34:47 -0500
Subject: [PATCH 122/127] move cwd and cd to private vocabs
---
core/debugger/debugger-docs.factor | 3 ++-
core/io/files/files-docs.factor | 11 ++++++-----
core/io/files/files.factor | 9 ++++++---
extra/editors/jedit/jedit.factor | 2 +-
extra/io/unix/files/files.factor | 7 ++++++-
extra/io/unix/sockets/sockets.factor | 2 +-
extra/io/windows/nt/files/files.factor | 4 ++++
7 files changed, 26 insertions(+), 12 deletions(-)
diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor
index f8b53d4abc..ca6aa59cc4 100755
--- a/core/debugger/debugger-docs.factor
+++ b/core/debugger/debugger-docs.factor
@@ -1,6 +1,7 @@
USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes
-help generic.standard continuations system debugger.private ;
+help generic.standard continuations system debugger.private
+io.files.private ;
IN: debugger
ARTICLE: "errors-assert" "Assertions"
diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
index 342967acfc..d1a59f3604 100755
--- a/core/io/files/files-docs.factor
+++ b/core/io/files/files-docs.factor
@@ -197,19 +197,20 @@ HELP: file-contents
HELP: cwd
{ $values { "path" "a pathname string" } }
{ $description "Outputs the current working directory of the Factor process." }
-{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
+{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
+{ $warning "Modifying the current directory through system calls is unsafe. Use the " { $link with-directory } " word instead." } ;
HELP: cd
{ $values { "path" "a pathname string" } }
{ $description "Changes the current working directory of the Factor process." }
-{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
+{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
+{ $warning "Modifying the current directory through system calls is unsafe. Use the " { $link with-directory } " word instead." } ;
-{ cd cwd with-directory } related-words
+{ cd cwd current-directory with-directory } related-words
HELP: with-directory
{ $values { "path" "a pathname string" } { "quot" quotation } }
-{ $description "Changes the current working directory for the duration of a quotation's execution." }
-{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
+{ $description "Changes the " { $link current-directory } " variable for the duration of a quotation's execution. Words that use the file-system should call " { $link normalize-path } " in order to obtain a path relative to the current directory." } ;
HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 45bf0602f2..08ec78492a 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -176,15 +176,18 @@ SYMBOL: +unknown+
: directory? ( path -- ? )
file-info file-info-type +directory+ = ;
-! Current working directory
+<PRIVATE
+
HOOK: cd io-backend ( path -- )
HOOK: cwd io-backend ( -- path )
-SYMBOL: current-directory
-
M: object cwd ( -- path ) "." ;
+PRIVATE>
+
+SYMBOL: current-directory
+
[ cwd current-directory set-global ] "io.files" add-init-hook
: resource-path ( path -- newpath )
diff --git a/extra/editors/jedit/jedit.factor b/extra/editors/jedit/jedit.factor
index 92320addef..e4f19781ef 100755
--- a/extra/editors/jedit/jedit.factor
+++ b/extra/editors/jedit/jedit.factor
@@ -4,7 +4,7 @@ USING: arrays definitions io kernel math
namespaces parser prettyprint sequences strings words
editors io.files io.sockets io.streams.byte-array io.binary
math.parser io.encodings.ascii io.encodings.binary
-io.encodings.utf8 ;
+io.encodings.utf8 io.files.private ;
IN: editors.jedit
: jedit-server-info ( -- port auth )
diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor
index f6bb3edcde..3085827483 100755
--- a/extra/io/unix/files/files.factor
+++ b/extra/io/unix/files/files.factor
@@ -3,10 +3,13 @@
USING: io.backend io.nonblocking io.unix.backend io.files io
unix unix.stat unix.time kernel math continuations
math.bitfields byte-arrays alien combinators calendar
-io.encodings.binary accessors sequences strings system ;
+io.encodings.binary accessors sequences strings system
+io.files.private ;
IN: io.unix.files
+<PRIVATE
+
M: unix cwd ( -- path )
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
[ (io-error) ] unless* ;
@@ -14,6 +17,8 @@ M: unix cwd ( -- path )
M: unix cd ( path -- )
chdir io-error ;
+PRIVATE>
+
: read-flags O_RDONLY ; inline
: open-read ( path -- fd )
diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor
index 477757e0ed..a54205a878 100755
--- a/extra/io/unix/sockets/sockets.factor
+++ b/extra/io/unix/sockets/sockets.factor
@@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces
io.nonblocking parser threads unix sequences
byte-arrays io.sockets io.binary io.unix.backend
io.streams.duplex io.sockets.impl math.parser continuations libc
-combinators io.backend io.files system ;
+combinators io.backend io.files io.files.private system ;
IN: io.unix.sockets
: pending-init-error ( port -- )
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index 7bac540ddc..590bc59023 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -5,6 +5,8 @@ alien.c-types alien.arrays sequences combinators combinators.lib
sequences.lib ascii splitting alien strings assocs namespaces ;
IN: io.windows.nt.files
+<PRIVATE
+
M: winnt cwd
MAX_UNICODE_PATH dup "ushort" <c-array>
[ GetCurrentDirectory win32-error=0/f ] keep
@@ -13,6 +15,8 @@ M: winnt cwd
M: winnt cd
SetCurrentDirectory win32-error=0/f ;
+PRIVATE>
+
: unicode-prefix ( -- seq )
"\\\\?\\" ; inline
From 344a98802ff651d5e078636ed0983eaecb4e18cb Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 18:36:53 -0500
Subject: [PATCH 123/127] tweak word
---
extra/math/bitfields/lib/lib.factor | 5 ++---
1 file changed, 2 insertions(+), 3 deletions(-)
diff --git a/extra/math/bitfields/lib/lib.factor b/extra/math/bitfields/lib/lib.factor
index 4a8f3835ca..72b33b9ae7 100644
--- a/extra/math/bitfields/lib/lib.factor
+++ b/extra/math/bitfields/lib/lib.factor
@@ -4,7 +4,6 @@ IN: math.bitfields.lib
: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
: set-bit ( x n -- y ) 2^ bitor ; foldable
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
-: bit-set? ( x n -- ? ) bit-clear? not ; foldable
: unmask ( x n -- ? ) bitnot bitand ; foldable
: unmask? ( x n -- ? ) unmask 0 > ; foldable
: mask ( x n -- ? ) bitand ; foldable
@@ -18,8 +17,8 @@ IN: math.bitfields.lib
: bitroll ( x s w -- y )
[ wrap ] keep
- [ shift-mod ] 3keep
- [ - ] keep shift-mod bitor ; inline
+ [ shift-mod ]
+ [ [ - ] keep shift-mod ] 3bi bitor ; inline
: bitroll-32 ( n s -- n' ) 32 bitroll ;
From 82f3239012690afbc3f884cb5b6777d63948e976 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 18:40:51 -0500
Subject: [PATCH 124/127] remove private stuff
---
extra/io/unix/files/files.factor | 4 ----
extra/io/windows/nt/files/files.factor | 4 ----
2 files changed, 8 deletions(-)
diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor
index 3085827483..39c18b4601 100755
--- a/extra/io/unix/files/files.factor
+++ b/extra/io/unix/files/files.factor
@@ -8,8 +8,6 @@ io.files.private ;
IN: io.unix.files
-<PRIVATE
-
M: unix cwd ( -- path )
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
[ (io-error) ] unless* ;
@@ -17,8 +15,6 @@ M: unix cwd ( -- path )
M: unix cd ( path -- )
chdir io-error ;
-PRIVATE>
-
: read-flags O_RDONLY ; inline
: open-read ( path -- fd )
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index 590bc59023..7bac540ddc 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -5,8 +5,6 @@ alien.c-types alien.arrays sequences combinators combinators.lib
sequences.lib ascii splitting alien strings assocs namespaces ;
IN: io.windows.nt.files
-<PRIVATE
-
M: winnt cwd
MAX_UNICODE_PATH dup "ushort" <c-array>
[ GetCurrentDirectory win32-error=0/f ] keep
@@ -15,8 +13,6 @@ M: winnt cwd
M: winnt cd
SetCurrentDirectory win32-error=0/f ;
-PRIVATE>
-
: unicode-prefix ( -- seq )
"\\\\?\\" ; inline
From 45b0dd9042625584bcd936027cd194c67721f8f7 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 18:41:12 -0500
Subject: [PATCH 125/127] add using
---
extra/io/windows/nt/files/files.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index 7bac540ddc..3232ab6ff3 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -2,7 +2,8 @@ USING: continuations destructors io.buffers io.files io.backend
io.timeouts io.nonblocking io.windows io.windows.nt.backend
kernel libc math threads windows windows.kernel32 system
alien.c-types alien.arrays sequences combinators combinators.lib
-sequences.lib ascii splitting alien strings assocs namespaces ;
+sequences.lib ascii splitting alien strings assocs namespaces
+io.files.private ;
IN: io.windows.nt.files
M: winnt cwd
From 36fc0b26ac9078241223853ae6c50cc002eaaa14 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 18:51:53 -0500
Subject: [PATCH 126/127] fix load error
---
extra/io/unix/launcher/launcher.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index 8e5531a40c..5f0a9b96cb 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -4,7 +4,7 @@ USING: io io.backend io.launcher io.nonblocking io.unix.backend
io.unix.files io.nonblocking sequences kernel namespaces math
system alien.c-types debugger continuations arrays assocs
combinators unix.process strings threads unix
-io.unix.launcher.parser accessors io.files ;
+io.unix.launcher.parser accessors io.files io.files.private ;
IN: io.unix.launcher
! Search unix first
From 653bc1cd80819cbfb81f2082a8240cfda7a54ab7 Mon Sep 17 00:00:00 2001
From: erg <erg@ergb.local>
Date: Thu, 3 Apr 2008 18:59:04 -0500
Subject: [PATCH 127/127] update docs
---
core/io/files/files-docs.factor | 9 ++++++---
1 file changed, 6 insertions(+), 3 deletions(-)
diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
index d1a59f3604..85e17ded46 100755
--- a/core/io/files/files-docs.factor
+++ b/core/io/files/files-docs.factor
@@ -28,11 +28,14 @@ ARTICLE: "pathnames" "Pathname manipulation"
{ $subsection <pathname> } ;
ARTICLE: "directories" "Directories"
-"Current and home directories:"
+"Current directory:"
+{ $subsection with-directory }
+{ $subsection current-directory }
+"Home directory:"
+{ $subsection home }
+"Current system directory:"
{ $subsection cwd }
{ $subsection cd }
-{ $subsection with-directory }
-{ $subsection home }
"Directory listing:"
{ $subsection directory }
{ $subsection directory* }