-CC = gcc34
-DEFAULT_CFLAGS = -Wall -export-dynamic -g $(SITE_CFLAGS)
+CC = gcc
+DEFAULT_CFLAGS = -Wall -g $(SITE_CFLAGS)
DEFAULT_LIBS = -lm
STRIP = strip
native/sbuf.o native/socket.o native/stack.o \
native/string.o native/types.o native/vector.o \
native/write.o native/word.o native/compiler.o \
- native/ffi.o native/signal.o
+ native/ffi.o native/signal.o native/boolean.o
default:
@echo "Run 'make' with one of the following parameters:"
@echo "bsd"
@echo "bsd-nopthread - on FreeBSD 4, if you want to use profiling"
@echo "linux"
+ @echo "macosx"
@echo "solaris"
@echo ""
@echo "Also, you might want to set the SITE_CFLAGS environment"
bsd:
$(MAKE) f \
- CFLAGS="$(DEFAULT_CFLAGS) -DFFI -pthread" \
+ CFLAGS="$(DEFAULT_CFLAGS) -DFFI -export-dynamic -pthread" \
LIBS="$(DEFAULT_LIBS)"
bsd-nopthread:
+ $(MAKE) f \
+ CFLAGS="$(DEFAULT_CFLAGS) -DFFI -export-dynamic" \
+ LIBS="$(DEFAULT_LIBS)"
+
+macosx:
$(MAKE) f \
CFLAGS="$(DEFAULT_CFLAGS) -DFFI" \
LIBS="$(DEFAULT_LIBS)"
linux:
$(MAKE) f \
- CFLAGS="$(DEFAULT_CFLAGS) -DFFI" \
+ CFLAGS="$(DEFAULT_CFLAGS) -DFFI -export-dynamic" \
LIBS="$(DEFAULT_LIBS) -ldl"
solaris:
\r
+ listener/plugin:\r
\r
+- extract word in wrong place\r
- twice in completion list\r
- accept multi-line input in listener\r
- don't show listener on certain commands\r
\r
+ kernel:\r
\r
+- save restore stacks between longjmp in case they are in registers\r
- profiler is inaccurate: wrong word on cs\r
- better i/o scheduler\r
- >lower, >upper for strings\r
SYMBOL: b
SYMBOL: c
SYMBOL: d
-SYMBOL: width
-SYMBOL: height
: next-x ( x y -- x ) a get * sin swap b get * cos - ;
: next-y ( x y -- y ) swap c get * sin swap d get * cos - ;
2.4 c set
-2.1 d set
- 640 dup width set
- 480 dup height set
- 32 SDL_HWSURFACE SDL_SetVideoMode drop
+ 640 480 32 SDL_HWSURFACE [
+ [ 0 0 100000 draw-dejong ] with-surface
- [
- 0 0 100000 draw-dejong
- ] with-surface
-
- <event> event-loop
- SDL_Quit ;
+ <event> event-loop
+ SDL_Quit
+ ] with-screen ;
dejong
] with-pixels ;
: mandel ( -- )
- 640 480 32 SDL_HWSURFACE SDL_SetVideoMode drop
-
- [
- 0.8 zoom-fact set
- -0.65 center set
- 100 nb-iter set
- [ render ] time
- "Done." print flush
- ] with-surface
-
- <event> event-loop
- SDL_Quit ;
+ 640 480 32 SDL_HWSURFACE [
+ [
+ 0.8 zoom-fact set
+ -0.65 center set
+ 100 nb-iter set
+ [ render ] time
+ "Done." print flush
+ ] with-surface
+
+ <event> event-loop
+ SDL_Quit
+ ] with-screen ;
mandel
#! after the quotation returns.
over >r call r> ;
+: 2keep ( a b quot -- a b )
+ #! Execute the quotation with a and b on the stack, and
+ #! restore a and b after the quotation returns.
+ over >r pick >r call r> r> ;
+
: apply ( code input -- code output )
#! Apply code to input.
swap dup >r call r> swap ;
USE: compiler
USE: errors
USE: hashtables
+USE: kernel
USE: lists
+USE: logic
USE: math
USE: namespaces
USE: parser
"box_c_string" "boxer" set
"unbox_c_string" "unboxer" set
] "char*" define-c-type
+
+[
+ [ alien-4 0 = not ] "getter" set
+ [ 1 0 ? set-alien-4 ] "setter" set
+ cell "width" set
+ "box_boolean" "boxer" set
+ "unbox_boolean" "unboxer" set
+] "bool" define-c-type
+++ /dev/null
-IN: scratchpad
-USE: graphics
-USE: test
-USE: namespaces
-USE: lists
-USE: kernel
-
-<rectangle> [
- #{ 0 0 } from set
- #{ 20 20 } to set
-] extend "rect" set
-
-[ t ] [ #{ 5 5 } "rect" get inside? ] unit-test
-[ f ] [ #{ 5 50 } "rect" get inside? ] unit-test
-[ f ] [ #{ 30 5 } "rect" get inside? ] unit-test
-
-<rectangle> [
- #{ 10 15 } from set
- #{ 20 35 } to set
-] extend "another-rect" set
-
-"rect" get "another-rect" get 2list "scene" set
-
-[ t ] [ #{ 5 5 } "scene" get grab "rect" get eq? ] unit-test
-[ t ] [ #{ 19 30 } "scene" get grab "another-rect" get eq? ] unit-test
-[ f ] [ #{ 50 50 } "scene" get grab ] unit-test
+++ /dev/null
-! :sidekick.parser=none:
-
-IN: graphics
-
-USE: alien
-USE: combinators
-USE: errors
-USE: kernel
-USE: lists
-USE: logic
-USE: math
-USE: namespaces
-USE: sdl
-USE: stack
-USE: vectors
-USE: oop
-
-: black 0 0 0 255 rgba ;
-: white 255 255 255 255 rgba ;
-
-: clear-surface ( -- )
- #! Crappy
- surface get
- NULL
- surface get surface-format 255 255 255 SDL_MapRGB
- SDL_FillRect drop ;
-
-! These variables are set in shape objects.
-SYMBOL: from ( complex number, x/y )
-SYMBOL: to ( complex number, w/h )
-SYMBOL: filled?
-SYMBOL: color
-SYMBOL: string ( text objects only )
-
-! Draw an object.
-GENERIC: draw ( obj -- )
-
-! Return if the point is inside the object.
-GENERIC: inside? ( #{ x y } obj -- ? )
-
-! Scale factor for all rendering, can be set in object too
-SYMBOL: scale
-
-! Translation
-SYMBOL: origin
-
-: center ( -- #{ x y } )
- width get 2 / height get 2 / rect> ;
-
-: scene>screen ( #{ x y } -- #{ x y } )
- origin get - scale get * center + ;
-
-: screen>scene ( #{ x y } -- #{ x y } )
- center - scale get / origin get + ;
-
-: 2>irect >r >rect swap >fixnum swap >fixnum r> >rect swap >fixnum swap >fixnum ;
-
-: (rect) ( -- surface x y w h color )
- surface get
- from get scene>screen
- to get scene>screen
- 2>irect color get ;
-
-: in-rect? ( #{ x y } #{ x1 y1 } #{ x2 y2 } -- ? )
- #! Return if x/y is in the rectangle bounded by x1/y1, x2/y2
- 3dup
- rot real rot real rot real between? >r
- rot imaginary rot imaginary rot imaginary between? r> and ;
-
-TRAITS: rectangle
-M: rectangle draw ( -- )
- (rect) filled? get [
- boxColor
- ] [
- rectangleColor
- ] ifte ;M
-
-M: rectangle inside? ( #{ x y } -- ? )
- from get to get in-rect? ;M
-
-TRAITS: line
-M: line draw ( -- )
- (rect) lineColor ;M
-
-M: line inside? ( #{ x y } -- ? )
- from get to get in-rect? [
- t
- ] [
- f
- ] ifte ;M
-
-TRAITS: text
-M: text draw ( -- )
- surface get from get >rect color get string get
- stringColor ;M
-
-: grab ( #{ x y } list -- shape )
- #! Return shape containing x/y.
- dup [
- 2dup car inside? [ nip car ] [ cdr grab ] ifte
- ] [
- 2drop f
- ] ifte ;
+++ /dev/null
-IN: scratchpad
-USE: test
-USE: namespaces
-USE: oop
-USE: stack
-
-TRAITS: test-traits
-
-[ t ] [ <test-traits> test-traits? ] unit-test
-[ f ] [ "hello" test-traits? ] unit-test
-[ f ] [ <namespace> test-traits? ] unit-test
-
-GENERIC: foo
-
-M: test-traits foo 12 ;M
-
-TRAITS: another-test
-
-M: another-test foo 13 ;M
-
-[ 12 ] [ <test-traits> foo ] unit-test
-[ 13 ] [ <another-test> foo ] unit-test
+++ /dev/null
-! :sidekick.parser=none:
-IN: oop
-
-USE: combinators
-USE: errors
-USE: kernel
-USE: lists
-USE: namespaces
-USE: parser
-USE: stack
-USE: strings
-USE: words
-
-SYMBOL: traits
-
-: traits-map ( word -- hash )
- #! The method map word property maps selector words to
- #! definitions.
- "traits-map" word-property ;
-
-: object-map ( obj -- hash )
- dup has-namespace? [ traits swap get* ] [ drop f ] ifte ;
-
-: init-traits-map ( word -- )
- <namespace> "traits-map" set-word-property ;
-
-: no-method
- "No applicable method." throw ;
-
-: method ( traits selector -- quot )
- #! Execute the method with the traits object on the stack.
- over object-map get* [ [ no-method ] ] unless* ;
-
-: constructor-word ( word -- word )
- word-name "<" swap ">" cat3 "in" get create ;
-
-: define-constructor ( word -- )
- #! <foo> where foo is a traits type creates a new instance
- #! of foo.
- [ constructor-word [ <namespace> ] ] keep
- traits-map [ traits pick set* ] cons append
- define-compound ;
-
-: predicate-word ( word -- word )
- word-name "?" cat2 "in" get create ;
-
-: define-predicate ( word -- )
- #! foo? where foo is a traits type tests if the top of stack
- #! is of this type.
- dup predicate-word swap
- [ object-map ] swap traits-map [ eq? ] cons append
- define-compound ;
-
-: TRAITS:
- #! TRAITS: foo creates a new traits type. Instances can be
- #! created with <foo>, and tested with foo?.
- CREATE
- dup define-symbol
- dup init-traits-map
- dup define-constructor
- define-predicate ; parsing
-
-: GENERIC:
- #! GENERIC: bar creates a generic word bar that calls the
- #! bar method on the traits object, with the traits object
- #! on the namestack.
- CREATE
- dup unit [ car method bind ] cons
- define-compound ; parsing
-
-: M:
- #! M: foo bar begins a definition of the bar generic word
- #! specialized to the foo type.
- scan-word scan-word f ; parsing
-
-: ;M
- #! ;M ends a method definition.
- reverse transp traits-map set* ; parsing
+++ /dev/null
-! :sidekick.parser=none:
-
-IN: graphics
-
-USE: combinators
-USE: errors
-USE: kernel
-USE: lists
-USE: logic
-USE: math
-USE: namespaces
-USE: sdl
-USE: stack
-USE: vectors
-USE: stdio
-USE: prettyprint
-USE: inspector
-
-SYMBOL: scene
-SYMBOL: tool
-SYMBOL: current ( shape we're drawing right now )
-SYMBOL: moving? ( are we moving or resizing current shape? )
-SYMBOL: buttons ( mouse buttons down )
-SYMBOL: clicked ( mouse click location )
-
-: ch>tool ( ch -- quot )
- [
- [ CHAR: a ]
- [ CHAR: r <rectangle> ]
- [ CHAR: l <line> ]
- ] assoc ;
-
-: render ( -- )
- clear-surface
- scene get [ draw ] each
- current get [ draw ] when* ;
-
-: mouse-xy ( mouse-event -- #{ x y } )
- dup motion-event-x swap motion-event-y rect> ;
-
-: begin-draw ( #{ x y } -- )
- tool get call [
- dup from set to set
- black color set
- ] extend current set ;
-
-: begin-move ( #{ x y } -- )
- scene get grab
- [ dup scene remove@ current set moving? on ] when* ;
-
-: button-down ( event -- )
- button-event-button buttons unique@ ;
-
-: mouse-down-event ( event -- )
- dup button-down
- 1 buttons get contains? [
- mouse-xy screen>scene tool get [ begin-draw ] [ begin-move ] ifte
- ] [
- drop
- ] ifte ;
-
-: button-up ( event -- )
- button-event-button buttons remove@ ;
-
-: mouse-up-event ( event -- )
- button-up
- current get [
- scene cons@ current off moving? off
- ] when* ;
-
-: mouse-delta ( mouse-event -- #{ x y } )
- dup motion-event-xrel swap motion-event-yrel rect> ;
-
-: mouse-motion-event ( event -- )
- 2 buttons get contains? [
- mouse-delta scale get / origin -@
- ] [
- current get dup [
- [
- moving? get [
- mouse-delta scale get / dup from +@ to +@
- ] [
- mouse-xy screen>scene to set
- ] ifte
- ] bind
- ] [
- 2drop
- ] ifte
- ] ifte ;
-
-: key-down-event
- keyboard-event-sym [
- [ CHAR: - = ] [ drop 1.1 scale /@ ]
- [ CHAR: = = ] [ drop 1.1 scale *@ ]
- [ drop t ] [ ch>tool tool set ]
- ] cond ;
-
-: debug-event ( event -- ? )
- [
- [ event-type SDL_MOUSEBUTTONDOWN = ] [ mouse-down-event t ]
- [ event-type SDL_MOUSEBUTTONUP = ] [ mouse-up-event t ]
- [ event-type SDL_MOUSEMOTION = ] [ mouse-motion-event t ]
- [ event-type SDL_KEYDOWN = ] [ key-down-event t ]
- [ event-type SDL_QUIT = ] [ drop f ]
- [ drop t ] [ drop t ]
- ] cond ;
-
-: debug-event-loop ( event -- )
- dup SDL_WaitEvent 1 = [
- dup debug-event [
- [ render ] with-surface
- debug-event-loop
- ] [
- drop
- ] ifte
- ] [
- drop
- ] ifte ;
-
-: zui-test ( -- )
- 640 480 32 SDL_HWSURFACE SDL_SetVideoMode drop
- 1 scale set
- 0 origin set
- buttons off
- 640 width set
- 480 height set
-
- scene off
- [ <line> ] tool set
-
- <event> debug-event-loop
- SDL_Quit ;
-
-zui-test
: neg 0 swap - ; inline
: recip 1 swap / ; inline
+
+: rem ( x y -- x%y )
+ #! Like modulus, but always gives a positive result.
+ dup >r + r> mod ;
+
+: sgn ( n -- -1/0/1 )
+ #! Push the sign of a real number.
+ dup 0 = [ drop 0 ] [ 1 < -1 1 ? ] ifte ;
: -@ ( num var -- ) tuck get swap - put ;
: *@ ( num var -- ) tuck get * put ;
: /@ ( num var -- ) tuck get swap / put ;
+: mod@ ( num var -- ) tuck get swap mod put ;
+: rem@ ( num var -- ) tuck get swap rem put ;
: pred@ ( var -- ) dup get pred put ;
: succ@ ( var -- ) dup get succ put ;
compilable-words compilable-word-list set
+"Bootstrapping is complete." print
+"Now, you can run ./f factor.image" print
+
! Save a bit of space
global [ "stdio" off ] bind
: SDL_WaitEvent ( event -- )
"int" "sdl" "SDL_WaitEvent" [ "event*" ] alien-call ;
+
+: SDL_PollEvent ( event -- ? )
+ "bool" "sdl" "SDL_PollEvent" [ "event*" ] alien-call ;
SYMBOL: surface
SYMBOL: width
SYMBOL: height
+SYMBOL: bpp
+SYMBOL: surface
+
+: with-screen ( width height bpp flags quot -- )
+ #! Set up SDL graphics and call the quotation.
+ [
+ >r
+ >r 3dup bpp set height set width set r>
+ SDL_SetVideoMode surface set
+ r> call SDL_Quit
+ ] with-scope ;
: rgba ( r g b a -- n )
swap 8 shift bitor
swap 16 shift bitor
swap 24 shift bitor ;
+: black 0 0 0 255 rgba ;
+: white 255 255 255 255 rgba ;
+: red 255 0 0 255 rgba ;
+: green 0 255 0 255 rgba ;
+: blue 0 0 255 255 rgba ;
+
+: clear-surface ( color -- )
+ >r surface get 0 0 width get height get r> boxColor ;
+
: pixel-step ( quot #{ x y } -- )
tuck >r call >r surface get r> r> >rect rot pixelColor ;
: with-pixels ( w h quot -- )
-rot rect> [ over >r pixel-step r> ] 2times* drop ;
-: (surface) ( -- surface )
- SDL_GetVideoSurface
- dup surface set
- dup surface-w width set
- dup surface-h height set ;
-
: with-surface ( quot -- )
#! Execute a quotation, locking the current surface if it
#! is required (eg, hardware surface).
[
- (surface) dup must-lock-surface? [
+ surface get dup must-lock-surface? [
dup SDL_LockSurface slip dup SDL_UnlockSurface
] [
slip
- ] ifte SDL_Flip
+ ] ifte SDL_Flip drop
] with-scope ;
: event-loop ( event -- )
! UpdateRects, UpdateRect
: SDL_Flip ( surface -- )
- "void" "sdl" "SDL_Flip" [ "surface*" ] alien-call ;
+ "bool" "sdl" "SDL_Flip" [ "surface*" ] alien-call ;
! SDL_SetGamma: float types
: SDL_FillRect ( surface rect color -- n )
#! If rect is null, fills entire surface.
- "int" "sdl" "SDL_FillRect"
+ "bool" "sdl" "SDL_FillRect"
[ "surface*" "rect*" "uint" ] alien-call ;
: SDL_LockSurface ( surface -- )
- "int" "sdl" "SDL_LockSurface" [ "surface*" ] alien-call ;
+ "bool" "sdl" "SDL_LockSurface" [ "surface*" ] alien-call ;
: SDL_UnlockSurface ( surface -- )
"void" "sdl" "SDL_UnlockSurface" [ "surface*" ] alien-call ;
: SDL_MapRGB ( surface r g b -- )
"uint" "sdl" "SDL_MapRGB"
[ "surface*" "uchar" "uchar" "uchar" ] alien-call ;
+
+: SDL_WM_SetCaption ( title icon -- )
+ "void" "sdl" "SDL_WM_SetCaption"
+ [ "char*" "char*" ] alien-call ;
! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html
-: ack ( m n -- )
+: ack ( m n -- x )
over 0 = [
nip succ
] [
[ 6 ] [ 2 [ sq ] keep + ] unit-test
+[ [ ] 2keep ] unit-test-fails
+[ 1 [ ] 2keep ] unit-test-fails
+[ 3 1 2 ] [ 1 2 [ 2drop 3 ] 2keep ] unit-test
+
[ cond ] unit-test-fails
[ [ [ 1 = ] [ ] ] cond ] unit-test-fails
! f -vs- hitype
[ ] [ [ f vector-length ] [ drop ] catch ] unit-test
+
+! See how well callstack overflow is handled
+: callstack-overflow callstack-overflow f ;
+[ callstack-overflow ] unit-test-fails
USE: namespaces
USE: stack
USE: test
+USE: strings
[ [ ] ] [ [ ] [ ] append ] unit-test
[ [ 1 ] ] [ [ 1 ] [ ] append ] unit-test
[ 2 ] [ 5 "x" /@ "x" get ] unit-test
[ 1 ] [ "x" pred@ "x" get ] unit-test
[ 2 ] [ "x" succ@ "x" get ] unit-test
+[ 7 ] [ -3 "x" set 10 "x" rem@ ] unit-test
+[ -3 ] [ -3 "x" set 10 "x" rem@ ] unit-test
[ t ]
[ 1000000000000/999999999999 1000000000001/999999999998 < ]
unit-test
+
+[ -3 ] [ -3 10 mod ] unit-test
+[ 7 ] [ -3 10 rem ] unit-test
+
+[ -1 ] [ -12.55 sgn ] unit-test
+[ 1 ] [ 100000000000000000000000000000000 sgn ] unit-test
+[ 0 ] [ 0.0 sgn ] unit-test
USE: stack
USE: test
USE: vectors
+USE: strings
[ { } ] [ [ ] list>vector ] unit-test
[ { 1 2 } ] [ [ 1 2 ] list>vector ] unit-test
[ { 1 2 3 4 5 6 } ]
[ { 1 2 3 } vector-clone dup { 4 5 6 } vector-append ] unit-test
+[ { "" "a" "aa" "aaa" } ]
+[ 4 [ CHAR: a fill ] vector-project ]
+unit-test
+
[ { 6 8 10 12 } ]
[ { 1 2 3 4 } { 5 6 7 8 } [ + ] vector-2map ]
unit-test
#! Destructively append v2 to v1.
[ over vector-push ] vector-each drop ;
-: vector-collect ( n quot -- accum )
+: vector-project ( n quot -- accum )
#! Execute the quotation n times, passing the loop counter
- #! the quotation, and collect results in a new vector.
+ #! the quotation as it ranges from 0..n-1. Collect results
+ #! in a new vector.
over <vector> rot [
-rot 2dup >r >r slip vector-push r> r>
] times* nip ;
void primitive_numberp(void)
{
- CELL tagged = dpeek();
- drepl(tag_boolean(realp(tagged) || type_of(tagged) == COMPLEX_TYPE));
+ CELL tagged = dpop();
+ box_boolean(realp(tagged) || type_of(tagged) == COMPLEX_TYPE);
}
bool zerop(CELL tagged)
{
ARRAY* y = to_bignum(dpop());
ARRAY* x = to_bignum(dpop());
- dpush(tag_boolean(s48_bignum_equal_p(x,y)));
+ box_boolean(s48_bignum_equal_p(x,y));
}
#define GC_AND_POP_BIGNUMS(x,y) \
{
ARRAY* y = to_bignum(dpop());
ARRAY* x = to_bignum(dpop());
- dpush(tag_boolean(
- s48_bignum_compare(x,y)
- == bignum_comparison_less));
+ box_boolean(s48_bignum_compare(x,y) == bignum_comparison_less);
}
void primitive_bignum_lesseq(void)
{
ARRAY* y = to_bignum(dpop());
ARRAY* x = to_bignum(dpop());
- dpush(tag_boolean(
- s48_bignum_compare(x,y)
- == bignum_comparison_greater));
+ box_boolean(s48_bignum_compare(x,y) == bignum_comparison_greater);
}
void primitive_bignum_greatereq(void)
void throw_error(CELL error)
{
- /* dpush(error); */
- /* call(userenv[BREAK_ENV]); */
thrown_error = error;
/* Return to run() method */
#ifndef __FACTOR_H__
#define __FACTOR_H__
+#if defined(i386) || defined(__i386) || defined(__i386__)
+ #define FACTOR_X86
+#endif
+
+/* CELL must be 32 bits and your system must have 32-bit pointers */
+typedef unsigned long int CELL;
+#define CELLS ((signed)sizeof(CELL))
+
+/* raw pointer to datastack bottom */
+CELL ds_bot;
+
+/* raw pointer to datastack top */
+#ifdef FACTOR_X86
+register CELL ds asm("%esi");
+#else
+CELL ds;
+#endif
+
+/* raw pointer to callstack bottom */
+CELL cs_bot;
+
+/* raw pointer to callstack top */
+CELL cs;
+
#include <dirent.h>
#include <errno.h>
#include <fcntl.h>
#include <dlfcn.h>
#endif /* FFI */
-#if defined(i386) || defined(__i386) || defined(__i386__)
- #define FACTOR_X86
-#endif
-
#define INLINE inline static
-/* CELL must be 32 bits and your system must have 32-bit pointers */
-typedef unsigned long int CELL;
-#define CELLS ((signed)sizeof(CELL))
-
#define FIXNUM_MAX (LONG_MAX >> TAG_BITS)
#define FIXNUM_MIN (LONG_MIN >> TAG_BITS)
#include "error.h"
#include "gc.h"
#include "types.h"
+#include "boolean.h"
#include "word.h"
#include "run.h"
#include "signal.h"
void primitive_open_file(void)
{
- bool write = untag_boolean(dpop());
- bool read = untag_boolean(dpop());
+ bool write = unbox_boolean();
+ bool read = unbox_boolean();
char* path;
int mode, fd;
{
FIXNUM y = to_fixnum(dpop());
FIXNUM x = to_fixnum(dpop());
- dpush(tag_boolean(x == y));
+ box_boolean(x == y);
}
void primitive_fixnum_add(void)
{
FIXNUM y = to_fixnum(dpop());
FIXNUM x = to_fixnum(dpop());
- dpush(tag_boolean(x < y));
+ box_boolean(x < y);
}
void primitive_fixnum_lesseq(void)
{
FIXNUM y = to_fixnum(dpop());
FIXNUM x = to_fixnum(dpop());
- dpush(tag_boolean(x <= y));
+ box_boolean(x <= y);
}
void primitive_fixnum_greater(void)
{
FIXNUM y = to_fixnum(dpop());
FIXNUM x = to_fixnum(dpop());
- dpush(tag_boolean(x > y));
+ box_boolean(x > y);
}
void primitive_fixnum_greatereq(void)
{
FIXNUM y = to_fixnum(dpop());
FIXNUM x = to_fixnum(dpop());
- dpush(tag_boolean(x >= y));
+ box_boolean(x >= y);
}
void primitive_fixnum_not(void)
void primitive_float_eq(void)
{
GC_AND_POP_FLOATS(x,y);
- dpush(tag_boolean(x == y));
+ box_boolean(x == y);
}
void primitive_float_add(void)
void primitive_float_less(void)
{
- double y = to_float(dpop());
- double x = to_float(dpop());
- dpush(tag_boolean(x < y));
+ GC_AND_POP_FLOATS(x,y);
+ box_boolean(x < y);
}
void primitive_float_lesseq(void)
{
- double y = to_float(dpop());
- double x = to_float(dpop());
- dpush(tag_boolean(x <= y));
+ GC_AND_POP_FLOATS(x,y);
+ box_boolean(x <= y);
}
void primitive_float_greater(void)
{
- double y = to_float(dpop());
- double x = to_float(dpop());
- dpush(tag_boolean(x > y));
+ GC_AND_POP_FLOATS(x,y);
+ box_boolean(x > y);
}
void primitive_float_greatereq(void)
{
- double y = to_float(dpop());
- double x = to_float(dpop());
- dpush(tag_boolean(x >= y));
+ GC_AND_POP_FLOATS(x,y);
+ box_boolean(x >= y);
}
void primitive_facos(void)
void primitive_eq(void)
{
- dpush(tag_boolean(dpop() == dpop()));
+ box_boolean(dpop() == dpop());
}
void primitive_millis(void)
void primitive_can_read_line(void)
{
PORT* port = untag_port(dpop());
- dpush(tag_boolean(can_read_line(port)));
+ box_boolean(can_read_line(port));
}
void primitive_add_read_line_io_task(void)
port = untag_port(dpop());
len = to_fixnum(dpop());
- dpush(tag_boolean(can_read_count(port,len)));
+ box_boolean(can_read_count(port,len));
}
void primitive_add_read_count_io_task(void)
sigsetjmp(toplevel, 1);
if(thrown_error != F)
{
+ fix_stacks();
dpush(thrown_error);
/* Notify any 'catch' blocks */
call(userenv[BREAK_ENV]);
/* TAGGED currently executing quotation */
CELL callframe;
-/* raw pointer to datastack bottom */
-CELL ds_bot;
-
-/* raw pointer to datastack top */
-#ifdef FACTOR_X86
-register CELL ds asm("%esi");
-#else
-CELL ds;
-#endif
-
-/* raw pointer to callstack bottom */
-CELL cs_bot;
-
-/* raw pointer to callstack top */
-CELL cs;
-
/* raw pointer to currently executing word */
WORD* executing;
void memory_signal_handler(int signal, siginfo_t* siginfo, void* uap)
{
- if(STACK_UNDERFLOW(ds,ds_bot))
- {
- reset_datastack();
- general_error(ERROR_DATASTACK_UNDERFLOW,F);
- }
- else if(STACK_OVERFLOW(ds,ds_bot))
- {
- reset_datastack();
- general_error(ERROR_DATASTACK_OVERFLOW,F);
- }
- else if(STACK_UNDERFLOW(cs,cs_bot))
- {
- reset_callstack();
- general_error(ERROR_CALLSTACK_UNDERFLOW,F);
- }
- else if(STACK_OVERFLOW(cs,cs_bot))
- {
- reset_callstack();
- general_error(ERROR_CALLSTACK_OVERFLOW,F);
- }
- else if(active.here > active.limit)
+ fprintf(stderr,"memory signal\n");
+ if(active.here > active.limit)
{
fprintf(stderr,"Out of memory\n");
fprintf(stderr,"active.base = %ld\n",active.base);
cs = cs_bot - CELLS;
}
+void fix_stacks(void)
+{
+ if(STACK_UNDERFLOW(ds,ds_bot))
+ reset_datastack();
+ else if(STACK_OVERFLOW(ds,ds_bot))
+ reset_datastack();
+ else if(STACK_UNDERFLOW(cs,cs_bot))
+ reset_callstack();
+ else if(STACK_OVERFLOW(cs,cs_bot))
+ reset_callstack();
+}
+
void init_stacks(void)
{
ds_bot = (CELL)alloc_guarded(STACK_SIZE);
void reset_datastack(void);
void reset_callstack(void);
+void fix_stacks(void);
void init_stacks(void);
void primitive_drop(void);
CELL type_of(CELL tagged);
bool typep(CELL type, CELL tagged);
-INLINE CELL tag_boolean(CELL untagged)
-{
- return (untagged == false ? F : T);
-}
-
-INLINE bool untag_boolean(CELL tagged)
-{
- return (tagged == F ? false : true);
-}
-
INLINE CELL tag_header(CELL cell)
{
return RETAG(cell << TAG_BITS,HEADER_TYPE);
void primitive_word_compiledp(void)
{
- WORD* word = untag_word(dpeek());
- /* is it bad to hardcode this? */
- drepl(tag_boolean(word->xt != (CELL)docol
- && word->xt != (CELL)dosym));
+ WORD* word = untag_word(dpop());
+ box_boolean(word->xt != (CELL)docol && word->xt != (CELL)dosym);
}
void fixup_word(WORD* word)
port = untag_port(dpop());
len = to_fixnum(dpop());
pending_io_error(port);
- dpush(tag_boolean(can_write(port,len)));
+ box_boolean(can_write(port,len));
}
void primitive_add_write_io_task(void)
projects / factor.git / commitdiff