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

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

db4
Slava Pestov 2008-06-11 02:42:45 -05:00
parent 4d2c88c38c 4cc5585a07
commit 66e8af04a8
17 changed files with 101 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
extra/combinators/lib/lib.factor
View File

@ -63,8 +63,8 @@ MACRO: napply ( n -- )
! short circuiting words
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : short-circuit ( quots quot default -- quot )
! 1quotation -rot { } map>assoc <reversed> alist>quot ;
: short-circuit ( quots quot default -- quot )
1quotation -rot { } map>assoc <reversed> alist>quot ;
! MACRO: && ( quots -- ? )
! [ [ not ] append [ f ] ] t short-circuit ;

2
extra/inverse/inverse.factor
View File

@ -77,7 +77,7 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
{ [ word? ] [ primitive? not ] [
{ "inverse" "math-inverse" "pop-inverse" }
[ word-prop ] with contains? not
] } <-&& ;
] } 1&& ;
: (flatten) ( quot -- )
[ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ;

2
extra/lcs/lcs.factor
View File

@ -56,7 +56,7 @@ TUPLE: trace-state old new table i j ;
{
[ i>> 0 > ] [ j>> 0 > ]
[ [ old-nth ] [ new-nth ] bi = ]
} <-&& ;
} 1&& ;
: do-retain ( state -- state )
dup old-nth retain boa ,

64
extra/lisp/lisp-tests.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: lisp lisp.parser tools.test sequences math kernel parser arrays ;
USING: lisp lisp.parser tools.test sequences math kernel parser arrays lists
quotations ;
IN: lisp.test
@ -13,33 +14,36 @@ IN: lisp.test
"+" "math" "+" define-primitive
"-" "math" "-" define-primitive
"cons" "lists" "cons" define-primitive
"car" "lists" "car" define-primitive
"cdr" "lists" "cdr" define-primitive
"append" "lists" "lappend" define-primitive
"nil" "lists" "nil" define-primitive
"nil?" "lists" "nil?" define-primitive
[ seq>list ] "##list" lisp-define
"define" "lisp" "defun" define-primitive
"(lambda (&rest xs) xs)" lisp-string>factor "list" lisp-define
{ 5 } [
[ 2 3 ] "+" <lisp-symbol> funcall
! [ 2 3 ] "+" <lisp-symbol> funcall
"(+ 2 3)" lisp-eval
] unit-test
{ 8.3 } [
[ 10.4 2.1 ] "-" <lisp-symbol> funcall
! [ 10.4 2.1 ] "-" <lisp-symbol> funcall
"(- 10.4 2.1)" lisp-eval
] unit-test
{ 3 } [
"((lambda (x y) (+ x y)) 1 2)" lisp-eval
] unit-test
{ 42 } [
"((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval
] unit-test
{ T{ lisp-symbol f "if" } } [
"(defmacro if (pred tr fl) (quasiquote (cond ((unquote pred) (unquote tr)) (#t (unquote fl)))))" lisp-eval
] unit-test
{ t } [
T{ lisp-symbol f "if" } lisp-macro?
] unit-test
{ 1 } [
"(if #t 1 2)" lisp-eval
] unit-test
! { 42 } [
! "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval
! ] unit-test
{ "b" } [
"(cond (#f \"a\") (#t \"b\"))" lisp-eval
@ -49,8 +53,28 @@ IN: lisp.test
"(begin (+ 1 4))" lisp-eval
] unit-test
{ 3 } [
"((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval
{ { 1 2 3 4 5 } } [
"(list 1 2 3 4 5)" lisp-eval list>seq
] unit-test
{ { 1 2 { 3 { 4 } 5 } } } [
"(list 1 2 (list 3 (list 4) 5))" lisp-eval cons>seq
] unit-test
{ T{ lisp-symbol f "if" } } [
"(defmacro if (pred tr fl) (list (quote cond) (list (list pred tr) (list t fl))))" lisp-eval
] unit-test
{ t } [
T{ lisp-symbol f "if" } lisp-macro?
] unit-test
! { 1 } [
! "(if #t 1 2)" lisp-eval
! ] unit-test
! { 3 } [
! "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval
! ] unit-test
] with-interactive-vocabs

76
extra/lisp/lisp.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg sequences arrays strings combinators.lib
namespaces combinators math locals locals.private accessors
namespaces combinators math locals locals.private locals.backend accessors
vectors syntax lisp.parser assocs parser sequences.lib words
quotations fry lists inspector ;
IN: lisp
@ -11,19 +11,23 @@ DEFER: funcall
DEFER: lookup-var
DEFER: lookup-macro
DEFER: lisp-macro?
DEFER: lisp-var?
DEFER: macro-expand
DEFER: define-lisp-macro
ERROR: no-such-var variable-name ;
M: no-such-var summary drop "No such variable" ;
! Functions to convert s-exps to quotations
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: convert-body ( cons -- quot )
[ ] [ convert-form compose ] foldl ; inline
: convert-begin ( cons -- quot )
cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ;
cdr [ convert-form ] [ ] lmap-as '[ , [ call ] each ] ;
: convert-cond ( cons -- quot )
cdr [ 2car [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ]
cdr [ 2car [ convert-form ] bi@ [ '[ @ call ] ] dip 2array ]
{ } lmap-as '[ , cond ] ;
: convert-general-form ( cons -- quot )
@ -32,49 +36,33 @@ DEFER: define-lisp-macro
! words for convert-lambda
<PRIVATE
: localize-body ( assoc body -- assoc newbody )
[ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ;
{
{ [ dup list? ] [ [ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ] }
{ [ dup lisp-symbol? ] [ name>> over at ] }
[ ]
} cond ;
: localize-lambda ( body vars -- newbody newvars )
: localize-lambda ( body vars -- newvars newbody )
make-locals dup push-locals swap
[ swap localize-body convert-form swap pop-locals ] dip swap ;
: split-lambda ( cons -- body-cons vars-seq )
3car -rot nip [ name>> ] lmap>array ; inline
: split-lambda ( cons -- body-cons vars-seq )
cdr uncons [ car ] [ [ name>> ] lmap>array ] bi* ; inline
: rest-lambda ( body vars -- quot )
"&rest" swap [ index ] [ remove ] 2bi
localize-lambda <lambda>
'[ , cut '[ @ , ] , compose ] ;
swapd localize-lambda <lambda>
'[ , cut '[ @ , seq>list ] call , call ] ;
: normal-lambda ( body vars -- quot )
localize-lambda <lambda> '[ , compose ] ;
localize-lambda <lambda> lambda-rewrite [ compose call ] compose 1quotation ;
PRIVATE>
: convert-lambda ( cons -- quot )
split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ;
: convert-quoted ( cons -- quot )
cdr 1quotation ;
: convert-unquoted ( cons -- quot )
"unquote not valid outside of quasiquote!" throw ;
: convert-unquoted-splicing ( cons -- quot )
"unquote-splicing not valid outside of quasiquote!" throw ;
<PRIVATE
: quasiquote-unquote ( cons -- newcons )
[ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ]
[ cadr ] traverse ;
: quasiquote-unquote-splicing ( cons -- newcons )
[ { [ dup list? ] [ dup cdr [ cons? ] [ car cons? ] bi and ]
[ dup cadr car lisp-symbol? ] [ cadr car name>> "unquote-splicing" equal? dup ] } && nip ]
[ dup cadr cdr >>cdr ] traverse ;
PRIVATE>
: convert-quasiquoted ( cons -- newcons )
quasiquote-unquote quasiquote-unquote-splicing ;
cadr 1quotation ;
: convert-defmacro ( cons -- quot )
cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ;
@ -84,9 +72,6 @@ PRIVATE>
{ { "lambda" [ convert-lambda ] }
{ "defmacro" [ convert-defmacro ] }
{ "quote" [ convert-quoted ] }
{ "unquote" [ convert-unquoted ] }
{ "unquote-splicing" [ convert-unquoted-splicing ] }
{ "quasiquote" [ convert-quasiquoted ] }
{ "begin" [ convert-begin ] }
{ "cond" [ convert-cond ] }
[ drop convert-general-form ]
@ -102,6 +87,7 @@ PRIVATE>
: convert-form ( lisp-form -- quot )
{
{ [ dup cons? ] [ convert-list-form ] }
{ [ dup lisp-var? ] [ lookup-var 1quotation ] }
{ [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
[ 1quotation ]
} cond ;
@ -109,11 +95,8 @@ PRIVATE>
: compile-form ( lisp-ast -- quot )
convert-form lambda-rewrite call ; inline
: macro-call ( lambda -- cons )
call ; inline
: macro-expand ( cons -- quot )
uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form ] bi* ;
uncons [ list>seq [ ] like ] [ lookup-macro lambda-rewrite call ] bi* call compile-form call ;
: lisp-string>factor ( str -- quot )
lisp-expr parse-result-ast compile-form ;
@ -125,9 +108,6 @@ PRIVATE>
SYMBOL: lisp-env
SYMBOL: macro-env
ERROR: no-such-var variable-name ;
M: no-such-var summary drop "No such variable" ;
: init-env ( -- )
H{ } clone lisp-env set
@ -136,17 +116,27 @@ M: no-such-var summary drop "No such variable" ;
: lisp-define ( quot name -- )
lisp-env get set-at ;
: defun ( name quot -- name )
over name>> lisp-define ;
: lisp-get ( name -- word )
dup lisp-env get at [ ] [ no-such-var ] ?if ;
: lookup-var ( lisp-symbol -- quot )
name>> lisp-get ;
: lisp-var? ( lisp-symbol -- ? )
dup lisp-symbol? [ name>> lisp-env get key? ] [ drop f ] if ;
: funcall-arg-list ( args -- newargs )
[ ] [ dup \ funcall = [ drop 2 cut* [ funcall ] compose call ] when suffix ] reduce ;
: funcall ( quot sym -- * )
dup lisp-symbol? [ lookup-var ] when call ; inline
[ funcall-arg-list ] dip
dup lisp-symbol? [ lookup-var ] when curry call ; inline
: define-primitive ( name vocab word -- )
swap lookup 1quotation '[ , compose call ] swap lisp-define ;
swap lookup 1quotation '[ , compose call ] swap lisp-define ; ! '[ , compose call ] swap lisp-define ;
: lookup-macro ( lisp-symbol -- lambda )
name>> macro-env get at ;

2
extra/lisp/parser/parser.factor
View File

@ -34,6 +34,6 @@ string = dquote ( escaped | !(dquote) . )* dquote => [[ second >string ]]
atom = number
| identifier
| string
list-item = _ ( atom | s-expression ) _ => [[ second ]]
s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
list-item = _ ( atom | s-expression ) _ => [[ second ]]
;EBNF

2
extra/lists/lazy/examples/examples-tests.factor
View File

@ -1,4 +1,4 @@
USING: lists.lazy.examples lazy-lists tools.test ;
USING: lists.lazy.examples lists.lazy tools.test ;
IN: lists.lazy.examples.tests
[ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test

4
extra/lists/lists-tests.factor
View File

@ -63,4 +63,8 @@ IN: lists.tests
{ { 3 4 { 5 6 { 7 } } } } [
{ 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq
] unit-test
{ { 1 2 3 4 5 6 } } [
{ 1 2 3 } seq>list { 4 5 6 } seq>list lappend list>seq
] unit-test

5
extra/lists/lists.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Chris Double & James Cash
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors math arrays vectors classes words locals ;
@ -75,6 +75,9 @@ M: object nil? drop f ;
: lreverse ( list -- newlist )
nil [ swap cons ] foldl ;
: lappend ( list1 list2 -- newlist )
[ lreverse ] dip [ swap cons ] foldl ;
: seq>list ( seq -- list )
<reversed> nil [ swap cons ] reduce ;

2
extra/math/text/english/english.factor
View File

@ -26,7 +26,7 @@ IN: math.text.english
SYMBOL: and-needed?
: set-conjunction ( seq -- )
first { [ dup 100 < ] [ dup 0 > ] } && and-needed? set drop ;
first { [ dup 100 < ] [ dup 0 > ] } 0&& and-needed? set drop ;
: negative-text ( n -- str )
0 < "Negative " "" ? ;

2
extra/peg/ebnf/ebnf.factor
View File

@ -87,7 +87,7 @@ C: <ebnf> ebnf
[ dup CHAR: ? = ]
[ dup CHAR: : = ]
[ dup CHAR: ~ = ]
} || not nip
} 0|| not nip
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
: 'terminal' ( -- parser )

2
extra/project-euler/014/014.factor
View File

@ -59,7 +59,7 @@ PRIVATE>
<PRIVATE
: worth-calculating? ( n -- ? )
{ [ dup 1- 3 mod zero? ] [ dup 1- 3 / even? ] } && nip ;
{ [ dup 1- 3 mod zero? ] [ dup 1- 3 / even? ] } 0&& nip ;
PRIVATE>

2
extra/project-euler/021/021.factor
View File

@ -27,7 +27,7 @@ IN: project-euler.021
: amicable? ( n -- ? )
dup sum-proper-divisors
{ [ 2dup = not ] [ 2dup sum-proper-divisors = ] } && 2nip ;
{ [ 2dup = not ] [ 2dup sum-proper-divisors = ] } 0&& 2nip ;
: euler021 ( -- answer )
10000 [1,b] [ dup amicable? [ drop 0 ] unless ] sigma ;

2
extra/project-euler/036/036.factor
View File

@ -27,7 +27,7 @@ IN: project-euler.036
: both-bases? ( n -- ? )
{ [ dup palindrome? ]
[ dup >bin dup reverse = ] } && nip ;
[ dup >bin dup reverse = ] } 0&& nip ;
PRIVATE>

2
extra/project-euler/043/043.factor
View File

@ -47,7 +47,7 @@ IN: project-euler.043
[ 5 4 pick subseq-divisible? ]
[ 3 3 pick subseq-divisible? ]
[ 2 2 pick subseq-divisible? ]
} && nip ;
} 0&& nip ;
PRIVATE>

2
extra/project-euler/052/052.factor
View File

@ -29,7 +29,7 @@ IN: project-euler.052
[ number>digits natural-sort ] map all-equal? ;
: candidate? ( n -- ? )
{ [ dup odd? ] [ dup 3 mod zero? ] } && nip ;
{ [ dup odd? ] [ dup 3 mod zero? ] } 0&& nip ;
: next-all-same ( x n -- n )
dup candidate? [

6
extra/xmode/marker/marker.factor
View File

@ -19,7 +19,7 @@ strings regexp splitting parser-combinators ascii unicode.case ;
dup [ dupd matches? ] [ drop f ] if
] unless*
]
} && nip ;
} 0&& nip ;
: mark-number ( keyword -- id )
keyword-number? DIGIT and ;
@ -50,7 +50,7 @@ M: rule match-position drop position get ;
[ over matcher-at-line-start? over zero? implies ]
[ over matcher-at-whitespace-end? over whitespace-end get = implies ]
[ over matcher-at-word-start? over last-offset get = implies ]
} && 2nip ;
} 0&& 2nip ;
: rest-of-line ( -- str )
line get position get tail-slice ;
@ -273,7 +273,7 @@ M: mark-previous-rule handle-rule-start
[ check-end-delegate ]
[ check-every-rule ]
[ check-word-break ]
} || drop
} 0|| drop
position inc
mark-token-loop