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

possibly controversial: removed destructive list manipulation; other cleanups

cvs before-gc-trigger-changes
Slava Pestov 2004-10-12 05:11:35 +00:00
parent 96a5afc718
commit 9c2166b0be
34 changed files with 64 additions and 334 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
library/compiler/compile-all.factor
View File

@ -110,7 +110,11 @@ SYMBOL: compilable-word-list
[, [ dup can-compile? [ , ] [ drop ] ifte ] each-word ,] ;
: cannot-compile ( word -- )
"verbose-compile" get [ "Cannot compile " write . ] when ;
"verbose-compile" get [
"Cannot compile " write .
] [
drop
] ifte ;
: init-compiler ( -- )
#! Compile all words.

2
library/cross-compiler.factor
View File

@ -198,8 +198,6 @@ IN: image
cons
car
cdr
set-car
set-cdr
<vector>
vector-length
set-vector-length

2
library/httpd/html-tags.factor
View File

@ -78,7 +78,7 @@ USE: logic
: attrs>string ( alist -- string )
#! Convert the attrs alist to a string
#! suitable for embedding in an html tag.
nreverse <% [ dup car % "='" % cdr % "'" % ] each %> ;
reverse <% [ dup car % "='" % cdr % "'" % ] each %> ;
: write-attributes ( n: namespace -- )
#! With the attribute namespace on the stack, get the attributes

2
library/interpreter.factor
View File

@ -81,7 +81,7 @@ USE: vectors
: print-prompt ( -- )
<% " ( " % history# unparse % " )" % %>
[ "prompt" ] get-style write-attr
"prompt" get-style write-attr
! Print the space without a style, to workaround a bug in
! the GUI listener where the style from the prompt carries
! over to the input

17
library/list-namespaces.factor
View File

@ -31,17 +31,6 @@ USE: kernel
USE: namespaces
USE: stack
: append@ ( [ list ] var -- )
#! Append a proper list stored in a variable with another
#! list, storing the result back in the variable.
#! given variable using 'append'.
tuck get swap append put ;
: add@ ( elem var -- )
#! Add an element at the end of a proper list stored in a
#! variable, storing the result back in the variable.
tuck get swap add put ;
: cons@ ( x var -- )
#! Prepend x to the list stored in var.
tuck get cons put ;
@ -78,10 +67,6 @@ USE: stack
#! if the object does not already occur in the list.
"list-buffer" unique@ ;
: list, ( list -- )
#! Append each element to the currently constructing list.
[ , ] each ;
: ,] ( -- list )
#! Finish constructing a list and push it on the stack.
"list-buffer" get nreverse n> drop ;
"list-buffer" get reverse n> drop ;

129
library/lists.factor
View File

@ -41,45 +41,9 @@ USE: vectors
#! Construct a proper list of 3 elements.
2list cons ;
: 2rlist ( a b -- [ b a ] )
#! Construct a proper list of 2 elements in reverse stack order.
swap unit cons ;
: copy-cons ( accum cons -- accum cdr )
uncons >r unit dup rot set-cdr r> ;
: (clone-list) ( accum list -- last )
dup cons? [ copy-cons (clone-list) ] [ over set-cdr ] ifte ;
: clone-list* ( list -- list last )
#! Push the cloned list, and the last cons cell of the
#! cloned list.
uncons >r unit dup r> (clone-list) ;
: clone-list ( list -- list )
#! Push a shallow copy of a list.
dup [ clone-list* drop ] when ;
: append ( [ list1 ] [ list2 ] -- [ list1 list2 ] )
#! Append two lists. A new list is constructed by copying
#! the first list and setting its tail to the second.
over [ >r clone-list* r> swap set-cdr ] [ nip ] ifte ;
: add ( [ list1 ] elem -- [ list1 elem ] )
#! Push a new proper list with an element added to the end.
unit append ;
: caar ( list -- caar )
car car ; inline
: cdar ( list -- cadr )
cdr car ; inline
: cadr ( list -- cdar )
car cdr ; inline
: cddr ( list -- cddr )
cdr cdr ; inline
#! Append two lists.
over [ >r uncons r> append cons ] [ nip ] ifte ;
: contains? ( element list -- remainder )
#! If the proper list contains the element, push the
@ -115,48 +79,7 @@ USE: vectors
: list? ( list -- boolean )
#! Proper list test. A proper list is either f, or a cons
#! cell whose cdr is a proper list.
dup [
dup cons? [
cdr list?
] [
drop f
] ifte
] [
drop t
] ifte ;
: nappend ( [ list1 ] [ list2 ] -- [ list1 list2 ] )
#! DESTRUCTIVE. Append two lists. The last node of the first
#! list is destructively modified to point to the second
#! list, unless the first list is f, in which case the
#! second list is returned.
over [ over last* set-cdr ] [ nip ] ifte ;
: first ( list -- obj )
#! Push the head of the list, or f if the list is empty.
dup [ car ] when ;
: next ( obj list -- obj )
#! Push the next object in the list after an object. Wraps
#! around to beginning of list if object is at the end.
tuck contains? dup [
! Is there another entry in the list?
cdr dup [
nip car
] [
! No. Pick first
drop first
] ifte
] [
drop first
] ifte ;
: nreverse-iter ( list cons -- list cons )
[ dup dup cdr 2swap set-cdr nreverse-iter ] when* ;
: nreverse ( list -- list )
#! DESTRUCTIVE. Reverse the given list, without consing.
f swap nreverse-iter ;
[ dup cons? [ cdr list? ] [ drop f ] ifte ] [ t ] ifte* ;
: partition-add ( obj ? ret1 ret2 -- ret1 ret2 )
>r >r [ r> cons r> ] [ r> r> swapd cons ] ifte ; inline
@ -196,7 +119,7 @@ USE: vectors
! Recurse
tuck sort >r sort r>
! Combine
swapd cons nappend
swapd cons append
] [
drop
] ifte ; inline interpret-only
@ -209,11 +132,7 @@ USE: vectors
DEFER: tree-contains?
: =-or-contains? ( element obj -- ? )
dup cons? [
tree-contains?
] [
=
] ifte ;
dup cons? [ tree-contains? ] [ = ] ifte ;
: tree-contains? ( element tree -- ? )
dup [
@ -254,7 +173,7 @@ DEFER: tree-contains?
f transp [
! accum code elem -- accum code
transp over >r >r call r> cons r>
] each drop nreverse ; inline interpret-only
] each drop reverse ; inline interpret-only
: 2uncons ( list1 list2 -- car1 car2 cdr1 cdr2 )
uncons >r >r uncons r> swap r> ;
@ -283,31 +202,9 @@ DEFER: tree-contains?
#! two lists in turn, collecting the return value into a
#! new list. The quotation must have stack effect
#! ( x y -- z ).
<2map [ pick >r 2map-step r> ] 2each drop nreverse ;
<2map [ pick >r 2map-step r> ] 2each drop reverse ;
inline interpret-only
: substitute ( new old list -- list )
[ 2dup = [ drop over ] when ] map nip nip ;
: (head) ( accum list n -- last list )
dup 1 = [ drop ] [ pred >r copy-cons r> (head) ] ifte ;
: head* ( n list -- head last rest )
#! Push the head of the list, the last cons cell of the
#! head, and the rest of the list.
uncons >r unit tuck r> rot (head) ;
: head ( n list -- head )
#! Push a new list containing the first n elements.
over 0 = [ 2drop f ] [ head* 2drop ] ifte ;
: set-nth ( value index list -- list )
over 0 = [
nip cdr cons
] [
rot >r head* cdr r> swons swap set-cdr
] ifte ;
: subset-add ( car pred accum -- accum )
>r over >r call r> r> rot [ cons ] [ nip ] ifte ;
@ -326,24 +223,16 @@ DEFER: tree-contains?
#!
#! In order to compile, the quotation must consume as many
#! values as it produces.
f -rot subset-iter nreverse ; inline interpret-only
f -rot subset-iter reverse ; inline interpret-only
: remove ( obj list -- list )
#! Remove all occurrences of the object from the list.
[ dupd = not ] subset nip ;
: remove-nth ( n list -- list )
#! Push a new list with the nth element removed.
over 0 = [ nip cdr ] [ head* cdr swap set-cdr ] ifte ;
: length ( list -- length )
#! Pushes the length of the given proper list.
0 swap [ drop succ ] each ;
: leaves ( list -- length )
#! Like length, but counts each sub-list recursively.
0 swap [ dup list? [ leaves + ] [ drop succ ] ifte ] each ;
: reverse ( list -- list )
#! Push a new list that is the reverse of a proper list.
[ ] swap [ swons ] each ;
@ -401,4 +290,4 @@ DEFER: tree-contains?
[ ] swap [ swons ] vector-each ;
: vector>list ( vector -- list )
stack>list nreverse ;
stack>list reverse ;

19
library/namespaces.factor
View File

@ -53,17 +53,6 @@ USE: vectors
! bind ( namespace quot -- ) executes a quotation with a
! namespace pushed on the namespace stack.
: namestack ( -- stack )
#! Push a copy of the namespace stack; same naming
#! convention as the primitives datastack and callstack.
namestack* clone ; inline
: set-namestack ( stack -- )
#! Set the namespace stack to a copy of another stack; same
#! naming convention as the primitives datastack and
#! callstack.
clone set-namestack* ; inline
: >n ( namespace -- n:namespace )
#! Push a namespace on the namespace stack.
namestack* vector-push ; inline
@ -98,14 +87,6 @@ USE: vectors
#! result of evaluating [ a ].
over get [ drop get ] [ swap >r call dup r> set ] ifte ;
: alist> ( alist namespace -- )
#! Set each key in the alist to its value in the
#! namespace.
[ [ unswons set ] each ] bind ;
: alist>namespace ( alist -- namespace )
<namespace> tuck alist> ;
: traverse-path ( name object -- object )
dup has-namespace? [ get* ] [ 2drop f ] ifte ;

11
library/platform/jvm/cons.factor
View File

@ -51,14 +51,3 @@ IN: lists USE: kernel USE: stack
: cons? ( list -- boolean )
#! Test for cons cell type.
"factor.Cons" is ; inline
: deep-clone ( cons -- cons )
[ "factor.Cons" ] "factor.Cons" "deepClone" jinvoke-static ;
: set-car ( A [ B | C ] -- )
#! DESTRUCTIVE. Replace the head of a list.
"factor.Cons" "car" jvar-set ; inline
: set-cdr ( A [ B | C ] -- )
#! DESTRUCTIVE. Replace the tail of a list.
"factor.Cons" "cdr" jvar-set ; inline

6
library/platform/jvm/namespaces.factor
View File

@ -45,6 +45,12 @@ DEFER: namespace
interpreter
"factor.FactorInterpreter" "namestack" jvar-set ; inline
: namestack ( -- stack )
namestack* clone ; inline
: set-namestack ( stack -- )
clone set-namestack* ; inline
: global ( -- namespace )
interpreter "factor.FactorInterpreter" "global" jvar-get ;

9
library/platform/native/boot-stage2.factor
View File

@ -179,7 +179,14 @@ IN: compiler
DEFER: compilable-words
DEFER: compilable-word-list
[ warm-boot ] set-boot
IN: init
DEFER: init-interpreter
[
warm-boot
"interactive" get [ init-interpreter ] when
0 exit*
] set-boot
compilable-words compilable-word-list set

4
library/platform/native/errors.factor
View File

@ -32,6 +32,6 @@ USE: vectors
! This is a very lightweight exception handling system.
: catchstack* ( -- cs ) 6 getenv ;
: catchstack ( -- cs ) catchstack* clone ;
: catchstack ( -- cs ) catchstack* vector-clone ;
: set-catchstack* ( cs -- ) 6 setenv ;
: set-catchstack ( cs -- ) clone set-catchstack* ;
: set-catchstack ( cs -- ) vector-clone set-catchstack* ;

9
library/platform/native/init-stage2.factor
View File

@ -64,14 +64,11 @@ USE: words
t "ansi" set
t "compile" set
"ansi" get [ "stdio" get <ansi-stream> "stdio" set ] when
! The first CLI arg is the image name.
cli-args uncons parse-command-line "image" set
"compile" get [ init-compiler ] when
run-user-init
"ansi" get [ "stdio" get <ansi-stream> "stdio" set ] when
"interactive" get [ init-interpreter ] when
0 exit* ;
run-user-init ;

9
library/platform/native/kernel.factor
View File

@ -114,7 +114,6 @@ IN: kernel
: clone ( obj -- obj )
[
[ cons? ] [ clone-list ]
[ vector? ] [ vector-clone ]
[ sbuf? ] [ sbuf-clone ]
[ drop t ] [ ( return the object ) ]
@ -130,11 +129,3 @@ IN: kernel
! No compiler...
: inline ;
: interpret-only ;
! HACKS
IN: strings
: char? drop f ;
: >char ;
: >upper ;
: >lower ;

3
library/platform/native/namespaces.factor
View File

@ -41,6 +41,9 @@ DEFER: >n
: namestack* ( -- ns ) 3 getenv ;
: set-namestack* ( ns -- ) 3 setenv ;
: namestack ( -- stack ) namestack* vector-clone ;
: set-namestack ( stack -- ) vector-clone set-namestack* ;
: global ( -- g ) 4 getenv ;
: set-global ( g -- ) 4 setenv ;

2
library/platform/native/parse-stream.factor
View File

@ -69,7 +69,7 @@ USE: strings
: (parse-stream) ( name stream -- quot )
#! Uses the current namespace for temporary variables.
>r "file" set f r>
[ (parse) ] read-lines nreverse
[ (parse) ] read-lines reverse
"file" off
"line-number" off ;

6
library/platform/native/parse-syntax.factor
View File

@ -124,7 +124,7 @@ IN: syntax
! Lists
: [ [ ] ; parsing
: ] nreverse parsed ; parsing
: ] reverse parsed ; parsing
: | ( syntax: | cdr ] )
#! See the word 'parsed'. We push a special sentinel, and
@ -133,7 +133,7 @@ IN: syntax
! Vectors
: { f ; parsing
: } nreverse list>vector parsed ; parsing
: } reverse list>vector parsed ; parsing
! Do not execute parsing word
: POSTPONE: ( -- ) scan-word parsed ; parsing
@ -149,7 +149,7 @@ IN: syntax
: ;
#! End a word definition.
"in-definition" off
nreverse
reverse
;-hook ; parsing
! Symbols

6
library/platform/native/parser.factor
View File

@ -135,9 +135,9 @@ USE: unparser
] ifte
] when ;
: parsed| ( obj -- )
: parsed| ( parsed parsed obj -- parsed )
#! Some ugly ugly code to handle [ a | b ] expressions.
>r nreverse dup last* r> swap set-cdr swons ;
>r unswons r> cons swap [ swons ] each swons ;
: expect ( word -- )
dup scan = not [
@ -158,7 +158,7 @@ USE: unparser
: parse ( str -- code )
#! Parse the string into a parse tree that can be executed.
f swap (parse) nreverse ;
f swap (parse) reverse ;
: eval ( "X" -- X )
parse call ;

2
library/platform/native/primitives.factor
View File

@ -51,8 +51,6 @@ USE: words
[ cons | " car cdr -- [ car | cdr ] " ]
[ car | " [ car | cdr ] -- car " ]
[ cdr | " [ car | cdr ] -- cdr " ]
[ set-car | " car cons -- " ]
[ set-cdr | " cdr cons -- " ]
[ <vector> | " capacity -- vector" ]
[ vector-length | " vector -- n " ]
[ set-vector-length | " n vector -- " ]

6
library/platform/native/strings.factor
View File

@ -37,3 +37,9 @@ USE: stack
dup >r sbuf-append r>
dup >r sbuf-append r>
sbuf>str ;
! HACKS
: char? drop f ;
: >char ;
: >upper ;
: >lower ;

2
library/prettyprint.factor
View File

@ -141,7 +141,7 @@ DEFER: prettyprint*
dup ends-with-newline? dup [ nip ] [ drop ] ifte ;
: prettyprint-comment ( comment -- )
trim-newline [ "comments" ] get-style write-attr ;
trim-newline "comments" get-style write-attr ;
: word-link ( word -- link )
<%

31
library/styles.factor
View File

@ -36,32 +36,11 @@ USE: stack
! significance to the 'fwrite-attr' word when applied to a
! stream that supports attributed string output.
: default-style ( -- style )
#! Push the default style object.
"styles" get [ "default" get ] bind ;
: paragraph ( -- style )
#! Push the paragraph break meta-style.
"styles" get [ "paragraph" get ] bind ;
: <style> ( alist -- )
#! Create a new style object, cloned from the default
#! style.
default-style clone tuck alist> ;
: get-style ( obj-path -- style )
#! Push a style named by an object path, for example
#! [ "prompt" ] or [ "vocabularies" "math" ].
dup [
"styles" get [ object-path ] bind
[ default-style ] unless*
] [
drop default-style
] ifte ;
: set-style ( style name -- )
! XXX: use object path...
"styles" get [ set ] bind ;
: (get-style) ( name -- style ) "styles" get get* ;
: default-style ( -- style ) "default" (get-style) ;
: get-style ( name -- style )
(get-style) [ default-style ] unless* ;
: set-style ( style name -- ) "styles" get set* ;
<namespace> "styles" set

4
library/test/jvm-compiler/miscellaneous.factor
View File

@ -90,8 +90,4 @@ test-word
[ [ 1 1 0 0 ] ] [ [ system-property ] ] [ balance>list ] test-word
! Make sure callstack only clones callframes, and not
! everything on the callstack.
[ ] [ ] [ f unit dup dup set-cdr >r callstack r> 2drop ] test-word
[ t ] [ "ifte" intern dup worddef word-of-worddef = ] unit-test

3
library/test/jvm-compiler/primitives.factor
View File

@ -7,9 +7,6 @@ USE: test
! jvar-get
"car" must-compile
! jvar-set
"set-car" must-compile
! jvar-get-static
"version" must-compile

1
library/test/lists/cons.factor
View File

@ -25,4 +25,3 @@ USE: test
[ [ 1 2 ] ] [ 1 2 2list ] unit-test
[ [ 1 2 3 ] ] [ 1 2 3 3list ] unit-test
[ [ 2 1 ] ] [ 1 2 2rlist ] unit-test

34
library/test/lists/destructive.factor
View File

@ -1,34 +0,0 @@
IN: scratchpad
USE: lists
USE: namespaces
USE: stack
USE: test
[ "a" | "b" ] clone-list "x" set
[ [ 1 | "b" ] ] [ 1 "x" get set-car "x" get ] unit-test
[ "a" | "b" ] clone-list "x" set
[ [ "a" | 2 ] ] [ 2 "x" get set-cdr "x" get ] unit-test
: clone-and-nappend ( list list -- list )
swap clone-list swap clone-list nappend ;
[ [ ] ] [ [ ] [ ] clone-and-nappend ] unit-test
[ [ 1 ] ] [ [ 1 ] [ ] clone-and-nappend ] unit-test
[ [ 2 ] ] [ [ ] [ 2 ] clone-and-nappend ] unit-test
[ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] clone-and-nappend ] unit-test
: clone-and-nreverse ( list -- list )
clone-list nreverse ;
[ [ ] ] [ [ ] clone-and-nreverse ] unit-test
[ [ 1 ] ] [ [ 1 ] clone-and-nreverse ] unit-test
[ [ 3 2 1 ] ] [ [ 1 2 3 ] clone-and-nreverse ] unit-test
[ 1 2 3 ] clone-list "x" set [ 4 5 6 ] clone-list "y" set
[ [ 4 5 6 ] ] [ "x" get "y" get nappend drop "y" get ] unit-test
[ 1 2 3 ] clone-list "x" set [ 4 5 6 ] clone-list "y" set
[ [ 1 2 3 4 5 6 ] ] [ "x" get "y" get ] [ nappend drop "x" get ] test-word

7
library/test/lists/java.factor
View File

@ -7,14 +7,11 @@ USE: test
[ [ 2 1 0 0 ] ] [ [ 2list ] ] [ balance>list ] test-word
[ [ 3 1 0 0 ] ] [ [ 3list ] ] [ balance>list ] test-word
[ [ 2 1 0 0 ] ] [ [ 2rlist ] ] [ balance>list ] test-word
[ [ 2 1 0 0 ] ] [ [ append ] ] [ balance>list ] test-word
[ [ 2 0 0 0 ] ] [ [ append@ ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ array>list ] ] [ balance>list ] test-word
[ [ 2 0 0 0 ] ] [ [ add@ ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ car ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ cdr ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ clone-list ] ] [ balance>list ] test-word
[ [ 2 1 0 0 ] ] [ [ cons ] ] [ balance>list ] test-word
[ [ 2 1 0 0 ] ] [ [ contains? ] ] [ balance>list ] test-word
[ [ 2 0 0 0 ] ] [ [ cons@ ] ] [ balance>list ] test-word
@ -25,12 +22,9 @@ USE: test
[ [ 1 1 0 0 ] ] [ [ length ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ list? ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ nreverse ] ] [ balance>list ] test-word
[ [ 2 1 0 0 ] ] [ [ nappend ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ cons? ] ] [ balance>list ] test-word
[ [ 2 1 0 0 ] ] [ [ remove ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ reverse ] ] [ balance>list ] test-word
[ [ 2 0 0 0 ] ] [ [ set-car ] ] [ balance>list ] test-word
[ [ 2 0 0 0 ] ] [ [ set-cdr ] ] [ balance>list ] test-word
[ [ 2 2 0 0 ] ] [ [ [ < ] partition ] ] [ balance>list ] test-word
[ [ 2 2 0 0 ] ] [ [ [ nip string? ] partition ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ num-sort ] ] [ balance>list ] test-word
@ -41,7 +35,6 @@ USE: test
[ [ 2 1 0 0 ] ] [ [ unique ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ unit ] ] [ balance>list ] test-word
[ [ 1 2 0 0 ] ] [ [ unswons ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ deep-clone ] ] [ balance>list ] test-word
[ [ ] ] [ [ ] ] [ array>list ] test-word
[ [ 1 2 3 ] ] [ [ 1 2 3 ] ] [ array>list ] test-word

24
library/test/lists/lists.factor
View File

@ -13,16 +13,6 @@ USE: test
[ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] append ] unit-test
[ [ 1 2 3 | 4 ] ] [ [ 1 2 3 ] 4 append ] unit-test
[ [ ] ] [ [ ] clone-list ] unit-test
[ [ 1 2 | 3 ] ] [ [ 1 2 | 3 ] clone-list ] unit-test
[ [ 1 2 3 4 ] ] [ [ 1 2 3 4 ] clone-list ] unit-test
: clone-list-actually-clones? ( list1 list2 -- )
>r clone-list ! we don't want to mutate literals
dup clone-list r> nappend = not ;
[ t ] [ [ 1 2 ] [ 3 4 ] clone-list-actually-clones? ] unit-test
[ f ] [ 3 [ ] contains? ] unit-test
[ f ] [ 3 [ 1 2 ] contains? ] unit-test
[ [ 1 2 ] ] [ 1 [ 1 2 ] contains? ] unit-test
@ -48,10 +38,6 @@ USE: test
[ t ] [ [ 1 2 ] list? ] unit-test
[ f ] [ [ 1 | 2 ] list? ] unit-test
[ 2 ] [ 1 [ 1 2 3 ] next ] unit-test
[ 1 ] [ 3 [ 1 2 3 ] next ] unit-test
[ 1 ] [ 4 [ 1 2 3 ] next ] unit-test
[ [ ] ] [ 1 [ ] remove ] unit-test
[ [ ] ] [ 1 [ 1 ] remove ] unit-test
[ [ 3 1 1 ] ] [ 2 [ 3 2 1 2 1 ] remove ] unit-test
@ -75,13 +61,3 @@ USE: test
[ [ 0 1 2 3 ] ] [ 4 count ] unit-test
[ [ 1 2 3 ] ] [ [ 1 4 2 5 3 6 ] [ 4 < ] subset ] unit-test
[ [ t f t f ] ] [ f 1 [ t 1 t 1 ] substitute ] unit-test
[ [ 0 1 2 4 5 6 7 8 9 ] ] [ 3 10 count remove-nth ] unit-test
[ [ 1 2 3 4 5 6 7 8 9 ] ] [ 0 10 count remove-nth ] unit-test
[ [ 0 1 2 3 4 5 6 7 8 ] ] [ 9 10 count remove-nth ] unit-test
[ [ 1 2 3 ] ] [ 2 1 [ 1 3 3 ] set-nth ] unit-test
[ [ 1 2 3 ] ] [ 1 0 [ 2 2 3 ] set-nth ] unit-test
[ [ 1 2 3 ] ] [ 3 2 [ 1 2 2 ] set-nth ] unit-test

6
library/test/lists/namespaces.factor
View File

@ -3,10 +3,6 @@ USE: lists
USE: namespaces
USE: test
[ [ 1 2 3 4 ] ] [ [ 3 4 ] [ 1 2 ] ] [ "x" set "x" append@ "x" get ] test-word
[ [ 1 2 3 4 ] ] [ 4 [ 1 2 3 ] ] [ "x" set "x" add@ "x" get ] test-word
[ [ 1 ] ] [ 1 f ] [ "x" set "x" cons@ "x" get ] test-word
[ [ 1 | 2 ] ] [ 1 2 ] [ "x" set "x" cons@ "x" get ] test-word
[ [ 1 2 ] ] [ 1 [ 2 ] ] [ "x" set "x" cons@ "x" get ] test-word
@ -42,5 +38,3 @@ USE: test
1/5 , 1/5 unique,
[, { } unique, ,] , ,]
] unit-test
[ [ 1 2 3 4 ] ] [ [, 1 , [ 2 3 ] list, 4 , ,] ] unit-test

1
library/test/test.factor
View File

@ -70,7 +70,6 @@ USE: unparser
"lists/cons"
"lists/lists"
"lists/assoc"
"lists/destructive"
"lists/namespaces"
"combinators"
"continuations"

15
library/vocabulary-style.factor
View File

@ -33,23 +33,18 @@ USE: namespaces
USE: stack
USE: styles
: get-vocab-style ( vocab -- style )
: vocab-style ( vocab -- style )
#! Each vocab has a style object specifying how words are
#! to be printed.
"vocabularies" 2rlist get-style ;
"vocabularies" get-style get* ;
: set-vocab-style ( style vocab -- )
swap default-style append swap
[ "styles" "vocabularies" ] object-path set* ;
>r default-style append r> "vocabularies" get-style set* ;
: word-style ( word -- style )
word-vocabulary dup [
get-vocab-style
] [
drop default-style
] ifte ;
word-vocabulary [ vocab-style ] [ default-style ] ifte* ;
"styles" get [ <namespace> "vocabularies" set ] bind
<namespace> "vocabularies" set-style
[
[ "ansi-fg" | "1" ]

14
native/cons.c
View File

@ -24,17 +24,3 @@ void primitive_cdr(void)
{
drepl(cdr(dpeek()));
}
void primitive_set_car(void)
{
CELL cons = dpop();
CELL car = dpop();
untag_cons(cons)->car = car;
}
void primitive_set_cdr(void)
{
CELL cons = dpop();
CELL cdr = dpop();
untag_cons(cons)->cdr = cdr;
}

2
native/cons.h
View File

@ -29,5 +29,3 @@ INLINE CELL cdr(CELL cons)
void primitive_cons(void);
void primitive_car(void);
void primitive_cdr(void);
void primitive_set_car(void);
void primitive_set_cdr(void);

2
native/primitives.c
View File

@ -10,8 +10,6 @@ XT primitives[] = {
primitive_cons,
primitive_car,
primitive_cdr,
primitive_set_car,
primitive_set_cdr,
primitive_vector,
primitive_vector_length,
primitive_set_vector_length,

2
native/primitives.h
View File

@ -1,4 +1,4 @@
extern XT primitives[];
#define PRIMITIVE_COUNT 196
#define PRIMITIVE_COUNT 194
CELL primitive_to_xt(CELL primitive);