\r
- when* compilation in jvm\r
- compile word twice; no more 'cannot compile' error!\r
-- doc comments in assoc, image, inferior\r
+- doc comments in image, inferior\r
- compiler: drop literal peephole optimization\r
- compiling when*\r
- compiling unless*\r
FactorWord use = define("syntax","USE:");
use.parsing = new Use(use);
+ FactorWord pushWord = define("syntax","\\");
+ pushWord.parsing = new PushWord(pushWord);
+
FactorWord interpreterGet = define("builtins","interpreter");
interpreterGet.def = new InterpreterGet(interpreterGet);
interpreterGet.inline = true;
--- /dev/null
+/* :folding=explicit:collapseFolds=1: */
+
+/*
+ * $Id$
+ *
+ * Copyright (C) 2004 Slava Pestov.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ *
+ * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+ * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+ * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+ * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+ * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+ * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+ * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+ * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ */
+
+package factor.parser;
+
+import factor.*;
+
+public class PushWord extends FactorParsingDefinition
+{
+ //{{{ PushWord constructor
+ /**
+ * A new definition.
+ */
+ public PushWord(FactorWord word)
+ throws Exception
+ {
+ super(word);
+ } //}}}
+
+ public void eval(FactorInterpreter interp, FactorReader reader)
+ throws Exception
+ {
+ FactorWord word = reader.nextWord(false);
+ reader.append(new Cons(word,null));
+ reader.append(interp.searchVocabulary(
+ new Cons("lists",null),"car"));
+ }
+}
USE: kernel
USE: stack
+! An association list is a list of conses where the car of each
+! cons is a key, and the cdr is a value. See the Factor
+! Developer's Guide for details.
+
: assoc? ( list -- ? )
- #! Push if the list appears to be an alist (each element is
- #! a cons).
+ #! Push if the list appears to be an alist.
dup list? [ [ cons? ] all? ] [ drop f ] ifte ;
: assoc* ( key alist -- [ key | value ] )
] ifte ;
: assoc ( key alist -- value )
- #! Looks up the key in an alist. An alist is a proper list
- #! of comma pairs, the car of each pair is a key, the cdr is
- #! the value. For example:
- #! [ [ 1 | "one" ] [ 2 | "two" ] [ 3 | "three" ] ]
+ #! Looks up the key in an alist.
assoc* dup [ cdr ] when ;
+: remove-assoc ( key alist -- alist )
+ #! Remove all key/value pairs with this key.
+ [ dupd car = not ] subset nip ;
+
: acons ( value key alist -- alist )
+ #! Adds the key/value pair to the alist. Existing pairs with
+ #! this key are not removed; the new pair simply shadows
+ #! existing pairs.
>r swons r> cons ;
: set-assoc ( value key alist -- alist )
- #! Sets the key in the alist. Does not modify the existing
- #! list by consing a new key/value pair onto the alist. The
- #! newly-added pair 'shadows' the previous value.
- [ dupd car = not ] subset acons ;
+ #! Adds the key/value pair to the alist.
+ dupd remove-assoc acons ;
: assoc-apply ( value-alist quot-alist -- )
#! Looks up the key of each pair in the first list in the
drop [ "width" get ] bind + ;
: define-constructor ( len -- )
- [ <alien> ] cons
- <% "<" % "struct-name" get % ">" % %>
- "in" get create swap
- define-compound ;
-
-: define-local-constructor ( len -- )
+ #! Make a word <foo> where foo is the structure name that
+ #! allocates a Factor heap-local instance of this structure.
+ #! Used for C functions that expect you to pass in a struct.
[ <local-alien> ] cons
- <% "<local-" % "struct-name" get % ">" % %>
+ <% "<" % "struct-name" get % ">" % %>
"in" get create swap
define-compound ;
-: define-struct-type ( len -- )
- #! For example, if len is 32, make a C type with getter:
- #! [ 32 >r alien-cell r> <alien> ] cons
+: define-struct-type ( -- )
#! The setter just throws an error for now.
[
- [ >r alien-cell r> <alien> ] cons "getter" set
+ [ alien-cell <alien> ] "getter" set
"unbox_alien" "unboxer" set
+ "box_alien" "boxer" set
cell "width" set
] "struct-name" get "*" cat2 define-c-type ;
: FIELD: ( offset -- offset )
scan scan define-field ; parsing
-: END-STRUCT ( offset -- )
- dup define-constructor
- dup define-local-constructor
- define-struct-type ; parsing
+: END-STRUCT ( length -- )
+ define-constructor define-struct-type ; parsing
global [ <namespace> "c-types" set ] bind
[
- [ alien-cell ] "getter" set
+ [ alien-cell <alien> ] "getter" set
[ set-alien-cell ] "setter" set
cell "width" set
- "does_not_exist" "boxer" set
+ "box_alien" "boxer" set
"unbox_alien" "unboxer" set
] "void*" define-c-type
global [ <namespace> "libraries" set ] bind
-[ alien-call compile-alien-call ]
-unswons "compiling" set-word-property
+\ alien-call [ compile-alien-call ] "compiling" set-word-property
dup "can-compile" word-property [
drop t
] [
- t over "can-compile" set-word-property
- dup >r (can-compile) dup r>
- "can-compile" set-word-property
+ dup t "can-compile" set-word-property
+ dup (can-compile)
+ [ "can-compile" set-word-property ] keep
] ifte ;
SYMBOL: compilable-word-list
+: reset-can-compile ( -- )
+ [ f "can-compile" set-word-property ] each-word ;
+
: compilable-words ( -- list )
#! Make a list of all words that can be compiled.
- [, [ dup can-compile? [ , ] [ drop ] ifte ] each-word ,] ;
+ reset-can-compile
+ [, [ dup can-compile? [ , ] [ drop ] ifte ] each-word ,]
+ reset-can-compile ;
: cannot-compile ( word -- )
"verbose-compile" get [
compiled-offset swap compiled-xts acons@ ;
: commit-xt ( xt word -- )
- t over "compiled" set-word-property set-word-xt ;
+ dup t "compiled" set-word-property set-word-xt ;
: commit-xts ( -- )
compiled-xts get [ unswons commit-xt ] each
pop-literal commit-literals
ARITHMETIC-TYPE compile-jump-table ;
-[ compile-generic ] \ generic "compiling" set-word-property
-[ compile-2generic ] \ 2generic "compiling" set-word-property
+\ generic [ compile-generic ] "compiling" set-word-property
+\ 2generic [ compile-2generic ] "compiling" set-word-property
( f -- ) compile-quot
r> end-if ;
-[ compile-ifte ] \ ifte "compiling" set-word-property
-[ compile-when ] \ when "compiling" set-word-property
-[ compile-unless ] \ unless "compiling" set-word-property
+\ ifte [ compile-ifte ] "compiling" set-word-property
+\ when [ compile-when ] "compiling" set-word-property
+\ unless [ compile-unless ] "compiling" set-word-property
"Cannot compile " swap cat2 throw ;
: word-interpret-only ( word -- )
- t over "interpret-only" set-word-property
+ dup t "interpret-only" set-word-property
dup word-name [ interpret-only-error ] cons
- swap
"compiling" set-word-property ;
\ call word-interpret-only
>float
numerator
denominator
- >fraction
fraction>
str>float
unparse-float
float>bits
real
imaginary
- >rect
rect>
fixnum=
fixnum+
2list cons ;
: append ( [ list1 ] [ list2 ] -- [ list1 list2 ] )
- #! Append two lists.
over [ >r uncons r> append cons ] [ nip ] ifte ;
: contains? ( element list -- remainder )
] ifte ;
: nth ( n list -- list[n] )
- #! Gets the nth element of a proper list by successively
- #! iterating down the cdr pointer.
+ #! Push the nth element of a proper list.
#! Supplying n <= 0 pushes the first element of the list.
#! Supplying an argument beyond the end of the list raises
#! an error.
: last* ( list -- last )
#! Pushes last cons of a list.
- #! For example, given a proper list, pushes a cons cell
- #! whose car is the last element of the list, and whose cdr
- #! is f.
dup cdr cons? [ cdr last* ] when ;
: last ( list -- last )
- #! Pushes last element of a list. Since this pushes the
- #! car of the last cons cell, the list may be an improper
- #! list.
+ #! Pushes last element of a list.
last* car ;
: list? ( list -- boolean )
#! already contained in the list.
2dup contains? [ nip ] [ cons ] ifte ;
-: each ( list quotation -- )
+: each-step ( list quot -- list quot )
+ >r uncons r> tuck 2slip ; inline interpret-only
+
+: each ( list quot -- )
#! Push each element of a proper list in turn, and apply a
- #! quotation to each element.
- #!
- #! The quotation must consume one more value than it
- #! produces.
- over [ >r uncons r> tuck 2slip each ] [ 2drop ] ifte ;
+ #! quotation with effect ( X -- ) to each element.
+ over [ each-step each ] [ 2drop ] ifte ;
inline interpret-only
: reverse ( list -- list )
#! Push a new list that is the reverse of a proper list.
[ ] swap [ swons ] each ;
-: map ( list code -- list )
- #! Applies the code to each item, returns a list that
- #! contains the result of each application.
- #!
- #! The quotation must consume as many values as it
- #! produces.
- f transp [
- ! accum code elem -- accum code
- transp over >r >r call r> cons r>
- ] each drop reverse ; inline interpret-only
+: map ( list quot -- list )
+ #! Push each element of a proper list in turn, and collect
+ #! return values of applying a quotation with effect
+ #! ( X -- Y ) to each element into a new list.
+ over [ each-step rot >r map r> swons ] [ drop ] ifte ;
+ inline interpret-only
: 2uncons ( list1 list2 -- car1 car2 cdr1 cdr2 )
uncons >r >r uncons r> swap r> ;
: word-property ( word pname -- pvalue )
swap [ get ] bind ;
-: set-word-property ( pvalue word pname -- )
- swap [ set ] bind ;
+: set-word-property ( word pvalue pname -- )
+ rot [ set ] bind ;
: redefine ( word def -- )
swap [ "def" set ] bind ;
"/library/sdl/sdl-video.factor"
"/library/sdl/sdl-event.factor"
"/library/sdl/sdl-gfx.factor"
+ "/library/sdl/sdl-utils.factor"
"/library/sdl/hsv.factor"
] [
dup print
compilable-words compilable-word-list set
+! Save a bit of space
+global [ "stdio" off ] bind
+
garbage-collection
"factor.image" save-image
0 exit*
: reduce ( x y -- x' y' )
dup 0 < [ swap neg swap neg ] when 2dup gcd tuck /i >r /i r> ;
: ratio ( x y -- x/y ) reduce fraction> ;
+: >fraction ( a/b -- a b ) dup numerator swap denominator ;
: 2>fraction ( a/b c/d -- a b c d ) >r >fraction r> >fraction ;
: ratio= ( a/b c/d -- ? ) 2>fraction 2= ;
: ratio> ( x y -- ? ) ratio-scale > ;
: ratio>= ( x y -- ? ) ratio-scale >= ;
+: >rect ( x -- x:re x: im ) dup real swap imaginary ;
: 2>rect ( x y -- x:re x:im y:re y:im ) >r >rect r> >rect ;
: complex= ( x y -- ? ) 2>rect 2= ;
! Colon defs
: CREATE ( -- word )
scan "in" get create dup set-word
- f over "documentation" set-word-property
- f over "stack-effect" set-word-property ;
+ dup f "documentation" set-word-property
+ dup f "stack-effect" set-word-property ;
: remember-where ( word -- )
- "line-number" get over "line" set-word-property
- "col" get over "col" set-word-property
- "file" get over "file" set-word-property
- drop ;
+ dup "line-number" get "line" set-word-property
+ dup "col" get "col" set-word-property
+ "file" get "file" set-word-property ;
! \x
: unicode-escape>ch ( -- esc )
: parsed-stack-effect ( parsed str -- parsed )
over doc-comment-here? [
- word "stack-effect" set-word-property
+ word swap "stack-effect" set-word-property
] [
drop
] ifte ;
-: documentation+ ( str word -- )
- [
- "documentation" word-property [
- swap "\n" swap cat3
- ] when*
- ] keep
+: documentation+ ( word str -- )
+ over "documentation" word-property [
+ swap "\n" swap cat3
+ ] when*
"documentation" set-word-property ;
: parsed-documentation ( parsed str -- parsed )
over doc-comment-here? [
- word documentation+
+ word swap documentation+
] [
drop
] ifte ;
#! Mark the most recently defined word to execute at parse
#! time, rather than run time. The word can use 'scan' to
#! read ahead in the input stream.
- t word "parsing" set-word-property ;
+ word t "parsing" set-word-property ;
: end? ( -- ? )
"col" get "line" get str-length >= ;
! Once this file has loaded, we can use 'parsing' normally.
! This hack is needed because in Java Factor, 'parsing' is
! not parsing, but in CFactor, it is.
-t "parsing" [ "parser" ] search "parsing" set-word-property
+\ parsing t "parsing" set-word-property
[ >float | " n -- float " ]
[ numerator | " a/b -- a " ]
[ denominator | " a/b -- b " ]
- [ >fraction | " a/b -- a b " ]
[ fraction> | " a b -- a/b " ]
[ str>float | " str -- float " ]
[ unparse-float | " float -- str " ]
[ float>bits | " float -- n " ]
[ real | " #{ re im } -- re " ]
[ imaginary | " #{ re im } -- im " ]
- [ >rect | " #{ re im } -- re im " ]
[ rect> | " re im -- #{ re im } " ]
[ fixnum= | " x y -- ? " ]
[ fixnum+ | " x y -- x+y " ]
[ dlsym | " name dll -- ptr " ]
[ dlsym-self | " name -- ptr " ]
[ dlclose | " dll -- " ]
- [ <alien> | " ptr len -- alien " ]
+ [ <alien> | " ptr -- alien " ]
[ <local-alien> | " len -- alien " ]
[ alien-cell | " alien off -- n " ]
[ set-alien-cell | " n alien off -- " ]
[ heap-stats | " -- instances bytes " ]
[ throw | " error -- " ]
] [
- unswons "stack-effect" set-word-property
+ uncons "stack-effect" set-word-property
] each
: word-property ( word pname -- pvalue )
swap word-plist assoc ;
-: set-word-property ( pvalue word pname -- )
- swap [ word-plist set-assoc ] keep set-word-plist ;
+: set-word-property ( word pvalue pname -- )
+ pick word-plist pick [ set-assoc ] [ remove-assoc nip ] ifte
+ swap set-word-plist ;
: defined? ( obj -- ? )
dup word? [ word-primitive 0 = not ] [ drop f ] ifte ;
IN: sdl
USE: alien
-USE: math
-USE: namespaces
-USE: stack
-USE: compiler
-USE: words
-USE: parser
-USE: kernel
-USE: errors
-USE: combinators
-USE: lists
-USE: logic
-
-! This is a kind of high level wrapper around SDL, and turtle
-! graphics, in one messy, undocumented package. Will be improved
-! later, and heavily refactored, so don't count on this
-! interface remaining unchanged.
-
-SYMBOL: surface
-SYMBOL: pixels
-SYMBOL: format
-SYMBOL: pen
-SYMBOL: angle
-SYMBOL: color
-
-: xy-4 ( #{ x y } -- offset )
- >rect surface get surface-pitch * swap 4 * + ;
-
-: set-pixel-4 ( color #{ x y } -- )
- xy-4 pixels get swap set-alien-4 ;
-
-: rgb ( r g b -- value )
- >r >r >r format get r> r> r> SDL_MapRGB ;
-
-: pixel-4-step ( quot #{ x y } -- )
- dup >r swap call rgb r> set-pixel-4 ;
-
-: with-pixels-4 ( w h quot -- )
- -rot rect> [ over >r pixel-4-step r> ] 2times* drop ;
-
-: move ( #{ x y } -- )
- pen +@ ;
-
-: turn ( angle -- )
- angle +@ ;
-
-: move-d ( distance -- )
- angle get cis * move ;
-
-: pixel ( -- )
- color get pen get set-pixel-4 ;
-
-: sgn ( x -- -1/0/1 ) dup 0 = [ 0 < -1 1 ? ] unless ;
-
-: line-h-step ( #{ dx dy } #{ px py } p -- p )
- over real fixnum- dup 0 < [
- swap imaginary fixnum+ swap
- ] [
- nip swap real
- ] ifte move pixel ;
-
-: line-more-h ( #{ dx dy } #{ px py } -- )
- dup imaginary 2 fixnum/i over imaginary [
- >r 2dup r> line-h-step
- ] times 3drop ;
-
-: line-v-step ( #{ dx dy } #{ px py } p -- p )
- over imaginary fixnum- dup 0 fixnum< [
- swap real fixnum+ swap
- ] [
- nip swap imaginary 0 swap rect>
- ] ifte move pixel ;
-
-: line-more-v ( #{ dx dy } #{ px py } -- )
- dup real 2 fixnum/i over real [
- >r 2dup r> line-v-step
- ] times 3drop ;
-
-: line ( #{ x y } -- )
- pixel ( first point )
- dup >r >rect swap sgn swap sgn rect> r>
- >rect swap abs swap abs 2dup fixnum< [
- rect> line-more-h
- ] [
- rect> line-more-v
- ] ifte ;
-
-: line-d ( distance -- )
- angle get cis * line ;
-
-: with-surface ( quot -- )
- #! Execute a quotation, locking the current surface if it
- #! is required (eg, hardware surface).
- surface get dup must-lock-surface? [
- dup SDL_LockSurface slip SDL_UnlockSurface
- ] [
- drop call
- ] ifte surface get SDL_Flip ;
-
-: event-loop ( event -- )
- dup SDL_WaitEvent 1 = [
- dup event-type SDL_QUIT = [
- drop
- ] [
- event-loop
- ] ifte
- ] [
- drop
- ] ifte ;
+
+: pixelColor ( surface x y color -- )
+ "void" "sdl-gfx" "pixelColor"
+ [ "surface*" "short" "short" "uint" ]
+ alien-call ;
+
+: hlineColor ( surface x1 x2 y color -- )
+ "void" "sdl-gfx" "hlineColor"
+ [ "surface*" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: vlineColor ( surface x y1 y2 color -- )
+ "void" "sdl-gfx" "vlineColor"
+ [ "surface*" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: rectangleColor ( surface x1 y1 x2 y2 color -- )
+ "void" "sdl-gfx" "rectangleColor"
+ [ "surface*" "short" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: boxColor ( surface x1 y1 x2 y2 color -- )
+ "void" "sdl-gfx" "boxColor"
+ [ "surface*" "short" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: lineColor ( surface x1 y1 x2 y2 color -- )
+ "void" "sdl-gfx" "lineColor"
+ [ "surface*" "short" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: aalineColor ( surface x1 y1 x2 y2 color -- )
+ "void" "sdl-gfx" "aalineColor"
+ [ "surface*" "short" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: circleColor ( surface x y r color -- )
+ "void" "sdl-gfx" "circleColor"
+ [ "surface*" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: aacircleColor ( surface x y r color -- )
+ "void" "sdl-gfx" "aacircleColor"
+ [ "surface*" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: filledCircleColor ( surface x y r color -- )
+ "void" "sdl-gfx" "filledCircleColor"
+ [ "surface*" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: ellipseColor ( surface x y rx ry color -- )
+ "void" "sdl-gfx" "ellipseColor"
+ [ "surface*" "short" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: aaellipseColor ( surface x y rx ry color -- )
+ "void" "sdl-gfx" "aaellipseColor"
+ [ "surface*" "short" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: filledEllipseColor ( surface x y rx ry color -- )
+ "void" "sdl-gfx" "filledEllipseColor"
+ [ "surface*" "short" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: pieColor ( surface x y rad start end color -- )
+ "void" "sdl-gfx" "pieColor"
+ [ "surface*" "short" "short" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: filledPieColor ( surface x y rad start end color -- )
+ "void" "sdl-gfx" "filledPieColor"
+ [ "surface*" "short" "short" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: trigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
+ "void" "sdl-gfx" "trigonColor"
+ [ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: aatrigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
+ "void" "sdl-gfx" "aatrigonColor"
+ [ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: filledTrigonColor ( surface x1 y1 x2 y2 x3 y3 color -- )
+ "void" "sdl-gfx" "filledTrigonColor"
+ [ "surface*" "short" "short" "short" "short" "short" "short" "uint" ]
+ alien-call ;
+
+: characterColor ( surface x y c color -- )
+ "void" "sdl-gfx" "characterColor"
+ [ "surface*" "short" "short" "char" "uint" ]
+ alien-call ;
+
+: stringColor ( surface x y str color -- )
+ "void" "sdl-gfx" "stringColor"
+ [ "surface*" "short" "short" "char*" "uint" ]
+ alien-call ;
] ifte ;
: SDL_VideoInit ( driver-name flags -- )
- "int" "sdl" "SDL_SetVideoMode"
+ "int" "sdl" "SDL_VideoInit"
[ "char*" "int" ] alien-call ;
: SDL_VideoQuit ( -- )
! SDL_ListModes needs array of structs support
: SDL_SetVideoMode ( width height bpp flags -- )
- "int" "sdl" "SDL_SetVideoMode"
+ "surface*" "sdl" "SDL_SetVideoMode"
[ "int" "int" "int" "int" ] alien-call ;
! UpdateRects, UpdateRect
[ ] [ ] [ ??nop ] test-word
[ ] [ ] [ ???nop ] test-word
-: while-test [ f ] [ ] while ; word must-compile
-
-[ ] [ ] [ while-test ] test-word
-
: times-test-1 [ nop ] times ; word must-compile
: times-test-2 [ succ ] times ; word must-compile
: times-test-3 0 10 [ succ ] times ; word must-compile
[ [ 0 0 0 0 ] ] [ [ null-rec ] ] [ balance>list ] test-word
-: null-rec ( -- )
- t [ drop null-rec ] when* ; word must-compile
-
-[ [ 0 0 0 0 ] ] [ [ null-rec ] ] [ balance>list ] test-word
+! : null-rec ( -- )
+! t [ drop null-rec ] when* ; word must-compile
+!
+! [ [ 0 0 0 0 ] ] [ [ null-rec ] ] [ balance>list ] test-word
!: null-rec ( -- )
! t [ t null-rec ] unless* drop ; word must-compile test-null-rec
[ ] [ ] [ tail-call-1 ] test-word
-: tail-call-2 ( list -- f )
- [ dup cons? ] [ uncons nip ] while ; word must-compile
-
-[ f ] [ [ 1 2 3 ] ] [ tail-call-2 ] test-word
-
: tail-call-3 ( x y -- z )
>r dup succ r> swap 6 = [
+
[ 8 ] [ 1 "value-alist" get "quot-alist" get assoc-apply ] unit-test
[ 1 ] [ 1 "value-alist" get f assoc-apply ] unit-test
+
+[ [ [ "one" + ] [ "four" * ] ] ] [
+ "three" "quot-alist" get remove-assoc
+] unit-test
[ [ 3 1 0 0 ] ] [ [ 3list ] ] [ balance>list ] test-word
[ [ 2 1 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
[ [ 2 1 0 0 ] ] [ [ cons ] ] [ balance>list ] test-word
[ [ 1 1 0 0 ] ] [ [ last ] ] [ balance>list ] test-word
[ [ 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
[ [ 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
[ t ] [ ] [ words-test ] test-word
+DEFER: plist-test
+
+[ t ] [
+ \ plist-test t "sample-property" set-word-property
+ \ plist-test "sample-property" word-property
+] unit-test
+
+[ f ] [
+ \ plist-test f "sample-property" set-word-property
+ \ plist-test "sample-property" word-property
+] unit-test
: test-last ( -- ) ;
word word-name "last-word-test" set
: word-name ( word -- name )
"name" word-property ;
-: set-word-name ( word name -- )
- "name" set-word-property ;
-
: word-vocabulary ( word -- vocab )
"vocabulary" word-property ;
-: set-word-vocabulary ( word vocab -- )
- "vocabulary" set-word-property ;
-
: each-word ( quot -- )
#! Apply a quotation to each word in the image.
vocabs [ words [ swap dup >r call r> ] each ] each drop ;
}
}
-void primitive_to_rect(void)
-{
- COMPLEX* c;
- switch(type_of(dpeek()))
- {
- case FIXNUM_TYPE:
- case BIGNUM_TYPE:
- case FLOAT_TYPE:
- case RATIO_TYPE:
- dpush(tag_fixnum(0));
- break;
- case COMPLEX_TYPE:
- c = untag_complex(dpop());
- dpush(c->real);
- dpush(c->imaginary);
- break;
- default:
- type_error(NUMBER_TYPE,dpeek());
- break;
- }
-}
-
void primitive_from_rect(void)
{
CELL imaginary, real;
void primitive_real(void);
void primitive_imaginary(void);
-void primitive_to_rect(void);
void primitive_from_rect(void);
#endif
}
+#ifdef FFI
+CELL unbox_alien(void)
+{
+ return untag_alien(dpop())->ptr;
+}
+
+void box_alien(CELL ptr)
+{
+ ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
+ alien->ptr = ptr;
+ alien->local = false;
+ dpush(tag_object(alien));
+}
+
+INLINE CELL alien_pointer(void)
+{
+ FIXNUM offset = unbox_integer();
+ ALIEN* alien = untag_alien(dpop());
+ CELL ptr = alien->ptr;
+
+ if(ptr == NULL)
+ general_error(ERROR_EXPIRED,tag_object(alien));
+
+ return ptr + offset;
+}
+#endif
+
void primitive_alien(void)
{
#ifdef FFI
- CELL length = unbox_integer();
CELL ptr = unbox_integer();
- ALIEN* alien;
maybe_garbage_collection();
- alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
- alien->ptr = ptr;
- alien->length = length;
- alien->local = false;
- dpush(tag_object(alien));
+ box_alien(ptr);
#else
general_error(ERROR_FFI_DISABLED,F);
#endif
alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
local = string(length / CHARS,'\0');
alien->ptr = (CELL)local + sizeof(STRING);
- alien->length = length;
alien->local = true;
dpush(tag_object(alien));
#else
#endif
}
-#ifdef FFI
-CELL unbox_alien(void)
-{
- return untag_alien(dpop())->ptr;
-}
-
-INLINE CELL alien_pointer(void)
-{
- FIXNUM offset = unbox_integer();
- ALIEN* alien = untag_alien(dpop());
- CELL ptr = alien->ptr;
-
- if(ptr == NULL)
- general_error(ERROR_EXPIRED,tag_object(alien));
-
- if(offset < 0 || offset >= alien->length)
- {
- range_error(tag_object(alien),offset,alien->length);
- return 0; /* can't happen */
- }
- else
- return ptr + offset;
-}
-#endif
-
void primitive_alien_cell(void)
{
#ifdef FFI
typedef struct {
CELL header;
CELL ptr;
- CELL length;
/* local aliens are heap-allocated as strings and must be collected. */
bool local;
} ALIEN;
primitive_to_float,
primitive_numerator,
primitive_denominator,
- primitive_to_fraction,
primitive_from_fraction,
primitive_str_to_float,
primitive_float_to_str,
primitive_float_to_bits,
primitive_real,
primitive_imaginary,
- primitive_to_rect,
primitive_from_rect,
primitive_fixnum_eq,
primitive_fixnum_add,
extern XT primitives[];
-#define PRIMITIVE_COUNT 194
+#define PRIMITIVE_COUNT 191
CELL primitive_to_xt(CELL primitive);
}
}
-void primitive_to_fraction(void)
-{
- RATIO* r;
-
- switch(type_of(dpeek()))
- {
- case FIXNUM_TYPE:
- case BIGNUM_TYPE:
- dpush(tag_fixnum(1));
- break;
- case RATIO_TYPE:
- r = untag_ratio(dpeek());
- drepl(r->numerator);
- dpush(r->denominator);
- break;
- default:
- type_error(RATIONAL_TYPE,dpeek());
- break;
- }
-}
-
void primitive_numerator(void)
{
switch(type_of(dpeek()))
void primitive_numerator(void);
void primitive_denominator(void);
void primitive_from_fraction(void);
-void primitive_to_fraction(void);
projects / factor.git / commitdiff