From 466f42e156ea9ef985ef7ea3f13781f6bc08654f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Nov 2005 00:14:35 +0000 Subject: [PATCH 001/373] fix some problems --- CHANGES.html | 1 + contrib/httpd/html-tags.factor | 2 +- library/syntax/prettyprint.factor | 7 +++++-- version.factor | 2 +- 4 files changed, 8 insertions(+), 4 deletions(-) diff --git a/CHANGES.html b/CHANGES.html index 3e212f0a04..701eb918b9 100644 --- a/CHANGES.html +++ b/CHANGES.html @@ -109,6 +109,7 @@ However, most uses of catch can be replaced by cleanup
  • Advanced math library with quaternions, matrices, polynomials, statistics and various functions in contrib/math/. (Doug Coleman)
  • Dimensioned units in contrib/units/. (Doug Coleman)
    • +
  • X11 binding in contrib/x11/ (Eduardo Cavazos)
    • diff --git a/contrib/httpd/html-tags.factor b/contrib/httpd/html-tags.factor index 4799188081..c7d1bffd2b 100644 --- a/contrib/httpd/html-tags.factor +++ b/contrib/httpd/html-tags.factor @@ -24,7 +24,7 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: html -USING: prettyprint ; +USE: prettyprint USE: strings USE: lists USE: kernel diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 45298aa5c2..ec8182e286 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -346,12 +346,15 @@ M: wrapper pprint* ( wrapper -- ) : .o >oct print ; : .h >hex print ; +: define-open t "pprint-open" set-word-prop ; +: define-close t "pprint-close" set-word-prop ; + { POSTPONE: [ POSTPONE: [[ POSTPONE: { POSTPONE: V{ POSTPONE: H{ POSTPONE: T{ POSTPONE: W{ -} [ t "pprint-open" set-word-prop ] each +} [ define-open ] each { POSTPONE: ] POSTPONE: } POSTPONE: ]] -} [ t "pprint-close" set-word-prop ] each +} [ define-close ] each diff --git a/version.factor b/version.factor index 01539fe5c7..b3dbef5364 100644 --- a/version.factor +++ b/version.factor @@ -1,2 +1,2 @@ IN: kernel -: version "0.79" ; +: version "0.80" ; From 8a834768f8d0d8631d9001e5a77e00104b597f8c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 7 Nov 2005 00:32:59 +0000 Subject: [PATCH 002/373] Removed "IN: dimensions" --- contrib/math/load.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/contrib/math/load.factor b/contrib/math/load.factor index d5297cec15..ef50d5d7ba 100644 --- a/contrib/math/load.factor +++ b/contrib/math/load.factor @@ -1,4 +1,3 @@ -IN: dimensions USING: parser sequences words compiler ; [ "contrib/math/utils.factor" From 6e4c994a4e6fd3fa202287b9e99de1e47c673c2f Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 7 Nov 2005 14:27:59 +0000 Subject: [PATCH 003/373] Added my version of x11 bindings, with nehe lesson2 demo --- contrib/x11/x11-wrunt/README.txt | 20 + contrib/x11/x11-wrunt/glx.factor | 84 +++ contrib/x11/x11-wrunt/keysymdef.factor | 69 +++ contrib/x11/x11-wrunt/lesson2.factor | 170 ++++++ contrib/x11/x11-wrunt/load.factor | 9 + contrib/x11/x11-wrunt/x-events.factor | 40 ++ contrib/x11/x11-wrunt/x.factor | 597 ++++++++++++++++++++++ contrib/x11/x11-wrunt/xlib.factor | 682 +++++++++++++++++++++++++ contrib/x11/x11-wrunt/xutil.factor | 58 +++ 9 files changed, 1729 insertions(+) create mode 100644 contrib/x11/x11-wrunt/README.txt create mode 100644 contrib/x11/x11-wrunt/glx.factor create mode 100644 contrib/x11/x11-wrunt/keysymdef.factor create mode 100644 contrib/x11/x11-wrunt/lesson2.factor create mode 100644 contrib/x11/x11-wrunt/load.factor create mode 100644 contrib/x11/x11-wrunt/x-events.factor create mode 100644 contrib/x11/x11-wrunt/x.factor create mode 100644 contrib/x11/x11-wrunt/xlib.factor create mode 100644 contrib/x11/x11-wrunt/xutil.factor diff --git a/contrib/x11/x11-wrunt/README.txt b/contrib/x11/x11-wrunt/README.txt new file mode 100644 index 0000000000..94ee7ce6e1 --- /dev/null +++ b/contrib/x11/x11-wrunt/README.txt @@ -0,0 +1,20 @@ +Most of these files take their content from corresponding C files: +x.factor -- X.h +xlib.factor -- Xlib.h +xutil.factor -- Xutil.h +glx.factor -- glx.h and glxtokens.h +keysymdef.factor -- keysymdef.h + +x-events.factor defines x-event predicates (see lesson2.factor for usage) + +Not all of these are complete, but they are complete to run lesson 2 of the +nehe opengl tutorials (and the other tutorials with small changes). To see a +demo run from factor's root dir: + "contrib/x11/x11-wrunt/load.factor" run-file + ( then wait for everything to compile... ) + USE: nehe + main + +Pressing 'q' or esc, or clicking the mouse will exit. If something goes wrong +you can kill off the window with: + current-window get kill-gl-window diff --git a/contrib/x11/x11-wrunt/glx.factor b/contrib/x11/x11-wrunt/glx.factor new file mode 100644 index 0000000000..9c6f3be4db --- /dev/null +++ b/contrib/x11/x11-wrunt/glx.factor @@ -0,0 +1,84 @@ +#! based on glx.h from xfree86, and some of glxtokens.h +IN: x11 +USING: alien ; + +LIBRARY: gl + +! Visual Config Attributes (glXGetConfig, glXGetFBConfigAttrib) +: GLX_USE_GL 1 ; ! support GLX rendering +: GLX_BUFFER_SIZE 2 ; ! depth of the color buffer +: GLX_LEVEL 3 ; ! level in plane stacking +: GLX_RGBA 4 ; ! true if RGBA mode +: GLX_DOUBLEBUFFER 5 ; ! double buffering supported +: GLX_STEREO 6 ; ! stereo buffering supported +: GLX_AUX_BUFFERS 7 ; ! number of aux buffers +: GLX_RED_SIZE 8 ; ! number of red component bits +: GLX_GREEN_SIZE 9 ; ! number of green component bits +: GLX_BLUE_SIZE 10 ; ! number of blue component bits +: GLX_ALPHA_SIZE 11 ; ! number of alpha component bits +: GLX_DEPTH_SIZE 12 ; ! number of depth bits +: GLX_STENCIL_SIZE 13 ; ! number of stencil bits +: GLX_ACCUM_RED_SIZE 14 ; ! number of red accum bits +: GLX_ACCUM_GREEN_SIZE 15 ; ! number of green accum bits +: GLX_ACCUM_BLUE_SIZE 16 ; ! number of blue accum bits +: GLX_ACCUM_ALPHA_SIZE 17 ; ! number of alpha accum bits + +TYPEDEF: XID GLXContextID +TYPEDEF: XID GLXPixmap +TYPEDEF: XID GLXDrawable +TYPEDEF: XID GLXPbuffer +TYPEDEF: XID GLXWindow +TYPEDEF: XID GLXFBConfigID +TYPEDEF: void* GLXContext ! typedef struct __GLXcontextRec *GLXContext; +TYPEDEF: void* GLXFBConfig ! typedef struct __GLXFBConfigRec *GLXFBConfig; + +FUNCTION: XVisualInfo* glXChooseVisual ( Display* dpy, int screen, int* attribList ) ; +FUNCTION: void glXCopyContext ( Display* dpy, GLXContext src, GLXContext dst, ulong mask ) ; +FUNCTION: GLXContext glXCreateContext ( Display* dpy, XVisualInfo* vis, GLXContext shareList, bool direct ) ; +FUNCTION: GLXPixmap glXCreateGLXPixmap ( Display* dpy, XVisualInfo* vis, Pixmap pixmap ) ; +FUNCTION: void glXDestroyContext ( Display* dpy, GLXContext ctx ) ; +FUNCTION: void glXDestroyGLXPixmap ( Display* dpy, GLXPixmap pix ) ; +FUNCTION: int glXGetConfig ( Display* dpy, XVisualInfo* vis, int attrib, int* value) ; +FUNCTION: GLXContext glXGetCurrentContext ( ) ; +FUNCTION: GLXDrawable glXGetCurrentDrawable ( ) ; +FUNCTION: bool glXIsDirect ( Display* dpy, GLXContext ctx ) ; +FUNCTION: bool glXMakeCurrent ( Display* dpy, GLXDrawable drawable, GLXContext ctx ) ; +FUNCTION: bool glXQueryExtension ( Display* dpy, int* errorBase, int* eventBase ) ; +FUNCTION: bool glXQueryVersion ( Display* dpy, int* major, int* minor ) ; +FUNCTION: void glXSwapBuffers ( Display* dpy, GLXDrawable drawable ) ; +FUNCTION: void glXUseXFont ( Font font, int first, int count, int listBase ) ; +FUNCTION: void glXWaitGL ( ) ; +FUNCTION: void glXWaitX ( ) ; +FUNCTION: char* glXGetClientString ( Display* dpy, int name ) ; +FUNCTION: char* glXQueryServerString ( Display* dpy, int screen, int name ) ; +FUNCTION: char* glXQueryExtensionsString ( Display* dpy, int screen ) ; + +! New for GLX 1.3 +FUNCTION: GLXFBConfig* glXGetFBConfigs ( Display* dpy, int screen, int* nelements ) ; +FUNCTION: GLXFBConfig* glXChooseFBConfig ( Display* dpy, int screen, int* attrib_list, int* nelements ) ; +FUNCTION: int glXGetFBConfigAttrib ( Display* dpy, GLXFBConfig config, int attribute, int* value ) ; +FUNCTION: XVisualInfo* glXGetVisualFromFBConfig ( Display* dpy, GLXFBConfig config ) ; +FUNCTION: GLXWindow glXCreateWindow ( Display* dpy, GLXFBConfig config, Window win, int* attrib_list ) ; +FUNCTION: void glXDestroyWindow ( Display* dpy, GLXWindow win ) ; +FUNCTION: GLXPixmap glXCreatePixmap ( Display* dpy, GLXFBConfig config, Pixmap pixmap, int* attrib_list ) ; +FUNCTION: void glXDestroyPixmap ( Display* dpy, GLXPixmap pixmap ) ; +FUNCTION: GLXPbuffer glXCreatePbuffer ( Display* dpy, GLXFBConfig config, int* attrib_list ) ; +FUNCTION: void glXDestroyPbuffer ( Display* dpy, GLXPbuffer pbuf ) ; +FUNCTION: void glXQueryDrawable ( Display* dpy, GLXDrawable draw, int attribute, uint* value ) ; +FUNCTION: GLXContext glXCreateNewContext ( Display* dpy, GLXFBConfig config, int render_type, GLXContext share_list, bool direct ) ; +FUNCTION: bool glXMakeContextCurrent ( Display* display, GLXDrawable draw, GLXDrawable read, GLXContext ctx ) ; +FUNCTION: GLXDrawable glXGetCurrentReadDrawable ( ) ; +FUNCTION: Display* glXGetCurrentDisplay ( ) ; +FUNCTION: int glXQueryContext ( Display* dpy, GLXContext ctx, int attribute, int* value ) ; +FUNCTION: void glXSelectEvent ( Display* dpy, GLXDrawable draw, ulong event_mask ) ; +FUNCTION: void glXGetSelectedEvent ( Display* dpy, GLXDrawable draw, ulong* event_mask ) ; + +! GLX 1.4 and later +! extern void (*glXGetProcAddress(const GLubyte* procname))(void ) ; + +! glxext stuff skipped + + +! GLX Events +! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks + diff --git a/contrib/x11/x11-wrunt/keysymdef.factor b/contrib/x11/x11-wrunt/keysymdef.factor new file mode 100644 index 0000000000..a93fbf40b5 --- /dev/null +++ b/contrib/x11/x11-wrunt/keysymdef.factor @@ -0,0 +1,69 @@ +! remarkably similar to parts of keysymdef.h +IN: x11 + +: XK_BackSpace HEX: FF08 ; ! back space, back char +: XK_Tab HEX: FF09 ; +: XK_Linefeed HEX: FF0A ; ! Linefeed, LF +: XK_Clear HEX: FF0B ; +: XK_Return HEX: FF0D ; ! Return, enter +: XK_Pause HEX: FF13 ; ! Pause, hold +: XK_Scroll_Lock HEX: FF14 ; +: XK_Sys_Req HEX: FF15 ; +: XK_Escape HEX: FF1B ; +: XK_Delete HEX: FFFF ; ! Delete, rubout + +! Cursor control & motion + +: XK_Home HEX: FF50 ; +: XK_Left HEX: FF51 ; ! Move left, left arrow +: XK_Up HEX: FF52 ; ! Move up, up arrow +: XK_Right HEX: FF53 ; ! Move right, right arrow +: XK_Down HEX: FF54 ; ! Move down, down arrow +: XK_Prior HEX: FF55 ; ! Prior, previous +: XK_Page_Up HEX: FF55 ; +: XK_Next HEX: FF56 ; ! Next +: XK_Page_Down HEX: FF56 ; +: XK_End HEX: FF57 ; ! EOL +: XK_Begin HEX: FF58 ; ! BOL + +! Keypad Functions, keypad numbers cleverly chosen to map to ascii + +: XK_KP_Space HEX: FF80 ; ! space +: XK_KP_Tab HEX: FF89 ; +: XK_KP_Enter HEX: FF8D ; ! enter +: XK_KP_F1 HEX: FF91 ; ! PF1, KP_A, ... +: XK_KP_F2 HEX: FF92 ; +: XK_KP_F3 HEX: FF93 ; +: XK_KP_F4 HEX: FF94 ; +: XK_KP_Home HEX: FF95 ; +: XK_KP_Left HEX: FF96 ; +: XK_KP_Up HEX: FF97 ; +: XK_KP_Right HEX: FF98 ; +: XK_KP_Down HEX: FF99 ; +: XK_KP_Prior HEX: FF9A ; +: XK_KP_Page_Up HEX: FF9A ; +: XK_KP_Next HEX: FF9B ; +: XK_KP_Page_Down HEX: FF9B ; +: XK_KP_End HEX: FF9C ; +: XK_KP_Begin HEX: FF9D ; +: XK_KP_Insert HEX: FF9E ; +: XK_KP_Delete HEX: FF9F ; +: XK_KP_Equal HEX: FFBD ; ! equals +: XK_KP_Multiply HEX: FFAA ; +: XK_KP_Add HEX: FFAB ; +: XK_KP_Separator HEX: FFAC ; ! separator, often comma +: XK_KP_Subtract HEX: FFAD ; +: XK_KP_Decimal HEX: FFAE ; +: XK_KP_Divide HEX: FFAF ; + +: XK_KP_0 HEX: FFB0 ; +: XK_KP_1 HEX: FFB1 ; +: XK_KP_2 HEX: FFB2 ; +: XK_KP_3 HEX: FFB3 ; +: XK_KP_4 HEX: FFB4 ; +: XK_KP_5 HEX: FFB5 ; +: XK_KP_6 HEX: FFB6 ; +: XK_KP_7 HEX: FFB7 ; +: XK_KP_8 HEX: FFB8 ; +: XK_KP_9 HEX: FFB9 ; + diff --git a/contrib/x11/x11-wrunt/lesson2.factor b/contrib/x11/x11-wrunt/lesson2.factor new file mode 100644 index 0000000000..a738949573 --- /dev/null +++ b/contrib/x11/x11-wrunt/lesson2.factor @@ -0,0 +1,170 @@ +IN: nehe +USING: opengl x11 syntax kernel sequences alien namespaces math threads generic io prettyprint ; + +TUPLE: gl-window dpy screen win ctx x y width height depth ; +SYMBOL: current-window + +SYMBOL: dpy +SYMBOL: screen +SYMBOL: root +SYMBOL: win +SYMBOL: ctx +SYMBOL: title +SYMBOL: vi +SYMBOL: x +SYMBOL: y +SYMBOL: width +SYMBOL: height + +: >int-array ( seq -- int-array ) + dup length dup -rot [ + pick set-int-nth + ] 2each ; + +: attr-list ( -- c-array ) + [ + GLX_RGBA , GLX_DOUBLEBUFFER , + GLX_RED_SIZE , 4 , + GLX_GREEN_SIZE , 4 , + GLX_BLUE_SIZE , 4 , + GLX_DEPTH_SIZE , 16 , + None , + ] f make >int-array ; + +: resize-gl-scene ( glwin -- ) + 0 0 rot [ gl-window-width ] keep [ gl-window-height ] keep >r glViewport + GL_PROJECTION glMatrixMode + glLoadIdentity + 45 r> [ gl-window-width ] keep gl-window-height / 0.1 100 gluPerspective + GL_MODELVIEW glMatrixMode ; + +: gl-init ( glwin -- ) + GL_SMOOTH glShadeModel + 0 0 0 0 glClearColor + 1 glClearDepth + GL_DEPTH_TEST glEnable + GL_LEQUAL glDepthFunc + GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint + resize-gl-scene + glFlush ; + +: normal-XSetWindowAttributes ( cmap -- valuemask attr ) + [ + set-XSetWindowAttributes-colormap + ] keep + ExposureMask KeyPressMask bitor ButtonPressMask bitor StructureNotifyMask bitor + over set-XSetWindowAttributes-event_mask +! dup 1 swap set-XSetWindowAttributes-border_pixel + CWColormap CWEventMask bitor swap ; +! CWBorderPixel CWColormap bitor CWEventMask bitor swap ; + +: make-display ( display-num -- display ) + XOpenDisplay dup dpy set ; + +: make-screen ( display -- screen ) + XDefaultScreen dup screen set ; + +: make-vi ( display screen -- vi ) + attr-list glXChooseVisual dup vi set ; + +: make-ctx ( display vi -- ) + 0 GL_TRUE glXCreateContext ctx set ; + +: make-colormap ( -- cmap ) + dpy get vi get 2dup XVisualInfo-screen XRootWindow dup root set + swap XVisualInfo-visual AllocNone XCreateColormap ; + +: make-win ( valuemask attr -- win ) + >r >r dpy get root get x get y get width get height get 0 vi get + dup XVisualInfo-depth InputOutput rot XVisualInfo-visual r> r> XCreateWindow dup win set ; + +: make-gl-window ( display-num x y width height depth title -- glwin ) + [ + title set depth set height set width set y set x set + make-display dup dup make-screen make-vi make-ctx + make-colormap normal-XSetWindowAttributes make-win + dpy get swap 2dup over "WM_DELETE_WINDOW" t XInternAtom 1 XSetWMProtocols drop + 2dup title get dup None 0 0 over XSetStandardProperties drop + 2dup XMapRaised drop + 2dup ctx get glXMakeCurrent 2drop + screen get win get ctx get x get y get width get height get depth get + dup gl-init + dup global [ current-window set ] bind + ] with-scope ; + +: draw-gl-scene ( -- ) + GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear + glLoadIdentity + -1.5 0 -6 glTranslatef + GL_TRIANGLES [ + 0 1 0 glVertex3f + -1 -1 0 glVertex3f + 1 -1 0 glVertex3f + ] do-state + 3 0 0 glTranslatef + GL_QUADS [ + -1 1 1 glVertex3f + 1 1 0 glVertex3f + 1 -1 0 glVertex3f + -1 -1 0 glVertex3f + ] do-state + current-window get dup gl-window-dpy swap gl-window-win glXSwapBuffers ; + +: kill-gl-window ( glwin -- ) + dup gl-window-ctx [ + over gl-window-dpy dup None 0 glXMakeCurrent drop + swap glXDestroyContext + 0 over set-gl-window-ctx + ] when* + gl-window-dpy XCloseDisplay ; + +GENERIC: (handle-event) ( glwin xevent -- continue? ) + +M: x-expose-event (handle-event) + nip XExposeEvent-count 0 = [ draw-gl-scene ] when t ; + +M: x-configure-notify-event (handle-event) + #! resize if the width or height has changed + [ XConfigureEvent-width swap gl-window-width = ] 2keep + [ XConfigureEvent-height swap gl-window-height = and ] 2keep rot [ + 2drop + ] [ + [ XConfigureEvent-width swap set-gl-window-width ] 2keep + [ XConfigureEvent-height swap set-gl-window-height ] 2keep + drop resize-gl-scene + ] if t ; + +M: x-button-press-event (handle-event) + #! quit if a mouse button is pressed + 2drop f ; + +PREDICATE: x-key-press-event quit-key-event +! 0 XLookupKeysym XK_Escape = ; + 0 XLookupKeysym dup CHAR: q = swap XK_Escape = or ; + +M: quit-key-event (handle-event) + 2drop f ; + +M: x-client-message-event (handle-event) + swap gl-window-dpy swap XClientMessageEvent-message_type XGetAtomName + "WM_PROTOCOLS" = not ; + +M: object (handle-event) + #! unknown event, ignore and continue + 2drop t ; + +: handle-event ( glwin -- continue? ) + ! TODO: don't create a new XEvent object each time (but don't use a global) + dup gl-window-dpy tuck XNextEvent drop (handle-event) ; + +: (loop) ( glwin -- continue? ) + dup gl-window-dpy XPending 0 > [ + dup handle-event [ (loop) ] [ drop f ] if + ] [ drop t ] if ; + +: loop ( glwin -- ) + dup (loop) [ draw-gl-scene loop ] [ drop ] if ; + +: main ( -- ) + ":0.0" 10 10 640 480 16 "NeHe Lesson 2" make-gl-window + dup loop kill-gl-window ; diff --git a/contrib/x11/x11-wrunt/load.factor b/contrib/x11/x11-wrunt/load.factor new file mode 100644 index 0000000000..a7b22c3b7d --- /dev/null +++ b/contrib/x11/x11-wrunt/load.factor @@ -0,0 +1,9 @@ +USING: kernel alien parser sequences words compiler ; + +"X11" "libX11.so" "cdecl" add-library + +[ "x.factor" "xlib.factor" "xutil.factor" "keysymdef.factor" "x-events.factor" + "glx.factor" "lesson2.factor" ] [ "contrib/x11/x11-wrunt/" swap append run-file ] each + +"x11" words [ try-compile ] each + diff --git a/contrib/x11/x11-wrunt/x-events.factor b/contrib/x11/x11-wrunt/x-events.factor new file mode 100644 index 0000000000..3286c79e58 --- /dev/null +++ b/contrib/x11/x11-wrunt/x-events.factor @@ -0,0 +1,40 @@ +IN: x11 +USING: alien kernel sequences namespaces strings syntax math generic parser ; + +: x-event-type + #! XEvent is a union of the various X*Event structs. All of them have + #! 'int type' as their first field. + 0 alien-signed-4 ; + +PREDICATE: integer upper + dup CHAR: A >= swap CHAR: Z <= and ; + +: uncapitalise ( "Capitalised" | "capitalised" -- "capitalised" ) + dup first ch>lower swap >sbuf 0 swap [ set-nth ] keep >string ; + +GENERIC: (camel>dashed) +M: upper (camel>dashed) ( CHAR: X -- ) + CHAR: - , ch>lower , ; +M: object (camel>dashed) ( CHAR: x -- ) , ; + +: camel>dashed ( "SomeName" -- "some-name" ) + uncapitalise [ [ (camel>dashed) ] each ] "" make ; + +: x-event-predicate ( EventName -- ) + #! creates a predicate for x-event-name-event + #! EventName should be a valid XEvent.type (defined in x.factor) + #! note: c structs are represented as byte-arrays in factor + [ "IN: x11 PREDICATE: byte-array x-" % dup camel>dashed % "-event x-event-type " % + % " = ;" % ] "" make eval ; + +[ + "KeyPress" "KeyRelease" "ButtonPress" "ButtonRelease" "MotionNotify" + "EnterNotify" "LeaveNotify" "FocusIn" "FocusOut" "KeymapNotify" + "Expose" "GraphicsExpose" "NoExpose" "VisibilityNotify" "CreateNotify" + "DestroyNotify" "UnmapNotify" "MapNotify" "MapRequest" "ReparentNotify" + "ConfigureNotify" "ConfigureRequest" "GravityNotify" "ResizeRequest" + "CirculateNotify" "CirculateRequest" "PropertyNotify" "SelectionClear" + "SelectionRequest" "SelectionNotify" "ColormapNotify" "ClientMessage" + "MappingNotify" +] [ x-event-predicate ] each + diff --git a/contrib/x11/x11-wrunt/x.factor b/contrib/x11/x11-wrunt/x.factor new file mode 100644 index 0000000000..6d9ce5e2d0 --- /dev/null +++ b/contrib/x11/x11-wrunt/x.factor @@ -0,0 +1,597 @@ +! Based on X.h +IN: x11 +USING: alien math ; + +TYPEDEF: ulong XID +TYPEDEF: ulong Mask +TYPEDEF: ulong Atom +TYPEDEF: ulong VisualID +TYPEDEF: ulong Time +TYPEDEF: ulong VisualID +TYPEDEF: XID Window +TYPEDEF: XID Drawable +TYPEDEF: XID Font +TYPEDEF: XID Pixmap +TYPEDEF: XID Cursor +TYPEDEF: XID Colormap +TYPEDEF: XID GContext +TYPEDEF: XID KeySym +TYPEDEF: uchar KeyCode + +! Reserved Resource and Constant Definitions +: None 0 ; +: ParentRelative 1 ; +: CopyFromParent 0 ; +: PointerWindow 0 ; +: InputFocus 1 ; +: PointerRoot 1 ; +: AnyPropertyType 0 ; +: AnyKey 0 ; +: AnyButton 0 ; +: AllTemporary 0 ; +: CurrentTime 0 ; +: NoSymbol 0 ; + +! Event Definitions +: NoEventMask 0 ; +: KeyPressMask 1 0 shift ; +: KeyReleaseMask 1 1 shift ; +: ButtonPressMask 1 2 shift ; +: ButtonReleaseMask 1 3 shift ; +: EnterWindowMask 1 4 shift ; +: LeaveWindowMask 1 5 shift ; +: PointerMotionMask 1 6 shift ; +: PointerMotionHintMask 1 7 shift ; +: Button1MotionMask 1 8 shift ; +: Button2MotionMask 1 9 shift ; +: Button3MotionMask 1 10 shift ; +: Button4MotionMask 1 11 shift ; +: Button5MotionMask 1 12 shift ; +: ButtonMotionMask 1 13 shift ; +: KeymapStateMask 1 14 shift ; +: ExposureMask 1 15 shift ; +: VisibilityChangeMask 1 16 shift ; +: StructureNotifyMask 1 17 shift ; +: ResizeRedirectMask 1 18 shift ; +: SubstructureNotifyMask 1 19 shift ; +: SubstructureRedirectMask 1 20 shift ; +: FocusChangeMask 1 21 shift ; +: PropertyChangeMask 1 22 shift ; +: ColormapChangeMask 1 23 shift ; +: OwnerGrabButtonMask 1 24 shift ; + +! Event names. Used in "type" field in XEvent structures. Not to be +! confused with event masks above. They start from 2 because 0 and 1 +! are reserved in the protocol for errors and replies. +: KeyPress 2 ; +: KeyRelease 3 ; +: ButtonPress 4 ; +: ButtonRelease 5 ; +: MotionNotify 6 ; +: EnterNotify 7 ; +: LeaveNotify 8 ; +: FocusIn 9 ; +: FocusOut 10 ; +: KeymapNotify 11 ; +: Expose 12 ; +: GraphicsExpose 13 ; +: NoExpose 14 ; +: VisibilityNotify 15 ; +: CreateNotify 16 ; +: DestroyNotify 17 ; +: UnmapNotify 18 ; +: MapNotify 19 ; +: MapRequest 20 ; +: ReparentNotify 21 ; +: ConfigureNotify 22 ; +: ConfigureRequest 23 ; +: GravityNotify 24 ; +: ResizeRequest 25 ; +: CirculateNotify 26 ; +: CirculateRequest 27 ; +: PropertyNotify 28 ; +: SelectionClear 29 ; +: SelectionRequest 30 ; +: SelectionNotify 31 ; +: ColormapNotify 32 ; +: ClientMessage 33 ; +: MappingNotify 34 ; +: LASTEvent 35 ; ! must be bigger than any event # + +! Key masks. Used as modifiers to GrabButton and GrabKey, results of QueryPointer, +! state in various key-, mouse-, and button-related events. + +: ShiftMask 1 0 shift ; +: LockMask 1 1 shift ; +: ControlMask 1 2 shift ; +: Mod1Mask 1 3 shift ; +: Mod2Mask 1 4 shift ; +: Mod3Mask 1 5 shift ; +: Mod4Mask 1 6 shift ; +: Mod5Mask 1 7 shift ; + +! modifier names. Used to build a SetModifierMapping request or +! to read a GetModifierMapping request. These correspond to the +! masks defined above. +: ShiftMapIndex 0 ; +: LockMapIndex 1 ; +: ControlMapIndex 2 ; +: Mod1MapIndex 3 ; +: Mod2MapIndex 4 ; +: Mod3MapIndex 5 ; +: Mod4MapIndex 6 ; +: Mod5MapIndex 7 ; + + +! button masks. Used in same manner as Key masks above. Not to be confused +! with button names below. + +: Button1Mask 1 8 shift ; +: Button2Mask 1 9 shift ; +: Button3Mask 1 10 shift ; +: Button4Mask 1 11 shift ; +: Button5Mask 1 12 shift ; + +: AnyModifier 1 15 shift ; ! used in GrabButton, GrabKey + +! button names. Used as arguments to GrabButton and as detail in ButtonPress +! and ButtonRelease events. Not to be confused with button masks above. +! Note that 0 is already defined above as "AnyButton". + +: Button1 1 ; +: Button2 2 ; +: Button3 3 ; +: Button4 4 ; +: Button5 5 ; + +! Notify modes + +: NotifyNormal 0 ; +: NotifyGrab 1 ; +: NotifyUngrab 2 ; +: NotifyWhileGrabbed 3 ; + +: NotifyHint 1 ; ! for MotionNotify events + +! Notify detail + +: NotifyAncestor 0 ; +: NotifyVirtual 1 ; +: NotifyInferior 2 ; +: NotifyNonlinear 3 ; +: NotifyNonlinearVirtual 4 ; +: NotifyPointer 5 ; +: NotifyPointerRoot 6 ; +: NotifyDetailNone 7 ; + +! Visibility notify + +: VisibilityUnobscured 0 ; +: VisibilityPartiallyObscured 1 ; +: VisibilityFullyObscured 2 ; + +! Circulation request + +: PlaceOnTop 0 ; +: PlaceOnBottom 1 ; + +! protocol families + +: FamilyInternet 0 ; ( IPv4 ) +: FamilyDECnet 1 ; +: FamilyChaos 2 ; +: FamilyInternet6 6 ; ( IPv6 ) + +! authentication families not tied to a specific protocol +: FamilyServerInterpreted 5 ; + +! Property notification + +: PropertyNewValue 0 ; +: PropertyDelete 1 ; + +! Color Map notification + +: ColormapUninstalled 0 ; +: ColormapInstalled 1 ; + +! GrabPointer, GrabButton, GrabKeyboard, GrabKey Modes + +: GrabModeSync 0 ; +: GrabModeAsync 1 ; + +! GrabPointer, GrabKeyboard reply status + +: GrabSuccess 0 ; +: AlreadyGrabbed 1 ; +: GrabInvalidTime 2 ; +: GrabNotViewable 3 ; +: GrabFrozen 4 ; + +! AllowEvents modes + +: AsyncPointer 0 ; +: SyncPointer 1 ; +: ReplayPointer 2 ; +: AsyncKeyboard 3 ; +: SyncKeyboard 4 ; +: ReplayKeyboard 5 ; +: AsyncBoth 6 ; +: SyncBoth 7 ; + +! Used in SetInputFocus, GetInputFocus + +: RevertToNone None ; +: RevertToPointerRoot PointerRoot ; +: RevertToParent 2 ; + +! ***************************************************************** +! * ERROR CODES +! ***************************************************************** + +: Success 0 ; ! everything's okay +: BadRequest 1 ; ! bad request code +: BadValue 2 ; ! int parameter out of range +: BadWindow 3 ; ! parameter not a Window +: BadPixmap 4 ; ! parameter not a Pixmap +: BadAtom 5 ; ! parameter not an Atom +: BadCursor 6 ; ! parameter not a Cursor +: BadFont 7 ; ! parameter not a Font +: BadMatch 8 ; ! parameter mismatch +: BadDrawable 9 ; ! parameter not a Pixmap or Window +: BadAccess 10 ; ! depending on context: + ! - key/button already grabbed + ! - attempt to free an illegal + ! cmap entry + ! - attempt to store into a read-only + ! color map entry. + ! - attempt to modify the access control + ! list from other than the local host. +: BadAlloc 11 ; ! insufficient resources +: BadColor 12 ; ! no such colormap +: BadGC 13 ; ! parameter not a GC +: BadIDChoice 14 ; ! choice not in range or already used +: BadName 15 ; ! font or color name doesn't exist +: BadLength 16 ; ! Request length incorrect +: BadImplementation 17 ; ! server is defective + +: FirstExtensionError 128 ; +: LastExtensionError 255 ; + +! ***************************************************************** +! * WINDOW DEFINITIONS +! ***************************************************************** + +! Window classes used by CreateWindow +! Note that CopyFromParent is already defined as 0 above + +: InputOutput 1 ; +: InputOnly 2 ; + +! Window attributes for CreateWindow and ChangeWindowAttributes + +: CWBackPixmap 1 0 shift ; +: CWBackPixel 1 1 shift ; +: CWBorderPixmap 1 2 shift ; +: CWBorderPixel 1 3 shift ; +: CWBitGravity 1 4 shift ; +: CWWinGravity 1 5 shift ; +: CWBackingStore 1 6 shift ; +: CWBackingPlanes 1 7 shift ; +: CWBackingPixel 1 8 shift ; +: CWOverrideRedirect 1 9 shift ; +: CWSaveUnder 1 10 shift ; +: CWEventMask 1 11 shift ; +: CWDontPropagate 1 12 shift ; +: CWColormap 1 13 shift ; +: CWCursor 1 14 shift ; + +! ConfigureWindow structure + +: CWX 1 0 shift ; +: CWY 1 1 shift ; +: CWWidth 1 2 shift ; +: CWHeight 1 3 shift ; +: CWBorderWidth 1 4 shift ; +: CWSibling 1 5 shift ; +: CWStackMode 1 6 shift ; + + +! Bit Gravity + +: ForgetGravity 0 ; +: NorthWestGravity 1 ; +: NorthGravity 2 ; +: NorthEastGravity 3 ; +: WestGravity 4 ; +: CenterGravity 5 ; +: EastGravity 6 ; +: SouthWestGravity 7 ; +: SouthGravity 8 ; +: SouthEastGravity 9 ; +: StaticGravity 10 ; + +! Window gravity + bit gravity above + +: UnmapGravity 0 ; + +! Used in CreateWindow for backing-store hint + +: NotUseful 0 ; +: WhenMapped 1 ; +: Always 2 ; + +! Used in GetWindowAttributes reply + +: IsUnmapped 0 ; +: IsUnviewable 1 ; +: IsViewable 2 ; + +! Used in ChangeSaveSet + +: SetModeInsert 0 ; +: SetModeDelete 1 ; + +! Used in ChangeCloseDownMode + +: DestroyAll 0 ; +: RetainPermanent 1 ; +: RetainTemporary 2 ; + +! Window stacking method (in configureWindow) + +: Above 0 ; +: Below 1 ; +: TopIf 2 ; +: BottomIf 3 ; +: Opposite 4 ; + +! Circulation direction + +: RaiseLowest 0 ; +: LowerHighest 1 ; + +! Property modes + +: PropModeReplace 0 ; +: PropModePrepend 1 ; +: PropModeAppend 2 ; + +! ***************************************************************** +! * GRAPHICS DEFINITIONS +! ***************************************************************** + +! graphics functions, as in GC.alu + +: GXclear HEX: 0 ; ! 0 +: GXand HEX: 1 ; ! src AND dst +: GXandReverse HEX: 2 ; ! src AND NOT dst +: GXcopy HEX: 3 ; ! src +: GXandInverted HEX: 4 ; ! NOT src AND dst +: GXnoop HEX: 5 ; ! dst +: GXxor HEX: 6 ; ! src XOR dst +: GXor HEX: 7 ; ! src OR dst +: GXnor HEX: 8 ; ! NOT src AND NOT dst +: GXequiv HEX: 9 ; ! NOT src XOR dst +: GXinvert HEX: a ; ! NOT dst +: GXorReverse HEX: b ; ! src OR NOT dst +: GXcopyInverted HEX: c ; ! NOT src +: GXorInverted HEX: d ; ! NOT src OR dst +: GXnand HEX: e ; ! NOT src OR NOT dst +: GXset HEX: f ; ! 1 + +! LineStyle + +: LineSolid 0 ; +: LineOnOffDash 1 ; +: LineDoubleDash 2 ; + +! capStyle + +: CapNotLast 0 ; +: CapButt 1 ; +: CapRound 2 ; +: CapProjecting 3 ; + +! joinStyle + +: JoinMiter 0 ; +: JoinRound 1 ; +: JoinBevel 2 ; + +! fillStyle + +: FillSolid 0 ; +: FillTiled 1 ; +: FillStippled 2 ; +: FillOpaqueStippled 3 ; + +! fillRule + +: EvenOddRule 0 ; +: WindingRule 1 ; + +! subwindow mode + +: ClipByChildren 0 ; +: IncludeInferiors 1 ; + +! SetClipRectangles ordering + +: Unsorted 0 ; +: YSorted 1 ; +: YXSorted 2 ; +: YXBanded 3 ; + +! CoordinateMode for drawing routines + +: CoordModeOrigin 0 ; ! relative to the origin +: CoordModePrevious 1 ; ! relative to previous point + +! Polygon shapes + +: Complex 0 ; ! paths may intersect +: Nonconvex 1 ; ! no paths intersect, but not convex +: Convex 2 ; ! wholly convex + +! Arc modes for PolyFillArc + +: ArcChord 0 ; ! join endpoints of arc +: ArcPieSlice 1 ; ! join endpoints to center of arc + +! GC components: masks used in CreateGC, CopyGC, ChangeGC, OR'ed into +! GC.stateChanges + +: GCFunction 1 0 shift ; +: GCPlaneMask 1 1 shift ; +: GCForeground 1 2 shift ; +: GCBackground 1 3 shift ; +: GCLineWidth 1 4 shift ; +: GCLineStyle 1 5 shift ; +: GCCapStyle 1 6 shift ; +: GCJoinStyle 1 7 shift ; +: GCFillStyle 1 8 shift ; +: GCFillRule 1 9 shift ; +: GCTile 1 10 shift ; +: GCStipple 1 11 shift ; +: GCTileStipXOrigin 1 12 shift ; +: GCTileStipYOrigin 1 13 shift ; +: GCFont 1 14 shift ; +: GCSubwindowMode 1 15 shift ; +: GCGraphicsExposures 1 16 shift ; +: GCClipXOrigin 1 17 shift ; +: GCClipYOrigin 1 18 shift ; +: GCClipMask 1 19 shift ; +: GCDashOffset 1 20 shift ; +: GCDashList 1 21 shift ; +: GCArcMode 1 22 shift ; +: GCLastBit 22 ; + +! ***************************************************************** +! * FONTS +! ***************************************************************** + +! used in QueryFont -- draw direction + +: FontLeftToRight 0 ; +: FontRightToLeft 1 ; + +: FontChange 255 ; + +! ***************************************************************** +! * IMAGING +! ***************************************************************** + +! ImageFormat -- PutImage, GetImage + +: XYBitmap 0 ; ! depth 1, XYFormat +: XYPixmap 1 ; ! depth == drawable depth +: ZPixmap 2 ; ! depth == drawable depth + +! ***************************************************************** +! * COLOR MAP STUFF +! ***************************************************************** + +! For CreateColormap + +: AllocNone 0 ; ! create map with no entries +: AllocAll 1 ; ! allocate entire map writeable + + +! Flags used in StoreNamedColor, StoreColors + +: DoRed 1 0 shift ; +: DoGreen 1 1 shift ; +: DoBlue 1 2 shift ; + +! ***************************************************************** +! * CURSOR STUFF +! ***************************************************************** + +! QueryBestSize Class + +: CursorShape 0 ; ! largest size that can be displayed +: TileShape 1 ; ! size tiled fastest +: StippleShape 2 ; ! size stippled fastest + +! ***************************************************************** +! * KEYBOARD/POINTER STUFF +! ***************************************************************** + +: AutoRepeatModeOff 0 ; +: AutoRepeatModeOn 1 ; +: AutoRepeatModeDefault 2 ; + +: LedModeOff 0 ; +: LedModeOn 1 ; + +! masks for ChangeKeyboardControl + +: KBKeyClickPercent 1 0 shift ; +: KBBellPercent 1 1 shift ; +: KBBellPitch 1 2 shift ; +: KBBellDuration 1 3 shift ; +: KBLed 1 4 shift ; +: KBLedMode 1 5 shift ; +: KBKey 1 6 shift ; +: KBAutoRepeatMode 1 7 shift ; + +: MappingSuccess 0 ; +: MappingBusy 1 ; +: MappingFailed 2 ; + +: MappingModifier 0 ; +: MappingKeyboard 1 ; +: MappingPointer 2 ; + +! ***************************************************************** +! * SCREEN SAVER STUFF +! ***************************************************************** + +: DontPreferBlanking 0 ; +: PreferBlanking 1 ; +: DefaultBlanking 2 ; + +: DisableScreenSaver 0 ; +: DisableScreenInterval 0 ; + +: DontAllowExposures 0 ; +: AllowExposures 1 ; +: DefaultExposures 2 ; + +! for ForceScreenSaver + +: ScreenSaverReset 0 ; +: ScreenSaverActive 1 ; + +! ***************************************************************** +! * HOSTS AND CONNECTIONS +! ***************************************************************** + +! for ChangeHosts + +: HostInsert 0 ; +: HostDelete 1 ; + +! for ChangeAccessControl + +: EnableAccess 1 ; +: DisableAccess 0 ; + +! Display classes used in opening the connection +! Note that the statically allocated ones are even numbered and the +! dynamically changeable ones are odd numbered + +: StaticGray 0 ; +: GrayScale 1 ; +: StaticColor 2 ; +: PseudoColor 3 ; +: TrueColor 4 ; +: DirectColor 5 ; + + +! Byte order used in imageByteOrder and bitmapBitOrder + +: LSBFirst 0 ; +: MSBFirst 1 ; + diff --git a/contrib/x11/x11-wrunt/xlib.factor b/contrib/x11/x11-wrunt/xlib.factor new file mode 100644 index 0000000000..760d3c9152 --- /dev/null +++ b/contrib/x11/x11-wrunt/xlib.factor @@ -0,0 +1,682 @@ +! based on Xlib.h from x.org, incomplete +IN: x11 +USING: alien ; + +LIBRARY: X11 + +TYPEDEF: char* XPointer +TYPEDEF: void* Display* +TYPEDEF: void* XExtData* +TYPEDEF: int Status +TYPEDEF: void* GC + +BEGIN-STRUCT: XSetWindowAttributes + FIELD: Pixmap background_pixmap + FIELD: ulong background_pixel + FIELD: Pixmap border_pixmap + FIELD: ulong border_pixel + FIELD: int bit_gravity + FIELD: int win_gravity + FIELD: int backing_store + FIELD: ulong backing_planes + FIELD: ulong backing_pixel + FIELD: bool save_under + FIELD: long event_mask + FIELD: long do_not_propagate_mask + FIELD: bool override_redirect + FIELD: Colormap colormap + FIELD: Cursor cursor +END-STRUCT + +BEGIN-STRUCT: XColor + FIELD: ulong pixel + FIELD: ushort red + FIELD: ushort green + FIELD: ushort blue + FIELD: char flags ! do_red, do_green, do_blue + FIELD: char pad +END-STRUCT + +BEGIN-STRUCT: XKeyEvent + FIELD: int type ! of event + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window window ! "event" window it is reported relative to + FIELD: Window root ! root window that the event occurred on + FIELD: Window subwindow ! child window + FIELD: Time time ! milliseconds + FIELD: int x ! pointer x, y coordinates in event window + FIELD: int y + FIELD: int x_root ! coordinates relative to root + FIELD: int y_root + FIELD: uint state ! key or button mask + FIELD: uint keycode ! detail + FIELD: bool same_screen ! same screen flag +END-STRUCT + +TYPEDEF: XKeyEvent XKeyPressedEvent +TYPEDEF: XKeyEvent XKeyReleasedEvent + +BEGIN-STRUCT: XButtonEvent + FIELD: int type ! of event + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window window ! "event" window it is reported relative to + FIELD: Window root ! root window that the event occurred on + FIELD: Window subwindow ! child window + FIELD: Time time ! milliseconds + FIELD: int x ! pointer x, y coordinates in event window + FIELD: int y + FIELD: int x_root ! coordinates relative to root + FIELD: int y_root + FIELD: uint state ! key or button mask + FIELD: uint button ! detail + FIELD: bool same_screen ! same screen flag +END-STRUCT + +TYPEDEF: XButtonEvent XButtonPressedEvent +TYPEDEF: XButtonEvent XButtonReleasedEvent + +BEGIN-STRUCT: XMotionEvent + FIELD: int type ! of event + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window window ! "event" window reported relative to + FIELD: Window root ! root window that the event occurred on + FIELD: Window subwindow ! child window + FIELD: Time time ! milliseconds + FIELD: int x ! pointer x, y coordinates in event window + FIELD: int y + FIELD: int x_root ! coordinates relative to root + FIELD: int y_root + FIELD: uint state ! key or button mask + FIELD: char is_hint ! detail + FIELD: bool same_screen ! same screen flag +END-STRUCT + +TYPEDEF: XMotionEvent XPointerMovedEvent + +BEGIN-STRUCT: XCrossingEvent + FIELD: int type ! of event + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window window ! "event" window reported relative to + FIELD: Window root ! root window that the event occurred on + FIELD: Window subwindow ! child window + FIELD: Time time ! milliseconds + FIELD: int x ! pointer x, y coordinates in event window + FIELD: int y + FIELD: int x_root ! coordinates relative to root + FIELD: int y_root + FIELD: int mode ! NotifyNormal, NotifyGrab, NotifyUngrab + FIELD: int detail + ! NotifyAncestor, NotifyVirtual, NotifyInferior, + ! NotifyNonlinear,NotifyNonlinearVirtual + FIELD: bool same_screen ! same screen flag + FIELD: bool focus ! boolean focus + FIELD: uint state ! key or button mask +END-STRUCT + +TYPEDEF: XCrossingEvent XEnterWindowEvent +TYPEDEF: XCrossingEvent XLeaveWindowEvent + +BEGIN-STRUCT: XFocusChangeEvent + FIELD: int type ! FocusIn or FocusOut + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window window ! window of event + FIELD: int mode ! NotifyNormal, NotifyGrab, NotifyUngrab + FIELD: int detail + ! NotifyAncestor, NotifyVirtual, NotifyInferior, + ! NotifyNonlinear,NotifyNonlinearVirtual, NotifyPointer, + ! NotifyPointerRoot, NotifyDetailNone +END-STRUCT + +TYPEDEF: XFocusChangeEvent XFocusInEvent +TYPEDEF: XFocusChangeEvent XFocusOutEvent + +! generated on EnterWindow and FocusIn when KeyMapState selected +BEGIN-STRUCT: XKeymapEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window window + ! char key_vector[32]; + FIELD: int pad ( TODO: get rid of this padding ) + FIELD: int pad + FIELD: int pad + FIELD: int pad + FIELD: int pad + FIELD: int pad + FIELD: int pad + FIELD: int pad +END-STRUCT + +BEGIN-STRUCT: XExposeEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server */ + FIELD: bool send_event ! true if this came from a SendEvent request */ + FIELD: Display* display ! Display the event was read from */ + FIELD: Window window + FIELD: int x + FIELD: int y + FIELD: int width + FIELD: int height + FIELD: int count ! if non-zero, at least this many more */ +END-STRUCT + +BEGIN-STRUCT: XGraphicsExposeEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Drawable drawable + FIELD: int x + FIELD: int y + FIELD: int width + FIELD: int height + FIELD: int count ! if non-zero, at least this many more + FIELD: int major_code ! core is CopyArea or CopyPlane + FIELD: int minor_code ! not defined in the core +END-STRUCT + +BEGIN-STRUCT: XNoExposeEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Drawable drawable + FIELD: int major_code ! core is CopyArea or CopyPlane + FIELD: int minor_code ! not defined in the core +END-STRUCT + +BEGIN-STRUCT: XVisibilityEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window window + FIELD: int state ! Visibility state +END-STRUCT + +BEGIN-STRUCT: XCreateWindowEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window parent ! parent of the window + FIELD: Window window ! window id of window created + FIELD: int x ! window location + FIELD: int y + FIELD: int width ! size of window + FIELD: int height + FIELD: int border_width ! border width + FIELD: bool override_redirect ! creation should be overridden +END-STRUCT + +BEGIN-STRUCT: XDestroyWindowEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window event + FIELD: Window window +END-STRUCT + +BEGIN-STRUCT: XUnmapEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window event + FIELD: Window window + FIELD: bool from_configure +END-STRUCT + +BEGIN-STRUCT: XMapEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window event + FIELD: Window window + FIELD: bool override_redirect ! boolean, is override set... +END-STRUCT + +BEGIN-STRUCT: XMapRequestEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window parent + FIELD: Window window +END-STRUCT + +BEGIN-STRUCT: XReparentEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window event + FIELD: Window window + FIELD: Window parent + FIELD: int x + FIELD: int y + FIELD: bool override_redirect +END-STRUCT + +BEGIN-STRUCT: XConfigureEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window event + FIELD: Window window + FIELD: int x + FIELD: int y + FIELD: int width + FIELD: int height + FIELD: int border_width + FIELD: Window above + FIELD: bool override_redirect +END-STRUCT + +BEGIN-STRUCT: XGravityEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window event + FIELD: Window window + FIELD: int x + FIELD: int y +END-STRUCT + +BEGIN-STRUCT: XResizeRequestEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window window + FIELD: int width + FIELD: int height +END-STRUCT + +BEGIN-STRUCT: XConfigureRequestEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window parent + FIELD: Window window + FIELD: int x + FIELD: int y + FIELD: int width + FIELD: int height + FIELD: int border_width + FIELD: Window above + FIELD: int detail ! Above, Below, TopIf, BottomIf, Opposite + FIELD: ulong value_mask +END-STRUCT + +BEGIN-STRUCT: XCirculateEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window event + FIELD: Window window + FIELD: int place ! PlaceOnTop, PlaceOnBottom +END-STRUCT + +BEGIN-STRUCT: XCirculateRequestEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window parent + FIELD: Window window + FIELD: int place ! PlaceOnTop, PlaceOnBottom +END-STRUCT + +BEGIN-STRUCT: XPropertyEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window window + FIELD: Atom atom + FIELD: Time time + FIELD: int state ! NewValue, Deleted +END-STRUCT + +BEGIN-STRUCT: XSelectionClearEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window window + FIELD: Atom selection + FIELD: Time time +END-STRUCT + +BEGIN-STRUCT: XSelectionRequestEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window owner + FIELD: Window requestor + FIELD: Atom selection + FIELD: Atom target + FIELD: Atom property + FIELD: Time time +END-STRUCT + +BEGIN-STRUCT: XSelectionEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window requestor + FIELD: Atom selection + FIELD: Atom target + FIELD: Atom property ! ATOM or None + FIELD: Time time +END-STRUCT + +BEGIN-STRUCT: XColormapEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window window + FIELD: Colormap colormap ! COLORMAP or None +! #if defined(__cplusplus) || defined(c_plusplus) +! Bool c_new; /* C++ */ +! #else + FIELD: bool new +! #endif + FIELD: int state ! ColormapInstalled, ColormapUninstalled +END-STRUCT + +BEGIN-STRUCT: XClientMessageEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window window + FIELD: Atom message_type + FIELD: int format + ! union { char b[20]; short s[10]; long l[5]; } data; + FIELD: int pad ! TODO + FIELD: int pad + FIELD: int pad + FIELD: int pad + FIELD: int pad +END-STRUCT + +BEGIN-STRUCT: XMappingEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window window ! unused + FIELD: int request ! one of MappingModifier, MappingKeyboard, MappingPointer + FIELD: int first_keycode ! first keycode + FIELD: int count ! defines range of change w. first_keycod +END-STRUCT + +BEGIN-STRUCT: XErrorEvent + FIELD: int type + FIELD: Display* display ! Display the event was read from + FIELD: XID resourceid ! resource id + FIELD: ulong serial ! serial number of failed request + FIELD: uchar error_code ! error code of failed request + FIELD: uchar request_code ! Major op-code of failed request + FIELD: uchar minor_code ! Minor op-code of failed request +END-STRUCT + +BEGIN-STRUCT: XAnyEvent + FIELD: int type + FIELD: ulong serial ! # of last request processed by server + FIELD: bool send_event ! true if this came from a SendEvent request + FIELD: Display* display ! Display the event was read from + FIELD: Window window ! window on which event was requested in event mask +END-STRUCT + +! this union is defined so Xlib can always use the same sized +! event structure internally, to avoid memory fragmentation. +BEGIN-UNION: XEvent + MEMBER: int + MEMBER: XAnyEvent + MEMBER: XKeyEvent + MEMBER: XButtonEvent + MEMBER: XMotionEvent + MEMBER: XCrossingEvent + MEMBER: XFocusChangeEvent + MEMBER: XExposeEvent + MEMBER: XGraphicsExposeEvent + MEMBER: XNoExposeEvent + MEMBER: XVisibilityEvent + MEMBER: XCreateWindowEvent + MEMBER: XDestroyWindowEvent + MEMBER: XUnmapEvent + MEMBER: XMapEvent + MEMBER: XMapRequestEvent + MEMBER: XReparentEvent + MEMBER: XConfigureEvent + MEMBER: XGravityEvent + MEMBER: XResizeRequestEvent + MEMBER: XConfigureRequestEvent + MEMBER: XCirculateEvent + MEMBER: XCirculateRequestEvent + MEMBER: XPropertyEvent + MEMBER: XSelectionClearEvent + MEMBER: XSelectionRequestEvent + MEMBER: XSelectionEvent + MEMBER: XColormapEvent + MEMBER: XClientMessageEvent + MEMBER: XMappingEvent + MEMBER: XErrorEvent + MEMBER: XKeymapEvent +! long pad[24] + MEMBER: long ! TODO: fixme + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long + MEMBER: long +END-UNION + +BEGIN-STRUCT: Visual + FIELD: XExtData* ext_data ! hook for extension to hang data + FIELD: VisualID visualid ! visual id of this visual +! #if defined(__cplusplus) || defined(c_plusplus) +! int c_class; /* C++ class of screen (monochrome, etc.) +! #else + FIELD: int class ! class of screen (monochrome, etc.) +! #endif + FIELD: ulong red_mask ! mask values + FIELD: ulong green_mask + FIELD: ulong blue_mask + FIELD: int bits_per_rgb ! log base 2 of distinct color values + FIELD: int map_entries ! color map entries +END-STRUCT + +FUNCTION: int XCloseDisplay ( Display* display ) ; +FUNCTION: Colormap XCreateColormap ( Display* display, Window w, Visual* visual, int alloc ) ; +FUNCTION: Window XCreateWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, int depth, uint class, Visual* visual, ulong valuemask, XSetWindowAttributes* attributes ) ; +FUNCTION: Atom XInternAtom ( Display* display, char* atom_name, bool only_if_exists ) ; +FUNCTION: int XMapRaised ( Display* display, Window w ) ; +FUNCTION: Status XGetGeometry ( Display* display, Drawable d, Window* root_return, int* x_return, int* y_return, uint* width_return, uint* height_return, uint* border_width_return, uint* depth_return ) ; +FUNCTION: KeySym XLookupKeysym ( XKeyEvent* key_event, int index ) ; +FUNCTION: char* XGetAtomName ( Display* display, Atom atom ) ; +FUNCTION: Status XSetWMProtocols ( Display* display, Window w, Atom* protocols, int count ) ; + +! dharmatech's stuff + +! The most popular guides to programming the X Window System are the +! series from Oreilly. For programming with Xlib, there is the +! reference manual and the programmers guide. However, a lesser known +! manual is the free Xlib manual that comes with the MIT X +! distribution. The arrangement and order of these bindings follows +! the structure of the free Xlib manual. If you add to this library +! and are wondering what part of the file to modify, just find the +! function or data structure in the manual and note the section. + +! +! 2 - Display Functions +! + +FUNCTION: Display* XOpenDisplay ( char* display_name ) ; + +! 2.2 Obtaining Information about the Display, Image Formats, or Screens + +FUNCTION: ulong XBlackPixel ( Display* display, int screen_number ) ; +FUNCTION: ulong XWhitePixel ( Display* display, int screen_number ) ; +FUNCTION: Colormap XDefaultColormap ( Display* display, int screen_number ) ; +FUNCTION: int XDefaultDepth ( Display* display, int screen_number ) ; +FUNCTION: GC XDefaultGC ( Display* display, int screen_number ) ; +FUNCTION: int XDefaultScreen ( Display* display ) ; +FUNCTION: Window XRootWindow ( Display* display, int screen_number ) ; +FUNCTION: Window XDefaultRootWindow ( Display* display ) ; +FUNCTION: int XProtocolVersion ( Display* display ) ; +FUNCTION: int XProtocolRevision ( Display* display ) ; +FUNCTION: int XQLength ( Display* display ) ; +FUNCTION: int XScreenCount ( Display* display ) ; +FUNCTION: int XConnectionNumber ( Display* display ) ; + +! +! 3 - Window Functions +! + +FUNCTION: Window XCreateSimpleWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, ulong border, ulong background ) ; +FUNCTION: Status XDestroyWindow ( Display* display, Window w ) ; +FUNCTION: Status XMapWindow ( Display* display, Window window ) ; +FUNCTION: Status XMapSubwindows ( Display* display, Window window ) ; +FUNCTION: Status XUnmapWindow ( Display* display, Window w ) ; +FUNCTION: Status XUnmapSubwindows ( Display* display, Window w ) ; +FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ; +FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ; +FUNCTION: Status XResizeWindow ( Display* display, Window w, uint width, uint height ) ; +FUNCTION: Status XSetWindowBorderWidth ( Display* display, ulong w, uint width ) ; +FUNCTION: Status XRaiseWindow ( Display* display, Window w ) ; +FUNCTION: Status XLowerWindow ( Display* display, Window w ) ; +FUNCTION: Status XChangeWindowAttributes ( Display* display, Window w, ulong valuemask, XSetWindowAttributes* attr ) ; +FUNCTION: Status XSetWindowBackground ( Display* display, Window w, ulong background_pixel ) ; +FUNCTION: Status XDefineCursor ( Display* display, Window w, Cursor cursor ) ; +FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ; + +! +! 4 - Window Information Functions +! + +FUNCTION: Status XQueryTree ( Display* display, Window w, Window* root_return, Window* parent_return, Window** children_return, uint* nchildren_return ) ; +FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ; +FUNCTION: bool XQueryPointer ( Display* display, Window w, Window* root_return, Window* child_return, int* root_x_return, int* root_y_return, int* win_x_return, int* win_y_return, uint* mask_return ) ; + +! +! 6 - Color Management Functions +! + +FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ; +FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ; +FUNCTION: Status XQueryColor ( Display* display, Colormap colormap, XColor* def_in_out ) ; + +! +! 7 - Graphics Context Functions +! + +FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ; +FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ; +FUNCTION: Status XGetGCValues ( Display* display, GC gc, ulong valuemask, XGCValues* values_return ) ; +FUNCTION: Status XSetForeground ( Display* display, GC gc, ulong foreground ) ; +FUNCTION: Status XSetBackground ( Display* display, GC gc, ulong background ) ; +FUNCTION: Status XSetFunction ( Display* display, GC gc, int function ) ; +FUNCTION: Status XSetSubwindowMode ( Display* display, GC gc, int subwindow_mode ) ; +FUNCTION: Status XSetFont ( Display* display, GC gc, Font font ) ; + +! +! 8 - Graphics Functions +! + +FUNCTION: Status XClearWindow ( Display* display, Window w ) ; +FUNCTION: Status XDrawPoint ( Display* display, Drawable d, GC gc, int x, int y ) ; +FUNCTION: Status XDrawLine ( Display* display, Drawable d, GC gc, int x1, int y1, int x2, int y2 ) ; +FUNCTION: Status XDrawArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ; +FUNCTION: Status XFillArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ; +FUNCTION: Font XLoadFont ( Display* display, char* name ) ; +FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ; +FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ; +FUNCTION: Status XDrawString ( Display* display, Drawable d, GC gc, int x, int y, char* string, int length ) ; + +! +! 9 - Window and Session Manager Functions +! + +FUNCTION: Status XReparentWindow ( Display* display, Window w, Window parent, int x, int y ) ; +FUNCTION: Status XAddToSaveSet ( Display* display, Window w ) ; +FUNCTION: Status XRemoveFromSaveSet ( Display* display, Window w ) ; +FUNCTION: Status XGrabServer ( Display* display ) ; +FUNCTION: Status XUngrabServer ( Display* display ) ; +FUNCTION: Status XKillClient ( Display* display, XID resource ) ; + +! +! 11 - Event Handling Functions +! + +FUNCTION: Status XSelectInput ( Display* display, Window w, long event_mask ) ; +FUNCTION: Status XFlush ( Display* display ) ; +FUNCTION: Status XSync ( Display* display, int discard ) ; +FUNCTION: int XPending ( Display* display ) ; +FUNCTION: Status XNextEvent ( Display* display, XEvent* event ) ; +FUNCTION: Status XMaskEvent ( Display* display, long event_mask, XEvent* event_return ) ; + +! +! 12 - Input Device Functions +! + +FUNCTION: int XGrabPointer ( Display* display, Window grab_window, bool owner_events, uint event_mask, int pointer_mode, int keyboard_mode, Window confine_to, Cursor cursor, Time time ) ; +FUNCTION: Status XUngrabPointer ( Display* display, Time time ) ; +FUNCTION: Status XChangeActivePointerGrab ( Display* display, uint event_mask, Cursor cursor, Time time ) ; +FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Window grab_window, bool owner_events, int pointer_mode, int keyboard_mode ) ; +FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ; +FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, int src_x, int src_y, uint src_width, uint src_height, int dest_x, int dest_y ) ; +! +! 14 - Inter-Client Communication Functions +! + +FUNCTION: Status XFetchName ( Display* display, Window w, char** window_name_return ) ; +FUNCTION: Status XGetTransientForHint ( Display* display, Window w, Window* prop_window_return ) ; + +! +! 16 - Application Utility Functions +! + +FUNCTION: int XLookupString ( XKeyEvent* event_struct, char* buffer_return, int bytes_buffer, KeySym* keysym_return, XComposeStatus* status_in_out ) ; + diff --git a/contrib/x11/x11-wrunt/xutil.factor b/contrib/x11/x11-wrunt/xutil.factor new file mode 100644 index 0000000000..b226272eee --- /dev/null +++ b/contrib/x11/x11-wrunt/xutil.factor @@ -0,0 +1,58 @@ +! from Xutil.h, incomplete +IN: x11 +USING: alien ; + +LIBRARY: X11 + +BEGIN-STRUCT: XSizeHints + FIELD: long flags ! marks which fields in this structure are defined + FIELD: int x ! obsolete for new window mgrs, but clients + FIELD: int y ! should set so old wm's don't mess up + FIELD: int width + FIELD: int height + FIELD: int min_width + FIELD: int min_height + FIELD: int max_width + FIELD: int max_height + FIELD: int width_inc + FIELD: int height_inc + ! struct { + ! int x; /* numerator */ + ! int y; /* denominator */ + ! } min_aspect, max_aspect; + FIELD: int min_aspect_x + FIELD: int min_aspect_y + FIELD: int max_aspect_x + FIELD: int max_aspect_y + FIELD: int base_width ! added by ICCCM version 1 + FIELD: int base_height + FIELD: int win_gravity; ! added by ICCCM version 1 +END-STRUCT + +FUNCTION: int XSetStandardProperties ( Display* display, Window w, char* window_name, char* icon_name, Pixmap icon_pixmap, char** argv, int argc, XSizeHints* hints ) ; + +! Information used by the visual utility routines to find desired visual +! type from the many visuals a display may support. + +BEGIN-STRUCT: XVisualInfo + FIELD: Visual* visual + FIELD: VisualID visualid + FIELD: int screen + FIELD: int depth +! #if defined(__cplusplus) || defined(c_plusplus) +! int c_class; /* C++ */ +! #else + FIELD: int class +! #endif + FIELD: ulong red_mask + FIELD: ulong green_mask + FIELD: ulong blue_mask + FIELD: int colormap_size + FIELD: int bits_per_rgb +END-STRUCT + +BEGIN-STRUCT: XComposeStatus + FIELD: XPointer compose_ptr ! state table pointer + FIELD: int chars_matched ! match state +END-STRUCT + From 5dddb20f789e13a67dba391a195abcc3e6dd5a71 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 7 Nov 2005 23:51:48 +0000 Subject: [PATCH 004/373] Made lesson2.factor slightly more efficient, still too slow though --- contrib/x11/x11-wrunt/lesson2.factor | 25 +++++++++++-------------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/contrib/x11/x11-wrunt/lesson2.factor b/contrib/x11/x11-wrunt/lesson2.factor index a738949573..4a6f8cd067 100644 --- a/contrib/x11/x11-wrunt/lesson2.factor +++ b/contrib/x11/x11-wrunt/lesson2.factor @@ -54,9 +54,8 @@ SYMBOL: height ] keep ExposureMask KeyPressMask bitor ButtonPressMask bitor StructureNotifyMask bitor over set-XSetWindowAttributes-event_mask -! dup 1 swap set-XSetWindowAttributes-border_pixel - CWColormap CWEventMask bitor swap ; -! CWBorderPixel CWColormap bitor CWEventMask bitor swap ; + dup 1 swap set-XSetWindowAttributes-border_pixel + CWBorderPixel CWColormap bitor CWEventMask bitor swap ; : make-display ( display-num -- display ) XOpenDisplay dup dpy set ; @@ -139,7 +138,6 @@ M: x-button-press-event (handle-event) 2drop f ; PREDICATE: x-key-press-event quit-key-event -! 0 XLookupKeysym XK_Escape = ; 0 XLookupKeysym dup CHAR: q = swap XK_Escape = or ; M: quit-key-event (handle-event) @@ -153,18 +151,17 @@ M: object (handle-event) #! unknown event, ignore and continue 2drop t ; -: handle-event ( glwin -- continue? ) - ! TODO: don't create a new XEvent object each time (but don't use a global) - dup gl-window-dpy tuck XNextEvent drop (handle-event) ; +: handle-event ( glwin xevent -- continue? ) + over gl-window-dpy over XNextEvent drop (handle-event) ; -: (loop) ( glwin -- continue? ) - dup gl-window-dpy XPending 0 > [ - dup handle-event [ (loop) ] [ drop f ] if - ] [ drop t ] if ; +: (loop) ( glwin xevent -- continue? ) + over gl-window-dpy XPending 0 > [ + 2dup handle-event [ (loop) ] [ 2drop f ] if + ] [ 2drop t ] if ; -: loop ( glwin -- ) - dup (loop) [ draw-gl-scene loop ] [ drop ] if ; +: loop ( glwin xevent -- ) + 2dup (loop) [ draw-gl-scene loop ] [ 2drop ] if ; : main ( -- ) ":0.0" 10 10 640 480 16 "NeHe Lesson 2" make-gl-window - dup loop kill-gl-window ; + dup loop kill-gl-window ; From f574eb714b5551c2abfa439a3ba97d6a31aa7226 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 8 Nov 2005 01:26:32 +0000 Subject: [PATCH 005/373] Added --- contrib/math/utils.factor | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/contrib/math/utils.factor b/contrib/math/utils.factor index a27fc402d3..810704ba03 100644 --- a/contrib/math/utils.factor +++ b/contrib/math/utils.factor @@ -1,5 +1,5 @@ IN: math-contrib -USING: errors kernel sequences math ; +USING: errors kernel sequences math sequences-internals ; : deg>rad pi * 180 / ; inline : rad>deg 180 * pi / ; inline @@ -31,3 +31,26 @@ USING: errors kernel sequences math ; : c. ( v v -- x ) #! Complex inner product. 0 [ ** + ] 2reduce ; + +TUPLE: frange from step length ; + +C: frange ( from step to -- seq ) + #! example: 0 .01 10 >array + >r pick - swap [ / ] keep -rot swapd >fixnum 1+ r> + [ set-frange-length ] keep + [ set-frange-step ] keep + [ set-frange-from ] keep ; + +M: frange length ( frange -- n ) + frange-length ; + +: decrement-length ( frange -- ) + [ frange-length 1- ] keep set-frange-length ; + +: increment-start ( frange -- ) + [ [ frange-from ] keep frange-step + ] keep set-frange-from ; + +M: frange nth ( n frange -- obj ) [ frange-step * ] keep frange-from + ; +M: frange nth-unsafe ( n frange -- obj ) nth ; + + From 99202ea76faaed3dd5cf03b8295d37153d81ac82 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 8 Nov 2005 01:27:34 +0000 Subject: [PATCH 006/373] Rect/trapezoidal integration Updated load.factor --- contrib/math/load.factor | 1 + contrib/math/numerical-integration.factor | 22 ++++++++++++++++++++++ 2 files changed, 23 insertions(+) create mode 100644 contrib/math/numerical-integration.factor diff --git a/contrib/math/load.factor b/contrib/math/load.factor index ef50d5d7ba..fb2b4f5288 100644 --- a/contrib/math/load.factor +++ b/contrib/math/load.factor @@ -7,6 +7,7 @@ USING: parser sequences words compiler ; "contrib/math/quaternions.factor" "contrib/math/matrices.factor" "contrib/math/statistics.factor" + "contrib/math/numerical-integration.factor" ] [ run-file ] each "math-contrib" words [ try-compile ] each diff --git a/contrib/math/numerical-integration.factor b/contrib/math/numerical-integration.factor new file mode 100644 index 0000000000..767572c7e6 --- /dev/null +++ b/contrib/math/numerical-integration.factor @@ -0,0 +1,22 @@ +IN: math-contrib + +USING: kernel sequences errors namespaces math lists vectors ; + +SYMBOL: step-size .01 step-size set + +: setup-range ( from to -- frange ) + step-size get swap ; + +: integrate-rect ( from to f -- x ) + >r setup-range dup decrement-length r> + [ step-size get * ] append map sum ; + +: integrate-trap ( from to f -- x ) + >r setup-range r> + map 1 over tail >r >vector dup pop drop r> + [ + 2 / step-size get * ] 2map sum ; + +! : integrate-simpson ( from to f -- x ) + ! >r setup-range r> ; + + From 2cceac0bd8414ba4b9afc465f46f5042e71c845a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Nov 2005 22:48:55 +0000 Subject: [PATCH 007/373] Simpsons rule --- contrib/math/numerical-integration.factor | 31 ++++++++++++++++++++--- contrib/math/utils.factor | 3 +++ 2 files changed, 31 insertions(+), 3 deletions(-) diff --git a/contrib/math/numerical-integration.factor b/contrib/math/numerical-integration.factor index 767572c7e6..7d36f3dbad 100644 --- a/contrib/math/numerical-integration.factor +++ b/contrib/math/numerical-integration.factor @@ -3,6 +3,7 @@ IN: math-contrib USING: kernel sequences errors namespaces math lists vectors ; SYMBOL: step-size .01 step-size set +SYMBOL: num-steps 180 num-steps set ! simpsons : setup-range ( from to -- frange ) step-size get swap ; @@ -16,7 +17,31 @@ SYMBOL: step-size .01 step-size set map 1 over tail >r >vector dup pop drop r> [ + 2 / step-size get * ] 2map sum ; -! : integrate-simpson ( from to f -- x ) - ! >r setup-range r> ; - + +: setup-simpson-range ( from to -- frange ) + [ swap - num-steps get /f ] 2keep swapd ; + +: generate-simpson-weights ( seq -- seq ) + length 2 / V{ 1 4 } clone swap 2 - + [ { 2 4 } append ] times { 1 } append ; + + +! take elements n at a time and apply the quotation, forming a new seq +: group-map ( seq n quot -- seq ) + pick length pick / + [ [ >r pick pick r> -rot pick over * [ + ] keep swap rot pick call + , ] repeat ] { } make 2nip nip ; + +: nths ( n seq -- seq ) + 2dup length 0 -rot dup decrement-length [ over nth ] map 2nip ; + +! broken +! take a set of every nth element and apply the quotation, forming a new seq +! { 1 2 3 4 5 6 } 3 [ sum ] -> { 1 4 } { 2 5 } { 3 6 } -> { 5 7 9 } +! : skip-map ( seq n quot -- seq ) + ! pick length pick / [ 1+ >r pick r> swap dupd nths 1- ] repeat ; + +: integrate-simpson ( from to f -- x ) + >r setup-simpson-range r> dupd map dup generate-simpson-weights + [ * ] 2map sum swap [ third ] keep first - 6 / * ; diff --git a/contrib/math/utils.factor b/contrib/math/utils.factor index 810704ba03..688af5b1ae 100644 --- a/contrib/math/utils.factor +++ b/contrib/math/utils.factor @@ -50,6 +50,9 @@ M: frange length ( frange -- n ) : increment-start ( frange -- ) [ [ frange-from ] keep frange-step + ] keep set-frange-from ; +: frange-range ( frange -- range ) + [ frange-step ] keep frange-length 1- * ; + M: frange nth ( n frange -- obj ) [ frange-step * ] keep frange-from + ; M: frange nth-unsafe ( n frange -- obj ) nth ; From 9440f385e556c4518768f9d89e412e255ec53b75 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Nov 2005 05:37:24 +0000 Subject: [PATCH 008/373] interruption checks get compiled now, fixnum/mod fixed on powerpc --- CHANGES.html | 6 ++ TODO.FACTOR.txt | 60 +++++++++---------- library/bootstrap/boot-stage1.factor | 9 ++- library/bootstrap/init.factor | 2 +- library/collections/hashtables.factor | 6 ++ library/collections/namespaces.factor | 59 ++++++------------ .../collections/sequence-combinators.factor | 3 + library/collections/sequences-epilogue.factor | 4 +- library/compiler/linearizer.factor | 3 +- library/compiler/ppc/fixnum.factor | 48 +++++++++------ library/compiler/ppc/generator.factor | 19 +++++- library/compiler/vops.factor | 5 ++ library/compiler/x86/generator.factor | 14 ++++- library/continuations.factor | 7 ++- library/errors.factor | 4 +- library/syntax/prettyprint.factor | 2 +- library/test/prettyprint.factor | 10 ++++ library/threads.factor | 2 +- library/tools/debugger.factor | 9 +-- library/tools/memory.factor | 10 +++- library/tools/walker.factor | 6 +- native/array.c | 2 +- native/debug.c | 2 + native/hashtable.c | 2 +- native/run.c | 1 - native/sbuf.c | 2 +- native/unix/signal.c | 7 --- 27 files changed, 175 insertions(+), 129 deletions(-) diff --git a/CHANGES.html b/CHANGES.html index 701eb918b9..1bc0311cc2 100644 --- a/CHANGES.html +++ b/CHANGES.html @@ -4,6 +4,12 @@ Factor change log +

    Factor 0.80:

    + +
      + +
    +

    Factor 0.79:

      diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 419eeaf4ae..8476e3ea0e 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,15 +1,36 @@ +- make-pane: if no input, just return pane-output +- friendlier .factor-rc load error handling +- intrinsic char-slot set-char-slot + +- default library names are not useful +- fix remaining GL issues +- fix up the min thumb size hack +- closing ui does not stop timers +- adding/removing timers automatically for animated gadgets +- saving image with UI open +- bug: left click to bring up context menu, click splitter bar + and pane grows to 100% +- bug: click tutorial, full screen, the right-most arrow icon + loses the vertical bar +- signal handler should not lose stack pointers +- callbacks +- FIELD: char key_vector[32]; +- FIELD: union { char b[20]; short s[10]; long l[5]; } data; +- MEMBER: long pad[24]; +- inference: try changing nth and set-nth array methods to call -unsafe, + unbalanced branches error +- floating point intrinsics +- new basic block optimizer +- declare slot types for built-ins +- split: return vectors +- set-path: iterative +- better prettyprinting of cond + + ui: -- fix remaining GL issues -- UI issue: try resizing slider while menu is open -- make-pane: if no input, just return pane-output - keyboard completion - get outliner working with lots of lines of output - listener continuations -- fix up the min thumb size hack -- off-by-one error in pick-up? -- closing ui does not stop timers -- adding/removing timers automatically for animated gadgets - tabular output - debugger should use outlining - support nested incremental layouts more efficiently @@ -19,11 +40,6 @@ - multiline editing in listener - text selection - clipboard support -- bug: slider bars go to 0 pixel width/height -- bug: left click to bring up context menu, click splitter bar - and pane grows to 100% -- bug: click tutorial, full screen, the right-most arrow icon - loses the vertical bar + tutorial: @@ -36,7 +52,6 @@ - code walker & exceptions - investigate if rehashing on startup is really necessary - remove word transfer hack in bootstrap -- signal handler should not lose stack pointers + ffi: @@ -48,25 +63,13 @@ - value type structs - bitfields in C structs - setting struct members that are not * -- callbacks -- FIELD: char key_vector[32]; -- FIELD: union { char b[20]; short s[10]; long l[5]; } data; -- MEMBER: long pad[24]; - convert factor sequences to c arrays, and vice versa + compiler: -- inference: try changing nth and set-nth array methods to call -unsafe, - unbalanced branches error -- compile interruption checks - check that set-datastack and set-callstack compile correctly in the face of optimization -- floating point intrinsics -- new basic block optimizer -- fix fixnum/mod overflow on PowerPC -- intrinsic char-slot set-char-slot - [ ] [ throw ] ifte ==> should raise 'unbalanced branches' error -- declare slot types for built-ins - remove dead code after a 'throw' - flushing optimization - [ [ dup call ] dup call ] infer hangs @@ -78,13 +81,8 @@ + sequences: - slice: if sequence or seq start is changed, abstraction violation -- split: return vectors -- set-path: iterative - specialized arrays -- instances: do not use make-list -- >c/c>: vector stack - search: slow -- vectorize >n, n>, (get) - mutable strings simplifying string operarations - real Unicode support (strings are already 16 bits and can be extended to 21 if the need arises, but we need full character classification @@ -92,10 +90,8 @@ + kernel: -- better prettyprinting of cond - better handling of random arrangements of html words when prettyprinting -- friendlier .factor-rc load error handling - reader syntax for byte arrays, displaced aliens - out of memory error when printing global namespace - merge timers with sleeping tasks diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 30ff1f3511..1f0273e58f 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: image -USING: generic hashtables kernel kernel-internals -lists math memory namespaces parser prettyprint -sequences io vectors words ; +USING: errors generic hashtables io kernel kernel-internals +lists math memory namespaces parser prettyprint sequences +vectors words ; "Bootstrap stage 1..." print @@ -12,6 +12,9 @@ sequences io vectors words ; ! The [ ] make form creates a boot quotation [ [ + ! initialize it twice so that we get a catchstack + ! early on for each-object. + init-error-handler [ hashtable? ] instances [ dup hash-size 1 max swap set-bucket-count ] each boot diff --git a/library/bootstrap/init.factor b/library/bootstrap/init.factor index 1b1fe7b282..ce5eaf2cf9 100644 --- a/library/bootstrap/init.factor +++ b/library/bootstrap/init.factor @@ -6,7 +6,7 @@ parser threads words ; : boot ( -- ) #! Initialize an interpreter with the basic services. - global >n + init-namespaces millis init-random init-threads init-io diff --git a/library/collections/hashtables.factor b/library/collections/hashtables.factor index 2a65e50616..3f9dbb8800 100644 --- a/library/collections/hashtables.factor +++ b/library/collections/hashtables.factor @@ -215,3 +215,9 @@ M: hashtable hashcode ( hash -- n ) #! Remove all elements from the sequence that are keys #! in the hashtable. [ swap hash* not ] subset-with ; flushable + +: hash-stack ( key seq -- value ) + #! Searches for a key in a sequence of hashtables, + #! where the most recently pushed hashtable is searched + #! first. + [ dupd hash* ] find-last nip ?hash ; flushable diff --git a/library/collections/namespaces.factor b/library/collections/namespaces.factor index a69c346648..b030493ebb 100644 --- a/library/collections/namespaces.factor +++ b/library/collections/namespaces.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2003, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: namespaces -USING: hashtables kernel kernel-internals lists math sequences -strings vectors words ; +USING: arrays hashtables kernel kernel-internals lists math +sequences strings vectors words ; ! Variables in Factor: ! @@ -24,58 +24,29 @@ strings vectors words ; ! bind ( namespace quot -- ) executes a quotation with a ! namespace pushed on the namespace stack. -: namestack ( -- ns ) 3 getenv ; inline - -: set-namestack ( ns -- ) 3 setenv ; inline - -: namespace ( -- namespace ) - #! Push the current namespace. - namestack car ; inline - -: >n ( namespace -- n:namespace ) - #! Push a namespace on the name stack. - namestack cons set-namestack ; inline - -: n> ( n:namespace -- namespace ) - #! Pop the top of the name stack. - namestack uncons set-namestack ; inline - -: global ( -- g ) 4 getenv ; - -: (get) ( var ns -- value ) - #! Internal word for searching the namestack. - dup [ - 2dup car hash* [ - nip cdr ( found ) - ] [ - cdr (get) ( keep looking ) - ] ?if - ] [ - 2drop f - ] if ; flushable - -: get ( variable -- value ) - #! Push the value of a variable by searching the namestack - #! from the top down. - namestack (get) ; flushable - +: namestack* ( -- ns ) 3 getenv ; inline +: namestack ( -- ns ) namestack* clone ; inline +: set-namestack ( ns -- ) clone 3 setenv ; inline +: namespace ( -- namespace ) namestack* peek ; inline +: >n ( namespace -- n:namespace ) namestack* push ; inline +: n> ( n:namespace -- namespace ) namestack* pop ; inline +: global ( -- g ) 4 getenv ; inline +: get ( variable -- value ) namestack* hash-stack ; flushable : set ( value variable -- ) namespace set-hash ; +: on ( var -- ) t swap set ; inline +: off ( var -- ) f swap set ; inline : nest ( variable -- hash ) #! If the variable is set in the current namespace, return #! its value, otherwise set its value to a new namespace. dup namespace hash [ ] [ >r H{ } clone dup r> set ] ?if ; -: change ( var quot -- ) +: change ( var quot -- quot: old -- new ) #! Execute the quotation with the variable value on the #! stack. The set the variable to the return value of the #! quotation. >r dup get r> rot slip set ; inline -: on ( var -- ) t swap set ; inline - -: off ( var -- ) f swap set ; inline - : inc ( var -- ) [ 1+ ] change ; inline : dec ( var -- ) [ 1- ] change ; inline @@ -138,3 +109,7 @@ IN: lists : alist>quot ( default alist -- quot ) [ unswons [ % , , \ if , ] [ ] make ] each ; + +IN: kernel-internals + +: init-namespaces ( -- ) global 1array >vector set-namestack ; diff --git a/library/collections/sequence-combinators.factor b/library/collections/sequence-combinators.factor index 2d671047a0..a674148305 100644 --- a/library/collections/sequence-combinators.factor +++ b/library/collections/sequence-combinators.factor @@ -119,6 +119,9 @@ M: object find ( seq quot -- i elt ) : find-last ( seq quot -- i elt ) >r [ length 1- ] keep r> find-last* ; inline +: find-last-with ( obj seq quot -- i elt | quot: elt -- ? ) + swap [ with rot ] find-last 2swap 2drop ; inline + : contains? ( seq quot -- ? ) find drop -1 > ; inline diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 2e0700aa79..045de71e5a 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -120,7 +120,9 @@ M: object peek ( sequence -- element ) : pop* ( sequence -- ) #! Shorten the sequence by one element. - dup length 1- swap set-length ; + [ length 1- ] keep + [ f -rot set-nth ] 2keep + set-length ; : pop ( sequence -- element ) #! Get value at end of sequence and remove it. diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor index b27fc4c274..1f76c65bdc 100644 --- a/library/compiler/linearizer.factor +++ b/library/compiler/linearizer.factor @@ -10,7 +10,7 @@ GENERIC: linearize* ( node -- ) #! Transform dataflow IR into linear IR. This strips out #! stack flow information, and flattens conditionals into #! jumps and labels. - [ %prologue , linearize* ] { } make ; + [ %prologue , %irq , linearize* ] { } make ; : linearize-next node-successor linearize* ; @@ -20,6 +20,7 @@ M: node linearize* ( node -- ) linearize-next ; M: #label linearize* ( node -- )
    diff --git a/contrib/cont-responder/todo.factor b/contrib/cont-responder/todo.factor index 459079bb43..6e4631f4be 100644 --- a/contrib/cont-responder/todo.factor +++ b/contrib/cont-responder/todo.factor @@ -151,7 +151,7 @@ USE: unparser : priority-comparator ( item1 item2 -- number ) #! Return 0 if item equals item2, -1 if item1 < item2 and #! 1 if item1 > item2. - >r item-priority r> item-priority lexi ; + >r item-priority r> item-priority <=> ; : todo-items ( -- alist ) #! Return a list of items for the given todo list. diff --git a/contrib/httpd/browser-responder.factor b/contrib/httpd/browser-responder.factor index 3e9d40fba7..4d6d89a350 100644 --- a/contrib/httpd/browser-responder.factor +++ b/contrib/httpd/browser-responder.factor @@ -50,7 +50,8 @@ USING: html cont-responder hashtables kernel io namespaces words lists prettypri #! Write out the HTML for the list of words in a vocabulary. Make the 'word' item #! the currently selected option. ; : word-source ( vocab word -- ) diff --git a/contrib/splay-trees.factor b/contrib/splay-trees.factor index 52b128137d..fe9bfa33c7 100644 --- a/contrib/splay-trees.factor +++ b/contrib/splay-trees.factor @@ -3,11 +3,6 @@ IN: splay-trees USING: kernel math sequences ; -GENERIC: <=> ( x y -- x <=> y ) - -M: number <=> - ; -M: sequence <=> lexi ; - TUPLE: splay-tree r ; TUPLE: splay-node v k l r ; diff --git a/doc/handbook/sequences.facts b/doc/handbook/sequences.facts index 289ff9af27..a119c17637 100644 --- a/doc/handbook/sequences.facts +++ b/doc/handbook/sequences.facts @@ -1,6 +1,6 @@ IN: sequences -USING: arrays help kernel-internals sequences-internals strings -vectors words ; +USING: arrays help kernel kernel-internals sequences-internals +strings vectors words ; GLOSSARY: "sequence" "a linearly-ordered finite collection of elements responding to the " { $link "sequence-protocol" "sequence protocol" } "." ; @@ -163,7 +163,7 @@ ARTICLE: "sequences-comparing" "Comparing sequences" { $subsection sequence= } { $subsection mismatch } "Lexicographic order:" -{ $subsection lexi } ; +{ $subsection <=> } ; GLOSSARY: "resizable sequence" "a sequence implementing the " { $link set-length } " generic word. For example, vectors and string buffers" ; @@ -260,13 +260,12 @@ ARTICLE: "sequences-sorting" "Sorting and binary search" { "zero - indicates that " { $snippet "elt1" } " is ordered equivalently to " { $snippet "elt2" } } { "negative - indicates that " { $snippet "elt1" } " precedes " { $snippet "elt2" } } } -"There are two sorting words, one outputs a new sequence and another one is in-place." -{ $subsection sort } +"In-place sorting:" { $subsection nsort } -"There are three utility words." -{ $subsection number-sort } -{ $subsection string-sort } -{ $subsection word-sort } ; +"Sorting elements in a new sequence:" +{ $subsection sort } +"Using the default comparator:" +{ $subsection natural-sort } ; ARTICLE: "sequences-unsafe" "Unsafe sequence operations" "The unsafe sequence protocol bypasses bounds checks for increased performance:" diff --git a/doc/handbook/words.facts b/doc/handbook/words.facts index 51e62003fc..cdd4f2faf7 100644 --- a/doc/handbook/words.facts +++ b/doc/handbook/words.facts @@ -17,7 +17,6 @@ ARTICLE: "words" "Words" { $subsection word? } { $subsection word-name } { $subsection word-vocabulary } -{ $subsection word-sort } { $subsection "vocabularies" } { $subsection "word-definition" } { $subsection "word-crossref" } diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index d6e3944ecb..119c6d72b4 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -220,6 +220,9 @@ vectors words ; "/library/collections/vectors.facts" "/library/collections/virtual-sequences.facts" "/library/generic/early-generic.facts" + "/library/generic/generic.facts" + "/library/generic/math-combination.facts" + "/library/generic/slots.facts" "/library/syntax/parse-stream.facts" "/library/syntax/parser.facts" "/library/syntax/parse-syntax.facts" diff --git a/library/collections/sequence-sort.factor b/library/collections/sequence-sort.factor index 870de04d59..9012b33d72 100644 --- a/library/collections/sequence-sort.factor +++ b/library/collections/sequence-sort.factor @@ -1,5 +1,5 @@ IN: sequences-internals -USING: arrays kernel math sequences ; +USING: arrays generic kernel math sequences ; : midpoint@ length 2 /i ; inline @@ -84,9 +84,7 @@ IN: sequences : sort ( seq quot -- seq | quot: elt elt -- -1/0/1 ) swap [ swap nsort ] immutable ; inline -: number-sort ( seq -- seq ) [ - ] sort ; - -: string-sort ( seq -- seq ) [ lexi ] sort ; +: natural-sort ( seq -- seq ) [ <=> ] sort ; : binsearch ( elt seq quot -- i | quot: elt elt -- -1/0/1 ) swap dup empty? diff --git a/library/collections/sequence-sort.facts b/library/collections/sequence-sort.facts index a85087af3a..7a8ad1315b 100644 --- a/library/collections/sequence-sort.facts +++ b/library/collections/sequence-sort.facts @@ -1,5 +1,5 @@ IN: sequences -USING: help words ; +USING: help kernel words ; HELP: sort "( seq quot -- sortedseq )" { $values { "seq" "a sequence" } { "quot" "a comparator quotation" } { "sortedseq" "a new sorted sequence" } } @@ -10,10 +10,6 @@ HELP: nsort "( seq quot -- sortedseq )" { $description "Sorts the sequence in-place." } { $side-effects "seq" } ; -HELP: number-sort "( seq -- sortedseq )" +HELP: natural-sort "( seq -- sortedseq )" { $values { "seq" "a sequence of real numbers" } { "sortedseq" "a new sorted sequence" } } -{ $description "Sorts a sequence of real numbers in increasing order." } ; - -HELP: string-sort "( seq -- sortedseq )" -{ $values { "seq" "a sequence of strings" } { "sortedseq" "a new sorted sequence" } } -{ $description "Sorts a sequence of strings in increasing order." } ; +{ $description "Sorts a sequence of objects in natural order using the " { $link <=> } " word." } ; diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index aee10310f2..8fbf0d87fc 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -1,21 +1,8 @@ -! Copyright (C) 2005 Slava Pestov. +! Copyright (C) 2005, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: sequences-internals -USING: errors generic kernel kernel-internals lists math -sequences strings vectors words ; - -: (lexi) ( seq seq i limit -- n ) - 2dup >= [ - 2drop [ length ] 2apply - - ] [ - >r 3dup 2nth-unsafe 2dup = [ - 2drop 1+ r> (lexi) - ] [ - r> drop - >r 3drop r> - ] if - ] if ; flushable - IN: sequences +USING: errors generic kernel kernel-internals lists math +sequences-internals strings vectors words ; : first2 ( { x y } -- x y ) 1 swap bounds-check nip first2-unsafe ; inline @@ -127,11 +114,6 @@ M: object reverse ( seq -- seq ) [ ] keep like ; [ >r 2dup r> 2nth-unsafe = not ] find swap >r 3drop r> ; flushable -: lexi ( s1 s2 -- n ) - 2dup mismatch dup -1 = - [ drop [ length ] 2apply - ] [ 2nth-unsafe - ] if ; - flushable - : flip ( seq -- seq ) dup empty? [ dup first [ length ] keep like @@ -140,6 +122,10 @@ M: object reverse ( seq -- seq ) [ ] keep like ; IN: kernel +M: object <=> + 2dup mismatch dup -1 = + [ drop [ length ] 2apply - ] [ 2nth-unsafe <=> ] if ; + : depth ( -- n ) datastack length ; : no-cond "cond fall-through" throw ; diff --git a/library/collections/sequences-epilogue.facts b/library/collections/sequences-epilogue.facts index 2dad00fdda..a5c460d686 100644 --- a/library/collections/sequences-epilogue.facts +++ b/library/collections/sequences-epilogue.facts @@ -131,17 +131,6 @@ HELP: mismatch "( seq1 seq2 -- i )" { $values { "seq1" "a sequence" } { "seq2" "a sequence" } { "i" "an index" } } { $description "Compares pairs of elements up to the minimum of the sequences' lengths, outputting the first index where the two sequences have non-equal elements, or -1 if all tested elements were equal." } ; -HELP: lexi "( str1 str2 -- n )" -{ $values { "str1" "a string" } { "str2" "a string" } { "n" "an integer" } } -{ $description - "Compares two sequences of integers lexicographically (dictionary order). The output value is one of the following:" - { $list - { "positive - indicating that " { $snippet "str1" } " follows " { $snippet "str2" } } - { "zero - indicating that " { $snippet "str1" } " is equal to " { $snippet "str2" } } - { "negative - indicating that " { $snippet "str1" } " precedes " { $snippet "str2" } } - } -} ; - HELP: flip "( matrix -- newmatrix )" { $values { "matrix" "a sequence of equal-length sequences" } { "newmatrix" "a sequence of equal-length sequences" } } { $description "Transposes the matrix; that is, rows become columns and columns become rows." } diff --git a/library/generic/math-combination.factor b/library/generic/math-combination.factor index 35b86d065e..f8bc656571 100644 --- a/library/generic/math-combination.factor +++ b/library/generic/math-combination.factor @@ -7,7 +7,6 @@ math namespaces sequences words ; ! Math combination for generic dyadic upgrading arithmetic. : math-priority ( class -- n ) - #! Non-number classes have the highest priority. "math-priority" word-prop [ 100 ] unless* ; : math-class< ( class class -- ? ) @@ -41,7 +40,7 @@ TUPLE: no-math-method left right generic ; object bootstrap-word applicable-method ; : math-method ( word left right -- quot ) - [ type>class ] 2apply 2dup and [ + 2dup and [ 2dup math-upgrade >r math-class-max over order min-class applicable-method r> swap append @@ -52,7 +51,7 @@ TUPLE: no-math-method left right generic ; : math-vtable ( picker quot -- ) [ swap , \ tag , - [ num-tags swap map % ] { } make , + [ num-tags [ type>class ] map swap map % ] { } make , \ dispatch , ] [ ] make ; inline @@ -61,7 +60,7 @@ TUPLE: no-math-method left right generic ; : math-combination ( word -- vtable ) \ over [ - dup type>class math-class? [ + dup math-class? [ \ dup [ >r 2dup r> math-method ] math-vtable ] [ over object-method diff --git a/library/generic/math-combination.facts b/library/generic/math-combination.facts new file mode 100644 index 0000000000..19e9b45739 --- /dev/null +++ b/library/generic/math-combination.facts @@ -0,0 +1,38 @@ +USING: generic help math ; + +HELP: math-priority "( class -- n )" +{ $values { "class" "a class word" } { "n" "a non-negative integer" } } +{ $description "Outputs the priority of a built-in number class. If class A has a lower priority than class B, then applying a binary math operation to an instance of A and B will upgrade the instance of A to B's type." } +{ $notes "To simplify implementation of the math method combination, this word outputs 100 for non-numeric classes. Priorities of numeric classes must always be less than 100." } ; + +HELP: math-class< "( class1 class2 -- ? )" +{ $values { "class1" "a class word" } { "class2" "a class word" } { "?" "a boolean" } } +{ $description "Defines a total ordering on built-in number classes." } ; + +HELP: math-upgrade "( class1 class2 -- quot )" +{ $values { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation with stack effect " { $snippet "( n n -- n n )" } } } +{ $description "Outputs a quotation for upgrading numberical types. It takes two numbers on the stack, an instance of " { $snippet "class1" } ", and an instance of " { $snippet "class2" } ", and converts the one with the lower priority to the higher priority type." } +{ $examples { $example "fixnum bignum math-upgrade ." "[ >r >bignum r> ]" } } ; + +HELP: no-math-method "( left right generic -- )" +{ $values { "left" "an object" } { "right" "an object" } { "generic" "a generic word" } } +{ $description } ; + +HELP: math-method "( word class1 class2 -- quot )" +{ $values { "word" "a generic word" } { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation" } } +{ $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." } +{ $examples { $example "\\ + fixnum float math-method ." "[ >r >float r> float+ ]" } } ; + +HELP: math-class? "( object -- ? )" +{ $values { "object" "an object" } { "?" "a boolean" } } +{ $description + "Tests if the object is a numerical class word. The numerical classes are precisely the following:" + { $list { $link fixnum } { $link bignum } { $link ratio } { $link float } { $link complex } } +} ; + +HELP: math-combination "( word -- quot )" +{ $values { "word" "a generic word" } { "quot" "a quotation" } } +{ $description "Generates a double-dispatching word definition. Only methods defined on numerical classes and " { $link object } " take effect in the math combination. Methods defined on numerical classes are guaranteed to have their two inputs upgraded to the highest priority type of the two." } ; + +HELP: 2generic f +{ $description "The class of generic words with the math combination." } ; diff --git a/library/generic/slots.factor b/library/generic/slots.factor index 90e012999a..b08ced86fe 100644 --- a/library/generic/slots.factor +++ b/library/generic/slots.factor @@ -1,16 +1,11 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. -! Some code for defining slot accessors and mutators. Used to -! implement tuples, as well as builtin types. IN: generic USING: arrays kernel kernel-internals lists math namespaces parser sequences strings words ; : define-typecheck ( class generic def -- ) - #! Just like: - #! GENERIC: generic - #! M: class generic def ; over define-generic -rot define-method ; : define-slot-word ( class slot word quot -- ) @@ -33,10 +28,6 @@ parser sequences strings words ; [ first3 [ dup [ first2 create ] when ] 2apply 3array ] map ; : define-slots ( class spec -- ) - #! Define a collection of slot readers and writers for the - #! given class. The spec is a list of lists of length 3 of - #! the form [ slot reader writer ]. slot is an integer, - #! reader and writer are either words, strings or f. [ first3 define-slot ] each-with ; : reader-word ( class name -- word ) @@ -49,10 +40,6 @@ parser sequences strings words ; [ reader-word ] 2keep writer-word ; : simple-slots ( class slots base -- spec ) - #! Takes a list of slot names, and for each slot name - #! defines a pair of words - and - #! set--. Slot numbering is consecutive and - #! begins at base. over length [ + ] map-with [ >r dupd simple-slot r> -rot 3array ] 2map nip intern-slots ; diff --git a/library/generic/slots.facts b/library/generic/slots.facts new file mode 100644 index 0000000000..db1a3550c9 --- /dev/null +++ b/library/generic/slots.facts @@ -0,0 +1,38 @@ +USING: generic help ; + +HELP: define-typecheck "( class generic quot -- )" +{ $values { "class" "a class word" } { "generic" "a generic word" } { "quot" "a quotation" } } +{ $description + "Defines a generic word with the " { $link simple-combination } " and having one method on " { $snippet "class" } "." + $terpri + "Analogous to the following code:" + { $code + "GENERIC: generic" + "M: class generic quot ;" + } +} +{ $notes "This word is used internally to wrap low-level code that does not do type-checking in safe user-visible words." } ; + +HELP: define-slot-word "( class slot word quot -- )" +{ $values { "class" "a class word" } { "slot" "a non-negative integer" } { "word" "a new word" } { "quot" "a quotation" } } +{ $description "Defines " { $snippet "word" } " to be a simple type-checking generic word that receives the slot number on the stack as a fixnum." } +$low-level-note ; + +HELP: define-slots "( class spec -- )" +{ $values { "class" "a class word" } { "spec" "a sequence of triples" } } +{ $description + "Defines a set of slot accessor/mutator words." + $terpri + "Each entry in the " { $snippet "spec" } " sequence is a three-element sequence with the following elements:" + { $list + "a slot number" + { "a reader word, or " { $link f } } + { "a writer word, or " { $link f } } + } + "If the reader or writer is " { $link f } ", the corresponding word is not defined." +} +$low-level-note ; + +HELP: simple-slots "( class slots base -- spec )" +{ $values { "class" "a class word" } { "slots" "a sequence of strings" } { "base" "a slot number" } } +{ $description "Constructs a slot specification for " { $link define-slots } " where each slot is named by an element of " { $snippet "slots" } " prefixed by the name of the class. Slots are numbered consecutively starting from " { $snippet "base" } ". Reader and writer words are defined in the current vocabulary, with the reader word having the same name as the slot, and the writer word name prefixed by " { $snippet "\"set-\"" } "." } ; diff --git a/library/help/markup.factor b/library/help/markup.factor index 557bf90155..2d17da2744 100644 --- a/library/help/markup.factor +++ b/library/help/markup.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2005, 2006 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: help -USING: arrays -generic hashtables io kernel lists namespaces parser -prettyprint sequences strings styles vectors words ; +USING: arrays generic hashtables io kernel lists namespaces +parser prettyprint sequences strings styles vectors words ; : uncons* dup first swap 1 swap tail ; @@ -160,7 +159,7 @@ DEFER: help : $predicate ( content -- ) { { "object" "an object" } } $values "Tests if the object is an instance of the " $description - format* $link " class." format* ; + $link " class." format* ; : $list ( content -- ) terpri* [ "- " format* print-element terpri* ] each ; diff --git a/library/io/files.factor b/library/io/files.factor index 3ee896e82d..c0749dd9d2 100644 --- a/library/io/files.factor +++ b/library/io/files.factor @@ -13,7 +13,8 @@ styles ; : directory? ( file -- ? ) stat car ; : directory ( dir -- list ) - (directory) [ { "." ".." } member? not ] subset string-sort ; + (directory) + [ { "." ".." } member? not ] subset natural-sort ; : file-length ( file -- length ) stat third ; diff --git a/library/kernel.factor b/library/kernel.factor index 4d8599d832..f718bd1db0 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2005 Slava Pestov. +! Copyright (C) 2004, 2006 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: kernel USING: generic kernel-internals math-internals ; @@ -13,6 +13,8 @@ M: object hashcode drop 0 ; GENERIC: = ( obj obj -- ? ) flushable M: object = eq? ; +GENERIC: <=> ( obj1 obj2 -- n ) flushable + GENERIC: clone ( obj -- obj ) flushable M: object clone ; diff --git a/library/kernel.facts b/library/kernel.facts index 16e8feb449..51766c4cc2 100644 --- a/library/kernel.facts +++ b/library/kernel.facts @@ -1,4 +1,4 @@ -USING: help kernel kernel-internals ; +USING: help kernel kernel-internals sequences ; HELP: eq? "( obj1 obj2 -- ? )" { $values { "obj1" "an object" } { "obj2" "an object" } } @@ -76,6 +76,21 @@ HELP: = "( obj1 obj2 -- ? )" } } ; +HELP: <=> "( obj1 obj2 -- n )" +{ $values { "obj1" "an object" } { "obj2" "an object" } { "n" "an integer" } } +{ $contract + "Compares two objects using an intrinsic partial order, for example, the natural order for real numbers and lexicographic order for strings." + $terpri + "The output value is one of the following:" + { $list + { "positive - indicating that " { $snippet "str1" } " follows " { $snippet "str2" } } + { "zero - indicating that " { $snippet "str1" } " is equal to " { $snippet "str2" } } + { "negative - indicating that " { $snippet "str1" } " precedes " { $snippet "str2" } } + } + "The default implementation treats the two objects as sequences, and recursively compares their elements. So no extra work is required to compare sequences lexicographically." +} +{ $see-also natural-sort } ; + HELP: clone "( obj -- cloned )" { $values { "obj" "an 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." @@ -220,9 +235,9 @@ HELP: array-capacity "( array -- n )" HELP: array-nth "( n array -- elt )" { $values { "n" "a non-negative fixnum" } { "array" "an array" } { "elt" "an object" } } { $description "Low-level array element accessor." } -{ $safety "This word is in the " { $snippet "kernel-internals" } " vocabulary because it is unsafe. It does not check types or array bounds, and improper use can corrupt memory." } ; +{ $warning "This word is in the " { $snippet "kernel-internals" } " vocabulary because it is unsafe. It does not check types or array bounds, and improper use can corrupt memory." } ; HELP: set-array-nth "( elt n array --)" { $values { "elt" "an object" } { "n" "a non-negative fixnum" } { "array" "an array" } } { $description "Low-level array element mutator." } -{ $safety "This word is in the " { $snippet "kernel-internals" } " vocabulary because it is unsafe. It does not check types or array bounds, and improper use can corrupt memory." } ; +{ $warning "This word is in the " { $snippet "kernel-internals" } " vocabulary because it is unsafe. It does not check types or array bounds, and improper use can corrupt memory." } ; diff --git a/library/math/math.factor b/library/math/math.factor index 255743c2f8..ca7a7107a9 100644 --- a/library/math/math.factor +++ b/library/math/math.factor @@ -76,19 +76,6 @@ GENERIC: absq ( n -- |n|^2 ) foldable : times ( n quot -- | quot: -- ) swap [ >r dup slip r> ] repeat drop ; inline -: power-of-2? ( n -- ? ) - dup 0 > [ - dup dup neg bitand = - ] [ - drop f - ] if ; foldable - -: log2 ( n -- b ) - #! Log base two for integers. - { - { [ dup 0 <= ] [ "Input must be positive" throw ] } - { [ dup 1 = ] [ drop 0 ] } - { [ t ] [ -1 shift log2 1+ ] } - } cond ; foldable - GENERIC: number>string ( str -- num ) foldable + +M: real <=> - ; diff --git a/library/math/pow.factor b/library/math/pow.factor index 0018ca805f..8fe48e406b 100644 --- a/library/math/pow.factor +++ b/library/math/pow.factor @@ -45,3 +45,18 @@ M: integer ^ ( z w -- z^w ) ] [ dup 0 < [ neg ^ recip ] [ (integer^) ] if ] if ; + +: power-of-2? ( n -- ? ) + dup 0 > [ + dup dup neg bitand = + ] [ + drop f + ] if ; foldable + +: log2 ( n -- b ) + #! Log base two for integers. + { + { [ dup 0 <= ] [ "Input must be positive" throw ] } + { [ dup 1 = ] [ drop 0 ] } + { [ t ] [ -1 shift log2 1+ ] } + } cond ; foldable diff --git a/library/syntax/see.factor b/library/syntax/see.factor index fa59a1168e..769be52646 100644 --- a/library/syntax/see.factor +++ b/library/syntax/see.factor @@ -121,5 +121,5 @@ M: word class. drop ; all-words [ word-name [ subseq? ] completion? ] subset-with ; : apropos ( substring -- ) - (apropos) word-sort + (apropos) natural-sort [ [ synopsis ] keep simple-object terpri ] each ; diff --git a/library/test/collections/sequences.factor b/library/test/collections/sequences.factor index ee2efbc90a..39cfaebd55 100644 --- a/library/test/collections/sequences.factor +++ b/library/test/collections/sequences.factor @@ -191,8 +191,8 @@ unit-test [ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] 2apply ] unit-test -[ -1 ] [ "ab" "abc" lexi ] unit-test -[ 1 ] [ "abc" "ab" lexi ] unit-test +[ -1 ] [ "ab" "abc" <=> ] unit-test +[ 1 ] [ "abc" "ab" <=> ] unit-test [ 1 4 9 16 16 V{ f 1 4 9 16 } ] [ V{ } clone "cache-test" set diff --git a/library/test/collections/strings.factor b/library/test/collections/strings.factor index f01fee33ed..45d5ccaf55 100644 --- a/library/test/collections/strings.factor +++ b/library/test/collections/strings.factor @@ -68,8 +68,8 @@ unit-test [ t ] [ CHAR: 0 digit? ] unit-test [ f ] [ CHAR: x digit? ] unit-test -[ t ] [ "abc" "abd" lexi 0 < ] unit-test -[ t ] [ "z" "abd" lexi 0 > ] unit-test +[ t ] [ "abc" "abd" <=> 0 < ] unit-test +[ t ] [ "z" "abd" <=> 0 > ] unit-test [ f ] [ [ 0 10 "hello" subseq ] catch not ] unit-test diff --git a/library/test/test.factor b/library/test/test.factor index 9bd0c1058e..4665e80dd1 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -1,15 +1,12 @@ ! Factor test suite. IN: test -USING: arrays errors kernel lists math memory namespaces parser -prettyprint sequences io strings words ; +USING: arrays errors inspector io kernel lists math memory +namespaces parser prettyprint sequences strings words ; TUPLE: assert got expect ; -M: assert error. - "Assertion failed" print - "Expected: " write dup assert-expect . - "Got: " write assert-got . ; +M: assert summary drop "Assertion failed" ; : assert= ( a b -- ) 2dup = [ 2drop ] [ throw ] if ; diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index f320058461..cfaee5657d 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2005 Slava Pestov. +! Copyright (C) 2004, 2006 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: errors USING: generic hashtables inspector io kernel kernel-internals @@ -68,18 +68,9 @@ M: kernel-error error. ( error -- ) [ user-interrupt. ] } dispatch ; -M: no-method error. ( error -- ) - "No suitable method." print - "Generic word: " write dup no-method-generic . - "Methods: " write dup no-method-generic order . - "Object: " write dup no-method-object short. - "Object class: " write no-method-object class short. ; +M: no-method summary drop "No suitable method" ; -M: no-math-method error. ( error -- ) - "No suitable arithmetic method." print - "Generic word: " write dup no-math-method-generic . - "Left operand: " write dup no-math-method-left short. - "Right operand: " write no-math-method-right short. ; +M: no-math-method summary drop "No suitable arithmetic method" ; : parse-dump ( error -- ) "Parsing " write @@ -95,14 +86,9 @@ M: no-math-method error. ( error -- ) M: parse-error error. ( error -- ) dup parse-dump delegate error. ; -M: bounds-error error. ( error -- ) - "Sequence index out of bounds" print - "Sequence: " write dup bounds-error-seq short. - "Minimum: 0" print - "Maximum: " write dup bounds-error-seq length . - "Requested: " write bounds-error-index . ; +M: bounds-error summary drop "Sequence index out of bounds" ; -M: string error. ( error -- ) print ; +M: tuple error. ( error -- ) describe ; M: object error. ( error -- ) . ; @@ -122,15 +108,13 @@ M: object error. ( error -- ) . ; [ "Error in default error handler!" print ] when ; : print-error ( error -- ) + "An unhandled error was caught:" print terpri [ dup error. ] catch nip flush-error-handler ; -: try ( quot -- ) - #! Execute a quotation, and if it throws an error, print it - #! and return to the caller. - [ print-error debug-help ] recover ; +: try ( quot -- ) [ print-error terpri debug-help ] recover ; : save-error ( error continuation -- ) - global [ error-continuation set error set ] bind ; + error-continuation set-global error set-global ; : error-handler ( error -- ) dup continuation save-error rethrow ; diff --git a/library/tools/debugger.facts b/library/tools/debugger.facts index 2401dddc80..fc3da822dd 100644 --- a/library/tools/debugger.facts +++ b/library/tools/debugger.facts @@ -2,11 +2,11 @@ USING: errors help ; HELP: error f { $description "Global variable holding most-recently thrown error." } -{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." ; +{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ; HELP: error-continuation f { $description "Global variable holding current continuation of most-recently thrown error." } -{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." ; +{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ; HELP: :s "( -- )" { $description "Prints the datastack at the time of the most recent error. Used for interactive debugging." } ; diff --git a/library/tools/describe.factor b/library/tools/describe.factor index 942ca07fef..5c69cb5650 100644 --- a/library/tools/describe.factor +++ b/library/tools/describe.factor @@ -89,7 +89,7 @@ DEFER: describe ] each-with ; : words. ( vocab -- ) - words word-sort [ (help) ] sequence-outliner ; + words natural-sort [ (help) ] sequence-outliner ; : vocabs. ( -- ) #! Outlining word browser. diff --git a/library/vocabularies.factor b/library/vocabularies.factor index c49ddb5425..77e8c91b67 100644 --- a/library/vocabularies.factor +++ b/library/vocabularies.factor @@ -12,7 +12,7 @@ SYMBOL: vocabularies : set-word ( word -- ) \ word set-global ; -: vocabs ( -- seq ) vocabularies get hash-keys string-sort ; +: vocabs ( -- seq ) vocabularies get hash-keys natural-sort ; : vocab ( name -- vocab ) vocabularies get hash ; diff --git a/library/words.factor b/library/words.factor index e3c2aec194..3a7c526b3c 100644 --- a/library/words.factor +++ b/library/words.factor @@ -4,6 +4,8 @@ IN: words USING: generic hashtables kernel kernel-internals lists math namespaces sequences strings vectors ; +M: word <=> [ word-name ] 2apply <=> ; + GENERIC: definer ( word -- word ) PREDICATE: word undefined ( obj -- ? ) word-primitive 0 = ; @@ -36,8 +38,6 @@ M: word word-xt ( w -- xt ) 7 integer-slot ; GENERIC: set-word-xt M: word set-word-xt ( xt w -- ) 7 set-integer-slot ; -: word-sort ( seq -- seq ) [ [ word-name ] 2apply lexi ] sort ; - : uses ( word -- uses ) [ word-def diff --git a/library/words.facts b/library/words.facts index cd2ad7bd27..8848dd0fbd 100644 --- a/library/words.facts +++ b/library/words.facts @@ -75,10 +75,6 @@ HELP: set-word-xt "( xt word -- )" { $warning "This word is unsafe. Specifying an invalid address can corrupt memory and crash the runtime." } { $notes "This word is used by the compiler." } ; -HELP: word-sort "( seq -- sorted )" -{ $values { "seq" "a sequence of words" } { "sorted" "a sorted sequence" } } -{ $description "Sorts a sequence of words by word name." } ; - HELP: uses "( word -- seq )" { $values { "word" "a word" } { "seq" "a sequence of words" } } { $description "Outputs a sequence of words directory called by the given word." } From 9d1f07cf0e2d0453bf3d0bb15f57e95b0acbe0dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 9 Jan 2006 21:19:40 +0000 Subject: [PATCH 226/373] Standard combination docs --- TODO.FACTOR.txt | 7 +++- library/bootstrap/boot-stage1.factor | 1 + library/generic/standard-combination.factor | 14 +++---- library/generic/standard-combination.facts | 45 +++++++++++++++++++++ 4 files changed, 57 insertions(+), 10 deletions(-) create mode 100644 library/generic/standard-combination.facts diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index a01ff16843..881e4435b7 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,5 +1,10 @@ +- UI word wrap: sometimes a space appears at the front +- need line and paragraph spacing +- update HTML stream +- help cross-referencing +- UI browser pane needs 'back' button +- tty help - if cell is rebound, and we allocate c objects, bang -- make-image leaks memory if there is an error while parsing files - runtime primitives like fopen: check for null input - -with combinators are awkward - cleanups: diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 119c6d72b4..e557d34c21 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -223,6 +223,7 @@ vectors words ; "/library/generic/generic.facts" "/library/generic/math-combination.facts" "/library/generic/slots.facts" + "/library/generic/standard-combination.facts" "/library/syntax/parse-stream.facts" "/library/syntax/parser.facts" "/library/syntax/parse-syntax.facts" diff --git a/library/generic/standard-combination.factor b/library/generic/standard-combination.factor index 3fa8f45f2e..c5d7a54e2e 100644 --- a/library/generic/standard-combination.factor +++ b/library/generic/standard-combination.factor @@ -63,15 +63,11 @@ math namespaces sequences vectors words ; "methods" word-prop hash-size 3 <= ; : standard-combination ( word picker -- quot ) - swap dup tag-generic? [ - num-tags \ tag big-generic - ] [ - dup small-generic? [ - small-generic - ] [ - num-types \ type big-generic - ] if - ] if ; + swap { + { [ dup tag-generic? ] [ num-tags \ tag big-generic ] } + { [ dup small-generic? ] [ small-generic ] } + { [ t ] [ num-types \ type big-generic ] } + } cond ; : simple-combination ( word -- quot ) [ dup ] standard-combination ; diff --git a/library/generic/standard-combination.facts b/library/generic/standard-combination.facts new file mode 100644 index 0000000000..d44ff78390 --- /dev/null +++ b/library/generic/standard-combination.facts @@ -0,0 +1,45 @@ +USING: generic help ; + +HELP: standard-combination "( word picker -- quot )" +{ $values { "word" "a generic word" } { "picker" "a quotation with stack effect " { $snippet "( -- obj )" } } { "quot" "a new quotation" } } +{ $description + "Performs standard method combination:" + { $list + "the word dispatches on the object produced by the picker," + "only the method with most specific class is invoked." + } + "There is an additional feature if the picker is " { $snippet "[ dup ]" } ":" + { $list + "if no suitable method is found, the generic word is called on the object's delegate." + } +} +{ $examples + "A generic word for append strings and characters to a sequence, dispatching on the second stack element:" + { $code + "G: build-string [ over ] standard-combination ;" + "M: string build-string swap nappend ;" + "M: integer build-string push ;" + } +} +{ $see-also POSTPONE: G: define-generic* } ; + +HELP: simple-combination "( word -- quot )" +{ $values { "word" "a generic word" } { "quot" "a new quotation" } } +{ $description + "Performs standard method combination with " { $snippet "[ dup ]" } " as the picker quotation. That is," + { $list + "the word dispatches on the top of the stack," + "only the method with most specific class is invoked," + "if no suitable method is found, the generic word is called on the object's delegate." + } +} +{ $examples "Most generic words in the standard library use this method combination." } +{ $see-also POSTPONE: GENERIC: define-generic } ; + +HELP: define-generic "( word -- )" +{ $values { "word" "a word" } } +{ $description "Defines a generic word with the " { $link simple-combination } " method combination. If the word is already a generic word, existing methods are retained." } +{ $see-also POSTPONE: GENERIC: define-generic* } ; + +HELP: simple-generic f +{ $description "The class of generic words with the " { $link simple-combination } ". They are typically defined by the " { $link POSTPONE: GENERIC: } " parsing word." } ; From 573c4192111d236b6191e6a07ad3c0847a98db21 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 9 Jan 2006 22:56:19 +0000 Subject: [PATCH 227/373] tuple documentation; rename array>tuple to >tuple --- library/bootstrap/boot-stage1.factor | 1 + library/bootstrap/image.factor | 2 +- library/bootstrap/primitives.factor | 2 +- library/generic/tuple.factor | 42 ++++----------- library/generic/tuple.facts | 80 ++++++++++++++++++++++++++++ library/inference/known-words.factor | 4 +- library/kernel.facts | 7 ++- library/syntax/parse-syntax.factor | 2 +- library/syntax/parse-syntax.facts | 23 +++++--- library/syntax/parser.factor | 3 ++ library/syntax/parser.facts | 4 ++ 11 files changed, 124 insertions(+), 46 deletions(-) create mode 100644 library/generic/tuple.facts diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index e557d34c21..4d275cc1dc 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -224,6 +224,7 @@ vectors words ; "/library/generic/math-combination.facts" "/library/generic/slots.facts" "/library/generic/standard-combination.facts" + "/library/generic/tuple.facts" "/library/syntax/parse-stream.facts" "/library/syntax/parser.facts" "/library/syntax/parse-syntax.facts" diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 17db0cf6ca..45f2b2ff32 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -257,7 +257,7 @@ M: string ' ( string -- pointer ) : transfer-tuple ( tuple -- tuple ) tuple>array dup first transfer-word 0 pick set-nth - array>tuple ; + >tuple ; M: tuple ' ( tuple -- pointer ) transfer-tuple diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 3da2cc1f76..4c710e43a1 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -218,7 +218,7 @@ call { "expired?" "alien" } { "" "kernel" } { "(clone)" "kernel-internals" } - { "(array>tuple)" "kernel-internals" } + { "array>tuple" "kernel-internals" } { "tuple>array" "generic" } { "array>vector" "vectors" } { "" "strings" } diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index 967d41e2b0..e4d33fe58a 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -13,14 +13,6 @@ USING: arrays errors hashtables kernel lists math namespaces parser sequences se IN: generic -! Tuples are really arrays in the runtime, but with a different -! type number. The layout is as follows: - -! slot 0 - object header with type number (as usual) -! slot 1 - length, including class/delegate slots -! slot 2 - the class, a word -! slot 3 - the delegate tuple, or f - : class ( object -- class ) dup tuple? [ 2 slot ] [ type type>class ] if ; inline @@ -28,8 +20,6 @@ IN: generic dup tuple? [ 2 slot ] [ drop f ] if ; inline : tuple-predicate ( word -- ) - #! Make a foo? word for testing the tuple class at the top - #! of the stack. dup predicate-word [ \ class-tuple , over literalize , \ eq? , ] [ ] make define-predicate ; @@ -38,8 +28,6 @@ IN: generic dup forget "predicate" word-prop car [ forget ] when* ; : check-shape ( word slots -- ) - #! If the new list of slots is different from the previous, - #! forget the old definition. >r in get lookup dup [ dup "tuple-size" word-prop r> length 2 + = [ drop ] [ forget-tuple ] if @@ -56,9 +44,6 @@ IN: generic 2dup delegate-slots swap append "slots" set-word-prop define-slots ; -: tuple-constructor ( class -- word ) - word-name in get constructor-word dup save-location ; - PREDICATE: word tuple-class "tuple-size" word-prop ; : check-tuple-class ( class -- ) @@ -70,7 +55,7 @@ PREDICATE: word tuple-class "tuple-size" word-prop ; ] [ ] make r> append define-compound ; : default-constructor ( tuple -- ) - [ tuple-constructor ] keep dup [ + [ create-constructor ] keep dup [ "slots" word-prop 1 swap tail-slice reverse-slice [ peek unit , \ keep , ] each ] [ ] make define-constructor ; @@ -86,29 +71,22 @@ PREDICATE: word tuple-class "tuple-size" word-prop ; default-constructor ; M: tuple clone ( tuple -- tuple ) - #! Clone a tuple and its delegate. (clone) dup delegate clone over set-delegate ; -M: tuple hashcode ( vec -- n ) - #! Poor. - array-capacity ; +M: tuple hashcode ( vec -- n ) array-capacity ; M: tuple = ( obj tuple -- ? ) - 2dup eq? [ - 2drop t - ] [ - over tuple? [ tuple= ] [ 2drop f ] if - ] if ; + 2dup eq? + [ 2drop t ] [ over tuple? [ tuple= ] [ 2drop f ] if ] if ; : is? ( obj pred -- ? | pred: obj -- ? ) - #! Tests if the object satisfies the predicate, or if - #! it delegates to an object satisfying it. - [ call ] 2keep rot [ - 2drop t + over [ + 2dup >r >r call + [ r> r> 2drop t ] [ r> delegate r> is? ] if ] [ - over [ >r delegate r> is? ] [ 2drop f ] if + 2drop f ] if ; inline -: array>tuple ( seq -- tuple ) +: >tuple ( seq -- tuple ) >vector dup first "tuple-size" word-prop over set-length - >array (array>tuple) ; + >array array>tuple ; diff --git a/library/generic/tuple.facts b/library/generic/tuple.facts new file mode 100644 index 0000000000..e3658e3980 --- /dev/null +++ b/library/generic/tuple.facts @@ -0,0 +1,80 @@ +USING: generic help kernel kernel-internals ; + +HELP: tuple= "( tuple1 tuple2 -- ? )" +{ $values { "tuple1" "a tuple" } { "tuple2" "a tuple" } } +{ $description "Low-level tuple equality test. Client code should use " { $link = } " instead." } +{ $warning "This word is in the " { $snippet "kernel-internals" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ; + +HELP: tuple f +{ $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." +$terpri +"Tuple classes have additional word properties:" +{ $list + { { $snippet "\"slot-names\"" } " - a sequence of strings naming the tuple's slots" } + { { $snippet "\"tuple-size\"" } " - the number of slots" } +} } +{ $notes "Low-level facilities need to be aware of tuple object layout. It is of no concern to client code. The layout of a tuple in memory is straightforward:" +{ $list + "slot 0 - object header with type number (as usual)" + "slot 1 - number of slots, include class and delegate" + "slot 2 - the tuple's class word" + { "slot 3 - a delegate or " { $link f } } +} } ; + +HELP: class "( object -- class )" +{ $values { "object" "an object" } { "class" "a class word" } } +{ $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either the built-in class, or if the object is a tuple, the tuple class." } +{ $examples { $example "1.0 class ." "float" } { $example "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ; + +HELP: tuple-predicate "( class -- )" +{ $values { "class" "a tuple class word" } } +{ $description "Defines a predicate word that tests if the top of the stack is an instance of " { $snippet class } ". This will only work if " { $snippet class } " is a tuple class." } +$low-level-note ; + +HELP: check-shape "( class slots -- )" +{ $values { "class" "a tuple class word" } { "slots" "a sequence of strings" } } +{ $description "If the new slot list does not have the same length as the current slot list for " { $snippet "class" } ", removes the class word from the dictionary. This allows a new class to be defined, and instances of the old class and the new class can co-exist, with new instances having a different number of slots. This prevents memory corruption if old accessors are called on new instances, or vice versa." +$terpri +"If " { $snippet "class" } " is not a tuple class word, or if no slots are being added or removed, this word does nothing. In this case, it is safe to redefine the class, and have the same set of accessor words operate on old and new instances." } +$low-level-note ; + +HELP: tuple-slots "( class slots -- )" +{ $values { "class" "a tuple class word" } { "slots" "a sequence of strings" } } +{ $description "Defines slot accessor and mutator words for the tuple." } +$low-level-note ; + +HELP: tuple-class f +{ $description "The class of tuple class words." } +{ $examples { $example "TUPLE: name title first last ;\nname tuple-class? ." "t" } } ; + +HELP: define-constructor "( word class def -- )" +{ $values { "word" "a constructor word" } { "class" "a tuple class word" } { "def" "a quotation" } } +{ $description "Define a constructor word for a tuple class. The constructor definition receives a new instance of the class on the stack, with all slots initially set to " { $link f } "." } +{ $see-also POSTPONE: C: } ; + +HELP: default-constructor "( class -- )" +{ $values { "class" "a tuple class word" } } +{ $description "Defines the default constructor for a tuple class. The default constructor fills slot values in from the stack." } +{ $examples { $example "TUPLE: account type balance ;\n\"savings\" 100 ." "T{ account f \"savings\" 100 }" } } ; + +HELP: define-tuple "( class slots -- )" +{ $values { "class" "a new word" } { "slots" "a sequence of strings" } } +{ $description "Defines a tuple class with slots named by " { $snippet "slots" } "." } +{ $see-also POSTPONE: TUPLE: } ; + +HELP: is? "( obj quot -- ? )" +{ $values { "obj" "an object" } { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "?" "a boolean" } } +{ $description "Tests if the object or one of its delegates satisfies the predicate quotation." +$terpri +"Class membership test pridicates only test if an object is a direct instance of that class. Sometimes, you need to check delegates, since this gives a clearer picture of what operations the object supports." } ; + +HELP: >tuple "( seq -- tuple )" +{ $values { "seq" "a sequence" } { "tuple" "a new tuple" } } +{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word, the second a delegate, and the remainder the declared slots." +$terpri +"If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." } +{ $errors "Throws an error if the first element of the sequence is not a tuple class word." } ; + +HELP: tuple>array "( tuple -- array )" +{ $values { "tuple" "a tuple" } { "array" "a new array" } } +{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and the second is the delegate; the remainder are declared slots." } ; diff --git a/library/inference/known-words.factor b/library/inference/known-words.factor index c698c0cc0f..558b1e3026 100644 --- a/library/inference/known-words.factor +++ b/library/inference/known-words.factor @@ -496,8 +496,8 @@ sequences strings vectors words prettyprint ; \ (clone) [ [ object ] [ object ] ] "infer-effect" set-word-prop \ (clone) t "flushable" set-word-prop -\ (array>tuple) [ [ array ] [ tuple ] ] "infer-effect" set-word-prop -\ (array>tuple) t "flushable" set-word-prop +\ array>tuple [ [ array ] [ tuple ] ] "infer-effect" set-word-prop +\ array>tuple t "flushable" set-word-prop \ tuple>array [ [ tuple ] [ array ] ] "infer-effect" set-word-prop \ tuple>array t "flushable" set-word-prop diff --git a/library/kernel.facts b/library/kernel.facts index 51766c4cc2..586f78acb5 100644 --- a/library/kernel.facts +++ b/library/kernel.facts @@ -1,4 +1,4 @@ -USING: help kernel kernel-internals sequences ; +USING: generic help kernel kernel-internals sequences ; HELP: eq? "( obj1 obj2 -- ? )" { $values { "obj1" "an object" } { "obj2" "an object" } } @@ -105,6 +105,11 @@ HELP: num-types "( -- n )" { $values { "n" "a postiive integer" } } { $description "Outputs one more than the maximum value from the " { $link type } " primitive." } ; +HELP: type "( object -- n )" +{ $values { "object" "an object" } { "n" "a type number" } } +{ $description "Outputs an object's type number. Often, the " { $link class } " word is more useful." } +{ $see-also type>class } ; + HELP: ? "( cond true false -- true/false )" { $values { "cond" "a generalized boolean" } { "true" "an object" } { "false" "an object" } { "true/false" "one two input objects" } } { $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ; diff --git a/library/syntax/parse-syntax.factor b/library/syntax/parse-syntax.factor index 906bf39d3f..4a4d3dc70e 100644 --- a/library/syntax/parse-syntax.factor +++ b/library/syntax/parse-syntax.factor @@ -32,7 +32,7 @@ SYMBOL: t : V{ [ >vector ] [ ] ; parsing : H{ [ alist>hash ] [ ] ; parsing : C{ [ first2 rect> ] [ ] ; parsing -: T{ [ array>tuple ] [ ] ; parsing +: T{ [ >tuple ] [ ] ; parsing : W{ [ first ] [ ] ; parsing : POSTPONE: scan-word swons ; parsing : \ scan-word literalize swons ; parsing diff --git a/library/syntax/parse-syntax.facts b/library/syntax/parse-syntax.facts index 03d9758833..00342ab611 100644 --- a/library/syntax/parse-syntax.facts +++ b/library/syntax/parse-syntax.facts @@ -97,7 +97,7 @@ HELP: : "word definition... ;" { $values { "word" "a new word to define" } { "definition" "a word definition" } } { $description "Defines a compound word in the current vocabulary." } { $examples { $code ": ask-name ( -- name )\n \"What is your name? \" write readln ;\n: greet ( name -- ) \"Greetings, \" write print ;\n: friend ( -- ) ask-name greet ;" } } -{ $see-also POSTPONE: ; } ; +{ $see-also POSTPONE: ; define-compound } ; HELP: ; "" { $description @@ -198,21 +198,25 @@ HELP: GENERIC: "word" $terpri "This parsing word is equivalent to the following usage of the more general " { $link POSTPONE: G: } " word:" { $code "G: word simple-combination ;" } -} ; +} +{ $see-also define-generic } ; HELP: G: "word combination... ;" { $values { "word" "a new word to define" } { "combination" "a method combination definition with stack effect " { $snippet "( word -- quot )" } } } { $description "Defines a generic word using the long-form. A method combination is a quotation that is given the generic word on the stack, and outputs a quotation " { $emphasis "that becomes the definition of the word" } "." } -{ $contract "The method combination quotation is called each time the generic word has to be updated (for example, when a method is added), and thus must be side-effect free." } ; +{ $contract "The method combination quotation is called each time the generic word has to be updated (for example, when a method is added), and thus must be side-effect free." } +{ $see-also define-generic* } ; HELP: M: "class generic definition... ;" { $values { "class" "a class word" } { "generic" "a generic word" } { "definition" "a method definition" } } -{ $description "Defines a method, that is, a behavior for the generic word specialized on instances of the class." } ; +{ $description "Defines a method, that is, a behavior for the generic word specialized on instances of the class." } +{ $see-also define-method } ; HELP: UNION: "class members... ;" { $values { "class" "a new class word to define" } { "members" "a list of class words separated by whitespace" } } { $description "Defines a union class. An object is an instance of a union class if it is an instance of one of its members." } -{ $notes "Union classes are used to associate the same method with several different classes, as well as to conveniently define predicates." } ; +{ $notes "Union classes are used to associate the same method with several different classes, as well as to conveniently define predicates." } +{ $see-also define-union } ; HELP: PREDICATE: "superclass class predicate... ;" { $values { "superclass" "an existing class word" } { "class" "a new class word to define" } { "predicate" "membership test with stack effect " { $snippet "( superclass -- ? )" } } } @@ -225,13 +229,15 @@ HELP: PREDICATE: "superclass class predicate... ;" "it satisfies the predicate" } "Each predicate must be defined as a subclass of some other class. This ensures that predicates inheriting from disjoint classes do not need to be exhaustively tested during method dispatch." -} ; +} +{ $see-also define-predicate-class } ; HELP: TUPLE: "class slots... ;" { $values { "class" "a new class word to define" } { "slots" "a list of slot names" } } { $description "Defines a new tuple class with membership predicate " { $snippet "name?" } " and constructor " { $snippet "" } "." $terpri -"Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ; +"Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } +{ $see-also define-tuple } ; HELP: C: "class definition... ;" { $values { "class" "a class word" } { "generic" "a generic word" } { "definition" "a constructor definition" } } @@ -239,4 +245,5 @@ HELP: C: "class definition... ;" $terpri "Constructors are named after the tuple class surrounded in angle brackets: " { $snippet "<" } " and " { $snippet ">" } "." } { $contract "The definition must only have one output, the new tuple itself." } -{ $notes "Each tuple class defines a default constructor that reads slot values from the stack. This parsing word redefines the default constructor." } ; +{ $notes "Each tuple class defines a default constructor that reads slot values from the stack. This parsing word redefines the default constructor." } +{ $see-also define-constructor } ; diff --git a/library/syntax/parser.factor b/library/syntax/parser.factor index 8b5b26acd9..15292062bc 100644 --- a/library/syntax/parser.factor +++ b/library/syntax/parser.factor @@ -62,6 +62,9 @@ C: parse-error ( error -- error ) : create-in in get create dup save-location ; +: create-constructor ( class -- word ) + word-name in get constructor-word dup save-location ; + : CREATE ( -- word ) scan create-in ; SYMBOL: string-mode diff --git a/library/syntax/parser.facts b/library/syntax/parser.facts index 022ce17d0b..9f75047bdf 100644 --- a/library/syntax/parser.facts +++ b/library/syntax/parser.facts @@ -92,6 +92,10 @@ HELP: create-in "( word -- )" { $description "Creates a word in the current vocabulary. Until re-defined, the word throws an error when invoked." } $parsing-note ; +HELP: create-constructor "( word -- constructor )" +{ $values { "class" "a word" } { "constructor" "a new word" } } +{ $description "Creates a new word in the current vocabulary, named by surrounding " { $link "word" } " with angle brackets." } ; + HELP: CREATE "( -- word )" { $values { "word" "a word" } } { $description "Reads the next token from the line currently being parsed, and creates a word with that name in the current vocabulary." } From b67c8ceb16c62f9328740e8ea0d851de966ac357 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 10 Jan 2006 02:17:58 +0000 Subject: [PATCH 228/373] boxing a null pointer pushes f --- native/alien.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/native/alien.c b/native/alien.c index ce78b6ecd7..022be5050a 100644 --- a/native/alien.c +++ b/native/alien.c @@ -59,9 +59,12 @@ ALIEN* alien(void* ptr) return alien; } -void box_alien(void* ptr) +void box_alien(void *ptr) { - dpush(tag_object(alien(ptr))); + if(ptr == NULL) + dpush(F); + else + dpush(tag_object(alien(ptr))); } void primitive_alien(void) From 6031ec0d76f58bba7a5a64561489c590ec081a9d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Jan 2006 04:44:17 +0000 Subject: [PATCH 229/373] documentation work; objective C runtime binding --- doc/handbook/objects.facts | 189 +++++++++++++++++++++ library/alien/compiler.factor | 6 +- library/alien/objective-c/runtime.factor | 129 ++++++++++++++ library/bootstrap/boot-stage1.factor | 1 + library/collections/hashtables.factor | 2 +- library/collections/slicing.factor | 3 +- library/collections/tree-each.factor | 2 +- library/generic/generic.facts | 6 + library/generic/math-combination.facts | 15 +- library/math/float.factor | 1 + library/math/math.factor | 2 - library/syntax/parse-syntax.factor | 2 +- library/syntax/parse-syntax.facts | 2 +- library/test/collections/hashtables.factor | 2 +- 14 files changed, 350 insertions(+), 12 deletions(-) create mode 100644 doc/handbook/objects.facts create mode 100644 library/alien/objective-c/runtime.factor diff --git a/doc/handbook/objects.facts b/doc/handbook/objects.facts new file mode 100644 index 0000000000..7b6c89a883 --- /dev/null +++ b/doc/handbook/objects.facts @@ -0,0 +1,189 @@ +USING: generic help kernel lists sequences ; +GLOSSARY: "object" "a datum which may appear on the stack" ; + +ARTICLE: "objects" "Objects" +"Objects model data in Factor. Objects have unique identity, and either hold intrinsic value -- for example, an integer object -- or are composed from named slots, each slot holding an object." +{ $subsection "equality" } +{ $subsection "generic" } +{ $subsection "classes" } +{ $subsection "tuples" } ; + +GLOSSARY: "equal" "two objects are equal if they have the same class and if their slots are equal, or alternatively, if both are numbers denoting the same value" ; + +ARTICLE: "equality" "Equality and comparison testing" +"There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object, or you can test if two objects are equal in some sense, usually by being instances of the same class, and having equal slot values. Both notions of equality are equality relations in the mathematical sense." +{ $subsection eq? } +{ $subsection = } +"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":" +{ $subsection <=> } +"An object can be cloned; the clone has distinct identity but equal value:" +{ $subsection clone } ; + +GLOSSARY: "generic word" "a word defined via the " { $link POSTPONE: GENERIC: } " or " { $link POSTPONE: G: } " parsing word. A generic word is comprised of a set of methods and a method combination. Methods are keyed by classes, and the method combination determines which stack element is inspected and which methods are called when the generic word executes." ; + +GLOSSARY: "method" +"gives the behavior of a generic word when dispatching on a specific class" ; + +ARTICLE: "generic" "Generic words and methods" +"A generic word's behavior depends on the class of the object at the top of the stack, although this can be generalized using custom method combination. A specific behavior of a generic word on a class is called a " { $emphasis "method" } "." +$terpri +"The key advantage of a generic word over a set of conditional tests is that methods are defined in a decentralized manner, thus adding new methods does not force unnecessary coupling between code." +$terpri +"In the overwhelming majority of cases, your interaction with the generic word system centers on two parsing words:" +{ $subsection POSTPONE: GENERIC: } +{ $subsection POSTPONE: M: } +"Since classes are not linearly ordered, method ordering is an issue to keep in mind." +{ $subsection "method-order" } +{ $subsection "method-combination" } ; + +ARTICLE: "method-order" "Method ordering" +"If two classes have a non-empty intersection, there is no guarantee that one is a subclass of the other. This means there is no canonical linear ordering of classes." +$terpri +"Consider the following set of definitions:" +{ $code + "GENERIC: explain" + "M: general-t explain drop \"a true value\" print ;" + "M: general-list explain drop \"a list\" print ;" + "M: object explain drop \"an object\" print ;" +} +"Neither " { $link general-t } " nor " { $link general-list } " contains the other, yet their intersection is the non-empty " { $link cons } " class. So the generic word system will place " { $link object } " first in the method order, however either " { $link general-t } " or " { $link general-list } " may come next, and it is pretty much a random choice that depends on hashing:" +{ $example "\\ bar order ." "{ object general-list general-t }" } +"Therefore, the outcome of calling " { $snippet "bar" } " with a cons cell as input is undefined." +$terpri +"As you can see above, the " { $link order } " word can be useful to clarify method dispatch." +{ $subsection order } ; + +GLOSSARY: "method combination" "control flow glue between methods in a generic word" ; + +ARTICLE: "method-combination" "Method combination" +"Abstractly, a generic word can be thought of as a big chain of type conditional tests applied to the top of the stack, with methods as the bodies of each test. The " { $emphasis "method combination" } " is this control flow glue between the set of methods, and several aspects of it can be customized:" +{ $list + "which stack item(s) the generic word dispatches upon," + "which methods out of the set of applicable methods are called" +} +"The " { $link POSTPONE: GENERIC: } " parsing word creates a generic word using the " { $emphasis "simple method combination." } ". Most generic words that come up in practice use this method combination:" +{ $subsection simple-combination } +"The " { $link POSTPONE: G: } " parsing word allows a different method combination to be specified:" +{ $subsection POSTPONE: G: } +"The simple method combination is a special case of the standard method combination:" +{ $subsection standard-combination } +"Another combination for arithmetic operators:" +{ $subsection math-combination } +"If nothing else will do:" +{ $subsection "custom-combination" } ; + +ARTICLE: "custom-combination" "Custom method combination" +"Developing a custom method combination requires a good understanding of higher-order programming (code that writes code) and Factor internals. Custom method combination has not been fully explored at this stage of Factor development, and this section can only give a brief sketch of what is involved." +$terpri +"A method combination quotation has stack effect " { $snippet "( word -- quot )" } "." +$terpri +"Generic words can be introspected:" +{ $subsection methods } +"Code generation utilities:" +{ $subsection alist>quot } +{ $subsection curry } +"Generic word generation utilities:" +{ $subsection class-predicates } +{ $subsection simplify-alist } +{ $subsection math-upgrade } +{ $subsection object-method } ; + +GLOSSARY: "class" "a set of objects on which generic words can specialize methods" ; + +ARTICLE: "classes" "Classes" +"A class is a set of objects on which generic words can specialize methods. Each class has a membership predicate named after the class with a \"?\" suffix, with the following two exceptions:" +{ $list + { { $link object } " - there is no need for a predicate word, since every object is an instance of this class" } + { { $link general-t } " - there is no need for a predicate word, since the " { $link if } " combinator makes an implicit test for instances of this class" } +} +{ $subsection object } +{ $subsection "builtin-classes" } +{ $subsection "unions" } +{ $subsection "predicates" } +{ $subsection "class-operations" } ; + +GLOSSARY: "type" "an object invariant that describes its shape. An object's type is constant for the lifetime of the object, and there is only a fixed number of types built-in to the run-time. See class" ; + +GLOSSARY: "built-in class" "see type" ; + +ARTICLE: "builtin-classes" "Built-in classes" +"Every object is an instance of to exactly one type, and the type is constant for the lifetime of the object. There is only a fixed number of types built-in to the run-time, and corresponding to each type is a \emph{built-in class}:" +{ $code + "alien" + "array" + "bignum" + "byte-array" + "complex" + "cons" + "displaced-alien" + "dll" + "f" + "fixnum" + "float" + "ratio" + "sbuf" + "string" + "t" + "tuple" + "vector" + "word" + "wrapper" +} +{ $subsection type } +{ $subsection class } ; + +GLOSSARY: "union" "a class whose set of instances is the union of the set of instances of a list of member classes" ; + +ARTICLE: "unions" "Union classes" +"An object is an instance of a union class if it is an instance of one of its members. Union classes are used to associate the same method with several different classes, as well as to conveniently define predicates." +{ $subsection POSTPONE: UNION: } +{ $subsection define-union } +{ $subsection union } ; + +GLOSSARY: "predicate" "a word with stack effect " { $snippet "( object -- ? )" } ", or alternatively, a class whose instances are the instances of a superclass that satisfy an arbitrary predicate" ; + +ARTICLE: "predicates" "Predicate classes" +"Predicate classes allow fine-grained control over method dispatch." +{ $subsection POSTPONE: PREDICATE: } +{ $subsection define-predicate-class } +{ $subsection predicate } ; + +ARTICLE: "class-operations" "Class operations" +{ $subsection class< } +{ $subsection class-compare } +{ $subsection class-and } +{ $subsection types } ; + +ARTICLE: "tuples" "Tuples" +"Tuples are user-defined classes composed of named slots. All tuples have the same type, however distinct classes of tuples are defined." +$terpri +"A parsing word defines tuple classes." +{ $subsection POSTPONE: TUPLE: } +{ $subsection "tuple-constructors" } +; + +GLOSSARY: "constructor" "a word whose primary role is to create new instances of a class" ; + +ARTICLE: "tuple-constructors" "Constructors and slots" +"New instances of tuple classes are created by calling a constructor word, whose name is the tuple's name surrounded by angle brackets:" +{ $code "TUPLE: point x y z ;\n1 2 3 " } +"The default constructor stores stack elements into consecutive slots, with the top of the stack going into the rightmost slot." +$terpri +"After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." +$terpri +"Custom constructors can be defined:" +{ $subsection POSTPONE: C: } ; + +GLOSSARY: "delegate" "an object acting as a sink for unhandled method calls on behalf of another object" ; + +ARTICLE: "tuple-delegation" "Delegation" +"Each tuple can have an optional delegate tuple. Most generic words called on the tuple that do not have a method for the tuple's class will be passed on to the delegate." +$terpri +"More precisely, any generic word using " { $link simple-combination } " delegates, and this includes all generic words defined via the " { $link POSTPONE: GENERIC: } " parsing word." +$terpri +"Factor uses delegation in place of implementation inheritance, but it is not a direct substitute; in particular, the semantics differ in that a delegated method call receives the delegate on the stack, not the original object." +{ $warning "Delegation to objects that are not tuples is not fully supported. Generic words support delegation to arbitrary types, as do slot accessors which are built from generic words. However, type-specific primitives do not." } +{ $subsection delegate } +{ $subsection set-delegate } +"There is a combinator to recursively apply a predicate to a delegate chain:" +{ $subsection is? } ; diff --git a/library/alien/compiler.factor b/library/alien/compiler.factor index 60b79b6c1e..9922ee64fc 100644 --- a/library/alien/compiler.factor +++ b/library/alien/compiler.factor @@ -74,13 +74,13 @@ C: alien-node make-node ; dup class get swap fastcall-regs >= ; : spill-param ( reg-class -- n reg-class ) - reg-size stack-params [ tuck + ] change + reg-class-size stack-params [ tuck + ] change T{ stack-params } ; : inc-reg-class ( reg-class -- ) #! On Mac OS X, float parameters 'shadow' integer registers. dup class inc dup float-regs? dual-fp/int-regs? and [ - int-regs [ over reg-size 4 / + ] change + int-regs [ over reg-class-size 4 / + ] change ] when drop ; : fastcall-param ( reg-class -- n reg-class ) @@ -124,7 +124,7 @@ M: alien-node linearize* ( node -- ) dup linearize-return linearize-next ; : parse-arglist ( lst -- types stack effect ) - 2 swap group unpair [ + unpair [ " " % [ "," ?tail drop % " " % ] each "-- " % ] "" make ; diff --git a/library/alien/objective-c/runtime.factor b/library/alien/objective-c/runtime.factor new file mode 100644 index 0000000000..5d6ef7589c --- /dev/null +++ b/library/alien/objective-c/runtime.factor @@ -0,0 +1,129 @@ +IN: objective-c +USING: alien arrays compiler kernel lists namespaces parser +sequences words ; + +TYPEDEF: void* SEL + +TYPEDEF: void* id + +FUNCTION: char* sel_getName ( SEL aSelector ) ; + +FUNCTION: bool sel_isMapped ( SEL aSelector ) ; + +FUNCTION: SEL sel_registerName ( char* str ) ; + +TUPLE: selector name object ; + +C: selector ( name -- sel ) [ set-selector-name ] keep ; + +: selector-valid? ( selector -- ? ) + selector-object dup [ expired? not ] when ; + +: selector ( selector -- alien ) + dup selector-valid? [ + selector-object + ] [ + dup selector-name sel_registerName + dup rot set-selector-object + ] if ; + +BEGIN-STRUCT: objc-class + FIELD: void* isa + FIELD: void* super-class + FIELD: char* name + FIELD: long version + FIELD: long info + FIELD: long instance-size + FIELD: void* ivars + FIELD: void* methodLists + FIELD: void* cache + FIELD: void* protocols +END-STRUCT + +FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ; compiled + +: objc-classes ( -- seq ) + f 0 objc_getClassList + [ "void*" dup ] keep objc_getClassList + [ swap void*-nth objc-class-name ] map-with ; + +FUNCTION: objc-class* objc_getClass ( char* class ) ; + +FUNCTION: objc-class* objc_getMetaClass ( char* class ) ; + +FUNCTION: id class_createInstance ( objc-class* class, uint additionalByteCount ) ; + +FUNCTION: id class_createInstanceFromZone ( objc-class* class, uint additionalByteCount, void* zone ) ; + +BEGIN-STRUCT: objc-method + FIELD: SEL name + FIELD: char* types + FIELD: void* imp +END-STRUCT + +FUNCTION: objc-method* class_getInstanceMethod ( objc-class* class, SEL selector ) ; + +FUNCTION: objc-method* class_getClassMethod ( objc-class* class, SEL selector ) ; + +BEGIN-STRUCT: objc-method-list + FIELD: void* obsolete + FIELD: int count + FIELD: objc-method elements +END-STRUCT + +FUNCTION: objc-method-list* class_nextMethodList ( objc-class* class, void** iterator ) ; + +FUNCTION: void class_addMethods ( objc-class* class, objc-method-list* methodList ) ; + +FUNCTION: void class_removeMethods ( objc-class* class, objc-method-list* methodList ) ; + +FUNCTION: uint method_getNumberOfArguments ( objc-method* method ) ; + +FUNCTION: uint method_getSizeOfArguments ( objc-method* method ) ; + +: method-list>seq ( method-list -- seq ) + dup objc-method-list-elements swap objc-method-list-count [ + swap objc-method-nth objc-method-name sel_getName + ] map-with ; + +: (objc-methods) ( objc-class iterator -- ) + 2dup class_nextMethodList [ + method-list>seq % (objc-methods) + ] [ + 2drop + ] if* ; + +: objc-methods ( class -- seq ) + [ objc_getClass f (objc-methods) ] { } make ; + +: OBJC-CLASS: + #! Syntax: name + CREATE dup word-name + [ objc_getClass ] curry define-compound ; parsing + +: make-dip ( quot n -- quot ) + dup \ >r -rot \ r> append3 ; + +: make-msg-send ( returns args selector -- ) + [ selector ] curry over length make-dip [ + % + swap , + [ f "objc_msgSend" ] % + [ "id" "SEL" ] swap append , + \ alien-invoke , + ] [ ] make ; + +: define-msg-send ( returns types selector -- ) + [ make-msg-send "[" ] keep "]" append3 create-in + swap define-compound ; + +: msg-send-args ( args -- types selector ) + dup length 1 = + [ first { } ] [ unpair >r concat r> ] if swap ; + +: OBJC-MESSAGE: + scan string-mode on + [ string-mode off msg-send-args define-msg-send ] f ; + parsing + +"objective-c" words [ try-compile ] each diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 4d275cc1dc..3de5afc094 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -234,6 +234,7 @@ vectors words ; "/doc/handbook/collections.facts" "/doc/handbook/dataflow.facts" + "/doc/handbook/objects.facts" "/doc/handbook/parser.facts" "/doc/handbook/sequences.facts" "/doc/handbook/syntax.facts" diff --git a/library/collections/hashtables.factor b/library/collections/hashtables.factor index 638e78ad53..6d778f2adf 100644 --- a/library/collections/hashtables.factor +++ b/library/collections/hashtables.factor @@ -252,6 +252,6 @@ M: hashtable = ( obj hash -- ? ) ] if* ; inline : map>hash ( seq quot -- hash | quot: key -- key value ) - swap [ length ] keep + over length rot [ -rot [ >r call swap r> set-hash ] 2keep ] each nip ; inline diff --git a/library/collections/slicing.factor b/library/collections/slicing.factor index 17424e42c3..eb77a22ba1 100644 --- a/library/collections/slicing.factor +++ b/library/collections/slicing.factor @@ -101,7 +101,8 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ; tuck swap tail-slice >r swap tail-slice r> ; : unpair ( seq -- firsts seconds ) - flip dup empty? [ drop { } { } ] [ first2 ] if ; + 2 swap group flip + dup empty? [ drop { } { } ] [ first2 ] if ; : concat ( seq -- seq ) dup empty? [ [ [ % ] each ] over first make ] unless ; diff --git a/library/collections/tree-each.factor b/library/collections/tree-each.factor index 82bb263ebd..9d9c200aff 100644 --- a/library/collections/tree-each.factor +++ b/library/collections/tree-each.factor @@ -7,7 +7,7 @@ G: tree-each* ( obj quot -- | quot: elt -- ) [ over ] standard-combination ; inline : tree-each ( obj quot -- | quot: elt -- ) - [ call ] 2keep tree-each* ; + [ call ] 2keep tree-each* ; inline : tree-each-with ( obj vector quot -- ) swap [ with ] tree-each 2drop ; inline diff --git a/library/generic/generic.facts b/library/generic/generic.facts index e5080362f4..1dc16b1f57 100644 --- a/library/generic/generic.facts +++ b/library/generic/generic.facts @@ -7,6 +7,12 @@ HELP: typemap f HELP: builtins f { $description "Global variable. Vector mapping type numbers to builtin class words." } ; +HELP: object f +{ $description + "The class of all objects. If a generic word defines a method specializing on this class, the method is used as a fallback, if no other applicable method is found. For instance:" + { $code "GENERIC: enclose" "M: number enclose 1array ;" "M: object enclose ;" } +} ; + HELP: type>class "( n -- class )" { $values { "n" "a non-negative integer" } { "class" "a class word" } } { $description "Outputs a builtin class whose instances are precisely those of a builtin type." } diff --git a/library/generic/math-combination.facts b/library/generic/math-combination.facts index 19e9b45739..58904ed6f9 100644 --- a/library/generic/math-combination.facts +++ b/library/generic/math-combination.facts @@ -32,7 +32,20 @@ HELP: math-class? "( object -- ? )" HELP: math-combination "( word -- quot )" { $values { "word" "a generic word" } { "quot" "a quotation" } } -{ $description "Generates a double-dispatching word definition. Only methods defined on numerical classes and " { $link object } " take effect in the math combination. Methods defined on numerical classes are guaranteed to have their two inputs upgraded to the highest priority type of the two." } ; +{ $description "Generates a double-dispatching word definition. Only methods defined on numerical classes and " { $link object } " take effect in the math combination. Methods defined on numerical classes are guaranteed to have their two inputs upgraded to the highest priority type of the two." +$terpri +"The math method combination is used for binary operators such as " { $link + } " and " { $link * } "." +$terpri +"A method can only be added to a generic word using the math combination if the method specializes on one of the below classes, or a union defined over one or more of the below classes:" +{ $code + "fixnum" + "bignum" + "ratio" + "float" + "complex" + "object" +} +"The math combination performs numerical upgrading as described in " { $link "number-protocol" } "." } ; HELP: 2generic f { $description "The class of generic words with the math combination." } ; diff --git a/library/math/float.factor b/library/math/float.factor index 8bcc198aa1..aa989e800b 100644 --- a/library/math/float.factor +++ b/library/math/float.factor @@ -9,6 +9,7 @@ M: real abs dup 0 < [ neg ] when ; M: real absq sq ; M: real hashcode ( n -- n ) >fixnum ; +M: real <=> - ; M: float number= float= ; M: float < float< ; diff --git a/library/math/math.factor b/library/math/math.factor index ca7a7107a9..b275e0c4d8 100644 --- a/library/math/math.factor +++ b/library/math/math.factor @@ -77,5 +77,3 @@ GENERIC: absq ( n -- |n|^2 ) foldable swap [ >r dup slip r> ] repeat drop ; inline GENERIC: number>string ( str -- num ) foldable - -M: real <=> - ; diff --git a/library/syntax/parse-syntax.factor b/library/syntax/parse-syntax.factor index 4a4d3dc70e..e27e0dd86b 100644 --- a/library/syntax/parse-syntax.factor +++ b/library/syntax/parse-syntax.factor @@ -63,7 +63,7 @@ DEFER: PRIMITIVE: parsing parsing : C: - scan-word [ tuple-constructor ] keep + scan-word [ create-constructor ] keep [ define-constructor ] [ ] ; parsing : FORGET: scan use get hash-stack [ forget ] when* ; parsing diff --git a/library/syntax/parse-syntax.facts b/library/syntax/parse-syntax.facts index 00342ab611..b1cc8ac7cd 100644 --- a/library/syntax/parse-syntax.facts +++ b/library/syntax/parse-syntax.facts @@ -1,4 +1,4 @@ -USING: help kernel math ; +USING: generic help kernel math words ; HELP: parsing "" { $description "Declares the most recently defined word as a parsing word." } diff --git a/library/test/collections/hashtables.factor b/library/test/collections/hashtables.factor index 43892fada8..a8df5ae499 100644 --- a/library/test/collections/hashtables.factor +++ b/library/test/collections/hashtables.factor @@ -13,7 +13,7 @@ USE: prettyprint [ H{ } ] [ { } [ ] map>hash ] unit-test -1000 [ sq ] map>hash "testhash" set +[ ] [ 1000 [ dup sq ] map>hash "testhash" set ] unit-test [ V{ } ] [ 1000 [ dup sq swap "testhash" get hash = not ] subset ] From bbf871e28ae5ed6e6b85fa2f47bbf430166ae45b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Jan 2006 04:56:00 +0000 Subject: [PATCH 230/373] split objective c bindings into files --- library/alien/objective-c/runtime.factor | 73 +----------------------- library/alien/objective-c/syntax.factor | 14 +++++ library/alien/objective-c/utils.factor | 60 +++++++++++++++++++ library/alien/syntax.factor | 2 +- library/bootstrap/boot-stage1.factor | 8 ++- 5 files changed, 84 insertions(+), 73 deletions(-) create mode 100644 library/alien/objective-c/syntax.factor create mode 100644 library/alien/objective-c/utils.factor diff --git a/library/alien/objective-c/runtime.factor b/library/alien/objective-c/runtime.factor index 5d6ef7589c..40b96017d3 100644 --- a/library/alien/objective-c/runtime.factor +++ b/library/alien/objective-c/runtime.factor @@ -1,6 +1,6 @@ +! Copyright (C) 2006 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. IN: objective-c -USING: alien arrays compiler kernel lists namespaces parser -sequences words ; TYPEDEF: void* SEL @@ -12,21 +12,6 @@ FUNCTION: bool sel_isMapped ( SEL aSelector ) ; FUNCTION: SEL sel_registerName ( char* str ) ; -TUPLE: selector name object ; - -C: selector ( name -- sel ) [ set-selector-name ] keep ; - -: selector-valid? ( selector -- ? ) - selector-object dup [ expired? not ] when ; - -: selector ( selector -- alien ) - dup selector-valid? [ - selector-object - ] [ - dup selector-name sel_registerName - dup rot set-selector-object - ] if ; - BEGIN-STRUCT: objc-class FIELD: void* isa FIELD: void* super-class @@ -40,12 +25,7 @@ BEGIN-STRUCT: objc-class FIELD: void* protocols END-STRUCT -FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ; compiled - -: objc-classes ( -- seq ) - f 0 objc_getClassList - [ "void*" dup ] keep objc_getClassList - [ swap void*-nth objc-class-name ] map-with ; +FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ; FUNCTION: objc-class* objc_getClass ( char* class ) ; @@ -80,50 +60,3 @@ FUNCTION: void class_removeMethods ( objc-class* class, objc-method-list* method FUNCTION: uint method_getNumberOfArguments ( objc-method* method ) ; FUNCTION: uint method_getSizeOfArguments ( objc-method* method ) ; - -: method-list>seq ( method-list -- seq ) - dup objc-method-list-elements swap objc-method-list-count [ - swap objc-method-nth objc-method-name sel_getName - ] map-with ; - -: (objc-methods) ( objc-class iterator -- ) - 2dup class_nextMethodList [ - method-list>seq % (objc-methods) - ] [ - 2drop - ] if* ; - -: objc-methods ( class -- seq ) - [ objc_getClass f (objc-methods) ] { } make ; - -: OBJC-CLASS: - #! Syntax: name - CREATE dup word-name - [ objc_getClass ] curry define-compound ; parsing - -: make-dip ( quot n -- quot ) - dup \ >r -rot \ r> append3 ; - -: make-msg-send ( returns args selector -- ) - [ selector ] curry over length make-dip [ - % - swap , - [ f "objc_msgSend" ] % - [ "id" "SEL" ] swap append , - \ alien-invoke , - ] [ ] make ; - -: define-msg-send ( returns types selector -- ) - [ make-msg-send "[" ] keep "]" append3 create-in - swap define-compound ; - -: msg-send-args ( args -- types selector ) - dup length 1 = - [ first { } ] [ unpair >r concat r> ] if swap ; - -: OBJC-MESSAGE: - scan string-mode on - [ string-mode off msg-send-args define-msg-send ] f ; - parsing - -"objective-c" words [ try-compile ] each diff --git a/library/alien/objective-c/syntax.factor b/library/alien/objective-c/syntax.factor new file mode 100644 index 0000000000..25663a977d --- /dev/null +++ b/library/alien/objective-c/syntax.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2006 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +IN: !syntax +USING: kernel lists namespaces objective-c parser syntax words ; + +: OBJC-CLASS: + #! Syntax: name + CREATE dup word-name + [ objc_getClass ] curry define-compound ; parsing + +: OBJC-MESSAGE: + scan string-mode on + [ string-mode off msg-send-args define-msg-send ] f ; + parsing diff --git a/library/alien/objective-c/utils.factor b/library/alien/objective-c/utils.factor new file mode 100644 index 0000000000..a856f9ca85 --- /dev/null +++ b/library/alien/objective-c/utils.factor @@ -0,0 +1,60 @@ +! Copyright (C) 2006 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +IN: objective-c +USING: alien arrays kernel lists namespaces parser sequences +words ; + +TUPLE: selector name object ; + +C: selector ( name -- sel ) [ set-selector-name ] keep ; + +: selector-valid? ( selector -- ? ) + selector-object dup [ expired? not ] when ; + +: selector ( selector -- alien ) + dup selector-valid? [ + selector-object + ] [ + dup selector-name sel_registerName + dup rot set-selector-object + ] if ; + +: objc-classes ( -- seq ) + f 0 objc_getClassList + [ "void*" dup ] keep objc_getClassList + [ swap void*-nth objc-class-name ] map-with ; + +: method-list>seq ( method-list -- seq ) + dup objc-method-list-elements swap objc-method-list-count [ + swap objc-method-nth objc-method-name sel_getName + ] map-with ; + +: (objc-methods) ( objc-class iterator -- ) + 2dup class_nextMethodList [ + method-list>seq % (objc-methods) + ] [ + 2drop + ] if* ; + +: objc-methods ( class -- seq ) + [ objc_getClass f (objc-methods) ] { } make ; + +: make-dip ( quot n -- quot ) + dup \ >r -rot \ r> append3 ; + +: make-msg-send ( returns args selector -- ) + [ selector ] curry over length make-dip [ + % + swap , + [ f "objc_msgSend" ] % + [ "id" "SEL" ] swap append , + \ alien-invoke , + ] [ ] make ; + +: define-msg-send ( returns types selector -- ) + [ make-msg-send "[" ] keep "]" append3 create-in + swap define-compound ; + +: msg-send-args ( args -- types selector ) + dup length 1 = + [ first { } ] [ unpair >r concat r> ] if swap ; diff --git a/library/alien/syntax.factor b/library/alien/syntax.factor index 976665a4ec..ca3130cfb6 100644 --- a/library/alien/syntax.factor +++ b/library/alien/syntax.factor @@ -1,5 +1,5 @@ ! Copyright (C) 2005 Alex Chapman. -! See http://factor.sf.net/license.txt for BSD license. +! See http://factorcode.org/license.txt for BSD license. IN: !syntax USING: alien compiler kernel lists math namespaces parser sequences syntax words ; diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 3de5afc094..75ca533654 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -1,5 +1,5 @@ -! Copyright (C) 2004, 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. +! Copyright (C) 2004, 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. IN: image USING: errors generic hashtables io kernel kernel-internals lists math memory namespaces parser prettyprint sequences @@ -144,6 +144,10 @@ vectors words ; "/library/alien/syntax.factor" "/library/alien/malloc.factor" + "/library/alien/objective-c/runtime.factor" + "/library/alien/objective-c/utils.factor" + "/library/alien/objective-c/syntax.factor" + "/library/io/buffer.factor" "/library/cli.factor" From 1167a22e10c8bd62c6bbfc14cc316d4e15f21016 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Jan 2006 05:22:01 +0000 Subject: [PATCH 231/373] an example; update change log --- CHANGES.html | 9 ++++++ examples/cocoa-speech.factor | 36 ++++++++++++++++++++++++ library/alien/objective-c/runtime.factor | 2 ++ 3 files changed, 47 insertions(+) create mode 100644 examples/cocoa-speech.factor diff --git a/CHANGES.html b/CHANGES.html index 2f7d3ac838..d7e4047d7a 100644 --- a/CHANGES.html +++ b/CHANGES.html @@ -48,6 +48,15 @@ this is lexicographic order, and for words, this compares word names.
  • C library interface:
      +
    • Support for binding to Objective C libraries is now included. +
        +
      • Normal usage of Objective C classes and methods is done using the OBJC-CLASS: +and OBJC-MESSAGE: parsing words. See the example in +examples/cocoa-speech.factor.
        • +
      • Objective C runtime introspection functions and structures are defined in the +objective-c vocabulary.
        • +
      +
    • Added a pair of words for between Factor strings and C strings, alien>string and string>alien.
      • diff --git a/examples/cocoa-speech.factor b/examples/cocoa-speech.factor new file mode 100644 index 0000000000..cb2fcf422a --- /dev/null +++ b/examples/cocoa-speech.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2006 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. + +! This example requires Mac OS X. It has only been tested on +! 10.4. It must be run from a Factor runtime linked against the +! Cocoa library; you can obtain one with the 'macosx-sdl' target +! in the Makefile. + +IN: cocoa-speech +USING: alien compiler kernel objective-c sequences words ; + +! Define classes and messages +OBJC-MESSAGE: id alloc ; +OBJC-CLASS: NSString +: NSASCIIStringEncoding 1 ; inline +OBJC-MESSAGE: id initWithCString: char* encoding: uint ; +OBJC-CLASS: NSSpeechSynthesizer +OBJC-MESSAGE: id initWithVoice: id ; +OBJC-MESSAGE: bool startSpeakingString: id ; + +! A utility +: ( string -- alien ) + NSString [alloc] + swap NSASCIIStringEncoding [initWithCString:encoding:] ; + +! As usual, alien invoke words need to be compiled +"cocoa-speech" words [ try-compile ] each + +! A utility +: ( voice -- synth ) + NSSpeechSynthesizer [alloc] swap [initWithVoice:] ; + +! Call the TTS API +f +"Hello from Factor" +[startSpeakingString:] diff --git a/library/alien/objective-c/runtime.factor b/library/alien/objective-c/runtime.factor index 40b96017d3..8c20a9e411 100644 --- a/library/alien/objective-c/runtime.factor +++ b/library/alien/objective-c/runtime.factor @@ -2,6 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. IN: objective-c +LIBRARY: objc + TYPEDEF: void* SEL TYPEDEF: void* id From 2e919a82d1bb757f4b75916bb16d6fc16232bd0e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Jan 2006 05:32:32 +0000 Subject: [PATCH 232/373] fix typo --- doc/handbook/objects.facts | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/handbook/objects.facts b/doc/handbook/objects.facts index 7b6c89a883..57df6fa24c 100644 --- a/doc/handbook/objects.facts +++ b/doc/handbook/objects.facts @@ -107,7 +107,7 @@ GLOSSARY: "type" "an object invariant that describes its shape. An object's type GLOSSARY: "built-in class" "see type" ; ARTICLE: "builtin-classes" "Built-in classes" -"Every object is an instance of to exactly one type, and the type is constant for the lifetime of the object. There is only a fixed number of types built-in to the run-time, and corresponding to each type is a \emph{built-in class}:" +"Every object is an instance of to exactly one type, and the type is constant for the lifetime of the object. There is only a fixed number of types built-in to the run-time, and corresponding to each type is a " { $emphasis "built-in class" } ":" { $code "alien" "array" @@ -160,7 +160,7 @@ $terpri "A parsing word defines tuple classes." { $subsection POSTPONE: TUPLE: } { $subsection "tuple-constructors" } -; +{ $subsection "tuple-delegation" } ; GLOSSARY: "constructor" "a word whose primary role is to create new instances of a class" ; From b843de7707c68f91075aee73e1ddca442ee18fdd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Jan 2006 05:40:11 +0000 Subject: [PATCH 233/373] optimization --- library/math/vectors.factor | 26 ++++++++------------------ 1 file changed, 8 insertions(+), 18 deletions(-) diff --git a/library/math/vectors.factor b/library/math/vectors.factor index e851393671..7735203f03 100644 --- a/library/math/vectors.factor +++ b/library/math/vectors.factor @@ -1,9 +1,8 @@ -! Copyright (C) 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. +! Copyright (C) 2005, 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. IN: math USING: arrays generic kernel sequences ; -! Vectors : vneg ( v -- v ) [ neg ] map ; : n*v ( n v -- v ) [ * ] map-with ; @@ -18,22 +17,13 @@ USING: arrays generic kernel sequences ; : vmax ( v v -- v ) [ max ] 2map ; : vmin ( v v -- v ) [ min ] 2map ; +: v. ( v v -- x ) 0 [ * + ] 2reduce ; +: norm-sq ( v -- n ) 0 [ absq + ] reduce ; +: norm ( vec -- n ) norm-sq sqrt ; +: normalize ( vec -- uvec ) dup norm v/n ; + : sum ( v -- n ) 0 [ + ] reduce ; : product ( v -- n ) 1 [ * ] reduce ; : set-axis ( x y axis -- v ) - 2dup v* >r >r drop dup r> v* v- r> v+ ; - -: v. ( v v -- x ) - #! Dot product. - 0 [ * + ] 2reduce ; - -: norm-sq ( v -- n ) 0 [ absq + ] reduce ; - -: norm ( vec -- n ) - #! Length of a vector. - norm-sq sqrt ; - -: normalize ( vec -- uvec ) - #! Unit vector with same direction as vec. - dup norm v/n ; + dup length [ >r 0 = pick pick ? r> swap nth ] 2map 2nip ; From f78ccc8fb83e7ad5b79be59eb579e4fef088fb3d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 11 Jan 2006 23:26:12 +0000 Subject: [PATCH 234/373] math docs --- library/bootstrap/boot-stage1.factor | 6 ++ library/math/arc-trig-hyp.factor | 6 -- library/math/arc-trig-hyp.facts | 60 +++++++++++ library/math/complex.factor | 2 - library/math/complex.facts | 69 +++++++++++++ library/math/float.facts | 8 ++ library/math/integer.factor | 13 +-- library/math/integer.facts | 39 ++++++++ library/math/math.factor | 19 ++-- library/math/math.facts | 143 +++++++++++++++++++++++++++ library/math/pow.factor | 3 - library/math/trig-hyp.factor | 6 -- 12 files changed, 336 insertions(+), 38 deletions(-) create mode 100644 library/math/arc-trig-hyp.facts create mode 100644 library/math/complex.facts create mode 100644 library/math/float.facts create mode 100644 library/math/integer.facts create mode 100644 library/math/math.facts diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 75ca533654..8fffa163b6 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -229,6 +229,12 @@ vectors words ; "/library/generic/slots.facts" "/library/generic/standard-combination.facts" "/library/generic/tuple.facts" + "/library/math/arc-trig-hyp.facts" + "/library/math/complex.facts" + "/library/math/constants.facts" + "/library/math/float.facts" + "/library/math/integer.facts" + "/library/math/math.facts" "/library/syntax/parse-stream.facts" "/library/syntax/parser.facts" "/library/syntax/parse-syntax.facts" diff --git a/library/math/arc-trig-hyp.factor b/library/math/arc-trig-hyp.factor index 5ec6adb6d8..da6bc52e80 100644 --- a/library/math/arc-trig-hyp.factor +++ b/library/math/arc-trig-hyp.factor @@ -3,12 +3,6 @@ IN: math USING: kernel math math-internals ; -! Inverse trigonometric functions: -! acos asec asin acosec atan acot - -! Inverse hyperbolic functions: -! acosh asech asinh acosech atanh acoth - : acosh dup sq 1- sqrt + log ; inline : asech recip acosh ; inline : asinh dup sq 1+ sqrt + log ; inline diff --git a/library/math/arc-trig-hyp.facts b/library/math/arc-trig-hyp.facts new file mode 100644 index 0000000000..3de4ff7047 --- /dev/null +++ b/library/math/arc-trig-hyp.facts @@ -0,0 +1,60 @@ +IN: help +USING: math ; + +: $values-x/y { { "x" "a complex number" } { "y" "a complex number" } } $values ; + +HELP: acosh "( x -- y )" +$values-x/y +{ $description "Inverse hyperbolic cosine." } ; + +HELP: asech "( x -- y )" +$values-x/y +{ $description "Inverse hyperbolic secant." } ; + +HELP: asinh "( x -- y )" +$values-x/y +{ $description "Inverse hyperbolic sine." } ; + +HELP: asinh "( x -- y )" +$values-x/y +{ $description "Inverse hyperbolic sine." } ; + +HELP: acosech "( x -- y )" +$values-x/y +{ $description "Inverse hyperbolic cosecant." } ; + +HELP: atanh "( x -- y )" +$values-x/y +{ $description "Inverse hyperbolic tangent." } ; + +HELP: acoth "( x -- y )" +$values-x/y +{ $description "Inverse hyperbolic cotangent." } ; + +HELP: acosh "( x -- y )" +$values-x/y +{ $description "Inverse trigonometric cosine." } ; + +HELP: asech "( x -- y )" +$values-x/y +{ $description "Inverse trigonometric secant." } ; + +HELP: asinh "( x -- y )" +$values-x/y +{ $description "Inverse trigonometric sine." } ; + +HELP: asinh "( x -- y )" +$values-x/y +{ $description "Inverse trigonometric sine." } ; + +HELP: acosech "( x -- y )" +$values-x/y +{ $description "Inverse trigonometric cosecant." } ; + +HELP: atanh "( x -- y )" +$values-x/y +{ $description "Inverse trigonometric tangent." } ; + +HELP: acoth "( x -- y )" +$values-x/y +{ $description "Inverse trigonometric cotangent." } ; diff --git a/library/math/complex.factor b/library/math/complex.factor index c6d46dbe07..38a6546a57 100644 --- a/library/math/complex.factor +++ b/library/math/complex.factor @@ -4,8 +4,6 @@ IN: math-internals USING: errors generic kernel kernel-internals math ; : (rect>) ( xr xi -- x ) - #! Does not perform a check that the arguments are reals. - #! Do not use in your own code. dup 0 number= [ drop ] [ ] if ; inline IN: math diff --git a/library/math/complex.facts b/library/math/complex.facts new file mode 100644 index 0000000000..23b5f7f5c7 --- /dev/null +++ b/library/math/complex.facts @@ -0,0 +1,69 @@ +USING: help math math-internals ; + +HELP: complex f +{ $description "The class of complex numbers with non-zero imaginary part." } ; + +HELP: real "( z -- x )" +{ $values { "z" "a complex number" } { "x" "a real number" } } +{ $description "Outputs the real part of a complex number. This acts as the identity on real numbers." } +{ $notes "This word also acts as the class word for the class of real numbers, which is a disjoint union of rationals and floats." } ; + +HELP: imaginary "( z -- y )" +{ $values { "z" "a complex number" } { "y" "a real number" } } +{ $description "Outputs the imaginary part of a complex number. This outputs zero for real numbers." } ; + +HELP: (rect>) "( x y -- z )" +{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a complex number" } } +{ $description "Creates a complex number from real and imaginary components." } +{ $warning "This word does not check that the arguments are real numbers, which can have undefined consequences. Use the " { $link rect> } " word instead." } ; + +HELP: number f +{ $description "The class of numbers." } ; + +HELP: rect> "( x y -- z )" +{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a complex number" } } +{ $description "Creates a complex number from real and imaginary components." } ; + +HELP: >rect "( z -- x y )" +{ $values { "z" "a complex number" } { "x" "a real number" } { "y" "a real number" } } +{ $description "Extracts the real and imaginary components of a complex number." } ; + +HELP: conjugate "( z -- z* )" +{ $values { "z" "a complex number" } { "z*" "a complex number" } } +{ $description "Computes the complex conjugate by flipping the sign of the imaginary part of " { $snippet "z" } "." } ; + +HELP: arg "( z -- arg )" +{ $values { "z" "a complex number" } { "arg" "a number in the interval " { $snippet "(-pi,pi]" } } } +{ $description "Computes the complex argument." } ; + +HELP: >polar "( z -- abs arg )" +{ $values { "z" "a complex number" } { "abs" "a non-negative real number" } { "arg" "a number in the interval " { $snippet "(-pi,pi]" } } } +{ $description "Creates a complex number from an absolute value and argument (polar form)." } ; + +HELP: cis "( arg --- z )" +{ $values { "arg" "a real number" } { "z" "a complex number on the unit circle" } } +{ $description "Computes a point on the unit circle using Euler's formula for " { $snippet "exp(arg*i)" } "." } +{ $see-also exp } ; + +HELP: polar> "( abs arg -- z )" +{ $values { "z" "a complex number" } { "abs" "a non-negative real number" } { "arg" "a real number" } } +{ $description "Converts an absolute value and argument (polar form) to a complex number." } ; + +HELP: quadrant "( z -- n )" +{ $values { "z" "a complex number" } { "n" "0, 1, 2, or 3" } } +{ $description "If the imaginary axis runs from bottom to top and the real axis runs from left to right, the quadrants of the complex plane run anti-clockwise starting from the positive real axis:" { $code "1|0" "---" "2|3" } } ; + +HELP: 2>rect "( x y -- xr xi yr yi )" +{ $values { "x" "a complex number" } { "y" "a complex number" } { "xr" "real part of " { $snippet "x" } } { "xi" "imaginary part of " { $snippet "x" } } { "yr" "real part of " { $snippet "y" } } { "yi" "imaginary part of " { $snippet "y" } } } +{ $description "Extracts real and imaginary components of two numbers at once." } ; + +HELP: complex/ "( x y -- r i m )" +{ $values { "x" "a complex number" } { "y" "a complex number" } { "r" "a real number" } { "i" "a real number" } { "m" "a real number" } } +{ $description + "Complex division kernel. If we use the notation from " { $link 2>rect } ", this word computes:" + { $code + "r = xr*yr+xi*yi" + "i = xi*yr-xr*yi" + "m = yr*yr+yi*yi" + } +} ; diff --git a/library/math/float.facts b/library/math/float.facts new file mode 100644 index 0000000000..3d6daba080 --- /dev/null +++ b/library/math/float.facts @@ -0,0 +1,8 @@ +USING: help math ; + +HELP: float f +{ $description "The class of double-precision floating point numbers." } ; + +HELP: >float "( x -- y )" +{ $values { "x" "a real number" } { "y" "a float" } } +{ $description "Converts a real to a float. This is the identity on floats, and performs a floating point division on rationals." } ; diff --git a/library/math/integer.factor b/library/math/integer.factor index 20f50ecf44..faa93381ca 100644 --- a/library/math/integer.factor +++ b/library/math/integer.factor @@ -17,10 +17,7 @@ UNION: integer fixnum bignum ; tuck /mod >r pick * swap >r swapd - r> r> (gcd) ] if ; inline -: gcd ( x y -- a d ) - #! Compute the greatest common divisor d and multiplier a - #! such that a*x=d mod y. - swap 0 1 2swap (gcd) abs ; foldable +: gcd ( x y -- a d ) swap 0 1 2swap (gcd) abs ; foldable : (next-power-of-2) ( i n -- n ) 2dup >= [ @@ -29,8 +26,7 @@ UNION: integer fixnum bignum ; >r 1 shift r> (next-power-of-2) ] if ; -: next-power-of-2 ( n -- n ) - 1 swap (next-power-of-2) ; +: next-power-of-2 ( n -- n ) 1 swap (next-power-of-2) ; IN: math-internals @@ -47,10 +43,7 @@ M: integer / ( x y -- x/y ) 2dup gcd nip tuck /i >r /i r> fraction> ] if ; -M: fixnum number= - #! Fixnums are immediate values, so equality testing is - #! trivial. - eq? ; +M: fixnum number= eq? ; M: fixnum < fixnum< ; M: fixnum <= fixnum<= ; diff --git a/library/math/integer.facts b/library/math/integer.facts new file mode 100644 index 0000000000..f519a90dd0 --- /dev/null +++ b/library/math/integer.facts @@ -0,0 +1,39 @@ +USING: help math math-internals ; + +HELP: fixnum f +{ $description "The class of fixnums, which are fixed-width integers small enough to fit in a machine cell. Because they are not heap-allocated, fixnums do not have object identity. Equality of tagged pointer bit patterns is actually " { $emphasis "value" } " equality for fixnums." } ; + +HELP: >fixnum "( x -- n )" +{ $values { "x" "a real number" } { "n" "a fixnum" } } +{ $description "Converts a real number to a fixnum, with a possible loss of precision and overflow." } ; + +HELP: bignum f +{ $description "The class of bignums, which are heap-allocated arbitrary-precision integers." } ; + +HELP: >bignum "( x -- n )" +{ $values { "x" "a real number" } { "n" "a bignum" } } +{ $description "Converts a real number to a bignum, with a possible loss of precision." } ; + +HELP: integer f +{ $description "The class of integers, which is a disjoint union of fixnums and bignums." } ; + +HELP: even? "( n -- ? )" +{ $values { "n" "an integer" } { "?" "a boolean" } } +{ $description "Tests if an integer is even." } ; + +HELP: odd? "( n -- ? )" +{ $values { "n" "an integer" } { "?" "a boolean" } } +{ $description "Tests if an integer is odd." } ; + +HELP: gcd "( x y -- a d )" +{ $values { "x" "an integer" } { "y" "an integer" } { "a" "an integer" } { "d" "an integer" } } +{ $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*x = d mod y" } } +{ $notes "If " { $snippet "d" } " is 1, then " { $snippet "a" } " is the inverse of " { $snippet "x" } " modulo " { $snippet "y" } "." } ; + +HELP: next-power-of-2 "( m -- n )" +{ $values { "m" "a non-negative integer" } { "n" "an integer" } } +{ $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ; + +HELP: fraction> "( a b -- a/b )" +{ $values { "a" "an integer" } { "b" "a positive integer" } { "a/b" "a rational number" } } +{ $description "Creates a new ratio, or outputs the numerator if the denominator is 1. This word does not reduce the fraction to lowest terms, and should not be called directly; use " { $link / } " instead." } ; diff --git a/library/math/math.factor b/library/math/math.factor index b275e0c4d8..78bbbf530b 100644 --- a/library/math/math.factor +++ b/library/math/math.factor @@ -1,5 +1,5 @@ -! Copyright (C) 2003, 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. +! Copyright (C) 2003, 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. IN: math USING: errors generic kernel math-internals ; @@ -27,11 +27,11 @@ G: bitor ( x y -- z ) math-combination ; foldable G: bitxor ( x y -- z ) math-combination ; foldable G: shift ( x n -- y ) math-combination ; foldable +GENERIC: bitnot ( n -- n ) foldable + GENERIC: 1+ ( x -- x+1 ) foldable GENERIC: 1- ( x -- x-1 ) foldable -GENERIC: bitnot ( n -- n ) foldable - GENERIC: truncate ( n -- n ) foldable GENERIC: floor ( n -- n ) foldable GENERIC: ceiling ( n -- n ) foldable @@ -39,10 +39,7 @@ GENERIC: ceiling ( n -- n ) foldable : max ( x y -- z ) [ > ] 2keep ? ; inline : min ( x y -- z ) [ < ] 2keep ? ; inline -: between? ( x min max -- ? ) - #! Push if min <= x <= max. Handles case where min > max - #! by swapping them. - pick rot >= [ <= ] [ 2drop f ] if ; inline +: between? ( x min max -- ? ) pick >= >r >= r> and ; inline : sq dup * ; inline @@ -51,17 +48,17 @@ GENERIC: ceiling ( n -- n ) foldable : rem ( x y -- x%y ) #! Like modulus, but always gives a positive result. - [ mod ] keep over 0 < [ + ] [ drop ] if ; inline + [ [ mod ] keep + ] keep mod ; inline : sgn ( n -- -1/0/1 ) #! Push the sign of a real number. - dup 0 = [ drop 0 ] [ 1 < -1 1 ? ] if ; foldable + dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable GENERIC: abs ( z -- |z| ) foldable GENERIC: absq ( n -- |n|^2 ) foldable : align ( offset width -- offset ) - 2dup mod dup 0 number= [ 2drop ] [ - + ] if ; inline + 1- [ + ] keep bitnot bitand ; inline : (repeat) ( i n quot -- ) pick pick >= diff --git a/library/math/math.facts b/library/math/math.facts new file mode 100644 index 0000000000..06a0ea3927 --- /dev/null +++ b/library/math/math.facts @@ -0,0 +1,143 @@ +USING: help kernel math ; + +HELP: number= "( x y -- ? )" +{ $values { "x" "a number" } { "y" "a number" } { "?" "a boolean" } } +{ $description "Tests if two numbers have the same numerical value." } +{ $notes "Do not call this word directly. Calling " { $link = } " has the same effect and is more concise." } ; + +HELP: < "( x y -- ? )" +{ $values { "x" "a real number" } { "y" "a real number" } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } ; + +HELP: <= "( x y -- ? )" +{ $values { "x" "a real number" } { "y" "a real number" } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } ; + +HELP: > "( x y -- ? )" +{ $values { "x" "a real number" } { "y" "a real number" } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } ; + +HELP: >= "( x y -- ? )" +{ $values { "x" "a real number" } { "y" "a real number" } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ; + +HELP: + "( x y -- z )" +{ $values { "x" "a number" } { "y" "a number" } { "z" "a number" } } +{ $description + "Adds two numbers." + { $list + "Addition of fixnums may overflow and convert the result to a bignum." + "Addition of bignums always yields a bignum." + "Addition of floats always yields a float." + "Addition of ratios and complex numbers proceeds using the relevant mathematical rules." + } +} ; + +HELP: - "( x y -- z )" +{ $values { "x" "a number" } { "y" "a number" } { "z" "a number" } } +{ $description + "Subtracts " { $link "y" } " from " { $snippet "x" } "." + { $list + "Subtraction of fixnums may overflow and convert the result to a bignum." + "Subtraction of bignums always yields a bignum." + "Subtraction of floats always yields a float." + "Subtraction of ratios and complex numbers proceeds using the relevant mathematical rules." + } +} ; + +HELP: * "( x y -- z )" +{ $values { "x" "a number" } { "y" "a number" } { "z" "a number" } } +{ $description + "Multiplies two numbers." + { $list + "Multiplication of fixnums may overflow and convert the result to a bignum." + "Multiplication of bignums always yields a bignum." + "Multiplication of floats always yields a float." + "Multiplication of ratios and complex numbers proceeds using the relevant mathematical rules." + } +} ; + +HELP: / "( x y -- z )" +{ $values { "x" "a number" } { "y" "a number" } { "z" "a number" } } +{ $description + "Divides " { $snippet "x" } " by " { $snippet "y" } ", retaining as much precision as possible." + { $list + "Division of fixnums may yield a ratio, or overflow and yield a bignum." + "Division of bignums may yield a ratio." + "Division of floats always yields a float." + "Division of ratios and complex numbers proceeds using the relevant mathematical rules." + } +} ; + +HELP: /i "( x y -- z )" +{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a real number" } } +{ $description + "Divides " { $snippet "x" } " by " { $snippet "y" } ", truncating the result to an integer." + { $list + "Integer division of fixnums may overflow and yield a bignum." + "Integer division of bignums always yields a bignum." + "Integer division of floats always yields a float." + "Integer division of ratios and complex numbers proceeds using the relevant mathematical rules." + } +} ; + +HELP: /f "( x y -- z )" +{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a real number" } } +{ $description + "Divides " { $snippet "x" } " by " { $snippet "y" } ", representing the result as a floating point number." + { $list + "Integer division of fixnums may overflow and yield a bignum." + "Integer division of bignums always yields a bignum." + "Integer division of floats always yields a float." + "Integer division of ratios and complex numbers proceeds using the relevant mathematical rules." + } +} ; + +HELP: mod "( x y -- z )" +{ $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } } +{ $description + "Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder being negative if " { $snippet "x" } " is negative." + { $list + "Modulus of fixnums always yields a fixnum." + "Modulus of bignums always yields a bignum." + } +} ; + +HELP: /mod "( x y -- z w )" +{ $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } { "w" "an integer" } } +{ $description + "Computes the quotient " { $snippet "z" } " and remainder " { $snippet "w" } " of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder being negative if " { $snippet "x" } " is negative." + { $list + "The quotient of two fixnums may overflow and yield a bignum; the remainder is always a fixnum" + "The quotient and remainder of two bignums is always a bignum." + } +} ; + +HELP: bitand "( x y -- z )" +{ $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } } +{ $description "Outputs a new integer where each bit is set if and only if the corresponding bit is set in both inputs." } +{ $examples + { $example "BIN: 101 BIN: 10 bitand .b" "0" } + { $example "BIN: 110 BIN: 10 bitand .b" "10" } +} ; + +HELP: bitor "( x y -- z )" +{ $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } } +{ $description "Outputs a new integer where each bit is set if and only if the corresponding bit is set in at least one of the inputs." } +{ $examples + { $example "BIN: 101 BIN: 10 bitor .b" "111" } + { $example "BIN: 110 BIN: 10 bitor .b" "110" } +} ; + +HELP: bitxor "( x y -- z )" +{ $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } } +{ $description "Outputs a new integer where each bit is set if and only if the corresponding bit is set in exactly one of the inputs." } +{ $examples + { $example "BIN: 101 BIN: 10 bitxor .b" "111" } + { $example "BIN: 110 BIN: 10 bitxor .b" "100" } +} ; + +HELP: shift "( x n -- y )" +{ $values { "x" "an integer" } { "n" "an integer" } { "y" "an integer" } } +{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "y" } " bits if " { $snippet "y" } " is positive, or " { $snippet "-y" } " bits to the right if " { $snippet "y" } " is negative. Bits ``falling off'' the right hand side are discarded." } +{ $examples { $example "BIN: 101 5 shift .b" "10100000" } { $example "BIN: 11111 -2 shift .b" "111" } } ; diff --git a/library/math/pow.factor b/library/math/pow.factor index 8fe48e406b..a2aca0426a 100644 --- a/library/math/pow.factor +++ b/library/math/pow.factor @@ -3,9 +3,6 @@ IN: math USING: errors kernel math math-internals ; -! Power-related functions: -! exp log sqrt pow ^mod - : exp >rect swap fexp swap polar> ; inline : log >polar swap flog swap rect> ; inline diff --git a/library/math/trig-hyp.factor b/library/math/trig-hyp.factor index 4b83b9ded5..54a1836cae 100644 --- a/library/math/trig-hyp.factor +++ b/library/math/trig-hyp.factor @@ -3,12 +3,6 @@ IN: math USING: kernel math math-internals ; -! Trigonometric functions: -! cos sec sin cosec tan cot - -! Hyperbolic functions: -! cosh sech sinh cosech tanh coth - : cos ( z -- cos ) >rect 2dup fcosh swap fcos * -rot From 49ab429423a52e840e33c82ca8b19697fa866eeb Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 12 Jan 2006 02:11:42 +0000 Subject: [PATCH 235/373] *** empty log message *** --- contrib/x11/concurrent-widgets.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/contrib/x11/concurrent-widgets.factor b/contrib/x11/concurrent-widgets.factor index 2e3b83b72b..d7427dc485 100644 --- a/contrib/x11/concurrent-widgets.factor +++ b/contrib/x11/concurrent-widgets.factor @@ -284,6 +284,11 @@ dup pwindow-key-action call ; M: pwindow handle-button-press-event ( event obj -- ) dup pwindow-button-action call ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M: pwindow handle-expose-event ( event obj -- ) +dup pwindow-expose-action call ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! event-loop ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 712ec2ce29353e7dddc74968e11cba120af29b0a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Jan 2006 05:34:56 +0000 Subject: [PATCH 236/373] finished math word docs --- contrib/math/utils.factor | 3 + library/bootstrap/boot-stage1.factor | 5 ++ library/help/markup.factor | 3 + library/math/arc-trig-hyp.facts | 5 +- library/math/integer.factor | 2 +- library/math/integer.facts | 4 +- library/math/math.factor | 36 +++----- library/math/math.facts | 119 +++++++++++++++++++++++++-- library/math/parse-numbers.factor | 7 +- library/math/parse-numbers.facts | 55 +++++++++++++ library/math/pow.factor | 6 +- library/math/random.factor | 2 +- library/math/random.facts | 10 +++ library/math/ratio.facts | 23 ++++++ library/math/trig-hyp.facts | 57 +++++++++++++ library/math/vectors.factor | 3 - library/math/vectors.facts | 74 +++++++++++++++++ library/syntax/see.facts | 64 ++++++++++++++ 18 files changed, 424 insertions(+), 54 deletions(-) create mode 100644 library/math/parse-numbers.facts create mode 100644 library/math/random.facts create mode 100644 library/math/ratio.facts create mode 100644 library/math/trig-hyp.facts create mode 100644 library/math/vectors.facts create mode 100644 library/syntax/see.facts diff --git a/contrib/math/utils.factor b/contrib/math/utils.factor index 98ac0e6060..b37a56702e 100644 --- a/contrib/math/utils.factor +++ b/contrib/math/utils.factor @@ -36,6 +36,9 @@ USING: errors kernel sequences math sequences-internals namespaces arrays ; #! Complex inner product. 0 [ ** + ] 2reduce ; +: sum ( v -- n ) 0 [ + ] reduce ; +: product ( v -- n ) 1 [ * ] reduce ; + : proj ( u v -- w ) #! Orthogonal projection of u onto v. [ [ v. ] keep norm-sq v/n ] keep n*v ; diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 8fffa163b6..930d1a21c4 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -235,6 +235,11 @@ vectors words ; "/library/math/float.facts" "/library/math/integer.facts" "/library/math/math.facts" + "/library/math/parse-numbers.facts" + "/library/math/random.facts" + "/library/math/ratio.facts" + "/library/math/trig-hyp.facts" + "/library/math/vectors.facts" "/library/syntax/parse-stream.facts" "/library/syntax/parser.facts" "/library/syntax/parse-syntax.facts" diff --git a/library/help/markup.factor b/library/help/markup.factor index 2d17da2744..a5b3477490 100644 --- a/library/help/markup.factor +++ b/library/help/markup.factor @@ -181,3 +181,6 @@ DEFER: help : $low-level-note drop "Calling this word directly is not necessary in most cases. Higher-level words call it automatically." print-element ; + +: $values-x/y + { { "x" "a complex number" } { "y" "a complex number" } } $values ; diff --git a/library/math/arc-trig-hyp.facts b/library/math/arc-trig-hyp.facts index 3de4ff7047..975bd00240 100644 --- a/library/math/arc-trig-hyp.facts +++ b/library/math/arc-trig-hyp.facts @@ -1,7 +1,4 @@ -IN: help -USING: math ; - -: $values-x/y { { "x" "a complex number" } { "y" "a complex number" } } $values ; +USING: help math ; HELP: acosh "( x -- y )" $values-x/y diff --git a/library/math/integer.factor b/library/math/integer.factor index faa93381ca..53b4c38ec4 100644 --- a/library/math/integer.factor +++ b/library/math/integer.factor @@ -17,7 +17,7 @@ UNION: integer fixnum bignum ; tuck /mod >r pick * swap >r swapd - r> r> (gcd) ] if ; inline -: gcd ( x y -- a d ) swap 0 1 2swap (gcd) abs ; foldable +: gcd ( x y -- a d ) 0 1 2swap (gcd) abs ; foldable : (next-power-of-2) ( i n -- n ) 2dup >= [ diff --git a/library/math/integer.facts b/library/math/integer.facts index f519a90dd0..ee653fc9da 100644 --- a/library/math/integer.facts +++ b/library/math/integer.facts @@ -27,8 +27,8 @@ HELP: odd? "( n -- ? )" HELP: gcd "( x y -- a d )" { $values { "x" "an integer" } { "y" "an integer" } { "a" "an integer" } { "d" "an integer" } } -{ $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*x = d mod y" } } -{ $notes "If " { $snippet "d" } " is 1, then " { $snippet "a" } " is the inverse of " { $snippet "x" } " modulo " { $snippet "y" } "." } ; +{ $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*y = d mod x" } } +{ $notes "If " { $snippet "d" } " is 1, then " { $snippet "a" } " is the inverse of " { $snippet "y" } " modulo " { $snippet "x" } "." } ; HELP: next-power-of-2 "( m -- n )" { $values { "m" "a non-negative integer" } { "n" "an integer" } } diff --git a/library/math/math.factor b/library/math/math.factor index 78bbbf530b..6b691d45b4 100644 --- a/library/math/math.factor +++ b/library/math/math.factor @@ -3,7 +3,6 @@ IN: math USING: errors generic kernel math-internals ; -! Math operations G: number= ( x y -- ? ) math-combination ; foldable M: object number= 2drop f ; @@ -35,42 +34,27 @@ GENERIC: 1- ( x -- x-1 ) foldable GENERIC: truncate ( n -- n ) foldable GENERIC: floor ( n -- n ) foldable GENERIC: ceiling ( n -- n ) foldable - -: max ( x y -- z ) [ > ] 2keep ? ; inline -: min ( x y -- z ) [ < ] 2keep ? ; inline - -: between? ( x min max -- ? ) pick >= >r >= r> and ; inline +GENERIC: abs ( z -- |z| ) foldable +GENERIC: absq ( n -- |n|^2 ) foldable : sq dup * ; inline - : neg 0 swap - ; inline : recip 1 swap / ; inline - -: rem ( x y -- x%y ) - #! Like modulus, but always gives a positive result. - [ [ mod ] keep + ] keep mod ; inline - -: sgn ( n -- -1/0/1 ) - #! Push the sign of a real number. - dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable - -GENERIC: abs ( z -- |z| ) foldable -GENERIC: absq ( n -- |n|^2 ) foldable - -: align ( offset width -- offset ) - 1- [ + ] keep bitnot bitand ; inline +: max ( x y -- z ) [ > ] 2keep ? ; inline +: min ( x y -- z ) [ < ] 2keep ? ; inline +: between? ( x min max -- ? ) pick >= >r >= r> and ; inline +: rem ( x y -- z ) tuck mod over + swap mod ; inline +: sgn ( m -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable +: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline : (repeat) ( i n quot -- ) pick pick >= [ 3drop ] [ [ swap >r call 1+ r> ] keep (repeat) ] if ; inline -: repeat ( n quot -- | quot: n -- n ) - #! The loop counter is kept on the stack, and ranges from - #! 0 to n-1. - 0 -rot (repeat) ; inline +: repeat ( n quot -- | quot: n -- n ) 0 -rot (repeat) ; inline : times ( n quot -- | quot: -- ) swap [ >r dup slip r> ] repeat drop ; inline -GENERIC: number>string ( str -- num ) foldable +GENERIC: number>string ( n -- str ) foldable diff --git a/library/math/math.facts b/library/math/math.facts index 06a0ea3927..9d32314495 100644 --- a/library/math/math.facts +++ b/library/math/math.facts @@ -67,7 +67,8 @@ HELP: / "( x y -- z )" "Division of floats always yields a float." "Division of ratios and complex numbers proceeds using the relevant mathematical rules." } -} ; +} +{ $errors "Throws an error if both inputs are integers, and the denominator is 0." } ; HELP: /i "( x y -- z )" { $values { "x" "a real number" } { "y" "a real number" } { "z" "a real number" } } @@ -79,7 +80,8 @@ HELP: /i "( x y -- z )" "Integer division of floats always yields a float." "Integer division of ratios and complex numbers proceeds using the relevant mathematical rules." } -} ; +} +{ $errors "Throws an error if both inputs are integers, and the denominator is 0." } ; HELP: /f "( x y -- z )" { $values { "x" "a real number" } { "y" "a real number" } { "z" "a real number" } } @@ -91,7 +93,8 @@ HELP: /f "( x y -- z )" "Integer division of floats always yields a float." "Integer division of ratios and complex numbers proceeds using the relevant mathematical rules." } -} ; +} +{ $errors "Throws an error if both inputs are integers, and the denominator is 0." } ; HELP: mod "( x y -- z )" { $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } } @@ -101,7 +104,9 @@ HELP: mod "( x y -- z )" "Modulus of fixnums always yields a fixnum." "Modulus of bignums always yields a bignum." } -} ; +} +{ $errors "Throws an error if the denominator is 0." } +{ $see-also rem } ; HELP: /mod "( x y -- z w )" { $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } { "w" "an integer" } } @@ -111,7 +116,8 @@ HELP: /mod "( x y -- z w )" "The quotient of two fixnums may overflow and yield a bignum; the remainder is always a fixnum" "The quotient and remainder of two bignums is always a bignum." } -} ; +} +{ $errors "Throws an error if the denominator is 0." } ; HELP: bitand "( x y -- z )" { $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } } @@ -139,5 +145,106 @@ HELP: bitxor "( x y -- z )" HELP: shift "( x n -- y )" { $values { "x" "an integer" } { "n" "an integer" } { "y" "an integer" } } -{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "y" } " bits if " { $snippet "y" } " is positive, or " { $snippet "-y" } " bits to the right if " { $snippet "y" } " is negative. Bits ``falling off'' the right hand side are discarded." } +{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "y" } " bits if " { $snippet "y" } " is positive, or " { $snippet "-y" } " bits to the right if " { $snippet "y" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits ``falling off'' the right hand side and being discarded." } { $examples { $example "BIN: 101 5 shift .b" "10100000" } { $example "BIN: 11111 -2 shift .b" "111" } } ; + +HELP: bitnot "( x -- y )" +{ $values { "x" "an integer" } { "y" "an integer" } } +{ $description "Computes the bitwise complement of the input; that is, each bit in the input number is flipped." } +{ $notes "Due to the two's complement representation of signed integers, the following two lines are equivalent:" { $code "bitnot" "neg 1-" } } ; + +HELP: 1+ "( x -- y )" +{ $values { "x" "a number" } { "y" "a number" } } +{ $description + "Increments a number by 1. The following two lines are equivalent, but the first is more efficient:" + { $code "1+" "1 +" } +} ; + +HELP: 1- "( x -- y )" +{ $values { "x" "a number" } { "y" "a number" } } +{ $description + "Decrements a number by 1. The following two lines are equivalent, but the first is more efficient:" + { $code "1-" "1 -" } +} ; + +HELP: truncate "( x -- y )" +{ $values { "x" "a real number" } { "y" "a whole real number" } } +{ $description "Outputs the number that results from subtracting the fractional component of " { $snippet "x" } "." } +{ $notes "The result is not necessarily an integer." } ; + +HELP: floor "( x -- y )" +{ $values { "x" "a real number" } { "y" "a whole real number" } } +{ $description "Outputs the greatest whole number smaller than or equal to " { $snippet "x" } "." } +{ $notes "The result is not necessarily an integer." } ; + +HELP: ceiling "( x -- y )" +{ $values { "x" "a real number" } { "y" "a whole real number" } } +{ $description "Outputs the least whole number greater than or equal to " { $snippet "x" } "." } +{ $notes "The result is not necessarily an integer." } ; + +HELP: abs "( x -- y )" +{ $values { "x" "a complex number" } { "y" "a non-negative real number" } } +{ $description "Computes the absolute value of a complex number." } ; + +HELP: absq "( x -- y )" +{ $values { "x" "a complex number" } { "y" "a non-negative real number" } } +{ $description "Computes the squared absolute value of a complex number. This is marginally more efficient than " { $link abs } "." } ; + +HELP: sq "( x -- y )" +{ $values { "x" "a number" } { "y" "a number" } } +{ $description "Multiplies a number by itself." } ; + +HELP: neg "( x -- -x )" +{ $values { "x" "a number" } { "-x" "a number" } } +{ $description "Computes a number's additive inverse." } ; + +HELP: recip "( x -- -x )" +{ $values { "x" "a number" } { "-x" "a number" } } +{ $description "Computes a number's multiplicative inverse." } +{ $errors "Throws an error if " { $snippet "x" } " is the integer 0." } ; + +HELP: max "( x y -- z )" +{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a real number" } } +{ $description "Outputs the greatest of two real numbers." } ; + +HELP: min "( x y -- z )" +{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a real number" } } +{ $description "Outputs the smallest of two real numbers." } ; + +HELP: between? "( x y z -- ? )" +{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a real number" } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." } +{ $notes "As per the closed interval notation, the end-points are included in the interval." } ; + +HELP: rem "( x y -- z )" +{ $values { "x" "an integer" } { "y" "an integer" } { "z" "an integer" } } +{ $description + "Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder always positive." + { $list + "Modulus of fixnums always yields a fixnum." + "Modulus of bignums always yields a bignum." + } +} +{ $errors "Throws an error if the denominator is 0." } +{ $see-also mod } ; + +HELP: sgn "( x -- n )" +{ $values { "x" "a real number" } { "n" "-1, 0 or 1" } } +{ $description + "Outputs one of the following:" + { $list + "-1 if " { $snippet "x" } " is negative" + "0 if " { $snippet "x" } " is equal to 0" + "1 if " { $snippet "x" } " is positive" + } +} ; + +HELP: align "( m w -- n )" +{ $values { "m" "an integer" } { "w" "a power of 2" } { "n" "an integer multiple of " { $snippet "w" } } } +{ $description "Outputs the least multiple of " { $snippet "w" } " greater than " { $snippet "m" } "." } +{ $notes "This word will give an incorrect result if " { $snippet "w" } " is not a power of 2." } ; + +HELP: number>string "( n -- str )" +{ $values { "n" "a real number" } { "str" "a string" } } +{ $description "Converts a real number to a string." } +{ $notes "Printing complex numbers requires the more general prettyprinter facility (see " { $link "prettyprint" } ")." } ; diff --git a/library/math/parse-numbers.factor b/library/math/parse-numbers.factor index 454c7b33d5..d742f46db2 100644 --- a/library/math/parse-numbers.factor +++ b/library/math/parse-numbers.factor @@ -1,11 +1,9 @@ ! Copyright (C) 2004, 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. +! See http://factorcode.org/license.txt for BSD license. IN: math USING: errors generic kernel math-internals namespaces sequences strings ; -! Number parsing - : not-a-number "Not a number" throw ; DEFER: base> @@ -54,7 +52,6 @@ M: object digit> not-a-number ; G: >base ( num radix -- string ) [ over ] standard-combination ; M: integer >base ( num radix -- string ) - #! Convert a number to a string in a certain base. [ over 0 < [ swap neg swap integer, CHAR: - , @@ -71,8 +68,6 @@ M: ratio >base ( num radix -- string ) ] "" make ; M: float >base ( num radix -- string ) - #! This is terrible. Will go away when we do our own float - #! output. drop float>string CHAR: . over member? [ ".0" append ] unless ; diff --git a/library/math/parse-numbers.facts b/library/math/parse-numbers.facts new file mode 100644 index 0000000000..4045915ea5 --- /dev/null +++ b/library/math/parse-numbers.facts @@ -0,0 +1,55 @@ +USING: help math prettyprint ; + +HELP: base> "( str radix -- n )" +{ $values { "str" "a string" } { "radix" "an integer between 2 and 36" } { "n" "a real number" } } +{ $description "Creates a real number from a string representation with the given radix. The radix is ignored for floating point literals; they are always taken to be in base 10." } +{ $errors "Throws an error if the string cannot be interpreted as a number in the given base." } +{ $see-also >base } ; + +HELP: string>number "( str -- n )" +{ $values { "str" "a string" } { "n" "a real number" } } +{ $description "Creates a real number from a string representation of a number in base 10." } +{ $errors "Throws an error if the string cannot be interpreted as a number in base 10." } +{ $see-also number>string } ; + +HELP: bin> "( str -- n )" +{ $values { "str" "a string" } { "n" "a real number" } } +{ $description "Creates a real number from a string representation of a number in base 2." } +{ $errors "Throws an error if the string cannot be interpreted as a number in base 2." } +{ $see-also POSTPONE: BIN: } ; + +HELP: oct> "( str -- n )" +{ $values { "str" "a string" } { "n" "a real number" } } +{ $description "Creates a real number from a string representation of a number in base 8." } +{ $errors "Throws an error if the string cannot be interpreted as a number in base 8." } +{ $see-also POSTPONE: OCT: } ; + +HELP: hex> "( str -- n )" +{ $values { "str" "a string" } { "n" "a real number" } } +{ $description "Creates a real number from a string representation of a number in base 16." } +{ $errors "Throws an error if the string cannot be interpreted as a number in base 16." } +{ $see-also POSTPONE: HEX: } ; + +HELP: >base "( n radix -- str )" +{ $values { "n" "a real number" } { "radix" "an integer between 2 and 36" } { "str" "a string" } } +{ $description "Converts a real number into a string representation using the given radix. If the number is a float, the radix is ignored and the output is always in base 10." } +{ $see-also base> } ; + +HELP: number>string "( n -- str )" +{ $values { "n" "a real number" } { "str" "a string" } } +{ $description "Outputs a string representation of a number using base 10." } ; + +HELP: >bin "( n -- str )" +{ $values { "n" "a real number" } { "str" "a string" } } +{ $description "Outputs a string representation of a number using base 2." } +{ $see-also .b } ; + +HELP: >oct "( n -- str )" +{ $values { "n" "a real number" } { "str" "a string" } } +{ $description "Outputs a string representation of a number using base 8." } +{ $see-also .o } ; + +HELP: >hex "( n -- str )" +{ $values { "n" "a real number" } { "str" "a string" } } +{ $description "Outputs a string representation of a number using base 16." } +{ $see-also .h } ; diff --git a/library/math/pow.factor b/library/math/pow.factor index a2aca0426a..f709ea29f4 100644 --- a/library/math/pow.factor +++ b/library/math/pow.factor @@ -1,5 +1,5 @@ ! Copyright (C) 2004, 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. +! See http://factorcode.org/license.txt for BSD license. IN: math USING: errors kernel math math-internals ; @@ -9,7 +9,6 @@ USING: errors kernel math math-internals ; GENERIC: sqrt ( n -- n ) foldable M: complex sqrt >polar swap fsqrt swap 2 / polar> ; - M: real sqrt dup 0 < [ neg fsqrt 0 swap rect> ] [ fsqrt ] if ; GENERIC: ^ ( z w -- z^w ) foldable @@ -24,8 +23,6 @@ M: number ^ ( z w -- z^w ) swap >polar 3dup ^theta >r ^mag r> polar> ; : each-bit ( n quot -- | quot: 0/1 -- ) - #! Apply the quotation to each bit of the number. The number - #! must be positive. over 0 number= pick -1 number= or [ 2drop ] [ @@ -51,7 +48,6 @@ M: integer ^ ( z w -- z^w ) ] if ; foldable : log2 ( n -- b ) - #! Log base two for integers. { { [ dup 0 <= ] [ "Input must be positive" throw ] } { [ dup 1 = ] [ drop 0 ] } diff --git a/library/math/random.factor b/library/math/random.factor index e6317b5c32..cdfea2b7ed 100644 --- a/library/math/random.factor +++ b/library/math/random.factor @@ -1,5 +1,5 @@ ! Copyright (C) 2005 Doug Coleman. -! See http://factor.sf.net/license.txt for BSD license. +! 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 diff --git a/library/math/random.facts b/library/math/random.facts new file mode 100644 index 0000000000..23fcf1431c --- /dev/null +++ b/library/math/random.facts @@ -0,0 +1,10 @@ +USING: help math ; + +HELP: (random-int) "( -- rand )" +{ $values { "rand" "an integer between 0 and 2^32-1" } } +{ $description "Generates a random 32-bit unsigned integer." } ; + +HELP: random-int "( n -- rand )" +{ $values { "rand" "an integer between 0 and n" } } +{ $description "Outputs a pseudo-random integer in the interval " { $snippet "[0,n]" } "." } +{ $notes "As per the closed interval notation, the end-points are included in the interval." } ; diff --git a/library/math/ratio.facts b/library/math/ratio.facts new file mode 100644 index 0000000000..e32983e337 --- /dev/null +++ b/library/math/ratio.facts @@ -0,0 +1,23 @@ +USING: help math math-internals ; + +HELP: ratio f +{ $description "The class of rational numbers with denominator not equal to 1." } ; + +HELP: rational f +{ $description "The class of rational numbers, a disjoint union of integers and ratios." } ; + +HELP: numerator "( a/b -- a )" +{ $values { "a/b" "a rational number" } { "a" "an integer" } } +{ $description "Outputs the numerator of a rational number. Acts as the identity on integers." } ; + +HELP: denominator "( a/b -- b )" +{ $values { "a/b" "a rational number" } { "b" "a positive integer" } } +{ $description "Outputs the denominator of a rational number. Always outputs 1 with integers." } ; + +HELP: >fraction "( a/b -- a b )" +{ $values { "a/b" "a rational number" } { "a" "an integer" } { "b" "a positive integer" } } +{ $description "Extracts the numerator and denominator of a rational number." } ; + +HELP: 2>fraction "( a/b c/d -- a c b d )" +{ $values { "a/b" "a rational number" } { "a" "an integer" } { "c" "an integer" } { "b" "a positive integer" } { "d" "a positive integer" } } +{ $description "Extracts the numerator and denominator of two rational numbers at once." } ; diff --git a/library/math/trig-hyp.facts b/library/math/trig-hyp.facts new file mode 100644 index 0000000000..d14a36410e --- /dev/null +++ b/library/math/trig-hyp.facts @@ -0,0 +1,57 @@ +USING: help math ; + +HELP: cosh "( x -- y )" +$values-x/y +{ $description "Hyperbolic cosine." } ; + +HELP: sech "( x -- y )" +$values-x/y +{ $description "Hyperbolic secant." } ; + +HELP: sinh "( x -- y )" +$values-x/y +{ $description "Hyperbolic sine." } ; + +HELP: sinh "( x -- y )" +$values-x/y +{ $description "Hyperbolic sine." } ; + +HELP: cosech "( x -- y )" +$values-x/y +{ $description "Hyperbolic cosecant." } ; + +HELP: tanh "( x -- y )" +$values-x/y +{ $description "Hyperbolic tangent." } ; + +HELP: coth "( x -- y )" +$values-x/y +{ $description "Hyperbolic cotangent." } ; + +HELP: cosh "( x -- y )" +$values-x/y +{ $description "Trigonometric cosine." } ; + +HELP: sech "( x -- y )" +$values-x/y +{ $description "Trigonometric secant." } ; + +HELP: sinh "( x -- y )" +$values-x/y +{ $description "Trigonometric sine." } ; + +HELP: sinh "( x -- y )" +$values-x/y +{ $description "Trigonometric sine." } ; + +HELP: cosech "( x -- y )" +$values-x/y +{ $description "Trigonometric cosecant." } ; + +HELP: tanh "( x -- y )" +$values-x/y +{ $description "Trigonometric tangent." } ; + +HELP: coth "( x -- y )" +$values-x/y +{ $description "Trigonometric cotangent." } ; diff --git a/library/math/vectors.factor b/library/math/vectors.factor index 7735203f03..3123c23508 100644 --- a/library/math/vectors.factor +++ b/library/math/vectors.factor @@ -22,8 +22,5 @@ USING: arrays generic kernel sequences ; : norm ( vec -- n ) norm-sq sqrt ; : normalize ( vec -- uvec ) dup norm v/n ; -: sum ( v -- n ) 0 [ + ] reduce ; -: product ( v -- n ) 1 [ * ] reduce ; - : set-axis ( x y axis -- v ) dup length [ >r 0 = pick pick ? r> swap nth ] 2map 2nip ; diff --git a/library/math/vectors.facts b/library/math/vectors.facts new file mode 100644 index 0000000000..1e532c74e1 --- /dev/null +++ b/library/math/vectors.facts @@ -0,0 +1,74 @@ +USING: help math ; + +HELP: vneg "( u -- v )" +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } +{ $description "Negates each element of " { $snippet "u" } "." } ; + +HELP: n*v "( n u -- v )" +{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } +{ $description "Multiplies each element of " { $snippet "u" } " by " { $snippet "n" } "." } ; + +HELP: v*n "( n u -- v )" +{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } +{ $description "Multiplies each element of " { $snippet "u" } " by " { $snippet "n" } "." } ; + +HELP: n/v "( n u -- v )" +{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } +{ $description "Divides " { $snippet "n" } " by each element of " { $snippet "u" } "." } ; + +HELP: v/n "( n u -- v )" +{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } +{ $description "Divides each element of " { $snippet "u" } " by " { $snippet "n" } "." } ; + +HELP: v+ "( u v -- w )" +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $description "Adds " { $snippet "u" } " and " { $snippet "v" } " component-wise." } ; + +HELP: v- "( u v -- w )" +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $description "Subtracts " { $snippet "v" } " from " { $snippet "u" } " component-wise." } ; + +HELP: v* "( u v -- w )" +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $description "Multiplies " { $snippet "u" } " and " { $snippet "v" } " component-wise." } ; + +HELP: v/ "( u v -- w )" +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $description "Divides " { $snippet "u" } " by " { $snippet "v" } " component-wise." } +{ $errors "Throws an error if an integer division by zero occurs." } ; + +HELP: vmax "( u v -- w )" +{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } +{ $description "Creates a sequence where each element is the maximum of the corresponding elements from " { $snippet "u" } " andd " { $snippet "v" } "." } +{ $examples { $example "{ 1 2 5 } { -7 6 3 } vmax ." "{ 1 6 5 }" } } ; + +HELP: vmin "( u v -- w )" +{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "w" "a sequence of real numbers" } } +{ $description "Creates a sequence where each element is the minimum of the corresponding elements from " { $snippet "u" } " andd " { $snippet "v" } "." } +{ $examples { $example "{ 1 2 5 } { -7 6 3 } vmin ." "{ -7 2 3 }" } } ; + +HELP: v. "( u v -- y )" +{ $values { "u" "a sequence of real numbers" } { "v" "a sequence of real numbers" } { "y" "a real number" } } +{ $description "Computes the real-valued dot product." } +{ $notes + "This word can also take complex number sequences as input, however mathematically it will compute the wrong result. The complex-valued dot product is defined differently:" + { $snippet "0 [ conjugate * + ] 2reduce" } +} ; + +HELP: norm-sq "( v -- y )" +{ $values { "v" "a sequence of numbers" } { "y" "a non-negative real number" } } +{ $description "Computes the squared length of a mathematical vector." } ; + +HELP: norm "( v -- y )" +{ $values { "v" "a sequence of numbers" } { "y" "a non-negative real number" } } +{ $description "Computes the length of a mathematical vector." } ; + +HELP: normalize "( v -- v )" +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } } +{ $description "Computes a mathematical vector with the same direction but length 1." } +{ $errors "Throws an error if " { $snippet "v" } " has zero length." } ; + +HELP: set-axis "( u v axis -- w )" +{ $values { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } { "w" "a sequence of numbers" } } +{ $description "Using " { $snippet "w" } " as a template, creates a new sequence containing corresponding elements from " { $snippet "x" } " in place of 0, and corresponding elements from " { $snippet "y" } " in place of 1." } +{ $examples { $example "{ 1 2 3 } { 4 5 6 } { 0 1 0 } set-axis ." "{ 1 5 3 }" } } ; diff --git a/library/syntax/see.facts b/library/syntax/see.facts new file mode 100644 index 0000000000..f3cfa9c398 --- /dev/null +++ b/library/syntax/see.facts @@ -0,0 +1,64 @@ +USING: help prettyprint ; + +HELP: declaration. "( word prop -- )" +{ $values { "word" "a word" } { "prop" "a word" } } +{ $description "Prettyprints " { $snippet "prop" } " if " { $snippet "word" } " defines a word property string named by " { $snippet "prop" } "." } +$prettyprinting-note ; + +HELP: in. "( word -- )" +{ $values { "word" "a word" } } +{ $description "Prettyprints a " { $snippet "IN:" } " declaration for the word." } +$prettyprinting-note ; + +HELP: (synopsis) "( word -- )" +{ $values { "word" "a word" } } +{ $description "Prettyprints the prologue of the word's source definition." } +$prettyprinting-note ; + +HELP: comment. "( string -- )" +{ $description "Prettyprints some text with the comment style." } +$prettyprinting-note ; + +HELP: stack-effect "( word -- str )" +{ $values { "word" "a word" } { "str" "a string" } } +{ $description "Outputs the stack effect of a word, as a stack picture string. The stack effect is taken from either online help, or a cached inferred effect." } +$prettyprinting-note ; + +HELP: synopsis "( word -- str )" +{ $values { "word" "a word" } { "str" "a string" } } +{ $description "Outputs a short string describing the word in Factor pseudo-code." } +{ $examples { $example "\\ append synopsis print" "IN: sequences : append ( seq1 seq2 -- seq )" } } ; + +HELP: (see) "( word -- )" +{ $values { "word" "a word" } } +{ $contract "Prettyprints the definition of the word." } +$prettyprinting-note ; + +HELP: see-body "( quot word -- )" +{ $values { "quot" "a quotation" } { "word" "a word" } } +{ $description "Prettyprints the elements of a quotation, followed by a semicolon (;) and any declarations for the word." } +$prettyprinting-note ; + +HELP: method. "( word class method -- )" +{ $values { "word" "a generic word" } { "class" "a class word" } { "method" "a method quotation" } } +{ $description "Prettyprints a method definition." } +$prettyprinting-note ; + +HELP: class. "( class -- )" +{ $values { "class" "a class word" } } +{ $contract "Prettyprints the class definition." } +$prettyprinting-note ; + +HELP: methods. "( class -- )" +{ $values { "class" "a class word" } } +{ $contract "Prettyprints all methods defined on this class." } +$prettyprinting-note ; + +HELP: see "( word -- )" +{ $values { "word" "a word" } } +{ $description "Prettyprints the definition of a word." } ; + +HELP: apropos "( substr -- )" +{ $values { "substr" "a string" } } +{ $description "Outputs a list of all words whose name is a completion for " { $snippet "substr" } ", in the sense that after tokenizing both the word name and " { $snippet "substr" } " on a set of dividers, each chunk in the word name contains the corresponding chunk from " { $snippet "substr" } "." } +{ $examples { $example "\"h-e\" apropos" "IN: hashtables : hash-subset ( hash quot -- subhash )\nIN: hashtables : hash-subset-with" } } ; From cd3e4172e9c80299a93802c7ee95ea38e3ac88b4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Jan 2006 05:49:15 +0000 Subject: [PATCH 237/373] fix bootstrap issue --- library/collections/sequence-combinators.facts | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/library/collections/sequence-combinators.facts b/library/collections/sequence-combinators.facts index dd7ef99908..fa38347f6c 100644 --- a/library/collections/sequence-combinators.facts +++ b/library/collections/sequence-combinators.facts @@ -14,8 +14,7 @@ HELP: reduce "( seq identity quot -- result )" { $description "Combines successive elements of the sequence using a binary operation, and outputs the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence." } { $examples { $example "{ 1 5 3 } 0 [ + ] reduce ." "9" } -} -{ $see-also sum product } ; +} ; HELP: accumulate "( seq identity quot -- newseq )" { $values { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( prev elt -- next )" } } } From f8d35998f86ac2c193bd1e25652695686c5b3209 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Jan 2006 06:06:23 +0000 Subject: [PATCH 238/373] add missing file --- library/bootstrap/boot-stage1.factor | 1 + library/math/pow.facts | 31 ++++++++++++++++++++++++++++ 2 files changed, 32 insertions(+) create mode 100644 library/math/pow.facts diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 930d1a21c4..b56c1c105f 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -236,6 +236,7 @@ vectors words ; "/library/math/integer.facts" "/library/math/math.facts" "/library/math/parse-numbers.facts" + "/library/math/pow.facts" "/library/math/random.facts" "/library/math/ratio.facts" "/library/math/trig-hyp.facts" diff --git a/library/math/pow.facts b/library/math/pow.facts new file mode 100644 index 0000000000..a64e43b0ca --- /dev/null +++ b/library/math/pow.facts @@ -0,0 +1,31 @@ +USING: help math ; + +HELP: exp "( x -- y )" +{ $values { "x" "a complex number" } { "y" "a complex number" } } +{ $description "Computes the exponential function." } ; + +HELP: log "( x -- y )" +{ $values { "x" "a complex number" } { "y" "a complex number" } } +{ $description "Computes the natural logarithm function. Outputs negative infinity if " { $snippet "x" } " is 0." } ; + +HELP: sqrt "( x -- y )" +{ $values { "x" "a complex number" } { "y" "a complex number" } } +{ $description "Computes the square root function." } ; + +HELP: ^ "( x y -- z )" +{ $values { "x" "a complex number" } { "y" "a complex number" } { "z" "a complex number" } } +{ $description "Raises " { $snippet "x" } " to the power of " { $snippet "y" } ". If \texttt{y}" { $snippet "y" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." } +{ $errors "Throws an error if " { $snippet "x" } " and " { $snippet "y" } " are both integer 0." } ; + +HELP: each-bit "( n quot -- )" +{ $values { "n" "an integer" } { "quot" "a quotation with stack effect " { $snippet "( 0/1 -- )" } } } +{ $description "Applies the quotation to each bit of the input, ranging from least significant to most significant." } ; + +HELP: power-of-2? "( n -- ? )" +{ $values { "n" "an integer" } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "n" } " is a power of 2." } ; + +HELP: log2 "( n -- b )" +{ $values { "n" "a positive integer" } { "b" "an integer" } } +{ $description "Computes the largest integer " { $snippet "b" } " such that " { $snippet "2^b" } " is less than " { $snippet "n" } "." } +{ $errors "Throws an error if " { $snippet "n" } " is zero or negative." } ; From 9da28cdc7831bc6eeb088ffe8b03f9114eab0f0d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Jan 2006 06:08:45 +0000 Subject: [PATCH 239/373] fix stack effect error --- library/help/markup.factor | 1 + library/math/arc-trig-hyp.facts | 14 +++++++------- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/library/help/markup.factor b/library/help/markup.factor index a5b3477490..1ecb650692 100644 --- a/library/help/markup.factor +++ b/library/help/markup.factor @@ -183,4 +183,5 @@ DEFER: help "Calling this word directly is not necessary in most cases. Higher-level words call it automatically." print-element ; : $values-x/y + drop { { "x" "a complex number" } { "y" "a complex number" } } $values ; diff --git a/library/math/arc-trig-hyp.facts b/library/math/arc-trig-hyp.facts index 975bd00240..bbc2c3e229 100644 --- a/library/math/arc-trig-hyp.facts +++ b/library/math/arc-trig-hyp.facts @@ -28,30 +28,30 @@ HELP: acoth "( x -- y )" $values-x/y { $description "Inverse hyperbolic cotangent." } ; -HELP: acosh "( x -- y )" +HELP: acos "( x -- y )" $values-x/y { $description "Inverse trigonometric cosine." } ; -HELP: asech "( x -- y )" +HELP: asec "( x -- y )" $values-x/y { $description "Inverse trigonometric secant." } ; -HELP: asinh "( x -- y )" +HELP: asin "( x -- y )" $values-x/y { $description "Inverse trigonometric sine." } ; -HELP: asinh "( x -- y )" +HELP: asin "( x -- y )" $values-x/y { $description "Inverse trigonometric sine." } ; -HELP: acosech "( x -- y )" +HELP: acosec "( x -- y )" $values-x/y { $description "Inverse trigonometric cosecant." } ; -HELP: atanh "( x -- y )" +HELP: atan "( x -- y )" $values-x/y { $description "Inverse trigonometric tangent." } ; -HELP: acoth "( x -- y )" +HELP: acot "( x -- y )" $values-x/y { $description "Inverse trigonometric cotangent." } ; From 50c636b9c4395868046b1c4db368eee9ac097117 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 12 Jan 2006 08:19:51 +0000 Subject: [PATCH 240/373] *** empty log message *** --- .../lindenmayer/lindenmayer-viewer.factor | 55 ++++ .../examples/lindenmayer/lindenmayer.factor | 296 ++++++++++++++++++ 2 files changed, 351 insertions(+) create mode 100644 contrib/x11/examples/lindenmayer/lindenmayer-viewer.factor create mode 100644 contrib/x11/examples/lindenmayer/lindenmayer.factor diff --git a/contrib/x11/examples/lindenmayer/lindenmayer-viewer.factor b/contrib/x11/examples/lindenmayer/lindenmayer-viewer.factor new file mode 100644 index 0000000000..e70c2f3c3f --- /dev/null +++ b/contrib/x11/examples/lindenmayer/lindenmayer-viewer.factor @@ -0,0 +1,55 @@ +USING: kernel alien math arrays sequences opengl namespaces concurrency +xlib x x11 gl concurrent-widgets lindenmayer ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USE: sequences + +: >float-array ( seq -- ) +dup length swap dup length >array [ pick set-float-nth ] 2each ; + +USE: lindenmayer + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: camera-position { 5 5 5 } camera-position set + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: display ( -- ) +GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear +camera-position get glLoadIdentity [ ] each 0.0 0.0 0.0 0.0 1.0 0.0 gluLookAt +reset result get interpret glFlush ; + +: reshape ( { width height } -- ) +>r 0 0 r> [ ] each glViewport +GL_PROJECTION glMatrixMode +glLoadIdentity -1.0 1.0 -1.0 1.0 1.5 200.0 glFrustum +GL_MODELVIEW glMatrixMode +display ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +f initialize-x + +create-pwindow +[ drop reshape ] over set-pwindow-resize-action +[ 2drop display ] over set-pwindow-expose-action +window-id win set +ExposureMask StructureNotifyMask bitor select-input +{ 500 500 } resize-window { 0 0 } move-window map-window + +[ GLX_RGBA ] choose-visual create-context make-current + +0.0 0.0 0.0 0.0 glClearColor +GL_SMOOTH glShadeModel + +GL_FRONT_AND_BACK GL_SPECULAR { 1.0 1.0 1.0 1.0 } >float-array glMaterialfv +GL_FRONT_AND_BACK GL_SHININESS { 50.0 } >float-array glMaterialfv +GL_LIGHT0 GL_POSITION { 1.0 1.0 1.0 0.0 } >float-array glLightfv + +GL_LIGHTING glEnable +GL_LIGHT0 glEnable +GL_DEPTH_TEST glEnable + +[ concurrent-event-loop ] spawn \ No newline at end of file diff --git a/contrib/x11/examples/lindenmayer/lindenmayer.factor b/contrib/x11/examples/lindenmayer/lindenmayer.factor new file mode 100644 index 0000000000..2e5f0afee6 --- /dev/null +++ b/contrib/x11/examples/lindenmayer/lindenmayer.factor @@ -0,0 +1,296 @@ +USING: kernel alien namespaces arrays vectors math opengl math-contrib +sequences hashtables strings ; + +IN: lindenmayer + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: make-matrix >r { } make r> swap group ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: RU ( angle -- RU ) deg>rad +[ dup cos , dup sin , 0 , + dup sin neg , dup cos , 0 , + 0 , 0 , 1 , ] 3 make-matrix nip ; + +: RL ( angle -- RL ) deg>rad +[ dup cos , 0 , dup sin neg , + 0 , 1 , 0 , + dup sin , 0 , dup cos , ] 3 make-matrix nip ; + +: RH ( angle -- RH ) deg>rad +[ 1 , 0 , 0 , + 0 , dup cos , dup sin neg , + 0 , dup sin , dup cos , ] 3 make-matrix nip ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: position +SYMBOL: orientation + +: rotate-U ( angle -- ) RU orientation get swap m. orientation set ; +: rotate-L ( angle -- ) RL orientation get swap m. orientation set ; +: rotate-H ( angle -- ) RH orientation get swap m. orientation set ; + +: step ( length -- ) +>r position get orientation get 0 0 r> 3array m.v v+ position set ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: record-vertex ( -- ) position get first3 glVertex3f ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: rotate-z rotate-U ; +: rotate-y neg rotate-L ; +: rotate-x neg rotate-H ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: reset ( -- ) { 0 0 0 } position set 3 identity-matrix orientation set ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +DEFER: polygon-vertex + +: draw-forward ( length -- ) +GL_LINES glBegin record-vertex step record-vertex glEnd ; + +: move-forward ( length -- ) step polygon-vertex ; + +: sneak-forward ( length -- ) step ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! (v0 - v1) x (v1 - v2) + +: polygon-normal ( { v0 v1 v2 } -- normal ) +0 over nth over 1 swap nth v- swap +1 over nth swap 2 swap nth v- cross ; + +: polygon ( vertices -- ) +GL_POLYGON glBegin dup polygon-normal first3 glNormal3f +[ first3 glVertex3f ] each glEnd ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: vertices + +V{ } vertices set + +: start-polygon ( -- ) 0 vertices set ; + +: finish-polygon ( -- ) vertices get polygon ; + +: polygon-vertex ( -- ) position get vertices get push ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Lindenmayer string rewriting and interpretation +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: rules +SYMBOL: command-table + +: lookup ( str -- str ) dup rules get hash dup [ nip ] [ drop ] if ; + +: rewrite ( str -- str ) "" swap [ ch>string lookup append ] each ; + +: interpret ( str -- ) +[ ch>string command-table get hash dup [ call ] [ drop ] if ] each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Lparser dialect +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: angle +SYMBOL: length +SYMBOL: thickness +SYMBOL: color-index + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +DEFER: set-thickness +DEFER: set-color-index + +TUPLE: state position orientation angle length thickness color-index ; + +SYMBOL: states V{ } states set + +: save-state ( -- ) +position get orientation get angle get length get thickness get +color-index get +states get push ; + +: restore-state ( -- ) +states get pop +dup state-position position set +dup state-orientation orientation set +dup state-length length set +dup state-angle angle set +dup state-color-index set-color-index +dup state-thickness set-thickness +drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: scale-length ( m -- ) length get * length set ; + +: scale-angle ( m -- ) angle get * angle set ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: color-table + +{ { 0 0 0 } ! black + { 0.5 0.5 0.5 } ! grey + { 1 0 0 } ! red + { 1 1 0 } ! yellow + { 0 1 0 } ! green + { 0.250 0.878 0.815 } ! turquoise + { 0 0 1 } ! blue + { 0.627 0.125 0.941 } ! purple + { 0 0.392 0 } ! dark green + { 0.0 0.807 0.819 } ! dark turquoise + { 0.0 0.0 0.545 } ! dark blue + { 0.580 0.0 0.827 } ! dark purple + { 0.545 0.0 0.0 } ! dark red + { 0.25 0.25 0.25 } ! dark grey + { 0.75 0.75 0.75 } ! medium grey + { 1 1 1 } ! white +} color-table set + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USE: sequences + +: >float-array ( seq -- ) +dup length swap dup length >array [ pick set-float-nth ] 2each ; + +USE: lindenmayer + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: material-color ( r g b -- ) +3array 1.0 add >float-array +GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot glMaterialfv ; + +: set-color-index ( i -- ) +dup color-index set color-table get nth dup +first3 glColor3f first3 material-color ; + +: inc-color-index ( -- ) color-index get 1 + set-color-index ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: set-thickness ( i -- ) dup thickness set glLineWidth ; + +: scale-thickness ( m -- ) thickness get * 0.5 max set-thickness ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: lparser-dialect ( -- ) + +1 length set 45 angle set 1 thickness set 2 set-color-index + +H{ [[ "+" [ angle get rotate-y ] ]] + [[ "-" [ angle get neg rotate-y ] ]] + [[ "&" [ angle get rotate-x ] ]] + [[ "^" [ angle get neg rotate-x ] ]] + [[ "<" [ angle get rotate-z ] ]] + [[ ">" [ angle get neg rotate-z ] ]] + [[ "|" [ 180.0 rotate-y ] ]] + [[ "%" [ 180.0 rotate-z ] ]] + + [[ "F" [ length get draw-forward ] ]] + [[ "Z" [ length get 2 / draw-forward ] ]] + [[ "f" [ length get move-forward ] ]] + [[ "z" [ length get 2 / move-forward ] ]] + [[ "g" [ length get sneak-forward ] ]] + +! [[ "." [ record-vertex ] ]] + [[ "." [ polygon-vertex ] ]] + [[ "[" [ save-state ] ]] + [[ "]" [ restore-state ] ]] +! [[ "{" [ GL_LINE_LOOP glBegin ] ]] +! [[ "{" [ GL_POLYGON glBegin ] ]] + [[ "{" [ start-polygon ] ]] +! [[ "}" [ glEnd ] ]] + [[ "}" [ finish-polygon ] ]] + + [[ "/" [ 1.1 scale-length ] ]] + [[ "'" [ 0.9 scale-length ] ]] + [[ ";" [ 1.1 scale-angle ] ]] + [[ ":" [ 0.9 scale-angle ] ]] + [[ "?" [ thickness get 1.4 * thickness set ] ]] + [[ "!" [ thickness get 0.7 * thickness set ] ]] + + [[ "c" [ inc-color-index ] ]] +} command-table set ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Examples +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: result + +: koch ( -- ) lparser-dialect 90 angle set + +[ 0.41 scale-length ] "1" command-table get set-hash +[ 2.439 scale-length ] "2" command-table get set-hash +[ 0.5 scale-length ] "3" command-table get set-hash +[ 0.2887 scale-length ] "4" command-table get set-hash +[ 3.4758 scale-length ] "5" command-table get set-hash +[ 60 rotate-z ] "6" command-table get set-hash +[ 120 rotate-z ] "7" command-table get set-hash +[ 180 rotate-x ] "8" command-table get set-hash +[ 109.5111 rotate-x ] "9" command-table get set-hash +[ -120 rotate-y ] "0" command-table get set-hash + +H{ [[ "K" "[[a|b] 1f2 |6 [a|b]]" ]] + [[ "k" "[ c3 K]" ]] + [[ "a" "[d 7 d 7 d ]" ]] + [[ "b" "e" ]] + [[ "e" "[^ 4f5 8 +z{.0f0f}]" ]] + [[ "d" "[^ 4f5 9 +zk{.0f0f}]" ]] +} rules set + +"K" 5 [ rewrite ] times dup result set ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: spiral-0 ( -- ) lparser-dialect 10 angle set + +H{ [[ "P" "[A]>>>>>>>>>[cB]>>>>>>>>>[ccC]>>>>>>>>>[cccD]" ]] + [[ "A" "F+;'A" ]] + [[ "B" "F!+F+;'B" ]] + [[ "C" "F!^+F^+;'C" ]] + [[ "D" "F!>^+F>^+;'D" ]] +} rules set + +"[P]|[P]" 5 [ rewrite ] times dup result set ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: tree-5 ( -- ) lparser-dialect 5 angle set + +[ 4 set-color-index ] "1" command-table get set-hash +[ 60 neg rotate-z ] "2" command-table get set-hash +[ 1.25 scale-length ] "3" command-table get set-hash +[ 0.8 scale-length ] "4" command-table get set-hash +[ 30 neg rotate-z ] "5" command-table get set-hash + +H{ [[ "S" "FFR2R2R2R2R2R5S" ]] + [[ "R" "[Ba]" ]] + [[ "a" "$tF[Cx]Fb" ]] + [[ "b" "$tF[Dy]Fa" ]] + [[ "B" "&B" ]] + [[ "C" "+C" ]] + [[ "D" "-D" ]] + [[ "x" "a" ]] + [[ "y" "b" ]] + [[ "F" "3F4" ]] +} rules set + +"1FFS" result set ; + From d265bebf884b6877576c222ddf19e36c709de2be Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 12 Jan 2006 08:24:18 +0000 Subject: [PATCH 241/373] *** empty log message *** --- contrib/x11/examples/lindenmayer/lindenmayer.factor | 4 ---- contrib/x11/examples/lindenmayer/load.factor | 5 +++++ 2 files changed, 5 insertions(+), 4 deletions(-) create mode 100644 contrib/x11/examples/lindenmayer/load.factor diff --git a/contrib/x11/examples/lindenmayer/lindenmayer.factor b/contrib/x11/examples/lindenmayer/lindenmayer.factor index 2e5f0afee6..9f74580564 100644 --- a/contrib/x11/examples/lindenmayer/lindenmayer.factor +++ b/contrib/x11/examples/lindenmayer/lindenmayer.factor @@ -208,14 +208,10 @@ H{ [[ "+" [ angle get rotate-y ] ]] [[ "z" [ length get 2 / move-forward ] ]] [[ "g" [ length get sneak-forward ] ]] -! [[ "." [ record-vertex ] ]] [[ "." [ polygon-vertex ] ]] [[ "[" [ save-state ] ]] [[ "]" [ restore-state ] ]] -! [[ "{" [ GL_LINE_LOOP glBegin ] ]] -! [[ "{" [ GL_POLYGON glBegin ] ]] [[ "{" [ start-polygon ] ]] -! [[ "}" [ glEnd ] ]] [[ "}" [ finish-polygon ] ]] [[ "/" [ 1.1 scale-length ] ]] diff --git a/contrib/x11/examples/lindenmayer/load.factor b/contrib/x11/examples/lindenmayer/load.factor new file mode 100644 index 0000000000..7432cf6453 --- /dev/null +++ b/contrib/x11/examples/lindenmayer/load.factor @@ -0,0 +1,5 @@ +USING: kernel parser words compiler sequences ; + +"lindenmayer.factor" run-file + +"lindenmayer" words [ try-compile ] each clear From 554a27029c2df95192b8d94fa554d7282d68d7e1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Jan 2006 22:59:45 +0000 Subject: [PATCH 242/373] fix typo --- TODO.FACTOR.txt | 2 +- library/kernel.facts | 4 ++-- library/math/complex.factor | 13 ++++--------- 3 files changed, 7 insertions(+), 12 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 881e4435b7..ec5b323971 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,9 +1,9 @@ +- FUNCTION: not updating crossref correctly - UI word wrap: sometimes a space appears at the front - need line and paragraph spacing - update HTML stream - help cross-referencing - UI browser pane needs 'back' button -- tty help - if cell is rebound, and we allocate c objects, bang - runtime primitives like fopen: check for null input - -with combinators are awkward diff --git a/library/kernel.facts b/library/kernel.facts index 586f78acb5..288098f771 100644 --- a/library/kernel.facts +++ b/library/kernel.facts @@ -182,13 +182,13 @@ HELP: if "( cond true false -- )" $terpri "The " { $snippet "cond" } " value is removed from the stack before either quotation is called." } ; -HELP: when "( cond true false -- )" +HELP: when "( cond true -- )" { $values { "cond" "a generalized boolean" } { "true" "a quotation" } } { $description "If " { $snippet "cond" } " is not " { $link f } ", calls the " { $snippet "true" } " quotation." $terpri "The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ; -HELP: unless "( cond true false -- )" +HELP: unless "( cond false -- )" { $values { "cond" "a generalized boolean" } { "false" "a quotation" } } { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation." $terpri diff --git a/library/math/complex.factor b/library/math/complex.factor index 38a6546a57..40873c3d06 100644 --- a/library/math/complex.factor +++ b/library/math/complex.factor @@ -26,21 +26,16 @@ M: number = ( n n -- ? ) number= ; : conjugate ( z -- z* ) >rect neg rect> ; inline -: arg ( z -- arg ) - #! Compute the complex argument. - >rect swap fatan2 ; inline +: arg ( z -- arg ) >rect swap fatan2 ; inline : >polar ( z -- abs arg ) dup abs swap >rect swap fatan2 ; inline -: cis ( theta -- cis ) - dup fcos swap fsin rect> ; inline +: cis ( theta -- cis ) dup fcos swap fsin rect> ; inline -: polar> ( abs arg -- z ) - cis * ; inline +: polar> ( abs arg -- z ) cis * ; inline -: quadrant ( z -- n ) - >rect >r 0 >= 0 1 ? r> 0 >= 0 3 ? bitxor ; +: quadrant ( z -- n ) >rect >r 0 >= 0 1 ? r> 0 >= 0 3 ? bitxor ; M: complex absq >rect [ sq ] 2apply + ; From 27c570e46057dab75998c7f56f00aea7d7d49b91 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Jan 2006 04:01:12 +0000 Subject: [PATCH 243/373] fix httpd load issues --- contrib/httpd/cont-responder.factor | 2 +- contrib/httpd/default-responders.factor | 3 +-- contrib/httpd/html.factor | 2 +- contrib/httpd/mime.factor | 4 ++-- 4 files changed, 5 insertions(+), 6 deletions(-) diff --git a/contrib/httpd/cont-responder.factor b/contrib/httpd/cont-responder.factor index 36b35138cd..48fde4ada8 100644 --- a/contrib/httpd/cont-responder.factor +++ b/contrib/httpd/cont-responder.factor @@ -21,7 +21,7 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: cont-responder -USING: http httpd math random namespaces io +USING: http httpd math namespaces io lists strings kernel html hashtables parser generic sequences ; diff --git a/contrib/httpd/default-responders.factor b/contrib/httpd/default-responders.factor index cc63049546..aa995af38d 100644 --- a/contrib/httpd/default-responders.factor +++ b/contrib/httpd/default-responders.factor @@ -2,8 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: httpd USING: browser-responder cont-responder file-responder kernel -namespaces prettyprint quit-responder resource-responder -test-responder ; +namespaces prettyprint ; #! Remove all existing responders, and create a blank #! responder table. diff --git a/contrib/httpd/html.factor b/contrib/httpd/html.factor index 294bbc73b2..6fb97cb766 100644 --- a/contrib/httpd/html.factor +++ b/contrib/httpd/html.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: html USING: generic hashtables http io kernel lists math namespaces -presentation sequences strings styles words ; +sequences strings styles words ; : html-entities ( -- alist ) H{ diff --git a/contrib/httpd/mime.factor b/contrib/httpd/mime.factor index 01ad7d86f5..1eb73cdc11 100644 --- a/contrib/httpd/mime.factor +++ b/contrib/httpd/mime.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. +! See http://factorcode.org/license.txt for BSD license. IN: httpd -USING: io hashtables kernel lists namespaces ; +USING: io hashtables kernel sequences math namespaces ; : file-extension ( filename -- extension ) "." split dup length 1 <= [ drop f ] [ peek ] if ; From ff6ba6ca3672979399df6a081a98f6fe965c933e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Jan 2006 06:48:29 +0000 Subject: [PATCH 244/373] math docs --- doc/handbook/math.facts | 227 +++++++++++++++++++++++++++ library/bootstrap/boot-stage1.factor | 1 + library/collections/hashtables.facts | 8 +- library/math/random.factor | 6 +- 4 files changed, 231 insertions(+), 11 deletions(-) create mode 100644 doc/handbook/math.facts diff --git a/doc/handbook/math.facts b/doc/handbook/math.facts new file mode 100644 index 0000000000..a651da2590 --- /dev/null +++ b/doc/handbook/math.facts @@ -0,0 +1,227 @@ +USING: help math prettyprint sequences ; + +ARTICLE: "math" "Mathematics" +"Factor attempts to preserve natural mathematical semantics for numbers. Multiplying two large integers never results in overflow, and dividing two integers yields an exact ratio. Floating point numbers are also supported, along with complex numbers." +$terpri +"Math words are in the " { $snippet "math" } " vocabulary. Implementation details are in the " { $snippet "math-internals" } " vocabulary." +{ $subsection "number-protocol" } +{ $subsection "number-types" } +{ $subsection "math-functions" } +{ $subsection "math-constants" } +{ $subsection "math-vectors" } ; + +ARTICLE: "number-types" "Types of numbers" +{ $subsection "integers" } +{ $subsection "rationals" } +{ $subsection "floats" } +{ $subsection "complex-numbers" } ; + +ARTICLE: "number-protocol" "Number protocol" +"Math operations obey certain numerical upgrade rules. If one of the inputs is a bignum and the other is a fixnum, the latter is first coerced to a bignum; if one of the inputs is a float, the other is coerced to a float." +$terpri +"Two examples where you should note the types of the inputs and outputs:" +{ $example "3 >fixnum 6 >bignum * class ." "bignum" } +{ $example "1/2 2.0 + ." "4.5" } +"The following usual operations are supported by all numbers." +{ $subsection + } +{ $subsection - } +{ $subsection * } +{ $subsection / } +"Non-commutative operations take operands from the stack in the natural order; " { $snippet "6 2 /" } " divides 6 by 2." +$terpri +"Real numbers (but not complex numbers) can be ordered:" +{ $subsection < } +{ $subsection <= } +{ $subsection > } +{ $subsection >= } ; + +ARTICLE: "integers" "Integers" +{ $subsection integer } +"Integers come in two varieties -- fixnums and bignums. Fixnums fit in a machine word and are faster to manipulate; if the result of a fixnum operation is too large to fit in a fixnum, the result is upgraded to a bignum. Here is an example where two fixnums are multiplied yielding a bignum:" +{ $example "134217728 class ." "fixnum" } +{ $example "128 class ." "fixnum" } +{ $example "134217728 128 * ." "17179869184" } +{ $example "134217728 128 * class ." "bignum" } +"Integers can be entered using a different base; see " { $link "integer-literals" } "." +$terpri +"Integers can be tested for, and real numbers can be converted to integers:" +{ $subsection fixnum? } +{ $subsection bignum? } +{ $subsection >fixnum } +{ $subsection >bignum } +"The " { $link . } " word prints numbers in decimal. A set of words in the " { $snippet "prettyprint" } " vocabulary is provided to print integers using another base." +{ $subsection .b } +{ $subsection .o } +{ $subsection .h } +"Some mathematical operations are only supported on integers." +{ $subsection "modular-arithmetic" } +{ $subsection "bitwise-arithmetic" } +{ $subsection "rational numbers" } ; + +ARTICLE: "modular-arithmetic" "Modular arithmetic" +{ $subsection mod } +{ $subsection rem } +{ $subsection /mod } +{ $subsection /i } +{ $subsection gcd } ; + +ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic" +"There are two ways of looking at an integer -- as an abstract mathematical entity, or as a string of bits. The latter representation motivates " { $emphasis "bitwise operations" } "." +{ $subsection bitand } +{ $subsection bitor } +{ $subsection bitxor } +{ $subsection bitnot } +{ $subsection shift } +{ $subsection log2 } +{ $subsection power-of-2? } +{ $subsection next-power-of-2 } +{ $subsection each-bit } ; + +ARTICLE: "random-numbers" "Generating random integers" +{ $subsection (random-int) } +{ $subsection random-int } ; + +ARTICLE: "rationals" "Rational numbers" +{ $subsection ratio } +"When we add, subtract or multiply any two integers, the result is always an integer. However, dividing a numerator by a denominator that is not an integral divisor of the denominator yields a ratio:" +{ $example "1210 11 / ." "110" } +{ $example "100 330 / ." "10/33" } +"Ratios are printed and can be input literally in the form above. Ratios are always reduced to lowest terms by factoring out the greatest common divisor of the numerator and denominator. A ratio with a denominator of 1 becomes an integer. Division with a denominator of 0 throws an error." +$terpri +"Ratios behave just like any other number -- all numerical operations work as you would expect." +{ $example "1/2 1/3 + ." "5/6" } +{ $example "100 6 / 3 * ." "50" } +"Ratios can be taken apart:" +{ $subsection numerator } +{ $subsection denominator } +{ $subsection >fraction } ; + +ARTICLE: "floats" "Floats" +"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximation" } ". While rationals can grow to any required precision, floating point numbers are fixed-width, and manipulating them is usually faster than manipulating ratios or bignums (but slower than manipulating fixnums). Floating point numbers are often used to represent irrational numbers, which have no exact representation as a ratio of two integers." +$terpri +"Floating point literals are input with a decimal point." +{ $example "1.23 1.5 + ." "1.73" } +"Introducing a floating point number in a computation forces the result to be expressed in floating point." +{ $example "5/4 1/2 + ." "7/4" } +{ $example "5/4 0.5 + ." "1.75" } +"Integers and rationals can be converted to floats:" +{ $subsection >float } +"Two real numbers can be divided yielding a float result:" +{ $subsection /f } +"Floating point numbers are represented internally in IEEE 754 double-precision format. This internal representation can be accessed for advanced operations and input/output purposes." +{ $subsection float>bits } +{ $subsection double>bits } +{ $subsection bits>float } +{ $subsection bits>double } ; + +ARTICLE: "complex-numbers" "Complex numbers" +{ $subsection complex } +"Complex numbers arise as solutions to quadratic equations whose graph does not intersect the " { $emphasis "x" } " axis. Their literal syntax is covered in " { $link "complex-literals" } "." +$terpri +"Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero." +$terpri +"Complex numbers can be taken apart:" +{ $subsection real } +{ $subsection imaginary } +{ $subsection >rect } +"Complex numbers can be constructed from real numbers:" +{ $subsection rect> } +"The polar form can be computed:" +{ $subsection abs } +{ $subsection absq } +{ $subsection arg } +{ $subsection >polar } +{ $subsection polar> } +"Reflection in the " { $snippet "x" } " axis:" +{ $subsection conjugate } ; + +ARTICLE: "math-functions" "Mathematical functions" +{ $subsection "arithmetic-functions" } +{ $subsection "power-functions" } +{ $subsection "trig-hyp-functions" } ; + +ARTICLE: "arithmetic-functions" "Arithmetic functions" +"Computing additive and multiplicative inverses:" +{ $subsection neg } +{ $subsection recip } +"Rounding:" +{ $subsection ceiling } +{ $subsection floor } +{ $subsection truncate } ; + +ARTICLE: "power-functions" "Powers and logarithms" +"Squares:" +{ $subsection sq } +{ $subsection sqrt } +"Exponential and natural logarithm:" +{ $subsection exp } +{ $subsection cis } +{ $subsection log } +"Raising a number to a power:" +{ $subsection ^ } ; + +ARTICLE: "trig-hyp-functions" "Trigonometric and hyperbolic functions" +"Trigonometric functions:" +{ $subsection cos } +{ $subsection sin } +{ $subsection tan } +"Reciprocals:" +{ $subsection sec } +{ $subsection cosec } +{ $subsection cot } +"Inverses:" +{ $subsection acos } +{ $subsection asin } +{ $subsection atan } +"Inverse reciprocals:" +{ $subsection asec } +{ $subsection acosec } +{ $subsection acot } +"Hyperbolic functions:" +{ $subsection cosh } +{ $subsection sinh } +{ $subsection tanh } +"Reciprocals:" +{ $subsection sech } +{ $subsection cosech } +{ $subsection coth } +"Inverses:" +{ $subsection acosh } +{ $subsection asinh } +{ $subsection atanh } +"Inverse reciprocals:" +{ $subsection asech } +{ $subsection acosech } +{ $subsection acoth } ; + +ARTICLE: "math-constants" "Constants" +{ $subsection i } +{ $subsection -i } +{ $subsection inf } +{ $subsection -inf } +{ $subsection e } +{ $subsection pi } +{ $subsection most-positive-fixnum } +{ $subsection most-negative-fixnum } ; + +ARTICLE: "math-vectors" "Vector arithmetic" +"Any Factor sequence can be used to represent a mathematical vector." +$terpri +"Acting on vectors by a scalar:" +{ $subsection vneg } +{ $subsection v*n } +{ $subsection n*v } +{ $subsection v/n } +{ $subsection n/v } +"Combining two vectors to form another vector using " { $link 2map } ":" +{ $subsection v+ } +{ $subsection v- } +{ $subsection v* } +{ $subsection v/ } +{ $subsection vmax } +{ $subsection vmin } +"Inner product and norm:" +{ $subsection v. } +{ $subsection norm } +{ $subsection norm-sq } +{ $subsection normalize } ; diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index b56c1c105f..8af383d8bc 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -250,6 +250,7 @@ vectors words ; "/doc/handbook/collections.facts" "/doc/handbook/dataflow.facts" + "/doc/handbook/math.facts" "/doc/handbook/objects.facts" "/doc/handbook/parser.facts" "/doc/handbook/sequences.facts" diff --git a/library/collections/hashtables.facts b/library/collections/hashtables.facts index e2b2a37d46..c27f9b1bce 100644 --- a/library/collections/hashtables.facts +++ b/library/collections/hashtables.facts @@ -74,10 +74,6 @@ HELP: (set-hash) "( value key hash -- )" { $values { "value" "a value" } { "key" "a key to add" } { "hash" "a hashtable" } } { $description "Stores the key/value pair into the hashtable. This word does not grow the hashtable if it exceeds capacity, therefore a hang can result. Client code should use " { $link set-hash } " instead, which grows the hashtable if necessary." } ; -HELP: (set-hash) "( value key hash -- )" -{ $values { "value" "a value" } { "key" "a key to add" } { "hash" "a hashtable" } } -{ $description "Stores the key/value pair into the hashtable. This word does not grow the hashtable if it exceeds capacity, therefore a hang can result. Client code should use " { $link set-hash } " instead, which grows the hashtable if necessary." } ; - HELP: grow-hash "( hash -- )" { $values { "hash" "a hashtable" } } { $description "Enlarges the capacity of a hashtable. Client code does not need to call this word directly." } @@ -145,8 +141,8 @@ HELP: remove-hash "( key hash -- )" { $description "Removes an entry from the hashtable." } { $see-also clear-hash } ; -HELP: set-hash "( key hash -- )" -{ $values { "key" "a key" } { "hash" "a hashtable" } } +HELP: set-hash "( value key hash -- )" +{ $values { "value" "a value" } { "key" "a key" } { "hash" "a hashtable" } } { $description "Stores an entry into the hashtable." } { $see-also hash remove-hash } ; diff --git a/library/math/random.factor b/library/math/random.factor index cdfea2b7ed..d1bee1ec80 100644 --- a/library/math/random.factor +++ b/library/math/random.factor @@ -48,7 +48,6 @@ SYMBOL: mti IN: math : init-random ( seed -- ) - #! Initialize the random number generator with a new seed. global [ mt-n 0 swap HEX: ffffffff bitand 0 pick set-nth @@ -58,12 +57,9 @@ IN: math ] bind ; : (random-int) ( -- rand ) - #! Generate a random integer between 0 and 2^32-1 inclusive. global [ mti get dup mt-n < [ drop generate-mt 0 ] unless mt-nth mt-temper mti inc ] bind ; -: random-int ( n -- rand ) - #! Generate a random integer between 0 and n-1 inclusive. - (random-int) * -32 shift ; +: random-int ( n -- rand ) (random-int) * -32 shift ; From 3131680364705e520c01f004cf81b8b9fbf37881 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Jan 2006 07:38:57 +0000 Subject: [PATCH 245/373] help fixes --- doc/handbook/handbook.facts | 34 ++++++++++++++++++++++++++++ doc/handbook/math.facts | 2 +- doc/handbook/tutorial.facts | 2 -- library/bootstrap/boot-stage1.factor | 1 + library/ui/listener.factor | 8 +++---- library/ui/ui.factor | 2 -- 6 files changed, 40 insertions(+), 9 deletions(-) create mode 100644 doc/handbook/handbook.facts diff --git a/doc/handbook/handbook.facts b/doc/handbook/handbook.facts new file mode 100644 index 0000000000..870cf09bdd --- /dev/null +++ b/doc/handbook/handbook.facts @@ -0,0 +1,34 @@ +USING: help parser prettyprint ; + +ARTICLE: "handbook" "Factor documentation" +"Welcome to Factor! Factor documentation is takes the form of an outline, with cross-referencing hyperlinks between topics. You can click the triangle next to a topic heading to expand the topic:" +{ $subsection "presentation-intro" } +"There is a short language tutorial:" +{ $subsection "tutorial" } +"Some words for performing common operations at the listener:" +{ $list + { + "You can read the documentation for a word with " { $link help } ":" + { $code "\\ reverse help" } + } + { "You can print the top of the stack with " { $link . } } + { + "Source files are loaded with " { $link run-file } ":" + { $code "\"tetris.factor\" run-file" } + } +} +"Detailed documentation:" +{ $subsection "syntax" } +{ $subsection "dataflow" } +{ $subsection "words" } +{ $subsection "objects" } +{ $subsection "math" } +{ $subsection "collections" } +{ $subsection "parser" } ; + +ARTICLE: "presentation-intro" "The presentation-based UI" +"Factor provides a " { $emphasis "presentation-based" } " user interface. A " { $emphasis "presentation" } " is a graphical representation of a live object. You can see presentations everywhere; help links, words, and code examples are all presentations." +$terpri +"When you place the mouse over a presentation, it is highlighted with a surrounding border." +$terpri +"Clicking a presentation with the left mouse button invokes a default command. Clicking the right mouse button displays a menu of applicable commands." ; diff --git a/doc/handbook/math.facts b/doc/handbook/math.facts index a651da2590..445e04ba17 100644 --- a/doc/handbook/math.facts +++ b/doc/handbook/math.facts @@ -56,7 +56,7 @@ $terpri "Some mathematical operations are only supported on integers." { $subsection "modular-arithmetic" } { $subsection "bitwise-arithmetic" } -{ $subsection "rational numbers" } ; +{ $subsection "random-numbers" } ; ARTICLE: "modular-arithmetic" "Modular arithmetic" { $subsection mod } diff --git a/doc/handbook/tutorial.facts b/doc/handbook/tutorial.facts index faeaee50c7..ca2f57c468 100644 --- a/doc/handbook/tutorial.facts +++ b/doc/handbook/tutorial.facts @@ -196,5 +196,3 @@ $terpri { $subsection "tutorial-classes" } { $subsection "tutorial-library" } { $subsection "tutorial-more" } ; - -: tutorial "tutorial" help ; diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 8af383d8bc..4969004907 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -250,6 +250,7 @@ vectors words ; "/doc/handbook/collections.facts" "/doc/handbook/dataflow.facts" + "/doc/handbook/handbook.facts" "/doc/handbook/math.facts" "/doc/handbook/objects.facts" "/doc/handbook/parser.facts" diff --git a/library/ui/listener.factor b/library/ui/listener.factor index 7701772be9..81383fb462 100644 --- a/library/ui/listener.factor +++ b/library/ui/listener.factor @@ -42,14 +42,14 @@ SYMBOL: browser-pane datastack-hook get call stack-bar get show-stack word-completion ; -: tutorial-button - { "tutorial" } $link terpri ; +: help-button + "Please read the " write { "handbook" } $link "." print ; : listener-thread pane get [ [ ui-listener-hook ] listener-hook set - tutorial-button - tty + help-button + listener ] with-stream* ; M: label set-message ( string/f status -- ) diff --git a/library/ui/ui.factor b/library/ui/ui.factor index fde6ad6150..fb80d5c90d 100644 --- a/library/ui/ui.factor +++ b/library/ui/ui.factor @@ -30,8 +30,6 @@ global [ first-time on ] bind IN: shells : ui ( -- ) - #! Start the Factor graphics subsystem with the given screen - #! dimensions. check-running [ init-world world get rect-dim first2 [ listener-application run-world ] with-gl-screen From 10359f2d96e21c1c8f22ba371a8451d743990528 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Jan 2006 08:04:04 +0000 Subject: [PATCH 246/373] fixed number-sort --- contrib/math/statistics.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/contrib/math/statistics.factor b/contrib/math/statistics.factor index da472dc762..4437713c78 100644 --- a/contrib/math/statistics.factor +++ b/contrib/math/statistics.factor @@ -14,9 +14,10 @@ USING: kernel math sequences ; #! positive reals only 0 [ recip + ] reduce recip ; +! : number-sort [ - ] sort ; : median ( seq -- n ) #! middle number if odd, avg of two middle numbers if even - number-sort dup length dup even? [ + [ - ] sort dup length dup even? [ 1+ 2 /i dup 1- rot [ nth ] keep swapd nth + 2 / ] [ 2 /i swap nth From 1bafed23f1f98fd624376e2024fd5d7ba03cefa6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Jan 2006 08:05:02 +0000 Subject: [PATCH 247/373] fixed sum's move to contrib-math --- contrib/crypto/load.factor | 1 + contrib/crypto/sha1.factor | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/contrib/crypto/load.factor b/contrib/crypto/load.factor index a09ef4ae86..5d8ef336ed 100644 --- a/contrib/crypto/load.factor +++ b/contrib/crypto/load.factor @@ -1,6 +1,7 @@ IN: crypto USING: parser sequences words compiler ; [ + "contrib/math/load.factor" "contrib/crypto/common.factor" "contrib/crypto/md5.factor" "contrib/crypto/sha1.factor" diff --git a/contrib/crypto/sha1.factor b/contrib/crypto/sha1.factor index 73d84617b4..b91cf8615c 100644 --- a/contrib/crypto/sha1.factor +++ b/contrib/crypto/sha1.factor @@ -1,6 +1,6 @@ IN: crypto-internals USING: kernel io strings sequences namespaces math prettyprint -test parser lists vectors hashtables kernel-internals crypto ; +test parser lists vectors hashtables kernel-internals math-contrib crypto ; ! Implemented according to RFC 3174. From 64e326e56d5500d1efc980718fab2191976e4642 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 13 Jan 2006 12:52:21 +0000 Subject: [PATCH 248/373] Replace use of '2list' in parser combinators code. parser-combinators are still broken though due to an error calling the 'parens' test. This used to work in 0.78... --- contrib/parser-combinators/lazy.factor | 34 +------------------------ contrib/parser-combinators/tests.factor | 2 +- 2 files changed, 2 insertions(+), 34 deletions(-) diff --git a/contrib/parser-combinators/lazy.factor b/contrib/parser-combinators/lazy.factor index 2ba6f89cfe..69b85b28bf 100644 --- a/contrib/parser-combinators/lazy.factor +++ b/contrib/parser-combinators/lazy.factor @@ -228,7 +228,7 @@ DEFER: list>llist : lappend ( llist1 llist2 -- llist ) #! Concatenate two lazy lists such that they appear to be one big #! lazy list. - 2list list>llist lappend* ; + [ ] cons cons list>llist lappend* ; : leach ( llist quot -- ) #! Call the quotation on each item in the lazy list. @@ -263,35 +263,3 @@ DEFER: list>llist drop lnil ] if ; -! M: lcons nth lnth ; - -: test1 - [ 1 ] list>llist - [ 2 ] list>llist - 2list - list>llist - lappend* ; - -: test2 - [ 1 2 ] list>llist - [ 3 4 ] list>llist - 2list - list>llist - lappend* ; - -: test3 - [ 1 2 3 ] list>llist - [ 4 5 6 ] list>llist - [ 7 8 9 ] list>llist - 2list cons - list>llist - lappend* ; - -: test4 - [ 1 2 3 4 5 ] list>llist - [ 2 mod 1 = ] lsubset ; - -: test5 lnil unit delay lunit [ lnil? not ] lsubset ; - -: test6 lnil unit delay lunit lappend* ; - diff --git a/contrib/parser-combinators/tests.factor b/contrib/parser-combinators/tests.factor index c2c856785d..b0f7d3135e 100644 --- a/contrib/parser-combinators/tests.factor +++ b/contrib/parser-combinators/tests.factor @@ -21,7 +21,7 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: scratchpad -USING: kernel lazy parser-combinators test errors strings parser lists math sequences unparser ; +USING: kernel lazy parser-combinators test errors strings parser lists math sequences ; ! Testing <&> [ [ [[ "cd" [[ "a" "b" ]] ]] ] ] [ From bb9ff1cc7bf30704ca2ed0dafd3d2e6734bed1d4 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 13 Jan 2006 12:58:11 +0000 Subject: [PATCH 249/373] Fix space invaders hashtable and array usage for 0.80. --- contrib/space-invaders/cpu-8080.factor | 192 ++++++++++++------------- 1 file changed, 96 insertions(+), 96 deletions(-) diff --git a/contrib/space-invaders/cpu-8080.factor b/contrib/space-invaders/cpu-8080.factor index e8c34aa1b2..14941a030d 100644 --- a/contrib/space-invaders/cpu-8080.factor +++ b/contrib/space-invaders/cpu-8080.factor @@ -1,4 +1,4 @@ -USING: kernel lists math sequences errors vectors prettyprint io unparser namespaces +USING: kernel lists math sequences errors vectors prettyprint io namespaces arrays words parser hashtables lazy parser-combinators kernel-internals strings ; IN: cpu-8080 @@ -558,18 +558,18 @@ C: cpu ( cpu -- cpu ) #! where the 1st item is the getter and the 2nd is the setter #! for that register. H{ - [[ "A" { cpu-a set-cpu-a } ]] - [[ "B" { cpu-b set-cpu-b } ]] - [[ "C" { cpu-c set-cpu-c } ]] - [[ "D" { cpu-d set-cpu-d } ]] - [[ "E" { cpu-e set-cpu-e } ]] - [[ "H" { cpu-h set-cpu-h } ]] - [[ "L" { cpu-l set-cpu-l } ]] - [[ "AF" { cpu-af set-cpu-af } ]] - [[ "BC" { cpu-bc set-cpu-bc } ]] - [[ "DE" { cpu-de set-cpu-de } ]] - [[ "HL" { cpu-hl set-cpu-hl } ]] - [[ "SP" { cpu-sp set-cpu-sp } ]] + { "A" { cpu-a set-cpu-a } } + { "B" { cpu-b set-cpu-b } } + { "C" { cpu-c set-cpu-c } } + { "D" { cpu-d set-cpu-d } } + { "E" { cpu-e set-cpu-e } } + { "H" { cpu-h set-cpu-h } } + { "L" { cpu-l set-cpu-l } } + { "AF" { cpu-af set-cpu-af } } + { "BC" { cpu-bc set-cpu-bc } } + { "DE" { cpu-de set-cpu-de } } + { "HL" { cpu-hl set-cpu-hl } } + { "SP" { cpu-sp set-cpu-sp } } } hash ; @@ -577,14 +577,14 @@ C: cpu ( cpu -- cpu ) #! Given a string containing a flag name, return a vector #! where the 1st item is a word that tests that flag. H{ - [[ "NZ" { flag-nz? } ]] - [[ "NC" { flag-nc? } ]] - [[ "PO" { flag-po? } ]] - [[ "PE" { flag-pe? } ]] - [[ "Z" { flag-z? } ]] - [[ "C" { flag-c? } ]] - [[ "P" { flag-p? } ]] - [[ "M" { flag-m? } ]] + { "NZ" { flag-nz? } } + { "NC" { flag-nc? } } + { "PO" { flag-po? } } + { "PE" { flag-pe? } } + { "Z" { flag-z? } } + { "C" { flag-c? } } + { "P" { flag-p? } } + { "M" { flag-m? } } } hash ; SYMBOL: $1 @@ -699,81 +699,81 @@ SYMBOL: $4 : patterns ( -- hashtable ) #! table of code quotation patterns for each type of instruction. H{ - [[ "NOP" [ drop ] ]] - [[ "RET-NN" [ ret-from-sub ] ]] - [[ "RST-0" [ 0 swap (emulate-RST) ] ]] - [[ "RST-8" [ 8 swap (emulate-RST) ] ]] - [[ "RST-10H" [ HEX: 10 swap (emulate-RST) ] ]] - [[ "RST-18H" [ HEX: 18 swap (emulate-RST) ] ]] - [[ "RST-20H" [ HEX: 20 swap (emulate-RST) ] ]] - [[ "RST-28H" [ HEX: 28 swap (emulate-RST) ] ]] - [[ "RST-30H" [ HEX: 30 swap (emulate-RST) ] ]] - [[ "RST-38H" [ HEX: 38 swap (emulate-RST) ] ]] - [[ "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] ]] - [[ "CP-N" [ [ cpu-a ] keep [ next-byte ] keep sub-byte drop ] ]] - [[ "CP-R" [ [ cpu-a ] keep [ $1 ] keep sub-byte drop ] ]] - [[ "CP-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] ]] - [[ "OR-N" [ [ cpu-a ] keep [ next-byte ] keep [ or-byte ] keep set-cpu-a ] ]] - [[ "OR-R" [ [ cpu-a ] keep [ $1 ] keep [ or-byte ] keep set-cpu-a ] ]] - [[ "OR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep set-cpu-a ] ]] - [[ "XOR-N" [ [ cpu-a ] keep [ next-byte ] keep [ xor-byte ] keep set-cpu-a ] ]] - [[ "XOR-R" [ [ cpu-a ] keep [ $1 ] keep [ xor-byte ] keep set-cpu-a ] ]] - [[ "XOR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep set-cpu-a ] ]] - [[ "AND-N" [ [ cpu-a ] keep [ next-byte ] keep [ and-byte ] keep set-cpu-a ] ]] - [[ "AND-R" [ [ cpu-a ] keep [ $1 ] keep [ and-byte ] keep set-cpu-a ] ]] - [[ "AND-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep set-cpu-a ] ]] - [[ "ADC-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] ]] - [[ "ADC-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] ]] - [[ "ADC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] ]] - [[ "ADD-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] ]] - [[ "ADD-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] ]] - [[ "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] ]] - [[ "ADD-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2 ] ]] - [[ "SBC-R,N" [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] ]] - [[ "SBC-R,R" [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] ]] - [[ "SBC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] ]] - [[ "SUB-R" [ [ cpu-a ] keep [ $1 ] keep [ sub-byte ] keep set-cpu-a ] ]] - [[ "SUB-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep set-cpu-a ] ]] - [[ "SUB-N" [ [ cpu-a ] keep [ next-byte ] keep [ sub-byte ] keep set-cpu-a ] ]] - [[ "CPL" [ (emulate-CPL) ] ]] - [[ "DAA" [ (emulate-DAA) ] ]] - [[ "RLA" [ (emulate-RLA) ] ]] - [[ "RRA" [ (emulate-RRA) ] ]] - [[ "CCF" [ carry-flag swap cpu-f-bitxor= ] ]] - [[ "SCF" [ carry-flag swap cpu-f-bitor= ] ]] - [[ "RLCA" [ (emulate-RLCA) ] ]] - [[ "RRCA" [ (emulate-RRCA) ] ]] - [[ "HALT" [ drop ] ]] - [[ "DI" [ [ 255 interrupt-flag - ] swap cpu-f-bitand ] ]] - [[ "EI" [ [ interrupt-flag ] swap cpu-f-bitor ] ]] - [[ "POP-RR" [ [ pop-sp ] keep $2 ] ]] - [[ "PUSH-RR" [ [ $1 ] keep push-sp ] ]] - [[ "INC-R" [ [ $1 ] keep [ inc-byte ] keep $2 ] ]] - [[ "DEC-R" [ [ $1 ] keep [ dec-byte ] keep $2 ] ]] - [[ "INC-RR" [ [ $1 ] keep [ inc-word ] keep $2 ] ]] - [[ "DEC-RR" [ [ $1 ] keep [ dec-word ] keep $2 ] ]] - [[ "DEC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] ]] - [[ "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] ]] - [[ "JP-NN" [ [ cpu-pc ] keep [ read-word ] keep set-cpu-pc ] ]] - [[ "JP-F|FF,NN" [ [ $1 ] keep swap [ [ next-word ] keep [ set-cpu-pc ] keep [ cpu-cycles ] keep swap 5 + swap set-cpu-cycles ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] ]] - [[ "JP-(RR)" [ [ $1 ] keep set-cpu-pc ] ]] - [[ "CALL-NN" [ (emulate-CALL) ] ]] - [[ "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] ]] - [[ "LD-RR,NN" [ [ next-word ] keep $2 ] ]] - [[ "LD-RR,RR" [ [ $3 ] keep $2 ] ]] - [[ "LD-R,N" [ [ next-byte ] keep $2 ] ]] - [[ "LD-(RR),N" [ [ next-byte ] keep [ $1 ] keep write-byte ] ]] - [[ "LD-(RR),R" [ [ $3 ] keep [ $1 ] keep write-byte ] ]] - [[ "LD-R,R" [ [ $3 ] keep $2 ] ]] - [[ "LD-R,(RR)" [ [ $3 ] keep [ read-byte ] keep $2 ] ]] - [[ "LD-(NN),RR" [ [ $1 ] keep [ next-word ] keep write-word ] ]] - [[ "LD-(NN),R" [ [ $1 ] keep [ next-word ] keep write-byte ] ]] - [[ "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] ]] - [[ "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] ]] - [[ "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] ]] - [[ "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep set-cpu-a ] ]] - [[ "EX-(RR),RR" [ [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] ]] - [[ "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] ]] + { "NOP" [ drop ] } + { "RET-NN" [ ret-from-sub ] } + { "RST-0" [ 0 swap (emulate-RST) ] } + { "RST-8" [ 8 swap (emulate-RST) ] } + { "RST-10H" [ HEX: 10 swap (emulate-RST) ] } + { "RST-18H" [ HEX: 18 swap (emulate-RST) ] } + { "RST-20H" [ HEX: 20 swap (emulate-RST) ] } + { "RST-28H" [ HEX: 28 swap (emulate-RST) ] } + { "RST-30H" [ HEX: 30 swap (emulate-RST) ] } + { "RST-38H" [ HEX: 38 swap (emulate-RST) ] } + { "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] } + { "CP-N" [ [ cpu-a ] keep [ next-byte ] keep sub-byte drop ] } + { "CP-R" [ [ cpu-a ] keep [ $1 ] keep sub-byte drop ] } + { "CP-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] } + { "OR-N" [ [ cpu-a ] keep [ next-byte ] keep [ or-byte ] keep set-cpu-a ] } + { "OR-R" [ [ cpu-a ] keep [ $1 ] keep [ or-byte ] keep set-cpu-a ] } + { "OR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep set-cpu-a ] } + { "XOR-N" [ [ cpu-a ] keep [ next-byte ] keep [ xor-byte ] keep set-cpu-a ] } + { "XOR-R" [ [ cpu-a ] keep [ $1 ] keep [ xor-byte ] keep set-cpu-a ] } + { "XOR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep set-cpu-a ] } + { "AND-N" [ [ cpu-a ] keep [ next-byte ] keep [ and-byte ] keep set-cpu-a ] } + { "AND-R" [ [ cpu-a ] keep [ $1 ] keep [ and-byte ] keep set-cpu-a ] } + { "AND-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep set-cpu-a ] } + { "ADC-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] } + { "ADC-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] } + { "ADC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] } + { "ADD-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] } + { "ADD-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] } + { "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] } + { "ADD-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2 ] } + { "SBC-R,N" [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] } + { "SBC-R,R" [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] } + { "SBC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] } + { "SUB-R" [ [ cpu-a ] keep [ $1 ] keep [ sub-byte ] keep set-cpu-a ] } + { "SUB-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep set-cpu-a ] } + { "SUB-N" [ [ cpu-a ] keep [ next-byte ] keep [ sub-byte ] keep set-cpu-a ] } + { "CPL" [ (emulate-CPL) ] } + { "DAA" [ (emulate-DAA) ] } + { "RLA" [ (emulate-RLA) ] } + { "RRA" [ (emulate-RRA) ] } + { "CCF" [ carry-flag swap cpu-f-bitxor= ] } + { "SCF" [ carry-flag swap cpu-f-bitor= ] } + { "RLCA" [ (emulate-RLCA) ] } + { "RRCA" [ (emulate-RRCA) ] } + { "HALT" [ drop ] } + { "DI" [ [ 255 interrupt-flag - ] swap cpu-f-bitand ] } + { "EI" [ [ interrupt-flag ] swap cpu-f-bitor ] } + { "POP-RR" [ [ pop-sp ] keep $2 ] } + { "PUSH-RR" [ [ $1 ] keep push-sp ] } + { "INC-R" [ [ $1 ] keep [ inc-byte ] keep $2 ] } + { "DEC-R" [ [ $1 ] keep [ dec-byte ] keep $2 ] } + { "INC-RR" [ [ $1 ] keep [ inc-word ] keep $2 ] } + { "DEC-RR" [ [ $1 ] keep [ dec-word ] keep $2 ] } + { "DEC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] } + { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] } + { "JP-NN" [ [ cpu-pc ] keep [ read-word ] keep set-cpu-pc ] } + { "JP-F|FF,NN" [ [ $1 ] keep swap [ [ next-word ] keep [ set-cpu-pc ] keep [ cpu-cycles ] keep swap 5 + swap set-cpu-cycles ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] } + { "JP-(RR)" [ [ $1 ] keep set-cpu-pc ] } + { "CALL-NN" [ (emulate-CALL) ] } + { "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] } + { "LD-RR,NN" [ [ next-word ] keep $2 ] } + { "LD-RR,RR" [ [ $3 ] keep $2 ] } + { "LD-R,N" [ [ next-byte ] keep $2 ] } + { "LD-(RR),N" [ [ next-byte ] keep [ $1 ] keep write-byte ] } + { "LD-(RR),R" [ [ $3 ] keep [ $1 ] keep write-byte ] } + { "LD-R,R" [ [ $3 ] keep $2 ] } + { "LD-R,(RR)" [ [ $3 ] keep [ read-byte ] keep $2 ] } + { "LD-(NN),RR" [ [ $1 ] keep [ next-word ] keep write-word ] } + { "LD-(NN),R" [ [ $1 ] keep [ next-word ] keep write-byte ] } + { "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] } + { "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] } + { "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] } + { "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep set-cpu-a ] } + { "EX-(RR),RR" [ [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] } + { "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] } } ; : 8-bit-registers ( -- parser ) From b071adbc25148cebd61381d25f35ffab7067496e Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 13 Jan 2006 13:01:16 +0000 Subject: [PATCH 250/373] fix vocab usage in space invaders --- contrib/space-invaders/space-invaders.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/contrib/space-invaders/space-invaders.factor b/contrib/space-invaders/space-invaders.factor index 21ed7eb958..17581a83f8 100644 --- a/contrib/space-invaders/space-invaders.factor +++ b/contrib/space-invaders/space-invaders.factor @@ -1,6 +1,5 @@ USING: alien cpu-8080 errors generic io kernel kernel-internals -lists math namespaces sdl sdl-event sdl-gfx sdl-video sequences -styles threads ; +lists math namespaces sdl sequences styles threads ; IN: space-invaders TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o ; From 05d800ed2839563f4505d20975d96780d29a46bb Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 13 Jan 2006 13:18:29 +0000 Subject: [PATCH 251/373] Get concurrency contrib code working with 0.80 changes. --- contrib/concurrency/concurrency-examples.factor | 4 ++-- contrib/concurrency/concurrency.factor | 2 +- contrib/concurrency/load.factor | 3 --- 3 files changed, 3 insertions(+), 6 deletions(-) diff --git a/contrib/concurrency/concurrency-examples.factor b/contrib/concurrency/concurrency-examples.factor index c798d3f82e..b97813db1f 100644 --- a/contrib/concurrency/concurrency-examples.factor +++ b/contrib/concurrency/concurrency-examples.factor @@ -23,8 +23,8 @@ ! ! Examples of using the concurrency library. IN: concurrency-examples -USING: concurrency dlists errors gadgets-theme io kernel lists -math namespaces opengl prettyprint sequences threads unparser ; +USING: concurrency dlists errors gadgets-theme gadgets-panes io kernel lists +math namespaces opengl prettyprint sequences threads ; : (logger) ( mailbox -- ) #! Using the given mailbox, start a thread which diff --git a/contrib/concurrency/concurrency.factor b/contrib/concurrency/concurrency.factor index 335302f4a3..4b81d553f9 100644 --- a/contrib/concurrency/concurrency.factor +++ b/contrib/concurrency/concurrency.factor @@ -24,7 +24,7 @@ ! Concurrency library for Factor based on Erlang/Termite style ! concurrency. USING: kernel lists generic threads io namespaces errors words - math sequences hashtables unparser strings vectors dlists ; + math sequences hashtables strings vectors dlists ; IN: concurrency #! Debug diff --git a/contrib/concurrency/load.factor b/contrib/concurrency/load.factor index 1ba87047a2..f224c4ac2c 100644 --- a/contrib/concurrency/load.factor +++ b/contrib/concurrency/load.factor @@ -1,5 +1,4 @@ USE: kernel -USE: httpd USE: threads USE: prettyprint USE: errors @@ -13,5 +12,3 @@ USE: parser : c "concurrency-tests.factor" run-file ; a b -USE: concurrency -USE: concurreny-examples \ No newline at end of file From 57840278425c404ead5309234b243a6d949ebb6a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jan 2006 01:13:14 +0000 Subject: [PATCH 252/373] fix weirdness --- CHANGES.html | 3 +++ doc/handbook/math.facts | 4 ++-- doc/handbook/sequences.facts | 2 +- doc/handbook/syntax.facts | 34 +++++++++++++++--------------- library/alien/compiler.factor | 4 ++-- library/collections/growable.facts | 6 +++--- library/help/commands.factor | 2 +- library/help/markup.factor | 10 +++++++-- library/help/stylesheet.factor | 3 +++ library/io/duplex-stream.factor | 3 ++- library/math/math.facts | 2 +- library/syntax/parse-syntax.facts | 6 +++--- library/syntax/parser.facts | 2 +- library/words.facts | 4 ++-- 14 files changed, 49 insertions(+), 36 deletions(-) diff --git a/CHANGES.html b/CHANGES.html index d7e4047d7a..1d8dbd0804 100644 --- a/CHANGES.html +++ b/CHANGES.html @@ -24,6 +24,8 @@ initial size.
    • The fill word to create a new string with an initial character repeated a certain number of times has been renamed to <string>.
      • +
    • The sum and product words have been moved to +contrib/math/.
    • stream-format ( string style stream -- ) now takes a hashtable @@ -102,6 +104,7 @@ USE: image
    • Contributed libraries:
        +
      • Updated contrib/x11/ with many more examples (Eduardo Cavazos)
      • Added splay tree library in contrib/splay-trees.factor (Mackenzie Straight)
      diff --git a/doc/handbook/math.facts b/doc/handbook/math.facts index 445e04ba17..085bc50ca2 100644 --- a/doc/handbook/math.facts +++ b/doc/handbook/math.facts @@ -42,7 +42,7 @@ ARTICLE: "integers" "Integers" { $example "128 class ." "fixnum" } { $example "134217728 128 * ." "17179869184" } { $example "134217728 128 * class ." "bignum" } -"Integers can be entered using a different base; see " { $link "integer-literals" } "." +"Integers can be entered using a different base; see " { $link "syntax-numbers" } "." $terpri "Integers can be tested for, and real numbers can be converted to integers:" { $subsection fixnum? } @@ -116,7 +116,7 @@ $terpri ARTICLE: "complex-numbers" "Complex numbers" { $subsection complex } -"Complex numbers arise as solutions to quadratic equations whose graph does not intersect the " { $emphasis "x" } " axis. Their literal syntax is covered in " { $link "complex-literals" } "." +"Complex numbers arise as solutions to quadratic equations whose graph does not intersect the " { $emphasis "x" } " axis. Their literal syntax is covered in " { $link "syntax-complex-numbers" } "." $terpri "Unlike math, where all real numbers are also complex numbers, Factor only considers a number to be a complex number if its imaginary part is non-zero. However, complex number operations are fully supported for real numbers; they are treated as having an imaginary part of zero." $terpri diff --git a/doc/handbook/sequences.facts b/doc/handbook/sequences.facts index a119c17637..d2af03469e 100644 --- a/doc/handbook/sequences.facts +++ b/doc/handbook/sequences.facts @@ -188,7 +188,7 @@ GLOSSARY: "array" "an instance of the" { $link array } "class, implementing a fixed-length mutable sequence of objects" ; ARTICLE: "arrays" "Arrays" -"An array is a fixed-size mutable sequence whose elements are stored in a contiguous range of memory. The literal syntax is covered in " { $link "array-literals" } ". Sometimes you need a growable array -- this is called a vector, and vectors are documented in " { $link "vectors" } "." +"An array is a fixed-size mutable sequence whose elements are stored in a contiguous range of memory. The literal syntax is covered in " { $link "syntax-arrays" } ". Sometimes you need a growable array -- this is called a vector, and vectors are documented in " { $link "vectors" } "." $terpri "Array words are in the " { $snippet "arrays" } " vocabulary. Unsafe implementation words are in the " { $snippet "kernel-internals" } " vocabulary." $terpri diff --git a/doc/handbook/syntax.facts b/doc/handbook/syntax.facts index a440f1cdd7..137a13865d 100644 --- a/doc/handbook/syntax.facts +++ b/doc/handbook/syntax.facts @@ -119,7 +119,7 @@ $terpri GLOSSARY: "number" "an instance of the " { $link number } " class" ; -ARTICLE: "syntax-numbers" "Numbers" +ARTICLE: "syntax-numbers" "Number syntax" "If a vocabulary lookup of a token fails, the parser attempts to parse it as a number." { $subsection "syntax-integers" } { $subsection "syntax-ratios" } @@ -132,7 +132,7 @@ GLOSSARY: "fixnum" "an instance of the " { $link fixnum } " class, representing GLOSSARY: "bignum" "an instance of the " { $link bignum } " class, representing an arbitrary-precision integer whose value is bounded by available object memory" ; -ARTICLE: "syntax-integers" "Integers" +ARTICLE: "syntax-integers" "Integer syntax" "The printed representation of an integer consists of a sequence of digits, optionally prefixed by a sign." { $code "123456" @@ -147,18 +147,18 @@ ARTICLE: "syntax-integers" "Integers" GLOSSARY: "ratio" "an instance of the " { $link ratio } " class, representing an exact ratio of two integers" ; -ARTICLE: "syntax-ratios" "Ratios" +ARTICLE: "syntax-ratios" "Ratio syntax" "The printed representation of a ratio is a pair of integers separated by a slash (/). No intermediate whitespace is permitted. Either integer may be signed, however the ratio will be normalized into a form where the denominator is positive and the greatest common divisor of the two terms is 1." { $code "75/33" "1/10" "-5/-6" } -"More information on ratios can be found in " { $link "ratios" } ; +"More information on ratios can be found in " { $link "rationals" } ; GLOSSARY: "float" "an instance of the " { $link float } " class, representing an IEEE 754 double-precision floating point number" ; -ARTICLE: "syntax-floats" "Floats" +ARTICLE: "syntax-floats" "Float syntax" "Floating point numbers contain an optional decimal part, an optional exponent, with an optional sign prefix on either the mantissa or exponent." { $code "10.5" @@ -170,7 +170,7 @@ ARTICLE: "syntax-floats" "Floats" GLOSSARY: "complex" "an instance of the " { $link complex } " class, representing a complex number with real and imaginary components, where both components are real numbers" ; -ARTICLE: "syntax-complex-numbers" "Complex numbers" +ARTICLE: "syntax-complex-numbers" "Complex number syntax" "A complex number is given by two components, a ``real'' part and ''imaginary'' part. The components must either be integers, ratios or floats." { $code "C{ 1/2 1/3 } ! the complex number 1/2+1/3i" @@ -180,7 +180,7 @@ ARTICLE: "syntax-complex-numbers" "Complex numbers" GLOSSARY: "wrapper" "an instance of the " { $link wrapper } " class, holding a reference to a single object. When the evaluator encounters a wrapper, it pushes the wrapped object on the data stack. Wrappers are used to push words literally on the data stack" ; -ARTICLE: "syntax-words" "Words" +ARTICLE: "syntax-words" "Word syntax" "A word occurring inside a quotation is executed when the quotation is called. Sometimes a word needs to be pushed on the data stack instead. The canonical use-case for this is passing the word to the " { $link execute } " combinator, or alternatively, reflectively accessing word properties (" { $link "word-props" } ")." { $subsection POSTPONE: \ } { $subsection POSTPONE: POSTPONE: } @@ -201,7 +201,7 @@ ARTICLE: "syntax-booleans" "Booleans" GLOSSARY: "escape" "a sequence allowing a non-literal character to be inserted in a string. For a list of escapes, see " { $link "escape" } ; -ARTICLE: "syntax-strings" "Characters and strings" +ARTICLE: "syntax-strings" "Character and string syntax" "Factor has no distinct character type, however Unicode character value integers can be read by specifying a literal character, or an escaped representation thereof." { $subsection POSTPONE: CHAR: } { $subsection POSTPONE: " } @@ -227,31 +227,31 @@ ARTICLE: "escape" "Character escape codes" } "While not useful for single characters, this syntax is also permitted inside strings." ; -ARTICLE: "syntax-sbufs" "String buffers" +ARTICLE: "syntax-sbufs" "String buffer syntax" { $subsection POSTPONE: SBUF" } -"String buffers are documented in " { $link "string-buffers" } "." ; +"String buffers are documented in " { $link "sbufs" } "." ; -ARTICLE: "syntax-arrays" "Arrays" +ARTICLE: "syntax-arrays" "Array syntax" { $subsection POSTPONE: { } { $subsection POSTPONE: } } "Arrays are documented in " { $link "arrays" } "." ; -ARTICLE: "syntax-vectors" "Vectors" +ARTICLE: "syntax-vectors" "Vector syntax" { $subsection POSTPONE: V{ } { $subsection POSTPONE: } } "Vectors are documented in " { $link "vectors" } "." ; -ARTICLE: "syntax-hashtables" "Hashtables" +ARTICLE: "syntax-hashtables" "Hashtable syntax" { $subsection POSTPONE: H{ } { $subsection POSTPONE: } } -"Hashtables are documented in " { $link "vectors" } "." ; +"Hashtables are documented in " { $link "hashtables" } "." ; -ARTICLE: "syntax-tuples" "Tuples" +ARTICLE: "syntax-tuples" "Tuple syntax" { $subsection POSTPONE: T{ } { $subsection POSTPONE: } } "Tuples are documented in " { $link "tuples" } "." ; -ARTICLE: "syntax-lists" "Lists" +ARTICLE: "syntax-lists" "Quotation syntax" { $subsection POSTPONE: [ } { $subsection POSTPONE: ] } -"Lists are documented in " { $link "lists" } "." ; +"Quotations are documented in " { $link "quotations" } "." ; diff --git a/library/alien/compiler.factor b/library/alien/compiler.factor index 9922ee64fc..1f745b4566 100644 --- a/library/alien/compiler.factor +++ b/library/alien/compiler.factor @@ -74,13 +74,13 @@ C: alien-node make-node ; dup class get swap fastcall-regs >= ; : spill-param ( reg-class -- n reg-class ) - reg-class-size stack-params [ tuck + ] change + reg-size stack-params [ tuck + ] change T{ stack-params } ; : inc-reg-class ( reg-class -- ) #! On Mac OS X, float parameters 'shadow' integer registers. dup class inc dup float-regs? dual-fp/int-regs? and [ - int-regs [ over reg-class-size 4 / + ] change + int-regs [ over reg-size 4 / + ] change ] when drop ; : fastcall-param ( reg-class -- n reg-class ) diff --git a/library/collections/growable.facts b/library/collections/growable.facts index 008037f213..392d7bc2c5 100644 --- a/library/collections/growable.facts +++ b/library/collections/growable.facts @@ -28,7 +28,7 @@ HELP: ensure "( n seq -- )" { $values { "n" "a positive integer" } { "seq" "a growable sequence" } } { $description "If " { $snippet "n" } " is less than the length of the sequence, does nothing. Otherwise, if " { $snippet "n" } " also exceeds the capacity of the underlying storage, the underlying storage is grown, and the fill pointer is reset. Finally, if " { $snippet "n" } " is greater than or equal to the length but less than the capacity of the underlying storage, the fill pointer is moved and nothing else is done." $terpri -"This word is used in the implementation of the " { $link set-nth } " generic for sequences supporting the growable sequence protocol (see " { $link "sequences-internals" } ")." +"This word is used in the implementation of the " { $link set-nth } " generic for sequences supporting the growable sequence protocol (see " { $link "sequences-growable" } ")." } ; HELP: bounds-error "( n seq -- )" @@ -41,8 +41,8 @@ HELP: bounds-check "( n seq -- n seq )" HELP: grow-length "( n seq -- )" { $values { "n" "a positive integer" } { "seq" "a sequence" } } -{ $description "An implementation of the " { $link set-length } " generic for sequences supporting the growable sequence protocol (see " { $link "sequences-internals" } ")." } ; +{ $description "An implementation of the " { $link set-length } " generic for sequences supporting the growable sequence protocol (see " { $link "sequences-growable" } ")." } ; HELP: clone-growable "( seq -- seq )" { $values { "seq" "a sequence" } { "seq" "a fresh sequence" } } -{ $description "An implementation of the " { $link clone } " generic for sequences supporting the growable sequence protocol (see " { $link "sequences-internals" } ")." } ; +{ $description "An implementation of the " { $link clone } " generic for sequences supporting the growable sequence protocol (see " { $link "sequences-growable" } ")." } ; diff --git a/library/help/commands.factor b/library/help/commands.factor index 984f1089c8..e2839d8b28 100644 --- a/library/help/commands.factor +++ b/library/help/commands.factor @@ -1,6 +1,6 @@ IN: help USING: gadgets-listener gadgets-presentations words ; -"Show word" [ word? ] [ help ] \ in-browser define-default-command +"Show word documentation" [ word? ] [ help ] \ in-browser define-default-command "Show term definition" [ term? ] [ help ] \ in-browser define-default-command "Show article" [ link? ] [ help ] \ in-browser define-default-command diff --git a/library/help/markup.factor b/library/help/markup.factor index 1ecb650692..1b19595ca7 100644 --- a/library/help/markup.factor +++ b/library/help/markup.factor @@ -55,7 +55,7 @@ M: word print-element : $url url-style ($span) ; -: $terpri terpri drop ; +: $terpri terpri terpri drop ; ! Some blocks M: simple-element print-element [ print-element ] each ; @@ -138,7 +138,13 @@ DEFER: help ] with-style ; : $link ( article -- ) - first dup article-name swap simple-object ; + first dup word? [ + pprint + ] [ + link-style [ + dup article-name swap simple-object + ] with-style + ] if ; : $glossary ( element -- ) first dup simple-object ; diff --git a/library/help/stylesheet.factor b/library/help/stylesheet.factor index df63620d76..e57f1d5544 100644 --- a/library/help/stylesheet.factor +++ b/library/help/stylesheet.factor @@ -8,6 +8,9 @@ USING: styles ; { wrap-margin 500 } } ; +: link-style + H{ { foreground { 0.3 0 0 1 } } { font-style bold } } ; + : emphasis-style H{ { font-style italic } } ; diff --git a/library/io/duplex-stream.factor b/library/io/duplex-stream.factor index 4e7edf1a20..6e344b13e7 100644 --- a/library/io/duplex-stream.factor +++ b/library/io/duplex-stream.factor @@ -1,6 +1,7 @@ ! Combine an input and output stream into one, and flush the ! stream more often. -USING: io kernel ; +IN: io +USING: kernel ; TUPLE: duplex-stream in out ; diff --git a/library/math/math.facts b/library/math/math.facts index 9d32314495..f098c877b7 100644 --- a/library/math/math.facts +++ b/library/math/math.facts @@ -36,7 +36,7 @@ HELP: + "( x y -- z )" HELP: - "( x y -- z )" { $values { "x" "a number" } { "y" "a number" } { "z" "a number" } } { $description - "Subtracts " { $link "y" } " from " { $snippet "x" } "." + "Subtracts " { $snippet "y" } " from " { $snippet "x" } "." { $list "Subtraction of fixnums may overflow and convert the result to a bignum." "Subtraction of bignums always yields a bignum." diff --git a/library/syntax/parse-syntax.facts b/library/syntax/parse-syntax.facts index b1cc8ac7cd..e15e966896 100644 --- a/library/syntax/parse-syntax.facts +++ b/library/syntax/parse-syntax.facts @@ -77,7 +77,7 @@ HELP: V{ "elements... }" HELP: H{ "{ key value }... }" { $values { "key" "an object" } { "value" "an object" } } { $description "Marks the beginning of a literal hashtable, given as a list of two-element arrays holding key/value pairs." } -{ $examples { $code "H{ { \"tuna\" \"fish\" } { \"jalapeno\" \"vegatable\" } }" } } ; +{ $examples { $code "H{ { \"tuna\" \"fish\" } { \"jalapeno\" \"vegetable\" } }" } } ; HELP: C{ "real imaginary }" { $values { "real" "a real number" } { "imaginary" "a real number" } } @@ -115,7 +115,7 @@ HELP: SYMBOL: "word" HELP: \ "word" { $values { "word" "a word" } } { $description "Reads the next word from the input and appends a wrapper holding the word to the parse tree. When the evaluator encounters a wrapper, it pushes the wrapped word literally on the data stack." } -{ $examples "The following two lines are equivalent:" { $code "0 \\ execute\n" } } ; +{ $examples "The following two lines are equivalent:" { $code "0 \\ execute\n0 " } } ; HELP: DEFER: "word" { $values { "word" "a new word to define" } } @@ -194,7 +194,7 @@ HELP: GENERIC: "word" { $values { "word" "a new word to define" } } { $description "Defines a new generic word in the current vocabulary. Initially, it contains no methods, and thus will throw an error when called." } { $notes - "A " { $link "method-combinations" "method combination" } " facility exists for customizing method dispatch behavior." + "A " { $link "method-combination" } " facility exists for customizing method dispatch behavior." $terpri "This parsing word is equivalent to the following usage of the more general " { $link POSTPONE: G: } " word:" { $code "G: word simple-combination ;" } diff --git a/library/syntax/parser.facts b/library/syntax/parser.facts index 9f75047bdf..85f73cfe60 100644 --- a/library/syntax/parser.facts +++ b/library/syntax/parser.facts @@ -94,7 +94,7 @@ $parsing-note ; HELP: create-constructor "( word -- constructor )" { $values { "class" "a word" } { "constructor" "a new word" } } -{ $description "Creates a new word in the current vocabulary, named by surrounding " { $link "word" } " with angle brackets." } ; +{ $description "Creates a new word in the current vocabulary, named by surrounding " { $snippet "word" } " with angle brackets." } ; HELP: CREATE "( -- word )" { $values { "word" "a word" } } diff --git a/library/words.facts b/library/words.facts index 8848dd0fbd..6772cf510d 100644 --- a/library/words.facts +++ b/library/words.facts @@ -145,6 +145,6 @@ HELP: definer "( word -- definer )" { $values { "word" "a word" } { "definer" "a word" } } { $description "Outputs the parsing word that defines the given word." } { $examples - { $example ": foo ; \ foo definer ." "POSTPONE: :" } - { $example "SYMBOL: foo \ foo definer ." "POSTPONE: SYMBOL:" } + { $example ": foo ; \\ foo definer ." "POSTPONE: :" } + { $example "SYMBOL: foo \\ foo definer ." "POSTPONE: SYMBOL:" } } ; From b757202a0727cb209779af4a2fa55bcc0764f77c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 Jan 2006 22:50:59 +0000 Subject: [PATCH 253/373] minor tweaks, add missing file --- doc/handbook/handbook.facts | 41 +++++++++++++++++++++------------ library/help/markup.factor | 4 +++- library/math/constants.facts | 39 +++++++++++++++++++++++++++++++ library/ui/presentations.factor | 3 ++- 4 files changed, 70 insertions(+), 17 deletions(-) create mode 100644 library/math/constants.facts diff --git a/doc/handbook/handbook.facts b/doc/handbook/handbook.facts index 870cf09bdd..e97d192ed9 100644 --- a/doc/handbook/handbook.facts +++ b/doc/handbook/handbook.facts @@ -1,23 +1,13 @@ USING: help parser prettyprint ; ARTICLE: "handbook" "Factor documentation" -"Welcome to Factor! Factor documentation is takes the form of an outline, with cross-referencing hyperlinks between topics. You can click the triangle next to a topic heading to expand the topic:" +"Welcome to Factor! Factor documentation is takes the form of an outline, with cross-referencing hyperlinks between topics. You can click the triangle next to a topic heading to expand the topic." +$terpri +"There is some introductory material you will find useful when starting out:" { $subsection "presentation-intro" } -"There is a short language tutorial:" { $subsection "tutorial" } -"Some words for performing common operations at the listener:" -{ $list - { - "You can read the documentation for a word with " { $link help } ":" - { $code "\\ reverse help" } - } - { "You can print the top of the stack with " { $link . } } - { - "Source files are loaded with " { $link run-file } ":" - { $code "\"tetris.factor\" run-file" } - } -} -"Detailed documentation:" +{ $subsection "quickref" } +"More detailed reference documentation:" { $subsection "syntax" } { $subsection "dataflow" } { $subsection "words" } @@ -32,3 +22,24 @@ $terpri "When you place the mouse over a presentation, it is highlighted with a surrounding border." $terpri "Clicking a presentation with the left mouse button invokes a default command. Clicking the right mouse button displays a menu of applicable commands." ; + +ARTICLE: "quickref" "Quick reference" +"Some words for performing common operations at the listener:" +{ $list + { + "You can read the documentation for a word with " { $link help } ":" + { $code "\\ reverse help" } + } + { "You can print the top of the stack with " { $link . } } + { + "Source files are loaded with " { $link run-file } ":" + { $code "\"tetris.factor\" run-file" } + } +} +"If you enter an invalid word name, you will get a \"not a number\" error:" +{ $example + "fdafasfa" + "An unhandled error was caught:\n\nParsing :1\nfdafasfa\n ^\n\"Not a number\"\n\n:s :r show stacks at time of error.\n:get ( var -- value ) inspects the error namestack." +} +"Sometimes, the word " { $emphasis "does" } " exist, but you might need to " { $link POSTPONE: USE: } " its vocabulary first. The " { $link apropos } " word can help locate the correct vocabulary:" +{ $example "\"
      • repeated a certain number of times has been renamed to <string>.
    • The sum and product words have been moved to contrib/math/.
      • +
    • Some alien word changes: +
      <foo> ==> "foo" <c-object>
+<foo-array> ==> "foo" <c-array>
    • stream-format ( string style stream -- ) now takes a hashtable @@ -104,6 +107,8 @@ USE: image
    • Contributed libraries:
        +
      • All libraries in contrib/ have been tested and updated for recent language +changes, and you can run contrib/load.factor to load all of them at once (Trent Buck)
      • Updated contrib/x11/ with many more examples (Eduardo Cavazos)
      • Added splay tree library in contrib/splay-trees.factor (Mackenzie Straight)
      diff --git a/README.txt b/README.txt index f31128a51a..36da3f79e9 100644 --- a/README.txt +++ b/README.txt @@ -20,6 +20,8 @@ regular basis: FreeBSD/AMD64 Linux/PowerPC +Other platforms are not supported. + * Compiling Factor The Factor runtime is written in C, and is built with GNU make and gcc. @@ -51,7 +53,7 @@ The former allows optimization flags to be specified, for example difference in Factor's performance, so willing hackers should experiment. -The latter flag disables optimization and builds an executable with +The DEBUG flag disables optimization and builds an executable with debug symbols. This is probably only of interest to people intending to hack on the runtime sources. @@ -128,7 +130,6 @@ as, and issue a command similar to the following to bootstrap Factor: freetype/ - FreeType binding, rendering glyphs to OpenGL textures generic/ - generic words, for object oriented programming style help/ - online help system - httpd/ - HTTP client, server, and web application framework inference/ - stack effect inference, used by compiler, as well as a useful development tool of its own io/ - input and output streams @@ -143,7 +144,6 @@ as, and issue a command similar to the following to bootstrap Factor: win32/ - Windows-specific I/O code contrib/ - various handy libraries not part of the core examples/ - small examples illustrating various language features - factor/ - Java code for the Factor jEdit plugin fonts/ - TrueType fonts used by UI * Learning Factor @@ -173,6 +173,7 @@ Slava Pestov: Lead developer Alex Chapman: OpenGL binding Doug Coleman: Mersenne Twister random number generator Mackenzie Straight: Windows port +Trent Buck: Debian package A number of contributed libraries not part of the core can be found in contrib/. See contrib/README.txt for details. diff --git a/library/kernel.facts b/library/kernel.facts index 288098f771..5599993894 100644 --- a/library/kernel.facts +++ b/library/kernel.facts @@ -242,7 +242,7 @@ HELP: array-nth "( n array -- elt )" { $description "Low-level array element accessor." } { $warning "This word is in the " { $snippet "kernel-internals" } " vocabulary because it is unsafe. It does not check types or array bounds, and improper use can corrupt memory." } ; -HELP: set-array-nth "( elt n array --)" +HELP: set-array-nth "( elt n array -- )" { $values { "elt" "an object" } { "n" "a non-negative fixnum" } { "array" "an array" } } { $description "Low-level array element mutator." } { $warning "This word is in the " { $snippet "kernel-internals" } " vocabulary because it is unsafe. It does not check types or array bounds, and improper use can corrupt memory." } ; From bc257b0df89ab40d8c9c19b9af06fc6f9d536a13 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Jan 2006 23:50:52 +0000 Subject: [PATCH 275/373] minor style cleanup --- contrib/httpd/html.factor | 5 -- doc/handbook/streams.facts | 70 +++++++++++++++++++++++++++ examples/factoroids/factoroids.factor | 4 +- library/io/styles.factor | 28 +++++++++++ library/kernel.facts | 4 +- library/styles.factor | 47 ------------------ library/ui/outliner.factor | 2 +- library/ui/sliders.factor | 2 +- 8 files changed, 104 insertions(+), 58 deletions(-) create mode 100644 doc/handbook/streams.facts create mode 100644 library/io/styles.factor delete mode 100644 library/styles.factor diff --git a/contrib/httpd/html.factor b/contrib/httpd/html.factor index 6fb97cb766..3a137f81a2 100644 --- a/contrib/httpd/html.factor +++ b/contrib/httpd/html.factor @@ -31,9 +31,6 @@ sequences strings styles words ; [ bold bold-italic ] member? [ "font-weight: bold; " % ] when ; -: underline-css, ( flag -- ) - [ "text-decoration: underline; " % ] when ; - : size-css, ( size -- ) "font-size: " % # "; " % ; @@ -57,7 +54,6 @@ sequences strings styles words ; { font [ font-css, ] } { font-style [ style-css, ] } { font-size [ size-css, ] } - { underline [ underline-css, ] } } hash-apply ] "" make ; @@ -138,7 +134,6 @@ C: html-stream ( stream -- stream ) #! font #! font-style #! font-size - #! underline #! file #! word #! vocab diff --git a/doc/handbook/streams.facts b/doc/handbook/streams.facts new file mode 100644 index 0000000000..4dba28d226 --- /dev/null +++ b/doc/handbook/streams.facts @@ -0,0 +1,70 @@ +USING: help io ; + +GLOSSARY: "stream" "an endpoint for input/output operations, supporting the " { $link "stream-protocol" } ; + +ARTICLE: "streams" "Streams" +"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of characters. Streams also support formatted output, which may be used to present styled text in a manner independent of output medium." +{ $subsection "stream-protocol" } +{ $subsection "stream-utilities" } +{ $subsection "stdio" } +; + +GLOSSARY: "input stream" "an object responding to the input words of the " { $link "stream-protocol" } ; + +GLOSSARY: "output stream" "an object responding to the output words of the " { $link "stream-protocol" } ; + +GLOSSARY: "bidirectional stream" "an object that is both an input and output stream" } ; + +ARTICLE: "stream-protocol" "Stream protocol" +"The stream protocol consits of a large number of generic words, many of which are optional." +$terpri +"A word required to be implemented for all streams:" +{ $subsection stream-close } +"Three words are required for input streams:" +{ $subsection stream-read1 } +{ $subsection stream-read } +{ $subsection stream-readln } +"If your stream supports the first two but not the last one, wrap it in a " { $link } " to get a default implementation." +$terpri +"Seven words are required for output streams:" +{ $subsection stream-flush } +{ $subsection stream-write1 } +{ $subsection stream-write } +{ $subsection stream-terpri } +{ $subsection stream-terpri* } +{ $subsection stream-format } +{ $subsection with-nested-stream } +"If your stream supports the first three but not the rest, wrap it in a " { $link } ", which provides plain text implementations of the stream formatting words (the so called " { $emphasis "extended stream output protocol" } ")." ; + +ARTICLE: "stream-utils" "Stream utilities" +"There are a few useful stream-related words which are not generic, but merely built up from the stream protocol." +$terpri +"First, a simple composition of " { $link stream-write } " and " { $link stream-terpri } ":" +{ $subsection stream-print } +"Next up, a pair of words for reading the entire contents of a stream as an array of lines, or a single string:" +{ $subsection lines } +{ $subsection contents } +"Finally, a word to copy the contents of one stream to another:" +{ $subsection stream-copy } ; + +GLOSSARY: "default stream" "see " { $link stdio } ; + +ARTICLE: "stdio" "The default stream" +"Various words take an implicit stream parameter from the " { $link stdio } " variable to reduce stack shuffling. Unless rebound in a child namespace, this variable will be set to a console stream for interacting with the user." +{ $link close } +{ $subsection read1 } +{ $subsection read } +{ $subsection readln } +{ $subsection flush } +{ $subsection write1 } +{ $subsection write } +{ $subsection print } +{ $subsection terpri } +{ $subsection terpri* } +{ $subsection format } +{ $subsection with-nesting } +"A pair of combinators support rebinding the " { $link stdio } " variable:" +{ $subsection with-stream } +{ $subsection with-stream* } ; + + diff --git a/examples/factoroids/factoroids.factor b/examples/factoroids/factoroids.factor index 04fb203853..41e3411ebc 100644 --- a/examples/factoroids/factoroids.factor +++ b/examples/factoroids/factoroids.factor @@ -11,7 +11,7 @@ IN: factoroids : draw-ground GL_DEPTH_TEST glDisable - black gl-color + { 0.0 0.0 0.0 1.0 } gl-color GL_QUADS [ { -1000 0 -1000 } gl-vertex { -1000 0 1000 } gl-vertex @@ -33,7 +33,7 @@ IN: factoroids ] do-matrix ; : draw-grid ( w h -- ) - white gl-color [ swap [ grid-square ] each-with ] each-with ; + { 1.0 1.0 1.0 1.0 } gl-color [ swap [ grid-square ] each-with ] each-with ; : make-ground-list ( -- id ) GL_COMPILE [ draw-ground 50 50 draw-grid ] make-dlist ; diff --git a/library/io/styles.factor b/library/io/styles.factor new file mode 100644 index 0000000000..d3df55707d --- /dev/null +++ b/library/io/styles.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2005, 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: styles + +SYMBOL: plain +SYMBOL: bold +SYMBOL: italic +SYMBOL: bold-italic + +! Character styles +SYMBOL: foreground +SYMBOL: background +SYMBOL: font +SYMBOL: font-size +SYMBOL: font-style +SYMBOL: presented +SYMBOL: file +SYMBOL: word-break + +! Paragraph styles +SYMBOL: page-color +SYMBOL: border-color +SYMBOL: border-width +SYMBOL: wrap-margin +SYMBOL: outline + +! Input history +TUPLE: input string ; diff --git a/library/kernel.facts b/library/kernel.facts index 5599993894..51995e6e9a 100644 --- a/library/kernel.facts +++ b/library/kernel.facts @@ -203,14 +203,14 @@ $terpri "The following two lines are equivalent:" { $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ; -HELP: when* "( cond true false -- )" +HELP: when* "( cond true -- )" { $values { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } } { $description "Variant of " { $link if* } " with no false quotation." $terpri "The following two lines are equivalent:" { $code "X [ Y ] when*" "X dup [ Y ] [ drop ] if" } } ; -HELP: unless* "( cond true false -- )" +HELP: unless* "( cond false -- )" { $values { "cond" "a generalized boolean" } { "false" "a quotation " } } { $description "Variant of " { $link if* } " with no true quotation." $terpri diff --git a/library/styles.factor b/library/styles.factor deleted file mode 100644 index e42f7357b7..0000000000 --- a/library/styles.factor +++ /dev/null @@ -1,47 +0,0 @@ -! Copyright (C) 2005, 2006 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. -IN: styles - -! Colors are RGBA quadruples -: black { 0.0 0.0 0.0 1.0 } ; -: dark-gray { 0.25 0.25 0.25 1.0 } ; -: gray { 0.5 0.5 0.5 1.0 } ; -: light-gray { 0.75 0.75 0.75 1.0 } ; -: white { 1.0 1.0 1.0 1.0 } ; -: red { 1.0 0.0 0.0 1.0 } ; -: green { 0.0 1.0 0.0 1.0 } ; -: blue { 0.0 0.0 1.0 1.0 } ; - -! Character styles - -SYMBOL: foreground ! Used for text and outline shapes. -SYMBOL: background ! Used for filled shapes. - -SYMBOL: font -SYMBOL: font-size -SYMBOL: font-style - -SYMBOL: plain -SYMBOL: bold -SYMBOL: italic -SYMBOL: bold-italic - -SYMBOL: underline - -SYMBOL: presented -SYMBOL: file - -! A quotation that writes an outline expansion to stdio -SYMBOL: outline - -! A word break inside a pragraph with wrap-margin set -SYMBOL: word-break - -! Paragraph styles -SYMBOL: page-color -SYMBOL: border-color -SYMBOL: border-width -SYMBOL: wrap-margin - -! Input history -TUPLE: input string ; diff --git a/library/ui/outliner.factor b/library/ui/outliner.factor index 8defdda316..3cbf16c303 100644 --- a/library/ui/outliner.factor +++ b/library/ui/outliner.factor @@ -24,7 +24,7 @@ DEFER: [ outliner? ] find-parent ; : ( ? -- gadget ) - arrow-right arrow-down ? gray swap + arrow-right arrow-down ? { 0.5 0.5 0.5 1.0 } swap ; : ( ? -- gadget ) diff --git a/library/ui/sliders.factor b/library/ui/sliders.factor index 88e961362a..150efa318c 100644 --- a/library/ui/sliders.factor +++ b/library/ui/sliders.factor @@ -106,7 +106,7 @@ M: elevator layout* ( elevator -- ) : slider-vertical? gadget-orientation { 0 1 0 } = ; : ( orientation polygon amount -- ) - >r gray swap r> + >r { 0.5 0.5 0.5 1.0 } swap r> [ swap slide-by-line ] curry [ set-gadget-orientation ] keep ; From 60a147bbfaf43c40e452a3340b7d4614b2e091f1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 19 Jan 2006 08:03:32 +0000 Subject: [PATCH 276/373] more I/O docs; added missing files from twb's patch --- contrib/cairo/load.factor | 13 +++ contrib/load.factor | 31 ++++++ contrib/parser-combinators/load.factor | 8 ++ contrib/sqlite/load.factor | 9 ++ contrib/sqlite/test.txt | 3 + doc/handbook/handbook.facts | 1 + doc/handbook/streams.facts | 134 ++++++++++++++++++++++++- library/bootstrap/boot-stage1.factor | 6 +- library/compiler/compiler.factor | 2 +- library/io/files.facts | 12 +++ 10 files changed, 213 insertions(+), 6 deletions(-) create mode 100644 contrib/cairo/load.factor create mode 100644 contrib/load.factor create mode 100644 contrib/parser-combinators/load.factor create mode 100644 contrib/sqlite/load.factor create mode 100644 contrib/sqlite/test.txt diff --git a/contrib/cairo/load.factor b/contrib/cairo/load.factor new file mode 100644 index 0000000000..05f8309581 --- /dev/null +++ b/contrib/cairo/load.factor @@ -0,0 +1,13 @@ +IN: scratchpad +USING: alien kernel parser compiler words sequences ; + +{ { "cairo" "libcairo" } + { "sdl-gfx" "libSDL_gfx" } + { "sdl" "libSDL" } } +[ first2 add-simple-library ] each + +{ "cairo" "cairo_sdl" } +[ "contrib/cairo/" swap ".factor" append3 run-file ] each + +{ "cairo" "cairo-sdl" } +[ words [ try-compile ] each ] each diff --git a/contrib/load.factor b/contrib/load.factor new file mode 100644 index 0000000000..bfb635aa22 --- /dev/null +++ b/contrib/load.factor @@ -0,0 +1,31 @@ +! Load all contrib libs, compile them, and save a new image. +IN: scratchpad +USING: alien kernel words sequences parser compiler memory ; + +! digraph dependencies { +! // run-file libs in the correct order to avoid repeated run-filing +! aim -> crypto +! concurrency -> dlists +! concurrency -> math +! cont-responder -> httpd +! crypto -> math +! factor -> x11 +! space-invaders -> parser-combinators +! cont-responder -> parser-combinators +! } + +: add-simple-library ( name file -- ) + win32? ".dll" ".so" ? append + win32? "stdcall" "cdecl" ? add-library ; + +{ "coroutines" "dlists" "splay-trees" } +[ dup + "contrib/" swap ".factor" append3 run-file + words [ try-compile ] each ] each + +{ "cairo" "math" "concurrency" "crypto" "aim" "httpd" "units" "sqlite" "win32" + "x11" ! "factory" has a C component, ick. + "postgresql" "parser-combinators" "cont-responder" "space-invaders" +} [ "contrib/" swap "/load.factor" append3 run-file ] each + +compile-all diff --git a/contrib/parser-combinators/load.factor b/contrib/parser-combinators/load.factor new file mode 100644 index 0000000000..1cc873d17b --- /dev/null +++ b/contrib/parser-combinators/load.factor @@ -0,0 +1,8 @@ +IN: scratchpad +USING: kernel parser sequences words compiler ; + +{ "lazy" "parser-combinators" "lazy-examples" "tests" } +[ "contrib/parser-combinators/" swap ".factor" append3 run-file ] each + +{ "lazy" "lazy-examples" "parser-combinators" } +[ words [ try-compile ] each ] each diff --git a/contrib/sqlite/load.factor b/contrib/sqlite/load.factor new file mode 100644 index 0000000000..ee2f9619e3 --- /dev/null +++ b/contrib/sqlite/load.factor @@ -0,0 +1,9 @@ +IN: scratchpad +USING: kernel alien parser compiler words sequences ; +"sqllite" "libsqlite3" add-simple-library + +{ "sqlite" "tuple-db" "test" "tuple-db-tests" } +[ "contrib/sqlite/" swap ".factor" append3 run-file ] each + +{ "sqlite" "tuple-db" } +[ words [ try-compile ] each ] each diff --git a/contrib/sqlite/test.txt b/contrib/sqlite/test.txt new file mode 100644 index 0000000000..5c7ae2b52a --- /dev/null +++ b/contrib/sqlite/test.txt @@ -0,0 +1,3 @@ +create table test (name varchar(30), address varchar(30)); +insert into test values('John', 'America'); +insert into test values('Jane', 'New Zealand'); diff --git a/doc/handbook/handbook.facts b/doc/handbook/handbook.facts index e97d192ed9..923f764f18 100644 --- a/doc/handbook/handbook.facts +++ b/doc/handbook/handbook.facts @@ -14,6 +14,7 @@ $terpri { $subsection "objects" } { $subsection "math" } { $subsection "collections" } +{ $subsection "streams" } { $subsection "parser" } ; ARTICLE: "presentation-intro" "The presentation-based UI" diff --git a/doc/handbook/streams.facts b/doc/handbook/streams.facts index 4dba28d226..7ee5b70eb7 100644 --- a/doc/handbook/streams.facts +++ b/doc/handbook/streams.facts @@ -1,19 +1,27 @@ -USING: help io ; +USING: +help +io +styles ; GLOSSARY: "stream" "an endpoint for input/output operations, supporting the " { $link "stream-protocol" } ; ARTICLE: "streams" "Streams" "Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of characters. Streams also support formatted output, which may be used to present styled text in a manner independent of output medium." +$terpri +"Stream words are in the " { $snippet "io" } " vocabulary." { $subsection "stream-protocol" } -{ $subsection "stream-utilities" } +{ $subsection "stream-utils" } { $subsection "stdio" } +{ $subsection "styles" } +{ $subsection "stream-binary" } +{ $subsection "stream-impls" } ; GLOSSARY: "input stream" "an object responding to the input words of the " { $link "stream-protocol" } ; GLOSSARY: "output stream" "an object responding to the output words of the " { $link "stream-protocol" } ; -GLOSSARY: "bidirectional stream" "an object that is both an input and output stream" } ; +GLOSSARY: "bidirectional stream" "an object that is both an input and output stream" ; ARTICLE: "stream-protocol" "Stream protocol" "The stream protocol consits of a large number of generic words, many of which are optional." @@ -67,4 +75,124 @@ ARTICLE: "stdio" "The default stream" { $subsection with-stream } { $subsection with-stream* } ; +ARTICLE: "styles" "Formatted output" +"The " { $link stream-format } " and " { $link with-nested-stream } " words take a hashtable of style attributes. The former acts on character styles, and the latter acts on paragraph styles. Output stream implementations are free to ignore style information." +$terpri +"Style hashtables are keyed by symbols from the " { $snippet "styles" } " vocabulary." +{ $subsection "character-styles" } +{ $subsection "paragraph-styles" } +{ $subsection "style-stack" } +{ $subsection "presentations" } ; +ARTICLE: "character-styles" "Character styles" +"Character styles for " { $link stream-format } ":" +{ $subsection foreground } +{ $subsection background } +{ $subsection foreground } +{ $subsection background } +{ $subsection font } +{ $subsection font-size } +{ $subsection font-style } +{ $subsection presented } +{ $subsection file } +{ $subsection word-break } ; + +ARTICLE: "paragraph-styles" "Paragraph styles" +"Paragraph styles for " { $link with-nested-stream } ":" +{ $subsection page-color } +{ $subsection border-color } +{ $subsection border-width } +{ $subsection wrap-margin } +{ $subsection outline } +{ $subsection presented } ; + +ARTICLE: "style-stack" "The style stack" +"The style stack provides a convenient facility for implementing logical nesting of character and paragraph styles." +$terpri +"A combinator pushes a style onto the style stack and calls a quotaiton:" +{ $subsection with-style } +"The contents of the style stack can be combined to form one style hashtable:" +{ $subsection current-style } +"A pair of words corresponding to " { $link format } " and " { $link with-nesting } ", but taking the current style from the style stack:" +{ $subsection format* } +{ $subsection with-nesting* } ; + +ARTICLE: "presentations" "Presentations and outliners" +"The " { $link presented } " and " { $link outline } " styles can be used to build sophisticated user interfaces in the Factor UI." +$terpri +"Associating the " { $link presented } " character style with a run of text displayed in a pane makes it a clickable presentation of an object. Two useful utility words wrap presentation output:" +{ $subsection write-object } +{ $subsection simple-object } +"Associating the " { $link outline } " paragraph style with a nested block displays it as an expandable outliner gadget, whose contents are lazily generated by a quotation. Two useful utility words wrap outliner output:" +{ $subsection write-outliner } +{ $subsection simple-outliner } ; + +GLOSSARY: "big endian" "a representation of an integer as a sequence of bytes, ordered from most significant to least significant. This is the native byte ordering for PowerPC processors" ; + +GLOSSARY: "little endian" "a representation of an integer as a sequence of bytes, ordered from least significant to most significant. This is the native byte ordering for x86 and AMD64 processors" ; + +ARTICLE: "stream-binary" "Working with binary data" +"The core stream words read and write strings. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")." +$terpri +"There are two ways to order the bytes making up an integer; " { $emphasis "little endian" } " byte order outputs the least significant byte first, and the most significant byte last, whereas " { $emphasis "big endian" } " is the other way around." +$terpri +"Consider the hexadecimal integer "{ $snippet "HEX: cafebabe" } ". Big endian byte order yields the following sequence of bytes:" +{ $code + "Byte: 1 2 3 4" + "Value: be ba fe ca" +} +"Compare this with little endian byte order:" +{ $code + "Byte: 1 2 3 4" + "Value: ca fe ba be" +} +"Two words convert a sequence of bytes into an integer:" +{ $subsection be> } +{ $subsection le> } +"Two words convert an integer into a sequence of bytes:" +{ $subsection >be } +{ $subsection >le } ; + +ARTICLE: "stream-impls" "Stream implementations" +"External resource streams communicate with the outside world:" +{ $subsection "file-streams" } +{ $subsection "network-streams" } +"Virtual streams serve as glue:" +{ $subsection "string-streams" } +"Wrapper streams convert partial implementations of the stream protocol into full-fledged streams:" +{ $subsection } +{ $subsection } +"A utility to combine a complementary input and output stream pair into a single stream:" +{ $subsection } +"As a final note, the " { $link f } " object implements the stream protocol, by yielding end-of-file on input and discarding all output." ; + +ARTICLE: "file-streams" "Reading and writing files" +{ $subsection } +{ $subsection } +"File system meta-data:" +{ $subsection exists? } +{ $subsection directory? } +{ $subsection file-length } +{ $subsection stat } ; + +GLOSSARY: "server stream" "a stream listening on a TCP/IP socket" ; + +GLOSSARY: "client stream" "a bidirectional stream for an to end-point of a TCP/IP connection" ; + +ARTICLE: "network-streams" "TCP/IP networking" +"Client connections are bidirectional streams opened with this word:" +{ $subsection } +"Network servers are implemented by first opening a server socket, then waiting for connections:" +{ $subsection } +{ $subsection accept } +"Some information can be obtained about incoming client connections:" +{ $subsection client-stream-host } +{ $subsection client-stream-port } ; + +ARTICLE: "string-streams" "String streams" +"Streams:" +{ $subsection } +{ $subsection } +"Utility combinators:" +{ $subsection string-in } +{ $subsection string-out } ; diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 44d0d5f719..85c1da696c 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -57,8 +57,8 @@ vectors words ; "/library/vocabularies.factor" "/library/continuations.factor" "/library/errors.factor" - "/library/styles.factor" - + + "/library/io/styles.factor" "/library/io/stream.factor" "/library/io/duplex-stream.factor" "/library/io/stdio.factor" @@ -240,6 +240,7 @@ vectors words ; "/library/io/stdio.facts" "/library/io/stream.facts" "/library/io/string-streams.facts" + "/library/io/styles.facts" "/library/math/arc-trig-hyp.facts" "/library/math/complex.facts" "/library/math/constants.facts" @@ -266,6 +267,7 @@ vectors words ; "/doc/handbook/objects.facts" "/doc/handbook/parser.facts" "/doc/handbook/sequences.facts" + "/doc/handbook/streams.facts" "/doc/handbook/syntax.facts" "/doc/handbook/tutorial.facts" "/doc/handbook/words.facts" diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor index 5b78f878d6..e3e8b9571d 100644 --- a/library/compiler/compiler.factor +++ b/library/compiler/compiler.factor @@ -4,7 +4,7 @@ USING: compiler-backend compiler-frontend errors hashtables inference io kernel lists math namespaces optimizer prettyprint sequences words ; -: (compile) ( word -- basic-blocks ) +: (compile) ( word -- ) #! Should be called inside the with-compiler scope. dup word-def dataflow optimize linearize [ split-blocks simplify generate ] hash-each ; diff --git a/library/io/files.facts b/library/io/files.facts index b25ecb0c71..455a59ae87 100644 --- a/library/io/files.facts +++ b/library/io/files.facts @@ -1,5 +1,17 @@ USING: help io ; +HELP: stat "( path -- list )" +{ $values { "path" "a pathname string" } { "list" "a new list" } } +{ $description + "Outputs a list of file system attributes, or " { $link f } " if the file does not exist. The elements of the list are precisely the following:" + { $list + "boolean indicating if the file is a directory" + "the length in bytes as an integer" + "a Unix permission bitmap, or 0 if not supported" + "the last modification time, as milliseconds since midnight, January 1st 1970 GMT" + } +} ; + HELP: path+ "( str1 str2 -- str )" { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } { $description "Concatenates two path names." } ; From 88f0182785396248a9b51d32e2cbd7cb92b7d9fa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 19 Jan 2006 08:28:10 +0000 Subject: [PATCH 277/373] tweak --- library/help/help.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/library/help/help.factor b/library/help/help.factor index 5e0275871b..57f578e080 100644 --- a/library/help/help.factor +++ b/library/help/help.factor @@ -12,3 +12,5 @@ DEFER: $heading dup article-title $heading (help) ; : glossary ( name -- ) help ; + +: handbook ( -- ) "handbook" help ; From f15da7d19f36ee14786606821c9b6ea2d76588cd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 19 Jan 2006 08:28:24 +0000 Subject: [PATCH 278/373] Added two test cases --- TODO.FACTOR.txt | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index ec5b323971..fd780195b8 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -41,3 +41,22 @@ - better i/o scheduler - if two tasks write to a unix stream, the buffer can overflow - inference bug +- test cases: +- float not commutative bug + : a 237241607 1516.925984289192 3036109462846 913470293/554864 + max min * 994.5872660892654 306803761/112249 -216866846 + - + max 6073750751093 364.7737275664338 3629914314951 + max max + 9630706289317 6275800738949 179761544 + + + 88005566/945 + 2358.939297157175 1365.124822588899 max max - 61906796 + 388692629/82301 342893943/210229 * min * 381.5493627025407 + 10548296/49539 996.7264162840083 * + - ; + +- min/max inline bug + : math-dummy + 1507049 1812.446640674088 2682190027553 7662348747253 max + max max 175956841558 9163603105116 100680937 max min min + 67305963/106562 78534496 63.25709285387058 max + min + 116934358/596083 124000630 27821944/48045 - + max + 357331489/880112 1760057/587415 7297976710833 - * max + -113698191 1404.610575779506 51191522 * * - + 1977.861343144055 -50892488 947579163/437404 * min * ; From 9819da867c1ce5fda251663fc6dd21c29de5c389 Mon Sep 17 00:00:00 2001 From: Trent Buck Date: Thu, 19 Jan 2006 09:06:31 +0000 Subject: [PATCH 279/373] Have the shell wrapper use the default image. --- debian/factor-vm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/debian/factor-vm b/debian/factor-vm index 985654bd10..17a7e3ffbf 100644 --- a/debian/factor-vm +++ b/debian/factor-vm @@ -1,3 +1,3 @@ #!/bin/sh # This script invokes factor with the default image. -exec /usr/share/factor/f /usr/share/factor/extended.image "$@" +exec /usr/share/factor/f /usr/share/factor/factor.image "$@" From 565d36d4e293bae578d3d9064ec3174fc0eb9efd Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 19 Jan 2006 10:13:14 +0000 Subject: [PATCH 280/373] Add copyright to space invaders --- contrib/space-invaders/cpu-8080.factor | 22 ++++++++++++++++++++ contrib/space-invaders/readme.txt | 2 +- contrib/space-invaders/space-invaders.factor | 22 ++++++++++++++++++++ contrib/space-invaders/tests.factor | 22 ++++++++++++++++++++ 4 files changed, 67 insertions(+), 1 deletion(-) diff --git a/contrib/space-invaders/cpu-8080.factor b/contrib/space-invaders/cpu-8080.factor index 14941a030d..41614219fb 100644 --- a/contrib/space-invaders/cpu-8080.factor +++ b/contrib/space-invaders/cpu-8080.factor @@ -1,3 +1,25 @@ +! Copyright (C) 2006 Chris Double. +! +! 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. USING: kernel lists math sequences errors vectors prettyprint io namespaces arrays words parser hashtables lazy parser-combinators kernel-internals strings ; IN: cpu-8080 diff --git a/contrib/space-invaders/readme.txt b/contrib/space-invaders/readme.txt index 6a5dae5470..ef5bd4fa4b 100644 --- a/contrib/space-invaders/readme.txt +++ b/contrib/space-invaders/readme.txt @@ -33,4 +33,4 @@ input/output ports. For more information, contact the author, Chris Double, at chris.double@double.co.nz or from my weblog -http://radio.weblogs.com/0102385 +http://www.bluishcoder.co.nz diff --git a/contrib/space-invaders/space-invaders.factor b/contrib/space-invaders/space-invaders.factor index 17581a83f8..00bd86d619 100644 --- a/contrib/space-invaders/space-invaders.factor +++ b/contrib/space-invaders/space-invaders.factor @@ -1,3 +1,25 @@ +! Copyright (C) 2006 Chris Double. +! +! 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. USING: alien cpu-8080 errors generic io kernel kernel-internals lists math namespaces sdl sequences styles threads ; IN: space-invaders diff --git a/contrib/space-invaders/tests.factor b/contrib/space-invaders/tests.factor index 98f8dfda36..d952a78cc2 100644 --- a/contrib/space-invaders/tests.factor +++ b/contrib/space-invaders/tests.factor @@ -1,3 +1,25 @@ +! Copyright (C) 2006 Chris Double. +! +! 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. USING: kernel cpu-8080 test lazy parser-combinators math hashtables lists sequences words ; ! Test read-byte from ROM From e73476e7752b8757231bda4f7a259ea1e233c5b6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 19 Jan 2006 16:28:38 +0000 Subject: [PATCH 281/373] (object -- object) -> ( object -- object ) --- TODO.FACTOR.txt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index fd780195b8..c227dba17e 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -60,3 +60,6 @@ 357331489/880112 1760057/587415 7297976710833 - * max -113698191 1404.610575779506 51191522 * * - 1977.861343144055 -50892488 947579163/437404 * min * ; + +- fix stack effect comment spacing in help for words without docs, + eg (object -- object object) -> ( object -- object object ) From 2afa36dbdcb162f6a7ac95a03243e27c65627061 Mon Sep 17 00:00:00 2001 From: Trent Buck Date: Thu, 19 Jan 2006 20:02:12 +0000 Subject: [PATCH 282/373] Have debian package suggest rlwrap. --- debian/control | 1 + 1 file changed, 1 insertion(+) diff --git a/debian/control b/debian/control index 2ae3b86809..d3de23ba0d 100644 --- a/debian/control +++ b/debian/control @@ -9,6 +9,7 @@ Package: factor Architecture: any Depends: ${shlibs:Depends}, ${misc:Depends} Recommends: libsdl1.2-dev, libfreetype6-dev, libcairo2-dev, libsqlite3-dev, libx11-dev, libpq-dev +Suggests: rlwrap Description: compiler for the concatenative language Factor Factor is a dynamic programming language. The end goal is to have a high performance, robust language for general-purpose client-side and server-side From 259860a61b949c136719c61a1f6c0d0b89dfc681 Mon Sep 17 00:00:00 2001 From: Trent Buck Date: Thu, 19 Jan 2006 20:14:36 +0000 Subject: [PATCH 283/373] Refactored debian package structure. --- debian/dirs | 1 + debian/docs | 3 -- debian/rules | 36 +++++++++++------- debian/scripts/factor-export | 38 +++++++++++++++++++ debian/scripts/factor-import | 38 +++++++++++++++++++ debian/scripts/factor-init | 47 +++++++++++++++++++++++ debian/scripts/factor-run | 72 ++++++++++++++++++++++++++++++++++++ 7 files changed, 218 insertions(+), 17 deletions(-) create mode 100644 debian/scripts/factor-export create mode 100644 debian/scripts/factor-import create mode 100644 debian/scripts/factor-init create mode 100644 debian/scripts/factor-run diff --git a/debian/dirs b/debian/dirs index 5da8268f4a..9a22bace1c 100644 --- a/debian/dirs +++ b/debian/dirs @@ -1,2 +1,3 @@ usr/bin +usr/lib/factor usr/share/factor diff --git a/debian/docs b/debian/docs index 531a735f5c..b873b8cdfe 100644 --- a/debian/docs +++ b/debian/docs @@ -6,6 +6,3 @@ doc/handbook.pdf doc/internals.txt doc/theory.pdf doc/handbook -examples -library -version.factor diff --git a/debian/rules b/debian/rules index 80295290e5..41de1acb98 100644 --- a/debian/rules +++ b/debian/rules @@ -4,6 +4,9 @@ # SITE_CFLAGS=-fPIC -ffast-math -funsigned-char -mpowerpc -mpowerpc-gpopt -mpowerpc-gfxopt -maltivec -mabi=altivec -mtune=G4 -mcpu=G4 -pipe # SITE_CFLAGS=-march=pentium4 +VERSION=0.80 +FARCH=$(shell sh debian/architecture.sh) + configure: configure-stamp configure-stamp: @@ -14,18 +17,19 @@ build: build-stamp build-stamp: configure-stamp dh_testdir - $(MAKE) linux-`sh debian/architecture.sh` -####### Build the bootstrap image - echo "USE: image \"`sh debian/architecture.sh`\" make-image 0 exit" | factor-vm debian/make-bootstrap-images.factor -# wget http://factorcode.org/boot.image.`sh debian/architecture.sh` -####### Build the factor image - ./f boot.image.`sh debian/architecture.sh` -libraries:sdl:name=libSDL.so -libraries:freetype:name=libfreetype.so -# cp /usr/share/factor/f /usr/share/factor/factor.image . -####### Build the extended image + $(MAKE) linux-$(FARCH) + mv f runtime + # Build the bootstrap image + echo "USE: image \"$(FARCH)\" make-image" | factor-run --basic debian/make-bootstrap-images.factor # || wget http://factorcode.org/boot.image.$(FARCH) + mv boot.image.$(FARCH) boot.image + # Build the factor image + ./runtime boot.image -libraries:sdl:name=libSDL.so -libraries:freetype:name=libfreetype.so + mv factor.image basic.image + # Build the extended image sqlite3 contrib/sqlite/test.db < contrib/sqlite/test.txt -# $(CC) $(CFLAGS) -L /usr/X11R6/lib -shared -o contrib/factory/simple-error-handler.so contrib/factory/simple-error-handler.c -lX11 - echo 'USING: image kernel ; "extended.image" save-image 0 exit' | ./f factor.image contrib/load.factor -####### Build the documentation + $(CC) $(CFLAGS) -L /usr/X11R6/lib -shared -o contrib/factory/simple-error-handler.so contrib/factory/simple-error-handler.c -lX11 + echo 'USING: image kernel ; "extended.image" save-image 0 exit' | ./runtime basic.image contrib/load.factor + # Build the documentation cd doc && for i in *.eps; do epstopdf $$i; done cd doc && rubber --pdf theory cd doc && sh makedoc @@ -36,7 +40,7 @@ clean: dh_testroot rm -f build-stamp configure-stamp -$(MAKE) clean - -rm -f f factor.image extended.image + -rm -f f runtime factor.image boot.image boot.image.$(FARCH) basic.image extended.image dh_clean install: build @@ -44,8 +48,12 @@ install: build dh_testroot dh_clean -k dh_installdirs - install f factor.image extended.image $(CURDIR)/debian/factor/usr/share/factor - install -m 755 debian/factor-vm $(CURDIR)/debian/factor/usr/bin + # Install binary files + install runtime boot.image basic.image extended.image $(CURDIR)/debian/factor/usr/lib/factor + # Install source files + install contrib examples fonts library version.factor $(CURDIR)/debian/factor/usr/share/factor + # Install wrapper scripts + install -m 755 debian/scripts/factor-* $(CURDIR)/debian/factor/usr/bin binary-indep: build install diff --git a/debian/scripts/factor-export b/debian/scripts/factor-export new file mode 100644 index 0000000000..a1af34b075 --- /dev/null +++ b/debian/scripts/factor-export @@ -0,0 +1,38 @@ +#!/bin/sh +# Help function +############### +help () { + cat <= 2 + +Yn Size of n-1 youngest generations, megabytes + +An Size of tenured and semi-spaces, megabytes + +Xn Code heap size, megabytes +EOF + exit 0 +} + +# Default values +################ +BINARY_PATH='/usr/lib/factor' +RESOURCE_PATH='/usr/share/factor' +IMAGE="$BINARY_PATH/basic.image" +RUNTIME="$BINARY_PATH/runtime" + +# Logic +####### +if test 0 -eq $# +then + # As a 'quick start' behaviour, so that new users can + # get something to play with immediately. + echo "Launching the Factor runtime with a read-only basic image." + echo "Use \`\"filename\" save-image' to write an editable image." + exec "$RUNTIME" "$IMAGE" -resource-path="$RESOURCE_PATH" +else + case "$1" in + -h|--help) + help + ;; + -b|--basic) + IMAGE="$BINARY_PATH/basic.image" + ;; + -e|--extended) + IMAGE="$BINARY_PATH/extended.image" + ;; + *) + IMAGE="$1" + ;; + esac + shift + exec "$RUNTIME" "$IMAGE" -resource-path="$RESOURCE_PATH" "$@" +fi From 5244c332ffbaaa54e41f098c853558d7562bd323 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 19 Jan 2006 21:14:05 +0000 Subject: [PATCH 284/373] missing file --- library/io/styles.facts | 100 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 100 insertions(+) create mode 100644 library/io/styles.facts diff --git a/library/io/styles.facts b/library/io/styles.facts new file mode 100644 index 0000000000..77b371444b --- /dev/null +++ b/library/io/styles.facts @@ -0,0 +1,100 @@ +USING: help styles io ; + +HELP: plain f +{ $description "A value for the " { $link font-style } " character style denoting plain text." } ; + +HELP: bold f +{ $description "A value for the " { $link font-style } " character style denoting boldface text." } ; + +HELP: italic f +{ $description "A value for the " { $link font-style } " character style denoting italicized text." } ; + +HELP: bold-italic f +{ $description "A value for the " { $link font-style } " character style denoting boldface italicized text." } ; + +HELP: foreground f +{ $description "Character style. Text color, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." } +{ $examples + { $code + "\"Hello world\" 10 [" + " { 0.1 0.1 0.2 1 } n*v { 1 1 1 1 } vmin" + " foreground associate format terpri" + "] each-with" + } +} ; + +HELP: background f +{ $description "Character style. Background color, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." } +{ $examples + { $code + "\"Hello world\" 10 [" + " { 0.1 0.4 0.1 } n*v { 1 1 1 } vmin { 1 } append" + " background associate format terpri" + "] each-with" + } +} ; + +HELP: font f +{ $description "Character style. Font family named by a string." } +{ $examples + "This example outputs some different font sizes:" + { $code "{ \"Monospaced\" \"Serif\" \"Sans Serif\" }\n[ dup font associate format terpri ] each" } +} ; + +HELP: font-size f +{ $description "Character style. Font size, an integer." } +{ $examples + "This example outputs some different font sizes:" + { $code "\"Bigger\" { 12 18 24 72 }\n[ font-size associate format terpri ] each-with" } +} ; + +HELP: font-style f +{ $description "Character style. Font style, one of " { $link plain } ", " { $link bold } ", " { $link italic } ", or " { $link bold-italic } "." } +{ $examples + "This example outputs text in all three styles:" + { $code "{ plain bold italic bold-italic }\n[ [ word-name ] keep font-style associate format terpri ] each" } +} ; + +HELP: presented f +{ $description "Character and paragraph style. An object associated with the text. In the Factor UI, this is shown as a clickable presentation of the object; left-clicking invokes a default command, and right-clicking shows a menu of commands." } +{ $see-also simple-object write-object } ; + +HELP: file f +{ $description "Character style. A pathname associated with the text. In the Factor HTTP server, this is rendered as a link to this path on the server." } ; + +HELP: word-break f +{ $description "Character style. Denotes that this text is a point in the text where the line can be wrapped." } +{ $see-also bl } ; + +HELP: page-color f +{ $description "Paragraph style. Background color of the paragraph block, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." } +{ $examples + { $code "H{ { page-color { 1 0.8 0.5 1 } } }\n[ \"A background\" write ] with-nesting terpri" } +} ; + +HELP: border-color f +{ $description "Paragraph style. Border color of the paragraph block, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." } +{ $examples + { $code "H{ { border-color { 1 0 0 1 } } }\n[ \"A border\" write ] with-nesting terpri" } +} ; + +HELP: border-width f +{ $description "Paragraph style. Pixels between edge of text and border color, an integer." } +{ $examples + { $code "H{ { border-width 10 } }\n[ \"Some inset text\" write ] with-nesting terpri" } +} ; + +HELP: wrap-margin f +{ $description "Paragraph style. Pixels between left margin and right margin where text is wrapped, an integer." } +{ $see-also bl } ; + +HELP: outline f +{ $description "Paragraph style. In the Factor UI, a quotation executed to produce outliner content when the outliner widget next to the paragraph block is expanded." } +{ $see-also simple-outliner write-outliner } ; + +HELP: input f +{ $description "A wrapper class. In the Factor UI, presentations of this class are output as blocks of text which insert themselves in the listener's input area when clicked." } +{ $examples + "This presentation class is used for the code examples you see in the online help:" + { $code "\"2 3 + .\" dup simple-object terpri" } +} ; From 39813cd2024ec8bb3d8559a0edf78c90b87013e4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 19 Jan 2006 21:23:50 +0000 Subject: [PATCH 285/373] more failures --- TODO.FACTOR.txt | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index c227dba17e..35c051e81f 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -42,6 +42,12 @@ - if two tasks write to a unix stream, the buffer can overflow - inference bug - test cases: + + +- fix stack effect comment spacing in help for words without docs, + eg (object -- object object) -> ( object -- object object ) + +ALL TESTS BELOW FAIL ON x86 linux 32bit - float not commutative bug : a 237241607 1516.925984289192 3036109462846 913470293/554864 max min * 994.5872660892654 306803761/112249 -216866846 + - @@ -61,5 +67,8 @@ -113698191 1404.610575779506 51191522 * * - 1977.861343144055 -50892488 947579163/437404 * min * ; -- fix stack effect comment spacing in help for words without docs, - eg (object -- object object) -> ( object -- object object ) +- compiled vs interpreted output differs! + : math-dummy 692476975489 >fixnum ; + +: math-dummy -248461184 float>bits ; FAILS + From d0f9eb46bccc923e431b8b19fa0245b4a0ad74a7 Mon Sep 17 00:00:00 2001 From: Trent Buck Date: Thu, 19 Jan 2006 21:29:52 +0000 Subject: [PATCH 286/373] Remove old-guard debian wrapper script. --- debian/factor-vm | 3 --- 1 file changed, 3 deletions(-) delete mode 100644 debian/factor-vm diff --git a/debian/factor-vm b/debian/factor-vm deleted file mode 100644 index 17a7e3ffbf..0000000000 --- a/debian/factor-vm +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/sh -# This script invokes factor with the default image. -exec /usr/share/factor/f /usr/share/factor/factor.image "$@" From 6d9c4d328bae4bf5d1c11f5f461a91c1b5738eb8 Mon Sep 17 00:00:00 2001 From: Trent Buck Date: Thu, 19 Jan 2006 21:31:25 +0000 Subject: [PATCH 287/373] Use the *new* source tree when building the bootstrap image. --- debian/rules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/debian/rules b/debian/rules index 41de1acb98..a485e658ee 100644 --- a/debian/rules +++ b/debian/rules @@ -20,7 +20,7 @@ build-stamp: configure-stamp $(MAKE) linux-$(FARCH) mv f runtime # Build the bootstrap image - echo "USE: image \"$(FARCH)\" make-image" | factor-run --basic debian/make-bootstrap-images.factor # || wget http://factorcode.org/boot.image.$(FARCH) + echo 'USE: image "$(FARCH)" make-image' | factor-run --basic -resource-path=. # || wget http://factorcode.org/boot.image.$(FARCH) mv boot.image.$(FARCH) boot.image # Build the factor image ./runtime boot.image -libraries:sdl:name=libSDL.so -libraries:freetype:name=libfreetype.so From c936a4ef881af4bdf61d26c7400a516fd3de8d62 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 19 Jan 2006 22:35:00 +0000 Subject: [PATCH 288/373] more compile errors --- TODO.FACTOR.txt | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 35c051e81f..2b6c77e365 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -72,3 +72,26 @@ ALL TESTS BELOW FAIL ON x86 linux 32bit : math-dummy -248461184 float>bits ; FAILS +---RATIO--- +Compiles VERY SLOWLY +: math-dummy + 292025505/568715131 587196182/778552531 cos neg + 133163510/474434699 >bignum 57689734/429093367 tan cos + 585585439/262485063 neg ; + +Compile fails +: math-dummy 41614997/15884070 392881821/294492125 + sin sin sin tan sin 830428019/886540270 * neg ; + +---FLOAT--- +Compile fails: +: math-dummy + 2.522378181825594 tan 7.825249292551574 - cos + 0.2875868408644093 + sin >bignum cos >float sin ; +Compile fails: +: math-dummy + 0.5589927916549555 tan 2.261878253481278 + tan sin ; + +SLOW compile +: math-dummy + 1.550108042325469 3.888423982091886 - tan tan ; + From 183d5702e26e1ba07b452529b98f41b85f22eb5c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 19 Jan 2006 22:40:37 +0000 Subject: [PATCH 289/373] more --- TODO.FACTOR.txt | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 2b6c77e365..9491ed3795 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -41,8 +41,10 @@ - better i/o scheduler - if two tasks write to a unix stream, the buffer can overflow - inference bug -- test cases: +- font problem: http://iarc1.ece.utexas.edu/~erg/font-bug.JPG + +- implement 3.3 floor 4.7 ceiling - fix stack effect comment spacing in help for words without docs, eg (object -- object object) -> ( object -- object object ) @@ -69,8 +71,7 @@ ALL TESTS BELOW FAIL ON x86 linux 32bit - compiled vs interpreted output differs! : math-dummy 692476975489 >fixnum ; - -: math-dummy -248461184 float>bits ; FAILS + : math-dummy -248461184 float>bits ; FAILS ---RATIO--- Compiles VERY SLOWLY @@ -84,10 +85,6 @@ Compile fails ---FLOAT--- Compile fails: -: math-dummy - 2.522378181825594 tan 7.825249292551574 - cos - 0.2875868408644093 + sin >bignum cos >float sin ; -Compile fails: : math-dummy 0.5589927916549555 tan 2.261878253481278 + tan sin ; @@ -95,3 +92,7 @@ SLOW compile : math-dummy 1.550108042325469 3.888423982091886 - tan tan ; +Compile fails: +: math-dummy + 2.522378181825594 tan 7.825249292551574 - cos + 0.2875868408644093 + sin >bignum cos >float sin ; From c156c09a4258a64e8c697aa715d27f0fea2d91e6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 19 Jan 2006 23:15:37 +0000 Subject: [PATCH 290/373] documentation updates --- doc/handbook/collections.facts | 34 +++++++++++++-- doc/handbook/handbook.facts | 6 ++- doc/handbook/prettyprinter.facts | 65 ++++++++++++++++++++++++++++ library/bootstrap/boot-stage1.factor | 1 + library/syntax/prettyprint.facts | 10 ++--- 5 files changed, 106 insertions(+), 10 deletions(-) create mode 100644 doc/handbook/prettyprinter.facts diff --git a/doc/handbook/collections.facts b/doc/handbook/collections.facts index dc3ae2d873..faa99ff71a 100644 --- a/doc/handbook/collections.facts +++ b/doc/handbook/collections.facts @@ -1,13 +1,17 @@ -USING: hashtables hashtables-internals help kernel namespaces -queues ; +USING: hashtables hashtables-internals help io-internals kernel +namespaces queues ; GLOSSARY: "collection" "an object whose primary purpose is to aggregate other objects; examples include sequences, queues and hashtables" ; ARTICLE: "collections" "Collections" +"Classical data structures:" { $subsection "sequences" } { $subsection "queues" } { $subsection "hashtables" } -{ $subsection "namespaces" } ; +"An abstraction on hashtables:" +{ $subsection "namespaces" } +"A low-level facility:" +{ $subsection "buffers" } ; ARTICLE: "queues" "Queues" "A simple last-in-first-out queue data structure." @@ -142,3 +146,27 @@ ARTICLE: "namespaces-internals" "Namespace implementation details" "A pair of words push and pop namespaces on the namestack." { $subsection >n } { $subsection n> } ; + +ARTICLE: "buffers" "Locked I/O buffers" +"I/O buffers are a circular ring structure, a fixed-size queue of characters. Their key feature is that they are backed by manually allocated storage that does not get moved by the garbage collector. They are typically used for asynchronous I/O in conjunction with the C library interface in Factor's implementation." +$terpri +"Buffer words are in the " { $snippet "io-internals" } " vocabulary." +{ $subsection buffer } +{ $subsection } +"Buffers must be manually deallocated:" +{ $subsection buffer-free } +"Buffer operations:" +{ $subsection buffer-reset } +{ $subsection buffer-length } +{ $subsection buffer-empty? } +{ $subsection buffer-capacity } +"Reading from the buffer:" +{ $subsection buffer-peek } +{ $subsection buffer-pop } +{ $subsection buffer> } +{ $subsection buffer>> } +{ $subsection buffer-contents } +"Writing to the buffer:" +{ $subsection buffer-extend } +{ $subsection ch>buffer } +{ $subsection >buffer } ; diff --git a/doc/handbook/handbook.facts b/doc/handbook/handbook.facts index 923f764f18..e4326a68a9 100644 --- a/doc/handbook/handbook.facts +++ b/doc/handbook/handbook.facts @@ -7,7 +7,7 @@ $terpri { $subsection "presentation-intro" } { $subsection "tutorial" } { $subsection "quickref" } -"More detailed reference documentation:" +"Detailed reference documentation:" { $subsection "syntax" } { $subsection "dataflow" } { $subsection "words" } @@ -15,7 +15,9 @@ $terpri { $subsection "math" } { $subsection "collections" } { $subsection "streams" } -{ $subsection "parser" } ; +{ $subsection "parser" } +{ $subsection "prettyprint" } +; ARTICLE: "presentation-intro" "The presentation-based UI" "Factor provides a " { $emphasis "presentation-based" } " user interface. A " { $emphasis "presentation" } " is a graphical representation of a live object. You can see presentations everywhere; help links, words, and code examples are all presentations." diff --git a/doc/handbook/prettyprinter.facts b/doc/handbook/prettyprinter.facts new file mode 100644 index 0000000000..ce9567657f --- /dev/null +++ b/doc/handbook/prettyprinter.facts @@ -0,0 +1,65 @@ +USING: help io prettyprint ; + +GLOSSARY: "prettyprinter" "a set of words for printing objects in readable form" ; + +ARTICLE: "prettyprint" "The prettyprinter" +"One of Factor's key features is the ability to print almost any object as a valid source literal expression. This greatly aids debugging and provides the building blocks for light-weight object serialization facilities." +$terpri +"Prettyprinter words are found in the " { $snippet "prettyprint" } " vocabulary." +$terpri +"The key words to print an object to the " { $link stdio } " stream; the first two emit a trailing newline, the second two do not:" +{ $subsection . } +{ $subsection short. } +{ $subsection pprint } +{ $subsection pprint-short } +"The string representation of an object can be requested:" +{ $subsection unparse } +{ $subsection unparse-short } +"The prettyprinter is flexible and extensible." +{ $subsection "prettyprint-limitations" } +{ $subsection "prettyprint-variables" } +{ $subsection "prettyprint-extension" } +; + +ARTICLE: "prettyprint-limitations" "Prettyprinter limitations" +"The prettyprinter has some limitations; namely, the following objects may not print in a readable form:" +{ $list + { "When printing words, no " { $link POSTPONE: USE: } " declarations are output, hence the result may not be immediately readable without prefixing appropriate declarations." } + "Shared structure is not reflected in the printed output; if the output is parsed back in, fresh objects are created for all literal denotations." + { "Circular structure is not printed in a readable way. Circular references print as " { $snippet "#" } "." } + "Floating point numbers might not equal themselves after being printed and read, since a decimal representation of a float is inexact." +} +"On a final note, the " { $link short. } ", " { $link pprint-short } " and " { $link unparse-short } " words restrict the length and nesting of printed sequences, their output will very likely not be valid syntax. They are only intended for interactive use." ; + +ARTICLE: "prettyprint-variables" "Prettyprint control variables" +"The following variables affect the " { $link . } " and " { $link pprint } " words if set in the current dynamic scope:" +{ $subsection tab-size } +{ $subsection margin } +{ $subsection nesting-limit } +{ $subsection length-limit } +{ $subsection line-limit } +{ $subsection string-limit } +"Note that the " { $link short. } " and " { $link pprint-short } " variables override some of these variables." +{ + $warning "Treat the global variables as essentially being constants. Only ever rebind them in a nested scope." + $terpri + "Some of the globals are safe to change, like the tab size and wrap margin. However setting limits globally could break code which uses the prettyprinter as a serialization mechanism." +} ; + +ARTICLE: "prettyprint-extension" "Extending the prettyprinter" +"It is possible to define literal syntax for a new class using the " { $link "parser" } ", and then define a corresponding prettyprint method for the class which reproduces the literal syntax." +$terpri +"The prettyprinter maintains some internal state while prettyprinting. First, the object graph is traversed and a tree of " { $emphasis "sections" } " is produced. A section is either a text node or a " { $emphasis "block" } " which itself consists of sections." +$terpri +"Once the output is divided into sections, the tree is traversed and intelligent decisions are made about indentation and line breaks. If a block does not fit on the remainder of the current line, a newline is output before and after the block, and additional indentation is used when printing the block." +$terpri +"The following generic word is called to output a prettyprinting section for an object:" +{ $subsection pprint* } +"Two types of leaf sections:" +{ $subsection text } +{ $subsection newline } +"Nesting and denesting is done using three words. There are two words to denest a block; they vary in indentation policy:" +{ $subsection } +{ $subsection block; } +"Recall that since " { $link text } " sections take style hashtables as input, any type of formatted text can be output, including presentations. See " { $link "styles" } " to explore the possibility." ; diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 85c1da696c..90a0e95818 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -266,6 +266,7 @@ vectors words ; "/doc/handbook/math.facts" "/doc/handbook/objects.facts" "/doc/handbook/parser.facts" + "/doc/handbook/prettyprinter.facts" "/doc/handbook/sequences.facts" "/doc/handbook/streams.facts" "/doc/handbook/syntax.facts" diff --git a/library/syntax/prettyprint.facts b/library/syntax/prettyprint.facts index b28fbc32c7..780b5d4604 100644 --- a/library/syntax/prettyprint.facts +++ b/library/syntax/prettyprint.facts @@ -1,9 +1,9 @@ -USING: help prettyprint words ; +USING: help kernel prettyprint words ; IN: help : $prettyprinting-note - { + drop { "This word should only be called from inside the " { $link with-pprint } " combinator." } $notes ; @@ -233,11 +233,11 @@ HELP: . "( obj -- )" HELP: unparse "( obj -- str )" { $values { "obj" "an object" } { "str" "Factor source string" } } -{ $description "Outputs a prettyprinted string representation of an object." } ; +{ $description "Outputs a prettyprinted string representation of an object. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ; HELP: pprint-short "( obj -- )" { $values { "obj" "an object" } } -{ $description "Prettyprints an object to the default stream. This word rebinds printer control variables to enforce ``shorter'' output." } ; +{ $description "Prettyprints an object to the default stream. This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ; HELP: short. "( obj -- )" { $values { "obj" "an object" } } @@ -245,7 +245,7 @@ HELP: short. "( obj -- )" HELP: unparse-short "( obj -- str )" { $values { "obj" "an object" } { "str" "Factor source string" } } -{ $description "Outputs a prettyprinted string representation of an object. This word rebinds printer control variables to enforce ``shorter'' output." } ; +{ $description "Outputs a prettyprinted string representation of an object. This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ; HELP: .b "( n -- )" { $values { "n" "an integer" } } From 2632d3e5246fb8b57c9a9dcd5c988177f122b3eb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 19 Jan 2006 23:19:55 +0000 Subject: [PATCH 291/373] fix stack comments --- TODO.FACTOR.txt | 3 --- library/syntax/see.factor | 4 ++-- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 9491ed3795..e18fb04798 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -46,9 +46,6 @@ - implement 3.3 floor 4.7 ceiling -- fix stack effect comment spacing in help for words without docs, - eg (object -- object object) -> ( object -- object object ) - ALL TESTS BELOW FAIL ON x86 linux 32bit - float not commutative bug : a 237241607 1516.925984289192 3036109462846 913470293/554864 diff --git a/library/syntax/see.factor b/library/syntax/see.factor index 769be52646..b8b80fa001 100644 --- a/library/syntax/see.factor +++ b/library/syntax/see.factor @@ -30,11 +30,11 @@ sequences strings styles words ; : effect>string ( effect -- string ) [ - "(" % + "( " % dup first stack-picture % " -- " % second stack-picture % - ")" % + " )" % ] "" make ; : stack-effect ( word -- string ) From 696bdce47b0838676c9df721c8a446fdf4618b74 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 19 Jan 2006 23:34:27 +0000 Subject: [PATCH 292/373] truncate for floats --- TODO.FACTOR.txt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index e18fb04798..8f2df9ac7a 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -44,7 +44,7 @@ - font problem: http://iarc1.ece.utexas.edu/~erg/font-bug.JPG -- implement 3.3 floor 4.7 ceiling +- implement 3.3 floor 4.7 ceiling 4.5 truncate ALL TESTS BELOW FAIL ON x86 linux 32bit - float not commutative bug @@ -93,3 +93,5 @@ Compile fails: : math-dummy 2.522378181825594 tan 7.825249292551574 - cos 0.2875868408644093 + sin >bignum cos >float sin ; + + From 7222ba552ade2d1ef136f4545878d2fff72244e4 Mon Sep 17 00:00:00 2001 From: Trent Buck Date: Thu, 19 Jan 2006 23:34:50 +0000 Subject: [PATCH 293/373] There's only one ell in sqlite. --- contrib/sqlite/load.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/contrib/sqlite/load.factor b/contrib/sqlite/load.factor index ee2f9619e3..028f304cb9 100644 --- a/contrib/sqlite/load.factor +++ b/contrib/sqlite/load.factor @@ -1,6 +1,6 @@ IN: scratchpad USING: kernel alien parser compiler words sequences ; -"sqllite" "libsqlite3" add-simple-library +"sqlite" "libsqlite3" add-simple-library { "sqlite" "tuple-db" "test" "tuple-db-tests" } [ "contrib/sqlite/" swap ".factor" append3 run-file ] each From 89a4eff5b7594b7d28c667c13f307ba97f962432 Mon Sep 17 00:00:00 2001 From: Trent Buck Date: Thu, 19 Jan 2006 23:57:27 +0000 Subject: [PATCH 294/373] Move add-simple-library to aliens. --- contrib/load.factor | 7 +------ library/alien/aliens.factor | 4 ++++ 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/contrib/load.factor b/contrib/load.factor index bfb635aa22..35c833c3f0 100644 --- a/contrib/load.factor +++ b/contrib/load.factor @@ -14,17 +14,12 @@ USING: alien kernel words sequences parser compiler memory ; ! cont-responder -> parser-combinators ! } -: add-simple-library ( name file -- ) - win32? ".dll" ".so" ? append - win32? "stdcall" "cdecl" ? add-library ; - { "coroutines" "dlists" "splay-trees" } [ dup "contrib/" swap ".factor" append3 run-file words [ try-compile ] each ] each -{ "cairo" "math" "concurrency" "crypto" "aim" "httpd" "units" "sqlite" "win32" - "x11" ! "factory" has a C component, ick. +{ "cairo" "math" "concurrency" "crypto" "aim" "httpd" "units" "sqlite" "win32" "x11" ! "factory" has a C component, ick. "postgresql" "parser-combinators" "cont-responder" "space-invaders" } [ "contrib/" swap "/load.factor" append3 run-file ] each diff --git a/library/alien/aliens.factor b/library/alien/aliens.factor index daa2d335bc..a746261913 100644 --- a/library/alien/aliens.factor +++ b/library/alien/aliens.factor @@ -32,6 +32,10 @@ M: alien = ( obj obj -- ? ) [ "abi" set "name" set ] make-hash swap set ] bind ; +: add-simple-library ( name file -- ) + win32? ".dll" ".so" ? append + win32? "stdcall" "cdecl" ? add-library ; + : library-abi ( library -- abi ) library "abi" swap ?hash [ "cdecl" ] unless* ; From 5a4087a69bda94e226c7064d45e68372295b0fc8 Mon Sep 17 00:00:00 2001 From: Trent Buck Date: Fri, 20 Jan 2006 00:04:33 +0000 Subject: [PATCH 295/373] Move add-simple-library to aliens. [amend] --- library/alien/aliens.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/alien/aliens.factor b/library/alien/aliens.factor index a746261913..51d303eba2 100644 --- a/library/alien/aliens.factor +++ b/library/alien/aliens.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: alien -USING: arrays hashtables io kernel lists math namespaces parser ; +USING: arrays hashtables io kernel lists math namespaces parser sequences ; UNION: c-ptr byte-array alien displaced-alien ; From 4e77f48d741412da8f2c206316278a8d25afa3a5 Mon Sep 17 00:00:00 2001 From: Trent Buck Date: Fri, 20 Jan 2006 00:30:18 +0000 Subject: [PATCH 296/373] Fix typo in stack effect. --- contrib/concurrency/concurrency-examples.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/contrib/concurrency/concurrency-examples.factor b/contrib/concurrency/concurrency-examples.factor index 2bca816c82..27c3b086e6 100644 --- a/contrib/concurrency/concurrency-examples.factor +++ b/contrib/concurrency/concurrency-examples.factor @@ -43,7 +43,7 @@ math math-contrib namespaces opengl prettyprint sequences threads ; "Pong server shutting down" swap send ] if ; -: pong-server0 ( -- process) +: pong-server0 ( -- process ) [ (pong-server0) ] spawn ; TUPLE: ping-message from ; From bba4812b9be6da21817a9ee1932c61fe7af6dd61 Mon Sep 17 00:00:00 2001 From: Trent Buck Date: Fri, 20 Jan 2006 00:37:24 +0000 Subject: [PATCH 297/373] Fix typo in stack effect. --- contrib/concurrency/concurrency.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/contrib/concurrency/concurrency.factor b/contrib/concurrency/concurrency.factor index 4b81d553f9..010e6844da 100644 --- a/contrib/concurrency/concurrency.factor +++ b/contrib/concurrency/concurrency.factor @@ -356,7 +356,7 @@ SYMBOL: quit-cc r> drop 3drop ] if ; -: server-cc ( -- cc | process) +: server-cc ( -- cc | process ) #! Captures the current continuation and returns the value. #! If that CC is called with a process on the stack it will #! set 'self' for the current process to it. Otherwise it will From 0b721bb54276adabe8b2e386b57a66795e5a3ff5 Mon Sep 17 00:00:00 2001 From: Trent Buck Date: Fri, 20 Jan 2006 01:27:38 +0000 Subject: [PATCH 298/373] Don't compile contrib/ files until the very end; reduces compile time considerably. --- contrib/aim/load.factor | 10 +++--- contrib/cairo/load.factor | 18 +++++------ contrib/concurrency/load.factor | 8 ++--- contrib/cont-responder/load.factor | 17 ++++++---- contrib/crypto/load.factor | 10 +++--- contrib/httpd/load.factor | 23 +++++++++++--- contrib/load.factor | 44 +++++++++++++------------- contrib/math/load.factor | 14 +++++--- contrib/parser-combinators/load.factor | 11 ++++--- contrib/postgresql/load.factor | 11 ++++--- contrib/space-invaders/load.factor | 12 +++---- contrib/sqlite/load.factor | 12 ++++--- contrib/units/load.factor | 10 +++--- contrib/win32/load.factor | 17 ++++++---- contrib/x11/load.factor | 4 +-- debian/changelog | 6 ++++ debian/rules | 12 ++++--- 17 files changed, 141 insertions(+), 98 deletions(-) diff --git a/contrib/aim/load.factor b/contrib/aim/load.factor index 89114b5940..fcfc45ea39 100644 --- a/contrib/aim/load.factor +++ b/contrib/aim/load.factor @@ -1,9 +1,9 @@ IN: scratchpad USING: kernel parser sequences words compiler ; + "contrib/crypto/load.factor" run-file -{ "net-bytes" "aim" } -[ "contrib/aim/" swap ".factor" append3 run-file ] - -{ "aim-internals" "aim" } -[ words [ try-compile ] each ] each +{ + "net-bytes" + "aim" +} [ "contrib/aim/" swap ".factor" append3 run-file ] diff --git a/contrib/cairo/load.factor b/contrib/cairo/load.factor index 05f8309581..48613bbbfc 100644 --- a/contrib/cairo/load.factor +++ b/contrib/cairo/load.factor @@ -1,13 +1,13 @@ IN: scratchpad USING: alien kernel parser compiler words sequences ; -{ { "cairo" "libcairo" } - { "sdl-gfx" "libSDL_gfx" } - { "sdl" "libSDL" } } -[ first2 add-simple-library ] each +{ + { "cairo" "libcairo" } + { "sdl-gfx" "libSDL_gfx" } + { "sdl" "libSDL" } +} [ first2 add-simple-library ] each -{ "cairo" "cairo_sdl" } -[ "contrib/cairo/" swap ".factor" append3 run-file ] each - -{ "cairo" "cairo-sdl" } -[ words [ try-compile ] each ] each +{ + "cairo" + "cairo_sdl" +} [ "contrib/cairo/" swap ".factor" append3 run-file ] each diff --git a/contrib/concurrency/load.factor b/contrib/concurrency/load.factor index f2c2953385..cfbe26f4d2 100644 --- a/contrib/concurrency/load.factor +++ b/contrib/concurrency/load.factor @@ -4,7 +4,7 @@ USING: kernel parser compiler words sequences ; "contrib/dlists.factor" run-file "contrib/math/load.factor" run-file -{ "concurrency" "concurrency-examples" } -dup -[ "contrib/concurrency/" swap ".factor" append3 run-file ] each -[ words [ try-compile ] each ] each +{ + "concurrency" + "concurrency-examples" +} [ "contrib/concurrency/" swap ".factor" append3 run-file ] each diff --git a/contrib/cont-responder/load.factor b/contrib/cont-responder/load.factor index 74d7d03dbe..ed24bd653f 100644 --- a/contrib/cont-responder/load.factor +++ b/contrib/cont-responder/load.factor @@ -1,11 +1,16 @@ IN: scratchpad USING: words kernel parser sequences io compiler ; + "contrib/httpd/load.factor" run-file "contrib/parser-combinators/load.factor" run-file -{ "cont-examples" "cont-numbers-game" "todo" "todo-example" "live-updater" "eval-responder" "live-updater-responder" "cont-testing" } -[ "contrib/cont-responder/" swap ".factor" append3 run-file ] each - -{ "cont-examples" "numbers-game" "cont-responder" "eval-responder" "live-updater-responder" "live-updater" "todo-example" "todo" } -[ words [ try-compile ] each ] each - +{ + "cont-examples" + "cont-numbers-game" + "todo" + "todo-example" + "live-updater" + "eval-responder" + "live-updater-responder" + "cont-testing" +} [ "contrib/cont-responder/" swap ".factor" append3 run-file ] each diff --git a/contrib/crypto/load.factor b/contrib/crypto/load.factor index 614a111fc8..8efa13cf2e 100644 --- a/contrib/crypto/load.factor +++ b/contrib/crypto/load.factor @@ -1,8 +1,10 @@ IN: scratchpad USING: kernel parser sequences words compiler ; + "contrib/math/load.factor" run-file -{ "common" "md5" "sha1" } -[ "contrib/crypto/" swap ".factor" append3 run-file ] each - -"crypto" words [ try-compile ] each +{ + "common" + "md5" + "sha1" +} [ "contrib/crypto/" swap ".factor" append3 run-file ] each diff --git a/contrib/httpd/load.factor b/contrib/httpd/load.factor index f8c26eec49..e46a6dc4a6 100644 --- a/contrib/httpd/load.factor +++ b/contrib/httpd/load.factor @@ -1,8 +1,21 @@ IN: scratchpad USING: words kernel parser sequences io compiler ; -{ "http-common" "mime" "html-tags" "html" "responder" "httpd" "file-responder" "cont-responder" "browser-responder" "default-responders" "http-client" - "test/html" "test/http-client" "test/httpd" "test/url-encoding" } -[ "contrib/httpd/" swap ".factor" append3 run-file ] each -{ "browser-responder" "cont-responder" "httpd" "file-responder" "html" "http-client" "http" "xml" } -[ words [ try-compile ] each ] each +{ + "http-common" + "mime" + "html-tags" + "html" + "responder" + "httpd" + "file-responder" + "cont-responder" + "browser-responder" + "default-responders" + "http-client" + + "test/html" + "test/http-client" + "test/httpd" + "test/url-encoding" +} [ "contrib/httpd/" swap ".factor" append3 run-file ] each diff --git a/contrib/load.factor b/contrib/load.factor index 35c833c3f0..a7a4020be1 100644 --- a/contrib/load.factor +++ b/contrib/load.factor @@ -1,26 +1,26 @@ ! Load all contrib libs, compile them, and save a new image. IN: scratchpad -USING: alien kernel words sequences parser compiler memory ; +USING: alien compiler kernel memory parser sequences words ; -! digraph dependencies { -! // run-file libs in the correct order to avoid repeated run-filing -! aim -> crypto -! concurrency -> dlists -! concurrency -> math -! cont-responder -> httpd -! crypto -> math -! factor -> x11 -! space-invaders -> parser-combinators -! cont-responder -> parser-combinators -! } +{ + "coroutines" + "dlists" + "splay-trees" +} [ "contrib/" swap ".factor" append3 run-file clear ] each -{ "coroutines" "dlists" "splay-trees" } -[ dup - "contrib/" swap ".factor" append3 run-file - words [ try-compile ] each ] each - -{ "cairo" "math" "concurrency" "crypto" "aim" "httpd" "units" "sqlite" "win32" "x11" ! "factory" has a C component, ick. - "postgresql" "parser-combinators" "cont-responder" "space-invaders" -} [ "contrib/" swap "/load.factor" append3 run-file ] each - -compile-all +{ "cairo" + "math" + "concurrency" + "crypto" + "aim" + "httpd" + "units" + "sqlite" + "win32" + "x11" + ! "factory" has a C component, ick. + "postgresql" + "parser-combinators" + "cont-responder" + "space-invaders" +} [ "contrib/" swap "/load.factor" append3 run-file clear ] each diff --git a/contrib/math/load.factor b/contrib/math/load.factor index 5f69577e22..ccf5b80e41 100644 --- a/contrib/math/load.factor +++ b/contrib/math/load.factor @@ -1,7 +1,13 @@ IN: scratchpad USING: kernel parser sequences words compiler ; -{ "utils" "combinatorics" "analysis" "polynomials" "quaternions" "matrices" "statistics" "numerical-integration" } -[ "contrib/math/" swap ".factor" append3 run-file ] each - -"math-contrib" words [ try-compile ] each +{ + "utils" + "combinatorics" + "analysis" + "polynomials" + "quaternions" + "matrices" + "statistics" + "numerical-integration" +} [ "contrib/math/" swap ".factor" append3 run-file ] each diff --git a/contrib/parser-combinators/load.factor b/contrib/parser-combinators/load.factor index 1cc873d17b..470c6de500 100644 --- a/contrib/parser-combinators/load.factor +++ b/contrib/parser-combinators/load.factor @@ -1,8 +1,9 @@ IN: scratchpad USING: kernel parser sequences words compiler ; -{ "lazy" "parser-combinators" "lazy-examples" "tests" } -[ "contrib/parser-combinators/" swap ".factor" append3 run-file ] each - -{ "lazy" "lazy-examples" "parser-combinators" } -[ words [ try-compile ] each ] each +{ + "lazy" + "parser-combinators" + "lazy-examples" + "tests" +} [ "contrib/parser-combinators/" swap ".factor" append3 run-file ] each diff --git a/contrib/postgresql/load.factor b/contrib/postgresql/load.factor index 88eeefbbdd..2e15f1c86e 100644 --- a/contrib/postgresql/load.factor +++ b/contrib/postgresql/load.factor @@ -1,8 +1,11 @@ IN: scratchpad USING: alien compiler kernel parser sequences words ; + "postgresql" "libpq" add-simple-library -{ "libpq" "postgresql" "postgresql-test" ! "private" ! Put your password in this file + +{ + "libpq" + "postgresql" + "postgresql-test" + ! "private" ! Put your password in this file } [ "contrib/postgresql/" swap ".factor" append3 run-file ] each - -"postgresql" words [ try-compile ] each - diff --git a/contrib/space-invaders/load.factor b/contrib/space-invaders/load.factor index 2f5c3ba58b..a222d190d8 100644 --- a/contrib/space-invaders/load.factor +++ b/contrib/space-invaders/load.factor @@ -1,11 +1,9 @@ IN: scratchpad USING: kernel parser compiler words sequences io ; + "contrib/parser-combinators/load.factor" run-file -{ "cpu-8080" "space-invaders" } -[ "contrib/space-invaders/" swap ".factor" append3 run-file ] each - -{ "cpu-8080" "space-invaders" } -[ words [ try-compile ] each ] each - -"Use 'run' in the 'space-invaders' vocabulary to start." print +{ + "cpu-8080" + "space-invaders" +} [ "contrib/space-invaders/" swap ".factor" append3 run-file ] each diff --git a/contrib/sqlite/load.factor b/contrib/sqlite/load.factor index 028f304cb9..2a80b829fe 100644 --- a/contrib/sqlite/load.factor +++ b/contrib/sqlite/load.factor @@ -1,9 +1,11 @@ IN: scratchpad USING: kernel alien parser compiler words sequences ; + "sqlite" "libsqlite3" add-simple-library -{ "sqlite" "tuple-db" "test" "tuple-db-tests" } -[ "contrib/sqlite/" swap ".factor" append3 run-file ] each - -{ "sqlite" "tuple-db" } -[ words [ try-compile ] each ] each +{ + "sqlite" + "tuple-db" + "test" + "tuple-db-tests" +} [ "contrib/sqlite/" swap ".factor" append3 run-file ] each diff --git a/contrib/units/load.factor b/contrib/units/load.factor index a3199b6dce..c24c6a1984 100644 --- a/contrib/units/load.factor +++ b/contrib/units/load.factor @@ -1,8 +1,8 @@ IN: scratchpad USING: kernel parser sequences words compiler ; -{ "dimensioned" "si-units" "constants" } -[ "contrib/units/" swap ".factor" append3 run-file ] each - -{ "units-internal" "units" "si-units" } -[ words [ try-compile ] each ] each +{ + "dimensioned" + "si-units" + "constants" +} [ "contrib/units/" swap ".factor" append3 run-file ] each diff --git a/contrib/win32/load.factor b/contrib/win32/load.factor index ac8eea3df7..3a19182e3a 100644 --- a/contrib/win32/load.factor +++ b/contrib/win32/load.factor @@ -1,11 +1,14 @@ IN: scratchpad USING: alien compiler kernel parser sequences words ; -{ { "user" "user32" } - { "kernel" "kernel32" } } -[ first2 add-simple-library ] each +{ + { "user" "user32" } + { "kernel" "kernel32" } +} [ first2 add-simple-library ] each -{ "utils" "types" "kernel32" "user32" } -[ "contrib/win32/" swap ".factor" append3 run-file ] each - -"win32" words [ try-compile ] each +{ + "utils" + "types" + "kernel32" + "user32" +} [ "contrib/win32/" swap ".factor" append3 run-file ] each diff --git a/contrib/x11/load.factor b/contrib/x11/load.factor index c82ae1f99f..953a8412e4 100644 --- a/contrib/x11/load.factor +++ b/contrib/x11/load.factor @@ -1,5 +1,5 @@ IN: scratchpad -USING: kernel parser words compiler sequences ; +USING: alien compiler kernel parser sequences words ; "X11" "libX11" add-simple-library @@ -13,4 +13,4 @@ USING: kernel parser words compiler sequences ; "gl" } [ "contrib/x11/" swap ".factor" append3 run-file ] each -{ "xlib" "x11" } [ words [ try-compile ] each ] each +! { "xlib" "x11" } [ words [ try-compile ] each ] each diff --git a/debian/changelog b/debian/changelog index 53f2164f4b..2bcac75095 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +factor (0.79+cvs20060120-1) unstable; urgency=low + + * Refactored wrapper scripts and reduced build time. + + -- Trent Buck Fri, 20 Jan 2006 12:18:21 +1100 + factor (0.79+cvs20060119-1) unstable; urgency=low * Make an extended.image. diff --git a/debian/rules b/debian/rules index a485e658ee..ab4ab5f649 100644 --- a/debian/rules +++ b/debian/rules @@ -28,7 +28,7 @@ build-stamp: configure-stamp # Build the extended image sqlite3 contrib/sqlite/test.db < contrib/sqlite/test.txt $(CC) $(CFLAGS) -L /usr/X11R6/lib -shared -o contrib/factory/simple-error-handler.so contrib/factory/simple-error-handler.c -lX11 - echo 'USING: image kernel ; "extended.image" save-image 0 exit' | ./runtime basic.image contrib/load.factor + echo 'USING: image kernel ; "contrib/load.factor" run-file compile-all "extended.image" save-image 0 exit' | ./runtime basic.image +X8 # Build the documentation cd doc && for i in *.eps; do epstopdf $$i; done cd doc && rubber --pdf theory @@ -49,11 +49,15 @@ install: build dh_clean -k dh_installdirs # Install binary files - install runtime boot.image basic.image extended.image $(CURDIR)/debian/factor/usr/lib/factor + install -m 755 -o root -g root runtime $(CURDIR)/debian/factor/usr/lib/factor + install -m 644 -o root -g root boot.image basic.image extended.image $(CURDIR)/debian/factor/usr/lib/factor # Install source files - install contrib examples fonts library version.factor $(CURDIR)/debian/factor/usr/share/factor + cp -r contrib examples fonts library version.factor $(CURDIR)/debian/factor/usr/share/factor + find $(CURDIR)/debian/factor/usr/share/factor -type d -exec chmod 755 {} \; + find $(CURDIR)/debian/factor/usr/share/factor -type f -exec chmod 644 {} \; + chown -R root.root $(CURDIR)/debian/factor/usr/share/factor # Install wrapper scripts - install -m 755 debian/scripts/factor-* $(CURDIR)/debian/factor/usr/bin + install -m 755 -o root -g root debian/scripts/factor-* $(CURDIR)/debian/factor/usr/bin binary-indep: build install From 978b3edc47c9fdbab935f7cdb7701d4bc2b2015b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 20 Jan 2006 04:28:45 +0000 Subject: [PATCH 299/373] inference fix --- TODO.FACTOR.txt | 11 ----------- library/alien/aliens.factor | 4 ---- library/alien/syntax.factor | 4 ++++ library/inference/words.factor | 23 +++++++++++++++-------- library/test/collections/sequences.factor | 4 ++-- library/test/math/integer.factor | 2 +- 6 files changed, 22 insertions(+), 26 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 8f2df9ac7a..f7d1f4f08f 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,5 +1,4 @@ - FUNCTION: not updating crossref correctly -- UI word wrap: sometimes a space appears at the front - need line and paragraph spacing - update HTML stream - help cross-referencing @@ -7,13 +6,6 @@ - if cell is rebound, and we allocate c objects, bang - runtime primitives like fopen: check for null input - -with combinators are awkward -- cleanups: - alien/compiler - inference/shuffle - inference-words inline-block - io/buffer - use aliens not integers - alien/malloc - use aliens not integers - ui/line-editor - don't use variables - amd64 to do: - alien calls - port ffi to win64 @@ -40,10 +32,7 @@ - stream server can hang because of exception handler limitations - better i/o scheduler - if two tasks write to a unix stream, the buffer can overflow -- inference bug - - font problem: http://iarc1.ece.utexas.edu/~erg/font-bug.JPG - - implement 3.3 floor 4.7 ceiling 4.5 truncate ALL TESTS BELOW FAIL ON x86 linux 32bit diff --git a/library/alien/aliens.factor b/library/alien/aliens.factor index 51d303eba2..208cef59da 100644 --- a/library/alien/aliens.factor +++ b/library/alien/aliens.factor @@ -38,7 +38,3 @@ M: alien = ( obj obj -- ? ) : library-abi ( library -- abi ) library "abi" swap ?hash [ "cdecl" ] unless* ; - -: DLL" skip-blank parse-string dlopen swons ; parsing - -: ALIEN: scan-word swons ; parsing diff --git a/library/alien/syntax.factor b/library/alien/syntax.factor index ca3130cfb6..674c114564 100644 --- a/library/alien/syntax.factor +++ b/library/alien/syntax.factor @@ -4,6 +4,10 @@ IN: !syntax USING: alien compiler kernel lists math namespaces parser sequences syntax words ; +: DLL" skip-blank parse-string dlopen swons ; parsing + +: ALIEN: scan-word swons ; parsing + ! usage of 'LIBRARY:' and 'FUNCTION:' : ! ! LIBRARY: gl diff --git a/library/inference/words.factor b/library/inference/words.factor index 7dbc19f095..67fb2b5064 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -25,7 +25,7 @@ strings vectors words ; " was already attempted, and failed" append3 inference-error ; -TUPLE: rstate label quot base-case? ; +TUPLE: rstate label base-case? ; : nest-node ( -- dataflow current ) dataflow-graph get dataflow-graph off @@ -37,8 +37,7 @@ TUPLE: rstate label quot base-case? ; r> current-node set ; : with-recursive-state ( word label base-case quot -- ) - >r >r over word-def r> cons - recursive-state [ cons ] change r> + >r cons recursive-state [ cons ] change r> nest-node 2slip unnest-node ; inline : inline-block ( word base-case -- node-block variables ) @@ -109,8 +108,10 @@ M: #call-label collect-recursion* ( label node -- ) #! control flow by throwing an exception or restoring a #! continuation. [ - recursive-state get init-inference over >r inline-block - nip [ terminated? get effect ] bind r> + dup inferring-base-case set + recursive-state get init-inference + over >r inline-block nip + [ terminated? get effect ] bind r> ] with-scope over consume/produce over [ terminate ] when ; GENERIC: apply-word @@ -119,12 +120,18 @@ M: object apply-word ( word -- ) #! A primitive with an unknown stack effect. no-effect ; +: save-effect ( word terminates effect -- ) + inferring-base-case get [ + 3drop + ] [ + >r dupd "terminates" set-word-prop r> + "infer-effect" set-word-prop + ] if ; + M: compound apply-word ( word -- ) #! Infer a compound word's stack effect. [ - dup dup f infer-compound - >r "terminates" set-word-prop r> - "infer-effect" set-word-prop + dup f infer-compound save-effect ] [ swap t "no-effect" set-word-prop rethrow ] recover ; diff --git a/library/test/collections/sequences.factor b/library/test/collections/sequences.factor index 39cfaebd55..8def7aaf83 100644 --- a/library/test/collections/sequences.factor +++ b/library/test/collections/sequences.factor @@ -134,12 +134,12 @@ unit-test sorter-seq >array nip ] unit-test -[ [ ] ] [ [ ] number-sort ] unit-test +[ [ ] ] [ [ ] natural-sort ] unit-test [ t ] [ 100 [ drop - 1000 [ drop 1000 random-int ] map number-sort [ <= ] monotonic? + 100 [ drop 20 random-int [ drop 1000 random-int ] map ] map natural-sort [ <=> 0 <= ] monotonic? ] all? ] unit-test diff --git a/library/test/math/integer.factor b/library/test/math/integer.factor index ee3b85e3c9..31e0c5d2fb 100644 --- a/library/test/math/integer.factor +++ b/library/test/math/integer.factor @@ -55,7 +55,7 @@ USING: kernel math namespaces prettyprint test ; ] unit-test : verify-gcd ( x y ) - 2dup gcd ( a d ) + 2dup swap gcd ( a d ) >r rot * swap rem r> = ; [ t ] [ 123 124 verify-gcd ] unit-test From cb378cd2c0aa6e53126bfc61e8a207e13d870bb2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 20 Jan 2006 06:26:50 +0000 Subject: [PATCH 300/373] HTTPD cleanups, working on help responder --- TODO.FACTOR.txt | 5 - contrib/cont-responder/todo-example.factor | 1 + contrib/httpd/browser-responder.factor | 17 +--- contrib/httpd/default-responders.factor | 10 +- contrib/httpd/help-responder.factor | 9 ++ contrib/httpd/html.factor | 106 ++++++++++++++------- contrib/httpd/load.factor | 2 + contrib/httpd/test/html.factor | 4 +- contrib/httpd/xml.factor | 41 ++++---- library/bootstrap/boot-stage1.factor | 4 +- library/bootstrap/boot-stage2.factor | 4 + library/freetype/freetype-gl.factor | 24 ++--- library/help/markup.factor | 7 +- library/help/stylesheet.factor | 14 +-- library/syntax/prettyprint.factor | 2 +- library/threads.factor | 40 -------- library/ui/presentations.factor | 2 +- library/ui/theme.factor | 6 +- library/ui/timers.factor | 40 ++++++++ library/ui/ui.factor | 8 +- library/ui/world.factor | 8 +- 21 files changed, 197 insertions(+), 157 deletions(-) create mode 100644 contrib/httpd/help-responder.factor create mode 100644 library/ui/timers.factor diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index f7d1f4f08f..34c769db9a 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,4 +1,3 @@ -- FUNCTION: not updating crossref correctly - need line and paragraph spacing - update HTML stream - help cross-referencing @@ -10,12 +9,8 @@ - alien calls - port ffi to win64 - intrinsic char-slot set-char-slot for x86 -- closing ui does not stop timers -- adding/removing timers automatically for animated gadgets -- saving image with UI open - fix up the min thumb size hack - the invalid recursion form case needs to be fixed, for inlines too -- what about tasks and timers between image restarts - code walker & exceptions - signal handler should not lose stack pointers - FIELD: char key_vector[32]; diff --git a/contrib/cont-responder/todo-example.factor b/contrib/cont-responder/todo-example.factor index 442249e2da..4476e668c8 100644 --- a/contrib/cont-responder/todo-example.factor +++ b/contrib/cont-responder/todo-example.factor @@ -27,6 +27,7 @@ ! list of things to do. All data is stored in a directory in the ! filesystem with the users name. IN: todo-example +USING: xml ; USE: cont-responder USE: html USE: io diff --git a/contrib/httpd/browser-responder.factor b/contrib/httpd/browser-responder.factor index 4d6d89a350..d3fc96ba5d 100644 --- a/contrib/httpd/browser-responder.factor +++ b/contrib/httpd/browser-responder.factor @@ -25,8 +25,8 @@ ! cont-responder facilities. ! IN: browser-responder -USING: html cont-responder hashtables kernel io namespaces words lists prettyprint - memory sequences ; +USING: cont-responder hashtables help html io kernel lists +memory namespaces prettyprint sequences words xml ; : option ( current text -- ) #! Output the HTML option tag for the given text. If @@ -56,13 +56,7 @@ USING: html cont-responder hashtables kernel io namespaces words lists prettypri : word-source ( vocab word -- ) #! Write the source for the given word from the vocab as HTML. - swap lookup [ - [ see ] with-simple-html-output - ] when* ; - -: vm-statistics ( -- ) - #! Display statistics about the vm. - 
       room.
      ; + swap lookup [ [ help ] with-html-stream ] when* ; : browser-body ( vocab word -- ) #! Write out the HTML for the body of the main browser page. @@ -70,15 +64,14 @@ USING: html cont-responder hashtables kernel io namespaces words lists prettypri "Vocabularies" write "Words" write - "Source" write + "Documentation" write over vocab-list 2dup word-list word-source - - vm-statistics ; + ; : browser-title ( vocab word -- ) #! Output the HTML title for the browser. diff --git a/contrib/httpd/default-responders.factor b/contrib/httpd/default-responders.factor index aa995af38d..8c5a05ea61 100644 --- a/contrib/httpd/default-responders.factor +++ b/contrib/httpd/default-responders.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: httpd -USING: browser-responder cont-responder file-responder kernel -namespaces prettyprint ; +USING: browser-responder cont-responder file-responder +help-responder kernel namespaces prettyprint ; #! Remove all existing responders, and create a blank #! responder table. @@ -14,6 +14,12 @@ global [ "404" "responder" set [ drop no-such-responder ] "get" set ] make-responder + + ! Online help browsing + [ + "help" "responder" set + [ help-responder ] "get" set + ] make-responder ! Servers Factor word definitions from the image. "browser" [ browser-responder ] install-cont-responder diff --git a/contrib/httpd/help-responder.factor b/contrib/httpd/help-responder.factor new file mode 100644 index 0000000000..1430c30458 --- /dev/null +++ b/contrib/httpd/help-responder.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: help-responder +USING: help html kernel sequences ; + +: help-responder ( filename -- ) + dup empty? [ drop "handbook" ] when + dup article-title + [ [ (help) ] with-html-stream ] html-document ; diff --git a/contrib/httpd/html.factor b/contrib/httpd/html.factor index 3a137f81a2..330bcbf3c9 100644 --- a/contrib/httpd/html.factor +++ b/contrib/httpd/html.factor @@ -1,38 +1,25 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: html -USING: generic hashtables http io kernel lists math namespaces -sequences strings styles words ; - -: html-entities ( -- alist ) - H{ - { CHAR: < "<" } - { CHAR: > ">" } - { CHAR: & "&" } - { CHAR: ' "'" } - { CHAR: " """ } - } ; - -: chars>entities ( str -- str ) - #! Convert <, >, &, ' and " to HTML entities. - [ - [ dup html-entities hash [ % ] [ , ] ?if ] each - ] "" make ; +USING: generic hashtables help http io kernel lists math +namespaces sequences strings styles words xml ; : hex-color, ( triplet -- ) 3 swap head [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ; -: fg-css, ( color -- ) - "color: #" % hex-color, "; " % ; +: fg-css, ( color -- ) "color: #" % hex-color, "; " % ; + +: bg-css, ( color -- ) "background-color: #" % hex-color, "; " % ; : style-css, ( flag -- ) - dup [ italic bold-italic ] member? + dup + { italic bold-italic } member? [ "font-style: italic; " % ] when - [ bold bold-italic ] member? + { bold bold-italic } member? [ "font-weight: bold; " % ] when ; : size-css, ( size -- ) - "font-size: " % # "; " % ; + "font-size: " % # "pt; " % ; : font-css, ( font -- ) "font-family: " % % "; " % ; @@ -47,10 +34,11 @@ sequences strings styles words ; swap rot hash dup [ call ] [ 2drop ] if ] hash-each-with ; -: css-style ( style -- ) +: span-css-style ( style -- str ) [ H{ { foreground [ fg-css, ] } + { background [ bg-css, ] } { font [ font-css, ] } { font-style [ style-css, ] } { font-size [ size-css, ] } @@ -58,12 +46,30 @@ sequences strings styles words ; ] "" make ; : span-tag ( style quot -- ) - over css-style dup "" = [ + over span-css-style dup empty? [ drop call ] [ call ] if ; +: div-css-style ( style -- str ) + drop "" ; + ! [ + ! H{ + ! { foreground [ fg-css, ] } + ! { font [ font-css, ] } + ! { font-style [ style-css, ] } + ! { font-size [ size-css, ] } + ! } hash-apply + ! ] "" make ; + +: div-tag ( style quot -- ) + over div-css-style dup empty? [ + drop call + ] [ +
      call
      + ] if ; + : resolve-file-link ( path -- link ) #! The file responder needs relative links not absolute #! links. @@ -81,22 +87,30 @@ sequences strings styles words ; call ] if* ; -: browser-link-href ( word -- href ) - dup word-name swap word-vocabulary - [ +GENERIC: browser-link-href ( presented -- href ) + +M: word browser-link-href + dup word-name swap word-vocabulary [ "/responder/browser/?vocab=" % url-encode % "&word=" % url-encode % ] "" make ; -: browser-link-tag ( style quot -- style ) - over presented swap hash dup word? [ - call +M: link browser-link-href + link-name [ \ f ] unless* dup word? [ + browser-link-href ] [ - drop call + [ "/responder/help/" % url-encode % ] "" make ] if ; +M: object browser-link-href + drop f ; + +: browser-link-tag ( style quot -- style ) + presented pick hash browser-link-href + [ call ] [ call ] if* ; + TUPLE: wrapper-stream scope ; C: wrapper-stream ( stream -- stream ) @@ -107,12 +121,19 @@ C: wrapper-stream ( stream -- stream ) : with-wrapper ( stream quot -- ) >r wrapper-stream-scope r> bind ; inline +TUPLE: nested-stream ; + +C: nested-stream [ set-delegate ] keep ; + +M: nested-stream stream-close drop ; + TUPLE: html-stream ; M: html-stream stream-write1 ( char stream -- ) - [ - dup html-entities hash [ write ] [ write1 ] ?if - ] with-wrapper ; + >r ch>string r> stream-write ; + +M: html-stream stream-write ( char stream -- ) + [ chars>entities write ] with-wrapper ; M: html-stream stream-format ( str style stream -- ) [ @@ -123,6 +144,23 @@ M: html-stream stream-format ( str style stream -- ) ] browser-link-tag ] with-wrapper ; +: pre-tag ( stream style quot -- ) + wrap-margin rot hash [ + call + ] [ + over [ [ 
       ] with-wrapper call ] keep
+        [
      ] with-wrapper + ] if ; + +M: html-stream with-nested-stream ( quot style stream -- ) + swap [ + [ swap with-stream ] pre-tag + ] div-tag ; + +M: html-stream stream-terpri [
      ] with-wrapper ; + +M: html-stream stream-terpri* [
      ] with-wrapper ; + C: html-stream ( stream -- stream ) #! Wraps the given stream in an HTML stream. An HTML stream #! converts special characters to entities when being diff --git a/contrib/httpd/load.factor b/contrib/httpd/load.factor index e46a6dc4a6..623438cea3 100644 --- a/contrib/httpd/load.factor +++ b/contrib/httpd/load.factor @@ -2,6 +2,7 @@ IN: scratchpad USING: words kernel parser sequences io compiler ; { + "xml" "http-common" "mime" "html-tags" @@ -9,6 +10,7 @@ USING: words kernel parser sequences io compiler ; "responder" "httpd" "file-responder" + "help-responder" "cont-responder" "browser-responder" "default-responders" diff --git a/contrib/httpd/test/html.factor b/contrib/httpd/test/html.factor index 2fa0f3d109..ea85c5ef80 100644 --- a/contrib/httpd/test/html.factor +++ b/contrib/httpd/test/html.factor @@ -1,5 +1,5 @@ IN: temporary -USING: html io kernel namespaces styles test ; +USING: html io kernel namespaces styles test xml ; [ "<html>&'sgml'" @@ -32,7 +32,7 @@ USING: html io kernel namespaces styles test ; [ [ "car" - H{ { font "Monospaced" } } + H{ { font "monospace" } } html-format ] string-out ] unit-test diff --git a/contrib/httpd/xml.factor b/contrib/httpd/xml.factor index c3e528029e..0c11914b01 100644 --- a/contrib/httpd/xml.factor +++ b/contrib/httpd/xml.factor @@ -1,5 +1,6 @@ -USING: kernel math infix parser namespaces sequences strings prettyprint - errors lists hashtables vectors html io generic words ; +USING: kernel math parser namespaces sequences strings +prettyprint errors lists hashtables vectors io generic +words ; IN: xml ! * Simple SAX-ish parser @@ -124,12 +125,18 @@ M: xml-string-error error. ] if ; : entities + #! We have both directions here as a shortcut. H{ - [[ "lt" CHAR: < ]] - [[ "gt" CHAR: > ]] - [[ "amp" CHAR: & ]] - [[ "apos" CHAR: ' ]] - [[ "quot" CHAR: " ]] + { "lt" CHAR: < } + { "gt" CHAR: > } + { "amp" CHAR: & } + { "apos" CHAR: ' } + { "quot" CHAR: " } + { CHAR: < "<" } + { CHAR: > ">" } + { CHAR: & "&" } + { CHAR: ' "'" } + { CHAR: " """ } } ; : parse-entity ( -- ch ) @@ -334,21 +341,13 @@ M: closer process GENERIC: (xml>string) ( object -- ) -: reverse-entities ! not as many as entities needed for printing - H{ - { CHAR: & "amp" } - { CHAR: < "lt" } - { CHAR: " "quot" } - } ; - -M: string (xml>string) +: chars>entities ( str -- str ) + #! Convert <, >, &, ' and " to HTML entities. [ - dup reverse-entities hash [ - CHAR: & , % CHAR: ; , - ] [ - , - ] ?if - ] each ; + [ dup entities hash [ % ] [ , ] ?if ] each + ] "" make ; + +M: string (xml>string) chars>entities % ; : print-open/close ( tag -- ) CHAR: > , diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 90a0e95818..cb4331a400 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -171,6 +171,7 @@ vectors words ; "/library/freetype/freetype.factor" "/library/freetype/freetype-gl.factor" + "/library/ui/timers.factor" "/library/ui/gadgets.factor" "/library/ui/layouts.factor" "/library/ui/hierarchy.factor" @@ -332,9 +333,6 @@ vocabularies get [ "!syntax" vocabularies get remove-hash -H{ } clone crossref set -recrossref - "Building generic words..." print flush all-words [ generic? ] subset [ make-generic ] each diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index b9ff813427..d4bdc1a5e3 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -43,6 +43,10 @@ sequences sequences-internals words ; 0 exit ] set-boot +"Building cross-referencing database..." print +H{ } clone crossref set +recrossref + [ compiled? ] word-subset length number>string write " compiled words" print diff --git a/library/freetype/freetype-gl.factor b/library/freetype/freetype-gl.factor index dc701b99c6..45e3011610 100644 --- a/library/freetype/freetype-gl.factor +++ b/library/freetype/freetype-gl.factor @@ -54,18 +54,18 @@ M: font = eq? ; : ttf-name ( font style -- name ) cons H{ - { [[ "Monospaced" plain ]] "VeraMono" } - { [[ "Monospaced" bold ]] "VeraMoBd" } - { [[ "Monospaced" bold-italic ]] "VeraMoBI" } - { [[ "Monospaced" italic ]] "VeraMoIt" } - { [[ "Sans Serif" plain ]] "Vera" } - { [[ "Sans Serif" bold ]] "VeraBd" } - { [[ "Sans Serif" bold-italic ]] "VeraBI" } - { [[ "Sans Serif" italic ]] "VeraIt" } - { [[ "Serif" plain ]] "VeraSe" } - { [[ "Serif" bold ]] "VeraSeBd" } - { [[ "Serif" bold-italic ]] "VeraBI" } - { [[ "Serif" italic ]] "VeraIt" } + { [[ "monospace" plain ]] "VeraMono" } + { [[ "monospace" bold ]] "VeraMoBd" } + { [[ "monospace" bold-italic ]] "VeraMoBI" } + { [[ "monospace" italic ]] "VeraMoIt" } + { [[ "sans-serif" plain ]] "Vera" } + { [[ "sans-serif" bold ]] "VeraBd" } + { [[ "sans-serif" bold-italic ]] "VeraBI" } + { [[ "sans-serif" italic ]] "VeraIt" } + { [[ "serif" plain ]] "VeraSe" } + { [[ "serif" bold ]] "VeraSeBd" } + { [[ "serif" bold-italic ]] "VeraBI" } + { [[ "serif" italic ]] "VeraIt" } } hash ; : ttf-path ( name -- string ) diff --git a/library/help/markup.factor b/library/help/markup.factor index 83f0cad2ea..5106fbf6bd 100644 --- a/library/help/markup.factor +++ b/library/help/markup.factor @@ -87,8 +87,7 @@ M: simple-element print-element [ print-element ] each ; : $synopsis ( content -- ) first dup word-vocabulary [ "Vocabulary" $subheading $snippet ] when* - dup parsing? [ $syntax ] [ $stack-effect ] if - terpri* ; + dup parsing? [ $syntax ] [ $stack-effect ] if ; : $description ( content -- ) "Description" $subheading print-element ; @@ -110,9 +109,7 @@ M: simple-element print-element [ print-element ] each ; [ "," format* bl ] interleave ; inline : $see ( content -- ) - terpri* - code-style [ [ first see ] with-nesting* ] with-style - terpri* ; + code-style [ [ first see ] with-nesting* ] with-style ; : $example ( content -- ) first2 swap dup diff --git a/library/help/stylesheet.factor b/library/help/stylesheet.factor index e57f1d5544..f438b61b54 100644 --- a/library/help/stylesheet.factor +++ b/library/help/stylesheet.factor @@ -3,7 +3,7 @@ USING: styles ; : default-style H{ - { font "Sans Serif" } + { font "sans-serif" } { font-size 12 } { wrap-margin 500 } } ; @@ -14,22 +14,22 @@ USING: styles ; : emphasis-style H{ { font-style italic } } ; -: heading-style H{ { font "Serif" } { font-size 16 } } ; +: heading-style H{ { font "serif" } { font-size 16 } } ; -: subheading-style H{ { font "Serif" } { font-style bold } } ; +: subheading-style H{ { font "serif" } { font-style bold } } ; : subsection-style - H{ { font "Serif" } { font-size 14 } { font-style bold } } ; + H{ { font "serif" } { font-size 14 } { font-style bold } } ; : snippet-style H{ - { font "Monospaced" } + { font "monospace" } { foreground { 0.3 0.3 0.3 1 } } } ; : code-style H{ - { font "Monospaced" } + { font "monospace" } { page-color { 0.9 0.9 1 0.5 } } { border-width 5 } { wrap-margin f } @@ -40,7 +40,7 @@ USING: styles ; : url-style H{ - { font "Monospaced" } + { font "monospace" } { foreground { 0.0 0.0 1.0 1.0 } } } ; diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index e4d3edc461..93420453d1 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -54,7 +54,7 @@ C: section ( length -- section ) last-newline set line-limit? [ "..." write end-printing get continue ] when line-count inc - "\n" write do-indent + terpri do-indent ] if ; TUPLE: text string style ; diff --git a/library/threads.factor b/library/threads.factor index e3dd092842..2bb70a83ee 100644 --- a/library/threads.factor +++ b/library/threads.factor @@ -42,48 +42,8 @@ DEFER: next-thread try stop ] callcc0 drop ; -TUPLE: timer object delay last ; - -: timer-now millis swap set-timer-last ; - -C: timer ( object delay -- timer ) - [ set-timer-delay ] keep - [ set-timer-object ] keep - dup timer-now ; - -GENERIC: tick ( ms object -- ) - -: timers ( -- hash ) \ timers global hash ; - -: add-timer ( object delay -- ) - over >r r> timers set-hash ; - -: remove-timer ( object -- ) timers remove-hash ; - -: restart-timer ( object -- ) - timers hash [ timer-now ] when* ; - -: next-time ( timer -- ms ) dup timer-delay swap timer-last + ; - -: advance-timer ( ms timer -- delay ) - #! Outputs the time since the last firing. - [ timer-last - 0 max ] 2keep set-timer-last ; - -: do-timer ( ms timer -- ) - #! Takes current time, and a timer. If the timer is set to - #! fire, calls its callback. - dup next-time pick <= [ - [ advance-timer ] keep timer-object tick - ] [ - 2drop - ] if ; - -: do-timers ( -- ) - millis timers hash-values [ do-timer ] each-with ; - : init-threads ( -- ) global [ \ run-queue set V{ } clone \ sleep-queue set - H{ } clone \ timers set ] bind ; diff --git a/library/ui/presentations.factor b/library/ui/presentations.factor index 3bef897684..d7025b371a 100644 --- a/library/ui/presentations.factor +++ b/library/ui/presentations.factor @@ -29,7 +29,7 @@ M: gadget-stream stream-write1 ( char stream -- ) background [ over set-gadget-interior ] apply-style ; : specified-font ( style -- font ) - [ font swap hash [ "Monospaced" ] unless* ] keep + [ font swap hash [ "monospace" ] unless* ] keep [ font-style swap hash [ plain ] unless* ] keep font-size swap hash [ 12 ] unless* 3array ; diff --git a/library/ui/theme.factor b/library/ui/theme.factor index ed44d7117e..7a539f11d5 100644 --- a/library/ui/theme.factor +++ b/library/ui/theme.factor @@ -76,13 +76,13 @@ USING: arrays gadgets kernel sequences styles ; : label-theme ( label -- ) { 0.0 0.0 0.0 1.0 } over set-label-color - { "Monospaced" plain 12 } swap set-label-font ; + { "monospace" plain 12 } swap set-label-font ; : editor-theme ( label -- ) { 0.0 0.0 0.0 1.0 } over set-label-color - { "Monospaced" bold 12 } swap set-label-font ; + { "monospace" bold 12 } swap set-label-font ; : status-theme ( label -- ) dup reverse-video-theme { 1.0 1.0 1.0 1.0 } over set-label-color - { "Monospaced" plain 12 } swap set-label-font ; + { "monospace" plain 12 } swap set-label-font ; diff --git a/library/ui/timers.factor b/library/ui/timers.factor new file mode 100644 index 0000000000..cba33e0961 --- /dev/null +++ b/library/ui/timers.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2005, 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: gadgets +USING: hashtables kernel math sequences ; + +TUPLE: timer object delay last ; + +: timer-now millis swap set-timer-last ; + +C: timer ( object delay -- timer ) + [ set-timer-delay ] keep + [ set-timer-object ] keep + dup timer-now ; + +GENERIC: tick ( ms object -- ) + +DEFER: timers + +: add-timer ( object delay -- ) + over >r r> timers set-hash ; + +: remove-timer ( object -- ) timers remove-hash ; + +: restart-timer ( object -- ) + timers hash [ timer-now ] when* ; + +: next-time ( timer -- ms ) dup timer-delay swap timer-last + ; + +: advance-timer ( ms timer -- delay ) + [ timer-last - 0 max ] 2keep set-timer-last ; + +: do-timer ( ms timer -- ) + dup next-time pick <= [ + [ advance-timer ] keep timer-object tick + ] [ + 2drop + ] if ; + +: do-timers ( -- ) + millis timers hash-values [ do-timer ] each-with ; diff --git a/library/ui/ui.factor b/library/ui/ui.factor index fb80d5c90d..757ddeed3a 100644 --- a/library/ui/ui.factor +++ b/library/ui/ui.factor @@ -21,16 +21,10 @@ global [ first-time on ] bind ] when ] bind ; -: check-running - world get [ - world-running? - [ "The UI is already running" throw ] when - ] when* ; - IN: shells : ui ( -- ) - check-running [ + [ init-world world get rect-dim first2 [ listener-application run-world ] with-gl-screen ] with-freetype ; diff --git a/library/ui/world.factor b/library/ui/world.factor index e1d2a6254f..2ae83eac18 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -9,13 +9,17 @@ sequences sequences strings styles threads ; ! gadgets are contained in. The current world is stored in the ! world variable. The invalid slot is a list of gadgets that ! need to be layout. -TUPLE: world running? glass status invalid ; +TUPLE: world running? glass status invalid timers ; + +: timers ( -- hash ) world get world-timers ; : add-layer ( gadget -- ) world get add-gadget ; C: world ( -- world ) - over set-delegate t over set-gadget-root? ; + over set-delegate + t over set-gadget-root? + H{ } clone over set-world-timers ; : add-invalid ( gadget -- ) world get [ world-invalid cons ] keep set-world-invalid ; From 4e15d921b3ab87f0a19561fe053e2fe619c9efb4 Mon Sep 17 00:00:00 2001 From: Trent Buck Date: Fri, 20 Jan 2006 07:17:37 +0000 Subject: [PATCH 301/373] Install example responders after all. --- contrib/cont-responder/cont-examples.factor | 10 +++++----- contrib/cont-responder/cont-numbers-game.factor | 2 +- contrib/cont-responder/eval-responder.factor | 3 +-- contrib/cont-responder/live-updater-responder.factor | 2 +- contrib/cont-responder/todo-example.factor | 2 +- 5 files changed, 9 insertions(+), 10 deletions(-) diff --git a/contrib/cont-responder/cont-examples.factor b/contrib/cont-responder/cont-examples.factor index d841334538..3de5f6ee1e 100644 --- a/contrib/cont-responder/cont-examples.factor +++ b/contrib/cont-responder/cont-examples.factor @@ -117,8 +117,8 @@ USE: sequences drop ; ! Install the examples -! ! "counter1" [ drop 0 counter-example ] install-cont-responder -! ! "counter2" [ drop counter-example2 ] install-cont-responder -! ! "test1" [ drop test-cont-responder ] install-cont-responder -! ! "test2" [ drop test-cont-responder2 ] install-cont-responder -! ! "test3" [ drop test-cont-responder3 ] install-cont-responder +"counter1" [ drop 0 counter-example ] install-cont-responder +"counter2" [ drop counter-example2 ] install-cont-responder +"test1" [ drop test-cont-responder ] install-cont-responder +"test2" [ drop test-cont-responder2 ] install-cont-responder +"test3" [ drop test-cont-responder3 ] install-cont-responder diff --git a/contrib/cont-responder/cont-numbers-game.factor b/contrib/cont-responder/cont-numbers-game.factor index 635d770fe9..02f271b380 100644 --- a/contrib/cont-responder/cont-numbers-game.factor +++ b/contrib/cont-responder/cont-numbers-game.factor @@ -97,4 +97,4 @@ USE: namespaces : numbers-game number-to-guess numbers-game-loop ; -! "numbers-game" [ numbers-game ] install-cont-responder +"numbers-game" [ numbers-game ] install-cont-responder diff --git a/contrib/cont-responder/eval-responder.factor b/contrib/cont-responder/eval-responder.factor index 11357b73ab..5f58089245 100644 --- a/contrib/cont-responder/eval-responder.factor +++ b/contrib/cont-responder/eval-responder.factor @@ -231,5 +231,4 @@ USE: hashtables dup [ show-message-page ] [ drop ] if ] forever ; -! "eval" [ [ ] "None" [ ] eval-responder ] install-cont-responder - +"eval" [ [ ] "None" [ ] eval-responder ] install-cont-responder diff --git a/contrib/cont-responder/live-updater-responder.factor b/contrib/cont-responder/live-updater-responder.factor index 34816398bb..b2cf0f78bb 100644 --- a/contrib/cont-responder/live-updater-responder.factor +++ b/contrib/cont-responder/live-updater-responder.factor @@ -76,4 +76,4 @@ USE: prettyprint ] show ; -! "live-updater" [ live-updater-responder ] install-cont-responder +"live-updater" [ live-updater-responder ] install-cont-responder diff --git a/contrib/cont-responder/todo-example.factor b/contrib/cont-responder/todo-example.factor index 4476e668c8..e3c2c37d3a 100644 --- a/contrib/cont-responder/todo-example.factor +++ b/contrib/cont-responder/todo-example.factor @@ -491,4 +491,4 @@ USE: sequences get-todo-list "todo" set show-todo-list ; -! "todo" [ drop "todo/" todo-example ] install-cont-responder +"todo" [ drop "todo/" todo-example ] install-cont-responder From c3ef16c2af22024793d3b80ee7e99dfa7754ccb1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 20 Jan 2006 09:58:12 +0000 Subject: [PATCH 302/373] fix test failure --- contrib/httpd/test/html.factor | 2 +- library/math/pow.facts | 2 +- library/math/trig-hyp.facts | 14 +++++++------- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/contrib/httpd/test/html.factor b/contrib/httpd/test/html.factor index ea85c5ef80..2cb19e1a95 100644 --- a/contrib/httpd/test/html.factor +++ b/contrib/httpd/test/html.factor @@ -28,7 +28,7 @@ USING: html io kernel namespaces styles test xml ; [ "hello world" H{ } html-format ] string-out ] unit-test -[ "car" ] +[ "car" ] [ [ "car" diff --git a/library/math/pow.facts b/library/math/pow.facts index a64e43b0ca..c6655e822c 100644 --- a/library/math/pow.facts +++ b/library/math/pow.facts @@ -14,7 +14,7 @@ HELP: sqrt "( x -- y )" HELP: ^ "( x y -- z )" { $values { "x" "a complex number" } { "y" "a complex number" } { "z" "a complex number" } } -{ $description "Raises " { $snippet "x" } " to the power of " { $snippet "y" } ". If \texttt{y}" { $snippet "y" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." } +{ $description "Raises " { $snippet "x" } " to the power of " { $snippet "y" } ". If " { $snippet "y" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." } { $errors "Throws an error if " { $snippet "x" } " and " { $snippet "y" } " are both integer 0." } ; HELP: each-bit "( n quot -- )" diff --git a/library/math/trig-hyp.facts b/library/math/trig-hyp.facts index d14a36410e..d4abde73bf 100644 --- a/library/math/trig-hyp.facts +++ b/library/math/trig-hyp.facts @@ -28,30 +28,30 @@ HELP: coth "( x -- y )" $values-x/y { $description "Hyperbolic cotangent." } ; -HELP: cosh "( x -- y )" +HELP: cos "( x -- y )" $values-x/y { $description "Trigonometric cosine." } ; -HELP: sech "( x -- y )" +HELP: sec "( x -- y )" $values-x/y { $description "Trigonometric secant." } ; -HELP: sinh "( x -- y )" +HELP: sin "( x -- y )" $values-x/y { $description "Trigonometric sine." } ; -HELP: sinh "( x -- y )" +HELP: sin "( x -- y )" $values-x/y { $description "Trigonometric sine." } ; -HELP: cosech "( x -- y )" +HELP: cosec "( x -- y )" $values-x/y { $description "Trigonometric cosecant." } ; -HELP: tanh "( x -- y )" +HELP: tan "( x -- y )" $values-x/y { $description "Trigonometric tangent." } ; -HELP: coth "( x -- y )" +HELP: cot "( x -- y )" $values-x/y { $description "Trigonometric cotangent." } ; From f9db19f91705ff786a6285d7706b873d29b7c9cf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 21 Jan 2006 02:37:38 +0000 Subject: [PATCH 303/373] fixes --- Makefile | 3 ++- library/compiler/amd64/alien.factor | 24 ++++++++++++++++++---- library/compiler/amd64/architecture.factor | 4 +--- library/compiler/ppc/alien.factor | 2 +- library/test/compiler/alien.factor | 8 ++++++++ native/ffi_test.c | 19 +++++++++++++++++ 6 files changed, 51 insertions(+), 9 deletions(-) create mode 100644 library/test/compiler/alien.factor create mode 100644 native/ffi_test.c diff --git a/Makefile b/Makefile index 0144cdbb52..9f6356b856 100644 --- a/Makefile +++ b/Makefile @@ -50,7 +50,8 @@ OBJS = $(PLAF_OBJS) native/array.o native/bignum.o \ native/hashtable.o \ native/icache.o \ native/io.o \ - native/wrapper.o + native/wrapper.o \ + native/ffi_test.o default: @echo "Run 'make' with one of the following parameters:" diff --git a/library/compiler/amd64/alien.factor b/library/compiler/amd64/alien.factor index d6b496e285..bd0df2d9bf 100644 --- a/library/compiler/amd64/alien.factor +++ b/library/compiler/amd64/alien.factor @@ -1,15 +1,31 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: compiler-backend -USING: alien assembler kernel math ; +USING: alien assembler kernel math sequences ; + +GENERIC: store-insn ( offset reg-class -- ) + +GENERIC: load-insn ( elt parameter reg-class -- ) + +M: int-regs store-insn drop >r 3 1 r> stack@ STW ; + +M: int-regs load-insn drop 3 + 1 rot stack@ LWZ ; M: %unbox generate-node ( vop -- ) - drop ; + drop + ! Call the unboxer + 1 input f compile-c-call + ! Store the return value on the C stack + 0 input 2 input store-insn ; M: %parameter generate-node ( vop -- ) ! Move a value from the C stack into the fastcall register - drop ; + drop 0 input 1 input 2 input load-insn ; -M: %box generate-node ( vop -- ) drop ; +M: %box generate-node ( vop -- ) + drop + ! Move return value of C function into input register + param-regs first RAX MOV + 0 input f compile-c-call ; M: %cleanup generate-node ( vop -- ) drop ; diff --git a/library/compiler/amd64/architecture.factor b/library/compiler/amd64/architecture.factor index 325d2394e2..080ff57f25 100644 --- a/library/compiler/amd64/architecture.factor +++ b/library/compiler/amd64/architecture.factor @@ -17,8 +17,6 @@ kernel-internals math sequences ; : vregs { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ; inline -: alien-regs { RDI RSI RDX RCX R8 R9 } ; inline - : param-regs { RDI RSI RDX RCX R8 R9 } ; inline : compile-c-call ( symbol dll -- ) @@ -29,7 +27,7 @@ kernel-internals math sequences ; param-regs swap [ MOV ] 2each compile-c-call ; M: int-regs return-reg drop RAX ; -M: int-regs fastcall-regs drop alien-regs length ; +M: int-regs fastcall-regs drop param-regs length ; M: float-regs fastcall-regs drop 0 ; diff --git a/library/compiler/ppc/alien.factor b/library/compiler/ppc/alien.factor index b5d48ce92a..35ff721e68 100644 --- a/library/compiler/ppc/alien.factor +++ b/library/compiler/ppc/alien.factor @@ -3,7 +3,7 @@ IN: compiler-backend USING: alien assembler kernel math ; -GENERIC: store-insn ( to offset reg-class -- ) +GENERIC: store-insn ( offset reg-class -- ) GENERIC: load-insn ( elt parameter reg-class -- ) diff --git a/library/test/compiler/alien.factor b/library/test/compiler/alien.factor new file mode 100644 index 0000000000..c25bb06012 --- /dev/null +++ b/library/test/compiler/alien.factor @@ -0,0 +1,8 @@ +USING: compiler test ; + +FUNCTION: void ffi_test_0 ; compiled +[ ] [ ffi_test_0 ] unit-test + +FUNCTION: int ffi_test_1 ; compiled +[ 3 ] [ ffi_test_1 ] unit-test + diff --git a/native/ffi_test.c b/native/ffi_test.c new file mode 100644 index 0000000000..d24625d2ef --- /dev/null +++ b/native/ffi_test.c @@ -0,0 +1,19 @@ +/* This file is linked into the runtime for the sole purpose + * of testing FFI code. */ + +void ffi_test_0(void) +{ + printf("ffi_test_0()\n"); +} + +int ffi_test_1(void) +{ + printf("ffi_test_1()\n"); + return 3; +} + +int ffi_test_2(int x, int y) +{ + printf("ffi_test_2(%d,%d)\n",x,y); + return x + y; +} From f411126dad9e2adc7cad2e3ea999d9fdc071908e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 21 Jan 2006 04:50:20 +0000 Subject: [PATCH 304/373] New bug --- TODO.FACTOR.txt | 58 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 58 insertions(+) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 34c769db9a..e43b4025f5 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -29,6 +29,7 @@ - if two tasks write to a unix stream, the buffer can overflow - font problem: http://iarc1.ece.utexas.edu/~erg/font-bug.JPG - implement 3.3 floor 4.7 ceiling 4.5 truncate +- make 3.4 bits>double an error ALL TESTS BELOW FAIL ON x86 linux 32bit - float not commutative bug @@ -79,3 +80,60 @@ Compile fails: 0.2875868408644093 + sin >bignum cos >float sin ; +x86 fixnum problem? +100 [ test-integer>x ] times + +IN: compiler-test : math-dummy -63545870 ceiling ; +Compiling math-dummy +-63545870 3562994 + +IN: compiler-test : math-dummy -172512992 double>bits ; +Compiling math-dummy +4800873998879566904 4780613886529085440 + +IN: compiler-test : math-dummy 268435455 float>bits ; +Compiling math-dummy +1102377402 4 + +IN: compiler-test : math-dummy 268435455 neg ; +Compiling math-dummy +-268435455 1 + +IN: compiler-test : math-dummy 48191798 neg ; +Compiling math-dummy +-48191798 18917066 + +IN: compiler-test : math-dummy -176408007 next-power-of-2 ; +Compiling math-dummy +1 33554432 + +IN: compiler-test : math-dummy -63194602 bits>float ; +Compiling math-dummy +80.08636474609375 110.8125 + +IN: compiler-test : math-dummy + 116813922808736214071768419862654566798144280646827276619588644136147298073359475589294679233724596355072 + bits>double ; +Compiling math-dummy +5.083189076777759e-270 5.097526873523571e-270 + +IN: compiler-test : math-dummy -43922848 1- ; +Compiling math-dummy +-43922849 23186015 + +IN: compiler-test : math-dummy -186662979 quadrant ; +Compiling math-dummy +1 0 + +IN: compiler-test : math-dummy -51219578 floor ; +Compiling math-dummy +-51219578 15889286 + +IN: compiler-test : math-dummy -56213080 numerator ; +Compiling math-dummy +-56213080 10895784 + +IN: compiler-test : math-dummy -268435456 truncate ; +Compiling math-dummy +-268435456 0 + From 59eb004b37f18a6266b6b806fb92c4fea1f8a29e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 21 Jan 2006 05:20:21 +0000 Subject: [PATCH 305/373] compile-1ified --- TODO.FACTOR.txt | 110 ++++++++++++++++++++++++++++-------------------- 1 file changed, 65 insertions(+), 45 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index e43b4025f5..86b8d8f681 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -80,60 +80,80 @@ Compile fails: 0.2875868408644093 + sin >bignum cos >float sin ; -x86 fixnum problem? -100 [ test-integer>x ] times +x86 problems below -IN: compiler-test : math-dummy -63545870 ceiling ; -Compiling math-dummy --63545870 3562994 +[ 0 bits>float ] +Compiling G:455019 +4.203895392974451e-45 110.8125 -IN: compiler-test : math-dummy -172512992 double>bits ; -Compiling math-dummy -4800873998879566904 4780613886529085440 +[ -1 float>bits ] +Compiling G:455338 +1099286058 4 -IN: compiler-test : math-dummy 268435455 float>bits ; -Compiling math-dummy -1102377402 4 +[ -15766735 double>bits ] +Compiling G:455023 +4702233936300867587 4777205847159578624 -IN: compiler-test : math-dummy 268435455 neg ; -Compiling math-dummy --268435455 1 +[ -23841331 bits>double ] +Compiling G:455027 +5.127236739868035e-270 5.097526873523571e-270 -IN: compiler-test : math-dummy 48191798 neg ; -Compiling math-dummy --48191798 18917066 +[ -251924354 1+ ] +Compiling G:455128 +-251924353 16511103 -IN: compiler-test : math-dummy -176408007 next-power-of-2 ; -Compiling math-dummy -1 33554432 +[ -258114108 1- ] +Compiling G:455920 +-258114109 10321347 -IN: compiler-test : math-dummy -63194602 bits>float ; -Compiling math-dummy -80.08636474609375 110.8125 +[ 259957324 bitnot ] +Compiling G:455227 +-259957325 8478131 -IN: compiler-test : math-dummy - 116813922808736214071768419862654566798144280646827276619588644136147298073359475589294679233724596355072 - bits>double ; -Compiling math-dummy -5.083189076777759e-270 5.097526873523571e-270 - -IN: compiler-test : math-dummy -43922848 1- ; -Compiling math-dummy --43922849 23186015 - -IN: compiler-test : math-dummy -186662979 quadrant ; -Compiling math-dummy +[ -268435456 quadrant ] +Compiling G:455335 1 0 -IN: compiler-test : math-dummy -51219578 floor ; -Compiling math-dummy --51219578 15889286 - -IN: compiler-test : math-dummy -56213080 numerator ; -Compiling math-dummy --56213080 10895784 - -IN: compiler-test : math-dummy -268435456 truncate ; -Compiling math-dummy +[ 620858855246776348355165240843829248 >fixnum ] +Compiling G:457023 -268435456 0 +[ 268435455 neg ] +Compiling G:457031 +-268435455 1 + +[ -60976708 next-power-of-2 ] +Compiling G:457308 +1 8388608 + +[ -132458581 real ] +Compiling G:459251 +-132458581 1759147 + +[ -200388566 floor ] +Compiling G:461226 +-200388566 938026 + + +2 ARGUEMENT INTEGER WORDS +[ 252475730 -1 * ] +Compiling G:452424 +-252475730 15959726 + +[ -268435456 209630756 min ] +Compiling G:452492 +-268435456 0 + +[ -258355397 -181752298 max ] +Compiling G:452699 +-181752298 19574294 + +[ -14282409 -22156592 + ] +Compiling G:452838 +-36439001 30669863 + +[ -48101335 0 - ] +Compiling G:454874 +-48101335 19007529 + + From ef09334ead8ec6e0ca848e97bad3b05fa7043c72 Mon Sep 17 00:00:00 2001 From: Trent Buck Date: Sat, 21 Jan 2006 05:30:49 +0000 Subject: [PATCH 306/373] Missing each. --- contrib/aim/load.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/contrib/aim/load.factor b/contrib/aim/load.factor index fcfc45ea39..635c31562a 100644 --- a/contrib/aim/load.factor +++ b/contrib/aim/load.factor @@ -6,4 +6,4 @@ USING: kernel parser sequences words compiler ; { "net-bytes" "aim" -} [ "contrib/aim/" swap ".factor" append3 run-file ] +} [ "contrib/aim/" swap ".factor" append3 run-file ] each From 389ebda01dd56123ed31ee5b91189c57168347a3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 21 Jan 2006 05:32:29 +0000 Subject: [PATCH 307/373] more test cases --- TODO.FACTOR.txt | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 86b8d8f681..9d39f7d837 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -156,4 +156,20 @@ Compiling G:452838 Compiling G:454874 -48101335 19007529 +[ -48174218 0 bitxor ] +Compiling G:561725 +-48174218 18934646 + +[ -57534898 -1 bitand ] +Compiling G:562430 +-57534898 9573966 + +[ 75915195 -268435456 bitor ] +Compiling G:563342 +-192520261 8806331 + +[ -264174045 66395852 align ] +Compiling G:564824 +-201187292 139300 + From 8914e9b64012b6da665b310faaebb3933fedb84e Mon Sep 17 00:00:00 2001 From: Trent Buck Date: Sat, 21 Jan 2006 06:04:03 +0000 Subject: [PATCH 308/373] Use run-resource for code distributed with Factor; run-file is for user code. --- contrib/aim/load.factor | 4 ++-- contrib/cairo/cairo_simple.factor | 3 +-- contrib/cairo/cairo_text.factor | 3 +-- contrib/cairo/load.factor | 2 +- contrib/concurrency/concurrency.html | 6 ++---- contrib/concurrency/load.factor | 6 +++--- contrib/cont-responder/load.factor | 6 +++--- contrib/crypto/load.factor | 4 ++-- contrib/httpd/load.factor | 2 +- contrib/load.factor | 4 ++-- contrib/math/load.factor | 2 +- contrib/parser-combinators/load.factor | 2 +- contrib/postgresql/load.factor | 2 +- contrib/space-invaders/load.factor | 4 ++-- contrib/sqlite/load.factor | 2 +- contrib/sqlite/tuple-db.html | 9 +++------ contrib/units/load.factor | 2 +- contrib/win32/load.factor | 2 +- contrib/x11/examples/lindenmayer/load.factor | 2 +- contrib/x11/load.factor | 2 +- contrib/x11/load2.factor | 2 +- doc/cont-responder-tutorial.txt | 4 ++-- examples/factoroids/load.factor | 18 ++++++++++-------- 23 files changed, 44 insertions(+), 49 deletions(-) diff --git a/contrib/aim/load.factor b/contrib/aim/load.factor index 635c31562a..a6ab7a2a8f 100644 --- a/contrib/aim/load.factor +++ b/contrib/aim/load.factor @@ -1,9 +1,9 @@ IN: scratchpad USING: kernel parser sequences words compiler ; -"contrib/crypto/load.factor" run-file +"/contrib/crypto/load.factor" run-resource { "net-bytes" "aim" -} [ "contrib/aim/" swap ".factor" append3 run-file ] each +} [ "/contrib/aim/" swap ".factor" append3 run-resource ] each diff --git a/contrib/cairo/cairo_simple.factor b/contrib/cairo/cairo_simple.factor index 6c87a3deaf..f88b364958 100644 --- a/contrib/cairo/cairo_simple.factor +++ b/contrib/cairo/cairo_simple.factor @@ -12,8 +12,7 @@ ! Then, start Factor as usual (./f factor.image) and enter these ! at the listener: ! -! "cairo.factor" run-file -! "cairo_sdl.factor" run-file +! "/contrib/cairo/load.factor" run-resource ! "cairo_simple.factor" run-file IN: cairo-simple diff --git a/contrib/cairo/cairo_text.factor b/contrib/cairo/cairo_text.factor index 18c94a194d..64479e4236 100644 --- a/contrib/cairo/cairo_text.factor +++ b/contrib/cairo/cairo_text.factor @@ -12,8 +12,7 @@ ! Then, start Factor as usual (./f factor.image) and enter these ! at the listener: ! -! "cairo.factor" run-file -! "cairo_sdl.factor" run-file +! "/contrib/cairo/load.factor" run-resource ! "cairo_text.factor" run-file IN: cairo-text diff --git a/contrib/cairo/load.factor b/contrib/cairo/load.factor index 48613bbbfc..b6eb218b2a 100644 --- a/contrib/cairo/load.factor +++ b/contrib/cairo/load.factor @@ -10,4 +10,4 @@ USING: alien kernel parser compiler words sequences ; { "cairo" "cairo_sdl" -} [ "contrib/cairo/" swap ".factor" append3 run-file ] each +} [ "/contrib/cairo/" swap ".factor" append3 run-resource ] each diff --git a/contrib/concurrency/concurrency.html b/contrib/concurrency/concurrency.html index f2d92806a2..eb6d67770a 100644 --- a/contrib/concurrency/concurrency.html +++ b/contrib/concurrency/concurrency.html @@ -19,11 +19,9 @@ processes can share data via Factor's mutable data structures it is not recommended as the use of shared state concurrency is often a cause of problems.

      Loading

      -

      The quickest way to get up and running with this library is to -change to the 'concurrency' directory and run Factor. Then execute the -following commands:

      +

      The quickest way to get up and running with this library is to type the following into the listener:

      -"load.factor" run-file
+"/contrib/concurrency/load.factor" run-resource
 USE: concurrency
 USE: concurrency-examples
      diff --git a/contrib/concurrency/load.factor b/contrib/concurrency/load.factor index cfbe26f4d2..460f9ddce5 100644 --- a/contrib/concurrency/load.factor +++ b/contrib/concurrency/load.factor @@ -1,10 +1,10 @@ IN: scratchpad USING: kernel parser compiler words sequences ; -"contrib/dlists.factor" run-file -"contrib/math/load.factor" run-file +"/contrib/dlists.factor" run-resource +"/contrib/math/load.factor" run-resource { "concurrency" "concurrency-examples" -} [ "contrib/concurrency/" swap ".factor" append3 run-file ] each +} [ "/contrib/concurrency/" swap ".factor" append3 run-resource ] each diff --git a/contrib/cont-responder/load.factor b/contrib/cont-responder/load.factor index ed24bd653f..4874692675 100644 --- a/contrib/cont-responder/load.factor +++ b/contrib/cont-responder/load.factor @@ -1,8 +1,8 @@ IN: scratchpad USING: words kernel parser sequences io compiler ; -"contrib/httpd/load.factor" run-file -"contrib/parser-combinators/load.factor" run-file +"/contrib/httpd/load.factor" run-resource +"/contrib/parser-combinators/load.factor" run-resource { "cont-examples" @@ -13,4 +13,4 @@ USING: words kernel parser sequences io compiler ; "eval-responder" "live-updater-responder" "cont-testing" -} [ "contrib/cont-responder/" swap ".factor" append3 run-file ] each +} [ "/contrib/cont-responder/" swap ".factor" append3 run-resource ] each diff --git a/contrib/crypto/load.factor b/contrib/crypto/load.factor index 8efa13cf2e..4388253a78 100644 --- a/contrib/crypto/load.factor +++ b/contrib/crypto/load.factor @@ -1,10 +1,10 @@ IN: scratchpad USING: kernel parser sequences words compiler ; -"contrib/math/load.factor" run-file +"/contrib/math/load.factor" run-resource { "common" "md5" "sha1" -} [ "contrib/crypto/" swap ".factor" append3 run-file ] each +} [ "/contrib/crypto/" swap ".factor" append3 run-resource ] each diff --git a/contrib/httpd/load.factor b/contrib/httpd/load.factor index 623438cea3..dd94925ac6 100644 --- a/contrib/httpd/load.factor +++ b/contrib/httpd/load.factor @@ -20,4 +20,4 @@ USING: words kernel parser sequences io compiler ; "test/http-client" "test/httpd" "test/url-encoding" -} [ "contrib/httpd/" swap ".factor" append3 run-file ] each +} [ "/contrib/httpd/" swap ".factor" append3 run-resource ] each diff --git a/contrib/load.factor b/contrib/load.factor index a7a4020be1..14f4b1b4e4 100644 --- a/contrib/load.factor +++ b/contrib/load.factor @@ -6,7 +6,7 @@ USING: alien compiler kernel memory parser sequences words ; "coroutines" "dlists" "splay-trees" -} [ "contrib/" swap ".factor" append3 run-file clear ] each +} [ "/contrib/" swap ".factor" append3 run-resource clear ] each { "cairo" "math" @@ -23,4 +23,4 @@ USING: alien compiler kernel memory parser sequences words ; "parser-combinators" "cont-responder" "space-invaders" -} [ "contrib/" swap "/load.factor" append3 run-file clear ] each +} [ "/contrib/" swap "/load.factor" append3 run-resource clear ] each diff --git a/contrib/math/load.factor b/contrib/math/load.factor index ccf5b80e41..f068373e47 100644 --- a/contrib/math/load.factor +++ b/contrib/math/load.factor @@ -10,4 +10,4 @@ USING: kernel parser sequences words compiler ; "matrices" "statistics" "numerical-integration" -} [ "contrib/math/" swap ".factor" append3 run-file ] each +} [ "/contrib/math/" swap ".factor" append3 run-resource ] each diff --git a/contrib/parser-combinators/load.factor b/contrib/parser-combinators/load.factor index 470c6de500..d772fa630d 100644 --- a/contrib/parser-combinators/load.factor +++ b/contrib/parser-combinators/load.factor @@ -6,4 +6,4 @@ USING: kernel parser sequences words compiler ; "parser-combinators" "lazy-examples" "tests" -} [ "contrib/parser-combinators/" swap ".factor" append3 run-file ] each +} [ "/contrib/parser-combinators/" swap ".factor" append3 run-resource ] each diff --git a/contrib/postgresql/load.factor b/contrib/postgresql/load.factor index 2e15f1c86e..0dd9674626 100644 --- a/contrib/postgresql/load.factor +++ b/contrib/postgresql/load.factor @@ -8,4 +8,4 @@ USING: alien compiler kernel parser sequences words ; "postgresql" "postgresql-test" ! "private" ! Put your password in this file -} [ "contrib/postgresql/" swap ".factor" append3 run-file ] each +} [ "/contrib/postgresql/" swap ".factor" append3 run-resource ] each diff --git a/contrib/space-invaders/load.factor b/contrib/space-invaders/load.factor index a222d190d8..1a9c3e88bd 100644 --- a/contrib/space-invaders/load.factor +++ b/contrib/space-invaders/load.factor @@ -1,9 +1,9 @@ IN: scratchpad USING: kernel parser compiler words sequences io ; -"contrib/parser-combinators/load.factor" run-file +"/contrib/parser-combinators/load.factor" run-resource { "cpu-8080" "space-invaders" -} [ "contrib/space-invaders/" swap ".factor" append3 run-file ] each +} [ "/contrib/space-invaders/" swap ".factor" append3 run-resource ] each diff --git a/contrib/sqlite/load.factor b/contrib/sqlite/load.factor index 2a80b829fe..43d4d45176 100644 --- a/contrib/sqlite/load.factor +++ b/contrib/sqlite/load.factor @@ -8,4 +8,4 @@ USING: kernel alien parser compiler words sequences ; "tuple-db" "test" "tuple-db-tests" -} [ "contrib/sqlite/" swap ".factor" append3 run-file ] each +} [ "/contrib/sqlite/" swap ".factor" append3 run-resource ] each diff --git a/contrib/sqlite/tuple-db.html b/contrib/sqlite/tuple-db.html index a3f9d22f83..1d7b463296 100644 --- a/contrib/sqlite/tuple-db.html +++ b/contrib/sqlite/tuple-db.html @@ -51,19 +51,16 @@ following command:

       ./f boot.image.le32 -libraries:sqlite:name=libsqlite3.so
      -

      The quickest way to get up and running with this library is to -change to the 'sqlite' directory and run Factor. Then execute the -following commands:

      +

      The quickest way to get up and running with this library is to type the following into the listener:

      -"sqlite.factor" run-file
-"tuple-db.factor" run-file
+"/contrib/sqlite/load.factor" run-resource
 USE: sqlite
 USE: tuple-db

      Some simple tests can be run to check that everything is working ok:

      -"tuple-db-tests.factor" run-file
+"/contrib/sqlite/tuple-db-tests.factor" run-resource

      Basic Usage

      This library can be used for storing simple Factor tuples in a diff --git a/contrib/units/load.factor b/contrib/units/load.factor index c24c6a1984..c1b7f04c1a 100644 --- a/contrib/units/load.factor +++ b/contrib/units/load.factor @@ -5,4 +5,4 @@ USING: kernel parser sequences words compiler ; "dimensioned" "si-units" "constants" -} [ "contrib/units/" swap ".factor" append3 run-file ] each +} [ "/contrib/units/" swap ".factor" append3 run-resource ] each diff --git a/contrib/win32/load.factor b/contrib/win32/load.factor index 3a19182e3a..3a039062a3 100644 --- a/contrib/win32/load.factor +++ b/contrib/win32/load.factor @@ -11,4 +11,4 @@ USING: alien compiler kernel parser sequences words ; "types" "kernel32" "user32" -} [ "contrib/win32/" swap ".factor" append3 run-file ] each +} [ "/contrib/win32/" swap ".factor" append3 run-resource ] each diff --git a/contrib/x11/examples/lindenmayer/load.factor b/contrib/x11/examples/lindenmayer/load.factor index 7432cf6453..66326d6ab7 100644 --- a/contrib/x11/examples/lindenmayer/load.factor +++ b/contrib/x11/examples/lindenmayer/load.factor @@ -1,5 +1,5 @@ USING: kernel parser words compiler sequences ; -"lindenmayer.factor" run-file +"/contrib/x11/examples/lindenmayer/lindenmayer.factor" run-resource "lindenmayer" words [ try-compile ] each clear diff --git a/contrib/x11/load.factor b/contrib/x11/load.factor index 953a8412e4..9c5307ac5c 100644 --- a/contrib/x11/load.factor +++ b/contrib/x11/load.factor @@ -11,6 +11,6 @@ USING: alien compiler kernel parser sequences words ; "concurrent-widgets" "glx" "gl" -} [ "contrib/x11/" swap ".factor" append3 run-file ] each +} [ "/contrib/x11/" swap ".factor" append3 run-resource ] each ! { "xlib" "x11" } [ words [ try-compile ] each ] each diff --git a/contrib/x11/load2.factor b/contrib/x11/load2.factor index 053e0e8fd7..e105e90bd9 100644 --- a/contrib/x11/load2.factor +++ b/contrib/x11/load2.factor @@ -8,7 +8,7 @@ USING: kernel alien parser sequences words compiler ; "keysymdef.factor" "x-events.factor" "glx.factor" -] [ "contrib/x11/" swap append run-file ] each +] [ "/contrib/x11/" swap append run-resource ] each "x11" words [ try-compile ] each "xlib" words [ try-compile ] each diff --git a/doc/cont-responder-tutorial.txt b/doc/cont-responder-tutorial.txt index 8f247a1c9d..29d9bfb237 100644 --- a/doc/cont-responder-tutorial.txt +++ b/doc/cont-responder-tutorial.txt @@ -582,7 +582,7 @@ The 'cont-testing.factor' file (in the contrib/cont-responder directory) contains some simple words that maintains this state for you in such a way that you can test the words from the console: - "cont-testing.factor" run-file + "/contrib/cont-testing/load.factor" run-resource For this example we'll call the 'subroutine-example1' responder from above. First we need to put a 'testing state' object on the stack. All @@ -671,4 +671,4 @@ Now we submit the post data along to the 'action' url: -As you can see the post data was sent correctly. \ No newline at end of file +As you can see the post data was sent correctly. diff --git a/examples/factoroids/load.factor b/examples/factoroids/load.factor index 1c9b13d4f6..57643aa79c 100644 --- a/examples/factoroids/load.factor +++ b/examples/factoroids/load.factor @@ -1,13 +1,15 @@ USING: io parser ; -"examples/factoroids/utils.factor" run-file -"examples/factoroids/models.factor" run-file -"examples/factoroids/bodies.factor" run-file -"examples/factoroids/actors.factor" run-file -"examples/factoroids/projectiles.factor" run-file -"examples/factoroids/ai.factor" run-file -"examples/factoroids/input.factor" run-file -"examples/factoroids/factoroids.factor" run-file +{ + "utils" + "models" + "bodies" + "actors" + "projectiles" + "ai" + "input" + "factoroids" +} [ "/examples/factoroids/" swap ".factor" append3 run-resource ] each "To play Factoroids, enter the following in the listener:" print terpri From 818d086988e7f420a8a16829a79cc69ce9014491 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 21 Jan 2006 06:12:13 +0000 Subject: [PATCH 309/373] Initial commit. Needs some rewriting --- contrib/random-tester/load.factor | 7 + contrib/random-tester/random-tester.factor | 384 +++++++++++++++++++++ contrib/random-tester/utils.factor | 22 ++ 3 files changed, 413 insertions(+) create mode 100644 contrib/random-tester/load.factor create mode 100644 contrib/random-tester/random-tester.factor create mode 100644 contrib/random-tester/utils.factor diff --git a/contrib/random-tester/load.factor b/contrib/random-tester/load.factor new file mode 100644 index 0000000000..473b43def0 --- /dev/null +++ b/contrib/random-tester/load.factor @@ -0,0 +1,7 @@ +USING: kernel parser sequences words compiler ; +IN: scratchpad + +{ + "utils" + "random-tester" +} [ "contrib/random-tester/" swap ".factor" append3 run-file ] each diff --git a/contrib/random-tester/random-tester.factor b/contrib/random-tester/random-tester.factor new file mode 100644 index 0000000000..a0b8234a02 --- /dev/null +++ b/contrib/random-tester/random-tester.factor @@ -0,0 +1,384 @@ +USING: kernel math sequences namespaces errors hashtables words arrays parser + compiler syntax lists io ; +USING: inspector prettyprint ; +USING: optimizer compiler-frontend compiler-backend inference ; +IN: random-tester + +! Tweak me +: max-length 5 ; inline +: max-value 1000000000 ; inline + + +! varying bit-length random number +: random-bits ( n -- int ) + random-int 2 swap ^ random-int ; + +: random-seq ( -- seq ) + { [ ] { } V{ } "" } nth-rand + [ max-length random-int [ max-value random-int , ] times ] swap make ; + +SYMBOL: special-integers +[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ] +{ } make \ special-integers set +: special-integers ( -- seq ) \ special-integers get ; +SYMBOL: special-floats +[ { 0.0 } % e , pi , inf , -inf , 0/0. , epsilon , epsilon neg , ] +{ } make \ special-floats set +: special-floats ( -- seq ) \ special-floats get ; +SYMBOL: special-complexes +[ + { -1 0 1 i -i } % + e , pi , 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> , + pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> , + e neg e neg rect> , e e rect> , +] { } make \ special-complexes set + +: special-complexes ( -- seq ) \ special-complexes get ; + +: random-fixnum ( -- fixnum ) + most-positive-fixnum random-int 1+ coin-flip [ neg 1- ] when >fixnum ; + +: random-bignum ( -- bignum ) + 400 random-bits first-bignum + coin-flip [ neg ] when ; + +: random-integer + coin-flip [ + random-fixnum + ] [ + coin-flip [ random-bignum ] [ special-integers nth-rand ] if + ] if ; + +: random-positive-integer ( -- int ) + random-integer dup 0 < [ + neg + ] [ + dup 0 = [ 1 + ] when + ] if ; + +: random-ratio ( -- ratio ) + 1000000000 dup [ random-int ] 2apply 1+ / coin-flip [ neg ] when dup [ drop random-ratio ] unless ; + +: random-float ( -- float ) + coin-flip [ random-ratio ] [ special-floats nth-rand ] if + coin-flip + [ .0000000000000000001 /f ] [ coin-flip [ .00000000000000001 * ] when ] if + >float ; + +: random-number ( -- number ) + { + [ random-integer ] + [ random-ratio ] + [ random-float ] + } do-one ; + +: random-complex ( -- C{ } ) + random-number random-number rect> ; + + +! Math vocabulary words +: math-1 ( -- seq ) + { + 1+ 1- >bignum >digit >fixnum abs absq arg + bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech + cosh cot coth denominator double>bits exp float>bits floor imaginary + log neg next-power-of-2 numerator quadrant real sec + sech sgn sin sinh sq sqrt tan tanh truncate + } ; +! TODO: take this out eventually +: math-throw-1 + { + recip + asec asech acot acoth acosec acosech acos acosh asin asinh atan atanh + } ; + +: integer>x + { + 1+ 1- >bignum >digit >fixnum abs absq arg + bitnot bits>double bits>float ceiling cis conjugate cos cosec cosech + cosh cot coth denominator double>bits exp float>bits floor imaginary + log neg next-power-of-2 numerator quadrant real sec + sech sgn sin sinh sq sqrt tan tanh truncate + } ; + +: ratio>x + { + 1+ 1- >bignum >digit >fixnum abs absq arg + cis conjugate cos cosec cosech + cosh cot coth double>bits exp float>bits floor imaginary + log neg next-power-of-2 quadrant real sec + sech sgn sin sinh sq sqrt tan tanh truncate + } ; + +! ceiling, truncate, floor eventually +: float>x ( float -- x ) + { + 1+ 1- >bignum >digit >fixnum abs absq arg + cis conjugate cos cosec cosech + cosh cot coth double>bits exp float>bits imaginary + log neg next-power-of-2 quadrant real sec + sech sgn sin sinh sq sqrt tan tanh + } ; + +: complex>x + { + 1+ 1- abs absq arg + conjugate cos cosec cosech + cosh cot coth exp imaginary + log neg quadrant real sec + sech sin sinh sq sqrt tan tanh + } ; + +: integer>integer + { + 1+ 1- >bignum >digit >fixnum abs absq + bitnot ceiling conjugate + denominator double>bits float>bits floor imaginary + neg next-power-of-2 numerator quadrant + real sgn sq truncate + } ; + +: ratio>ratio + { + 1+ 1- >digit abs absq conjugate neg real sq + } ; + +: float>float + { + 1+ 1- >digit abs absq arg + conjugate cos cosec cosech + cosh cot coth exp neg real sec + sech sin sinh sq tan tanh + } ; + +: complex>complex + { + 1+ 1- abs absq arg + conjugate cosec cosech + cosh cot coth exp + log neg quadrant + sech sin sinh sq sqrt tanh + } ; + + + + +: math-2 ( -- seq ) + { * + - /f max min polar> bitand bitor bitxor align shift } ; +: math-throw-2 ( -- seq ) { / /i ^ mod rem } ; + +! shift too but can't test with bignums.. +: 2integer>x ( n n -- x ) ( -- word ) + { * + - /f max min polar> bitand bitor bitxor align } ; +: 2ratio>x ( r r -- x ) ( -- word ) { * + - /f max min polar> } ; +: 2float>x ( f f -- x ) ( -- word ) { * + - /f max min polar> } ; +: 2complex>x ( c c -- x ) ( -- word ) { * + - /f } ; + +: 2integer>integer ( n n -- n ) ( -- word ) + { * + - /f max min polar> bitand bitor bitxor align } ; +: 2ratio>ratio ( r r -- r ) ( -- word ) { * + - /f max min } ; +: 2float>float ( f f -- f ) ( -- word ) { * + - /f max min polar> } ; +: 2complex>complex ( c c -- c ) ( -- word ) { * + - /f } ; + + + + +: random-integer-quotation ( -- quot ) + [ + random-integer , + max-length random-int + [ + [ + [ integer>integer nth-rand , ] + [ random-integer , 2integer>integer nth-rand , ] + ] do-one + ] times + ] [ ] make ; + +: random-ratio-quotation ( -- quot ) + [ + random-ratio , + max-length random-int + [ + [ + [ ratio>ratio nth-rand , ] + [ random-ratio , 2ratio>ratio nth-rand , ] + ] do-one + ] times + ] [ ] make ; + +: random-float-quotation ( -- quot ) + [ + random-float , + max-length random-int + [ + [ + [ float>float nth-rand , ] + [ random-float , 2float>float nth-rand , ] + ] do-one + ] times + ] [ ] make ; + +: random-complex-quotation ( -- quot ) + [ + random-complex , + max-length random-int + [ + [ + [ complex>complex nth-rand , ] + [ random-complex , 2complex>complex nth-rand , ] + ] do-one + ] times + ] [ ] make ; + + +: interp-compile-check ( quot -- ) + dup . [ call ] keep compile-1 + 2dup swap unparse write " " write unparse print + = [ "problem in math" throw ] unless ; + +! 1-arg tests +: test-integer>x ( -- ) + random-integer integer>x nth-rand f cons cons interp-compile-check ; + +: test-ratio>x ( -- ) + random-ratio ratio>x nth-rand f cons cons interp-compile-check ; + +: test-float>x ( -- ) + random-float float>x nth-rand f cons cons interp-compile-check ; + +: test-complex>x ( -- ) + random-complex complex>x nth-rand f cons cons interp-compile-check ; + + +! 2-arg tests +: test-2integer>x ( -- ) + random-integer random-integer 2integer>x nth-rand f cons cons cons interp-compile-check ; + +: test-2ratio>x ( -- ) + random-ratio random-ratio 2ratio>x nth-rand f cons cons cons interp-compile-check ; + +: test-2float>x ( -- ) + random-float random-float 2float>x nth-rand f cons cons cons interp-compile-check ; + +: test-2complex>x ( -- ) + random-complex random-complex 2complex>x nth-rand f cons cons cons interp-compile-check ; + + +: test-2random>x ( -- ) + random-number random-number math-2 nth-rand f cons cons cons interp-compile-check ; + + +! quotation tests +: test-integer random-integer-quotation interp-compile-check ; +: test-ratio random-ratio-quotation interp-compile-check ; +: test-float random-float-quotation interp-compile-check ; +: test-complex random-complex-quotation interp-compile-check ; + +: test-math { + [ test-integer ] + [ test-ratio ] + [ test-float ] + [ test-complex ] + } do-one ; + +: if-quot ( -- ) + max-length [ + ] times ; + + +! : test-if + ! nested-if-quot compile-check-output ; + + +: stack-identity-0 + H{ + { 1 drop } + { 1000000000000000000000000001 drop } + { -11111111111111111111111111 drop } + { -1 drop } + { 1.203 drop } + { -1.203 drop } + { "asdf" drop } + } ; inline +: stack-identity-1 + H{ + { dup drop } + { >r r> } + } ; inline +: stack-identity-2 + H{ + { swap swap } + { over drop } + { dupd nip } + { 2dup 2drop } + } ; inline +: stack-identity-3 + H{ + { rot -rot } + { pick drop } + { 3dup 3drop } + } ; inline +: stack-identity-4 + H{ + { 2swap 2swap } + } ; inline + +: get-stack-identity-table ( n -- hash ) + { + { [ dup 0 = ] [ drop stack-identity-0 ] } + { [ dup 1 = ] [ drop stack-identity-1 ] } + { [ dup 2 = ] [ drop stack-identity-2 ] } + { [ dup 3 = ] [ drop stack-identity-3 ] } + { [ dup 4 = ] [ drop stack-identity-4 ] } + { [ t ] [ drop f ] } + } cond ; + +: get-stack-identity-table<= ( n -- hash ) + 1+ random-int get-stack-identity-table ; + + +: random-stack-identity ( n -- quot ) + #! n is number of items on stack + [ + max-length random-int + [ dup get-stack-identity-table<= random-hash-entry swap , , ] times + drop + ] [ ] make ; + + +: stack-identity ; ! dummy + +: define-random-stack-identity ( n -- ) + random-stack-identity \ stack-identity dup reset-generic swap + define-compound \ stack-identity compile ; + +: test-random-stack-identity ( -- ) + 4 define-random-stack-identity + 1 2 3 4 stack-identity 4array { 1 2 3 4 } = + [ \ stack-identity see "bad stack-identity!" throw ] unless ; + +: (test-random-seq-iterate) ( seq -- ) + [ [ 2 3 4 stack-identity 3drop ] keep = [ "not equal" throw ] unless ] each ; + +: test-random-seq-iterate ( -- ) + 4 define-random-stack-identity + ! \ stack-identity see + random-seq + ! dup . + (test-random-seq-iterate) ; + + +: random-test + { test-random-stack-identity test-random-seq-iterate test-math } + nth-rand execute ; + +: random-test-loop ( n -- ) + [ random-test ] times ; + +: watch-simplifier + [ + dup word-def dataflow optimize + linearize [ split-blocks simplify . ] hash-each + ] with-compiler ; + + diff --git a/contrib/random-tester/utils.factor b/contrib/random-tester/utils.factor new file mode 100644 index 0000000000..81648eba4c --- /dev/null +++ b/contrib/random-tester/utils.factor @@ -0,0 +1,22 @@ +USING: kernel math sequences namespaces errors hashtables words arrays parser + compiler syntax lists io ; +USING: optimizer compiler-frontend compiler-backend inference + inspector prettyprint ; +IN: random-tester + +! SEQUENCES +: nth-rand ( seq -- elem ) [ length random-int ] keep nth ; + +! HASHTABLES +: random-hash-entry ( hash -- key value ) hash>alist nth-rand first2 ; + +! ARRAYS +: 4array ( a b c d -- seq ) 2array >r 2array r> append ; + +: coin-flip ( -- bool ) 2 random-int 1 = ; + +! UNCOMPILABLES +: do-one ( seq -- ) nth-rand call ; + + + From ddf5008e02ba990bc7824b9b97d93f01ae49e124 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 21 Jan 2006 06:16:34 +0000 Subject: [PATCH 310/373] another test --- TODO.FACTOR.txt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 9d39f7d837..db5f153144 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -82,6 +82,10 @@ Compile fails: x86 problems below +[ -235345183 ] +Compiling G:359656 +-235345183 33090273 + [ 0 bits>float ] Compiling G:455019 4.203895392974451e-45 110.8125 From 1fe3f6d0eeaf7488d44b73b9b200c208ad9d212d Mon Sep 17 00:00:00 2001 From: Trent Buck Date: Sat, 21 Jan 2006 06:20:33 +0000 Subject: [PATCH 311/373] Use run-resource for code distributed with Factor; run-file is for user code. --- contrib/random-tester/load.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/contrib/random-tester/load.factor b/contrib/random-tester/load.factor index 473b43def0..e9ad75b077 100644 --- a/contrib/random-tester/load.factor +++ b/contrib/random-tester/load.factor @@ -4,4 +4,4 @@ IN: scratchpad { "utils" "random-tester" -} [ "contrib/random-tester/" swap ".factor" append3 run-file ] each +} [ "/contrib/random-tester/" swap ".factor" append3 run-resource ] each From 9fb0cb6f6e91374f933f0cdca05458e3b7270221 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 21 Jan 2006 06:23:41 +0000 Subject: [PATCH 312/373] made another file --- contrib/random-tester/load.factor | 1 + contrib/random-tester/random-tester.factor | 67 ------------------- contrib/random-tester/random.factor | 75 ++++++++++++++++++++++ 3 files changed, 76 insertions(+), 67 deletions(-) create mode 100644 contrib/random-tester/random.factor diff --git a/contrib/random-tester/load.factor b/contrib/random-tester/load.factor index e9ad75b077..06583c7cb6 100644 --- a/contrib/random-tester/load.factor +++ b/contrib/random-tester/load.factor @@ -3,5 +3,6 @@ IN: scratchpad { "utils" + "random" "random-tester" } [ "/contrib/random-tester/" swap ".factor" append3 run-resource ] each diff --git a/contrib/random-tester/random-tester.factor b/contrib/random-tester/random-tester.factor index a0b8234a02..e8be9e507f 100644 --- a/contrib/random-tester/random-tester.factor +++ b/contrib/random-tester/random-tester.factor @@ -4,75 +4,8 @@ USING: inspector prettyprint ; USING: optimizer compiler-frontend compiler-backend inference ; IN: random-tester -! Tweak me -: max-length 5 ; inline -: max-value 1000000000 ; inline -! varying bit-length random number -: random-bits ( n -- int ) - random-int 2 swap ^ random-int ; - -: random-seq ( -- seq ) - { [ ] { } V{ } "" } nth-rand - [ max-length random-int [ max-value random-int , ] times ] swap make ; - -SYMBOL: special-integers -[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ] -{ } make \ special-integers set -: special-integers ( -- seq ) \ special-integers get ; -SYMBOL: special-floats -[ { 0.0 } % e , pi , inf , -inf , 0/0. , epsilon , epsilon neg , ] -{ } make \ special-floats set -: special-floats ( -- seq ) \ special-floats get ; -SYMBOL: special-complexes -[ - { -1 0 1 i -i } % - e , pi , 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> , - pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> , - e neg e neg rect> , e e rect> , -] { } make \ special-complexes set - -: special-complexes ( -- seq ) \ special-complexes get ; - -: random-fixnum ( -- fixnum ) - most-positive-fixnum random-int 1+ coin-flip [ neg 1- ] when >fixnum ; - -: random-bignum ( -- bignum ) - 400 random-bits first-bignum + coin-flip [ neg ] when ; - -: random-integer - coin-flip [ - random-fixnum - ] [ - coin-flip [ random-bignum ] [ special-integers nth-rand ] if - ] if ; - -: random-positive-integer ( -- int ) - random-integer dup 0 < [ - neg - ] [ - dup 0 = [ 1 + ] when - ] if ; - -: random-ratio ( -- ratio ) - 1000000000 dup [ random-int ] 2apply 1+ / coin-flip [ neg ] when dup [ drop random-ratio ] unless ; - -: random-float ( -- float ) - coin-flip [ random-ratio ] [ special-floats nth-rand ] if - coin-flip - [ .0000000000000000001 /f ] [ coin-flip [ .00000000000000001 * ] when ] if - >float ; - -: random-number ( -- number ) - { - [ random-integer ] - [ random-ratio ] - [ random-float ] - } do-one ; - -: random-complex ( -- C{ } ) - random-number random-number rect> ; ! Math vocabulary words diff --git a/contrib/random-tester/random.factor b/contrib/random-tester/random.factor new file mode 100644 index 0000000000..52f35a5a27 --- /dev/null +++ b/contrib/random-tester/random.factor @@ -0,0 +1,75 @@ +USING: kernel math sequences namespaces errors hashtables words arrays parser + compiler syntax lists io ; +USING: inspector prettyprint ; +USING: optimizer compiler-frontend compiler-backend inference ; +IN: random-tester + +! Tweak me +: max-length 5 ; inline +: max-value 1000000000 ; inline + +! varying bit-length random number +: random-bits ( n -- int ) + random-int 2 swap ^ random-int ; + +: random-seq ( -- seq ) + { [ ] { } V{ } "" } nth-rand + [ max-length random-int [ max-value random-int , ] times ] swap make ; + +SYMBOL: special-integers +[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ] +{ } make \ special-integers set +: special-integers ( -- seq ) \ special-integers get ; +SYMBOL: special-floats +[ { 0.0 } % e , pi , inf , -inf , 0/0. , epsilon , epsilon neg , ] +{ } make \ special-floats set +: special-floats ( -- seq ) \ special-floats get ; +SYMBOL: special-complexes +[ + { -1 0 1 i -i } % + e , pi , 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> , + pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> , + e neg e neg rect> , e e rect> , +] { } make \ special-complexes set + +: special-complexes ( -- seq ) \ special-complexes get ; + +: random-fixnum ( -- fixnum ) + most-positive-fixnum random-int 1+ coin-flip [ neg 1- ] when >fixnum ; + +: random-bignum ( -- bignum ) + 400 random-bits first-bignum + coin-flip [ neg ] when ; + +: random-integer + coin-flip [ + random-fixnum + ] [ + coin-flip [ random-bignum ] [ special-integers nth-rand ] if + ] if ; + +: random-positive-integer ( -- int ) + random-integer dup 0 < [ + neg + ] [ + dup 0 = [ 1 + ] when + ] if ; + +: random-ratio ( -- ratio ) + 1000000000 dup [ random-int ] 2apply 1+ / coin-flip [ neg ] when dup [ drop random-ratio ] unless ; + +: random-float ( -- float ) + coin-flip [ random-ratio ] [ special-floats nth-rand ] if + coin-flip + [ .0000000000000000001 /f ] [ coin-flip [ .00000000000000001 * ] when ] if + >float ; + +: random-number ( -- number ) + { + [ random-integer ] + [ random-ratio ] + [ random-float ] + } do-one ; + +: random-complex ( -- C{ } ) + random-number random-number rect> ; + From 2c4d058fdc8101141048dd249e4b705de3acf9b1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 21 Jan 2006 07:37:39 +0000 Subject: [PATCH 313/373] markup cleanups, removed terpri*, help responder and browser responder improvements --- contrib/httpd/browser-responder.factor | 116 +++++++++++-------------- contrib/httpd/html-tags.factor | 14 +-- contrib/httpd/html.factor | 101 ++++++++++----------- contrib/httpd/http-client.factor | 14 +-- contrib/httpd/xml.factor | 13 ++- doc/handbook/streams.facts | 5 +- library/help/help.factor | 11 ++- library/help/markup.factor | 116 ++++++++++++------------- library/help/stylesheet.factor | 3 + library/io/duplex-stream.factor | 3 - library/io/null-stream.factor | 1 - library/io/plain-stream.factor | 3 +- library/io/stdio.factor | 18 ++-- library/io/stdio.facts | 7 +- library/io/stream.factor | 1 - library/io/stream.facts | 5 -- library/io/string-streams.factor | 5 +- library/io/styles.factor | 1 - library/io/styles.facts | 4 - library/tools/describe.factor | 5 +- library/ui/panes.factor | 11 ++- library/ui/paragraphs.factor | 3 +- library/ui/presentations.factor | 64 +++++++++----- library/win32/win32-stream.factor | 4 - 24 files changed, 253 insertions(+), 275 deletions(-) diff --git a/contrib/httpd/browser-responder.factor b/contrib/httpd/browser-responder.factor index d3fc96ba5d..f0e75bfca9 100644 --- a/contrib/httpd/browser-responder.factor +++ b/contrib/httpd/browser-responder.factor @@ -4,11 +4,11 @@ ! 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. +! 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 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 @@ -29,81 +29,63 @@ USING: cont-responder hashtables help html io kernel lists memory namespaces prettyprint sequences words xml ; : option ( current text -- ) - #! Output the HTML option tag for the given text. If - #! it is equal to the current string, make the option selected. - 2dup = [ - "\n" write drop ; + #! Output the HTML option tag for the given text. If + #! it is equal to the current string, make the option selected. + 2dup = [ + "\n" write drop ; : vocab-list ( vocab -- ) - #! Write out the HTML for the list of vocabularies. Make the currently - #! selected vocab be 'vocab'. - ; + #! Write out the HTML for the list of vocabularies. Make the currently + #! selected vocab be 'vocab'. + ; : word-list ( vocab word -- ) - #! Write out the HTML for the list of words in a vocabulary. Make the 'word' item - #! the currently selected option. - ; + #! Write out the HTML for the list of words in a vocabulary. Make the 'word' item + #! the currently selected option. + ; : word-source ( vocab word -- ) - #! Write the source for the given word from the vocab as HTML. - swap lookup [ [ help ] with-html-stream ] when* ; + #! Write the source for the given word from the vocab as HTML. + swap lookup [ [ (help) ] with-html-stream ] when* ; : browser-body ( vocab word -- ) - #! Write out the HTML for the body of the main browser page. - - - - - - - - - - - -
      "Vocabularies" write "Words" write "Documentation" write
      over vocab-list 2dup word-list word-source
      ; + #! Write out the HTML for the body of the main browser page. + + + + + + + + + + + +
      "Vocabularies" write "Words" write "Documentation" write
      over vocab-list 2dup word-list word-source
      ; : browser-title ( vocab word -- ) - #! Output the HTML title for the browser. - - "Factor Browser - " write - swap write - " - " write - write - ; - -: browser-style ( -- ) - #! Stylesheet for browser pages - ; + #! Output the HTML title for the browser. + [ "Factor Browser - " % swap % " - " % % ] "" make ; : browse ( vocab word -- ) - #! Display a Smalltalk like browser for exploring words. - [ - - 2dup browser-title browser-style - -

      browser-body
      - - - ] show-final ; + #! Display a Smalltalk like browser for exploring words. + [ + 2dup browser-title [ +
      browser-body
      + ] html-document + ] show-final ; : browser-responder ( -- ) - #! Start the Smalltalk-like browser. - "vocab" "query" get hash [ "browser-responder" ] unless* - "word" "query" get hash [ "browse" ] unless* browse ; + #! Start the Smalltalk-like browser. + "vocab" "query" get hash [ "browser-responder" ] unless* + "word" "query" get hash [ "browse" ] unless* browse ; diff --git a/contrib/httpd/html-tags.factor b/contrib/httpd/html-tags.factor index c7d1bffd2b..60dd90c905 100644 --- a/contrib/httpd/html-tags.factor +++ b/contrib/httpd/html-tags.factor @@ -72,6 +72,10 @@ USE: sequences ! ! +SYMBOL: html + +: write-html H{ { html t } } format ; + : attrs>string ( alist -- string ) #! Convert the attrs alist to a string #! suitable for embedding in an html tag. @@ -81,7 +85,7 @@ USE: sequences #! With the attribute namespace on the stack, get the attributes #! and write them to standard output. If no attributes exist, write #! nothing. - "attrs" get attrs>string write ; + "attrs" get attrs>string write-html ; : html-word ( name def -- ) #! Define 'word creating' word to allow @@ -90,7 +94,7 @@ USE: sequences : "<" swap ">" append3 ; -: do- write ; +: do- write-html ; : def-for-html-word- ( name -- ) #! Return the name and code for the patterned @@ -99,7 +103,7 @@ USE: sequences : n V{ } clone "attrs" set ; +: do-n V{ } clone "attrs" set ; : def-for-html-word- ">" append ; -: do-foo> write-attributes n> drop ">" write ; +: do-foo> write-attributes n> drop ">" write-html ; : def-for-html-word-foo> ( name -- ) #! Return the name and code for the foo> patterned @@ -120,7 +124,7 @@ USE: sequences : def-for-html-word- ( name -- ) #! Return the name and code for the patterned #! word. - dup [ write ] cons html-word define-close ; + dup [ write-html ] cons html-word define-close ; : [ "<" % % "/>" % ] "" make ; diff --git a/contrib/httpd/html.factor b/contrib/httpd/html.factor index 330bcbf3c9..7700ef0cca 100644 --- a/contrib/httpd/html.factor +++ b/contrib/httpd/html.factor @@ -1,15 +1,18 @@ -! Copyright (C) 2004, 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. +! Copyright (C) 2004, 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. IN: html USING: generic hashtables help http io kernel lists math namespaces sequences strings styles words xml ; : hex-color, ( triplet -- ) - 3 swap head [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ; + 3 swap head + [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ; -: fg-css, ( color -- ) "color: #" % hex-color, "; " % ; +: fg-css, ( color -- ) + "color: #" % hex-color, "; " % ; -: bg-css, ( color -- ) "background-color: #" % hex-color, "; " % ; +: bg-css, ( color -- ) + "background-color: #" % hex-color, "; " % ; : style-css, ( flag -- ) dup @@ -53,15 +56,12 @@ namespaces sequences strings styles words xml ; ] if ; : div-css-style ( style -- str ) - drop "" ; - ! [ - ! H{ - ! { foreground [ fg-css, ] } - ! { font [ font-css, ] } - ! { font-style [ style-css, ] } - ! { font-size [ size-css, ] } - ! } hash-apply - ! ] "" make ; + [ + H{ + { page-color [ bg-css, ] } + ! { border-color [ font-css, ] } + } hash-apply + ] "" make ; : div-tag ( style quot -- ) over div-css-style dup empty? [ @@ -87,6 +87,9 @@ namespaces sequences strings styles words xml ; call ] if* ; +: do-escaping ( string style -- string ) + html swap hash [ chars>entities ] unless ; + GENERIC: browser-link-href ( presented -- href ) M: word browser-link-href @@ -111,16 +114,6 @@ M: object browser-link-href presented pick hash browser-link-href [ call ] [ call ] if* ; -TUPLE: wrapper-stream scope ; - -C: wrapper-stream ( stream -- stream ) - 2dup set-delegate [ - >r stdio associate r> set-wrapper-stream-scope - ] keep ; - -: with-wrapper ( stream quot -- ) - >r wrapper-stream-scope r> bind ; inline - TUPLE: nested-stream ; C: nested-stream [ set-delegate ] keep ; @@ -129,62 +122,62 @@ M: nested-stream stream-close drop ; TUPLE: html-stream ; +C: html-stream ( stream -- stream ) [ set-delegate ] keep ; + M: html-stream stream-write1 ( char stream -- ) >r ch>string r> stream-write ; -M: html-stream stream-write ( char stream -- ) - [ chars>entities write ] with-wrapper ; +: delegate-write delegate stream-write ; + +M: html-stream stream-write ( str stream -- ) + >r chars>entities r> delegate-write ; M: html-stream stream-format ( str style stream -- ) [ [ [ - [ drop chars>entities write ] span-tag + [ + do-escaping stdio get delegate-write + ] span-tag ] file-link-tag ] browser-link-tag - ] with-wrapper ; + ] with-stream* ; -: pre-tag ( stream style quot -- ) +: pre-tag ( style quot -- ) wrap-margin rot hash [ call ] [ - over [ [ 
       ] with-wrapper call ] keep
-        [
      ] with-wrapper + 
       call
      ] if ; M: html-stream with-nested-stream ( quot style stream -- ) - swap [ - [ swap with-stream ] pre-tag - ] div-tag ; + [ + [ + [ + stdio get swap with-stream* + ] pre-tag + ] div-tag + ] with-stream* ; -M: html-stream stream-terpri [
      ] with-wrapper ; - -M: html-stream stream-terpri* [
      ] with-wrapper ; - -C: html-stream ( stream -- stream ) - #! Wraps the given stream in an HTML stream. An HTML stream - #! converts special characters to entities when being - #! written, and supports writing attributed strings with - #! the following attributes: - #! - #! foreground - an rgb triplet in a list - #! background - an rgb triplet in a list - #! font - #! font-style - #! font-size - #! file - #! word - #! vocab - [ >r r> set-delegate ] keep ; +M: html-stream stream-terpri [
      ] with-stream* ; : with-html-stream ( quot -- ) - [ stdio [ ] change call ] with-scope ; + stdio get swap with-stream* ; + +: default-css ( -- ) + ; : html-document ( title quot -- ) swap chars>entities dup write + default-css

      write

      diff --git a/contrib/httpd/http-client.factor b/contrib/httpd/http-client.factor index 2983bc46f0..b0fd3401a9 100644 --- a/contrib/httpd/http-client.factor +++ b/contrib/httpd/http-client.factor @@ -34,18 +34,18 @@ sequences io strings ; DEFER: http-get -: do-redirect ( code headers stream -- code headers stream ) +: do-redirect ( code headers string -- code headers string ) #! Should this support Location: headers that are #! relative URLs? pick 302 = [ - stream-close "Location" swap hash nip http-get + drop "Location" swap hash nip http-get ] when ; : http-get ( url -- code headers stream ) #! Opens a stream for reading from an HTTP URL. parse-url over parse-host [ - [ get-request read-response ] with-stream* - ] keep do-redirect ; + get-request read-response stdio get contents + ] with-stream do-redirect ; : download ( url file -- ) #! Downloads the contents of a URL to a file. @@ -60,8 +60,10 @@ DEFER: http-get crlf ] keep write ; -: http-post ( content-type content url -- code headers stream ) +: http-post ( content-type content url -- code headers string ) #! Make a POST request. The content is URL encoded for you. parse-url over parse-host [ - [ post-request flush read-response ] with-stream* + [ + post-request flush read-response stdio get contents + ] with-stream ] keep ; diff --git a/contrib/httpd/xml.factor b/contrib/httpd/xml.factor index 0c11914b01..60bd418f1f 100644 --- a/contrib/httpd/xml.factor +++ b/contrib/httpd/xml.factor @@ -293,11 +293,8 @@ M: unclosed error. "Tags: " print unclosed-tags [ " <" write write ">" print ] each ; -: seq-last ( seq -- last ) - [ length 1 - ] keep nth ; - : push-datum ( object -- ) - xml-stack get seq-last cdr push ; + xml-stack get peek cdr push ; GENERIC: process ( object -- ) @@ -315,8 +312,8 @@ M: closer process closer-name xml-stack get pop uncons >r [ opener-name [ - 2dup = [ 2drop ] [ swap throw ] if - ] keep + 2dup = [ 2drop ] [ swap throw ] if + ] keep ] keep opener-props r> push-datum ; : initialize-xml-stack ( -- ) @@ -325,7 +322,7 @@ M: closer process : xml ( string -- tag ) #! Produces a tree of XML nodes [ - initialize-xml-stack + initialize-xml-stack [ process ] xml-each xml-stack get dup length 1 = [ throw ] unless @@ -407,7 +404,7 @@ TUPLE: process-missing process tag ; M: process-missing error. "Tag <" write process-missing-tag tag-name write - "> not implemented on process process " write + "> not implemented on process " write dup process-missing-process word-name print ; : run-process ( tag word -- ) diff --git a/doc/handbook/streams.facts b/doc/handbook/streams.facts index 7ee5b70eb7..16bf07225a 100644 --- a/doc/handbook/streams.facts +++ b/doc/handbook/streams.facts @@ -39,7 +39,6 @@ $terpri { $subsection stream-write1 } { $subsection stream-write } { $subsection stream-terpri } -{ $subsection stream-terpri* } { $subsection stream-format } { $subsection with-nested-stream } "If your stream supports the first three but not the rest, wrap it in a " { $link } ", which provides plain text implementations of the stream formatting words (the so called " { $emphasis "extended stream output protocol" } ")." ; @@ -68,7 +67,6 @@ ARTICLE: "stdio" "The default stream" { $subsection write } { $subsection print } { $subsection terpri } -{ $subsection terpri* } { $subsection format } { $subsection with-nesting } "A pair of combinators support rebinding the " { $link stdio } " variable:" @@ -94,8 +92,7 @@ ARTICLE: "character-styles" "Character styles" { $subsection font-size } { $subsection font-style } { $subsection presented } -{ $subsection file } -{ $subsection word-break } ; +{ $subsection file } ; ARTICLE: "paragraph-styles" "Paragraph styles" "Paragraph styles for " { $link with-nested-stream } ":" diff --git a/library/help/help.factor b/library/help/help.factor index 57f578e080..2ab2c4400f 100644 --- a/library/help/help.factor +++ b/library/help/help.factor @@ -1,15 +1,18 @@ IN: help -USING: arrays hashtables io kernel ; +USING: arrays hashtables io kernel namespaces ; + +SYMBOL: last-block : (help) ( topic -- ) default-style [ - [ article-content print-element ] with-nesting* terpri* - ] with-style ; + last-block on article-content print-element + ] with-nesting* terpri ; DEFER: $heading : help ( topic -- ) - dup article-title $heading (help) ; + default-style [ dup article-title $heading ] with-style + (help) ; : glossary ( name -- ) help ; diff --git a/library/help/markup.factor b/library/help/markup.factor index 5106fbf6bd..c207ea3a93 100644 --- a/library/help/markup.factor +++ b/library/help/markup.factor @@ -19,37 +19,26 @@ parser prettyprint sequences strings styles vectors words ; PREDICATE: array simple-element dup empty? [ drop t ] [ first word? not ] if ; -: write-term ( string -- ) - dup terms get hash [ - dup presented associate [ format* ] with-style - ] [ - format* - ] if ; +M: string print-element last-block off format* ; -M: string print-element - " " split - [ dup empty? [ drop ] [ write-term ] if ] - [ bl ] interleave ; +M: array print-element unswons* execute ; -M: array print-element - unswons* execute ; - -M: word print-element - { } swap execute ; +M: word print-element { } swap execute ; : ($span) ( content style -- ) - [ print-element ] with-style ; + last-block off [ print-element ] with-style ; -: ($block) ( content style -- ) - terpri* - [ [ print-element ] with-nesting* ] with-style - terpri* ; +: ($block) ( quot -- ) + last-block [ [ terpri ] unless f ] change + call + terpri + last-block on ; inline ! Some spans -: $heading heading-style ($block) ; +: $heading [ heading-style ($span) ] ($block) ; -: $subheading subheading-style ($block) ; +: $subheading [ subheading-style ($span) ] ($block) ; : $snippet snippet-style ($span) ; @@ -57,18 +46,19 @@ M: word print-element : $url url-style ($span) ; -: $terpri terpri terpri drop ; +: $terpri last-block off terpri terpri drop ; ! Some blocks -M: simple-element print-element [ print-element ] each ; +M: simple-element print-element + [ print-element ] each ; : ($code) ( presentation quot -- ) - terpri* - code-style [ - >r current-style swap presented pick set-hash r> - with-nesting - ] with-style - terpri* ; inline + [ + code-style [ + >r current-style swap presented pick set-hash r> + with-nesting + ] with-style + ] ($block) ; inline : $code ( content -- ) "\n" join dup [ format* ] ($code) ; @@ -82,11 +72,16 @@ M: simple-element print-element [ print-element ] each ; ] if* ; : $stack-effect ( word -- ) - stack-effect [ "Stack effect" $subheading $snippet ] when* ; + stack-effect [ + "Stack effect" $subheading $snippet + ] when* ; + +: $vocabulary ( content -- ) + "Vocabulary" $subheading $snippet ; : $synopsis ( content -- ) first dup - word-vocabulary [ "Vocabulary" $subheading $snippet ] when* + word-vocabulary [ $vocabulary ] when* dup parsing? [ $syntax ] [ $stack-effect ] if ; : $description ( content -- ) @@ -99,21 +94,20 @@ M: simple-element print-element [ print-element ] each ; "Examples" $subheading print-element ; : $warning ( content -- ) - terpri* - current-style warning-style hash-union [ - "Warning" $subheading print-element - ] with-nesting - terpri* ; + [ + current-style warning-style hash-union [ + "Warning" $subheading print-element + ] with-nesting + ] ($block) ; : textual-list ( seq quot -- ) - [ "," format* bl ] interleave ; inline + [ ", " print-element ] interleave ; inline : $see ( content -- ) - code-style [ [ first see ] with-nesting* ] with-style ; + code-style [ first see ] with-nesting* ; : $example ( content -- ) - first2 swap dup - [ + first2 swap dup [ input-style [ format* ] with-style terpri format* ] ($code) ; @@ -129,15 +123,16 @@ M: link article-content link-name article-content ; DEFER: help : $subsection ( object -- ) - terpri* - subsection-style [ - first dup article-title swap - dup [ link-name (help) ] curry - simple-outliner - ] with-style ; + [ + subsection-style [ + first dup article-title swap + dup [ link-name (help) ] curry + simple-outliner + ] with-style + ] ($block) ; : $link ( article -- ) - first dup word? [ + last-block off first dup word? [ pprint ] [ link-style [ @@ -145,9 +140,6 @@ DEFER: help ] with-style ] if ; -: $glossary ( element -- ) - first dup simple-object ; - : $definition ( content -- ) "Definition" $subheading $see ; @@ -155,19 +147,24 @@ DEFER: help "See also" $subheading [ 1array $link ] textual-list ; : $values ( content -- ) - "Arguments and values" $subheading [ - unswons* $snippet " -- " format* print-element - ] [ - terpri - ] interleave ; + "Arguments and values" $subheading + [ unswons* $snippet " -- " format* print-element ] + [ terpri ] interleave ; : $predicate ( content -- ) { { "object" "an object" } } $values - "Tests if the object is an instance of the " $description - $link " class." format* ; + [ + "Tests if the object is an instance of the " , + { $link } swap append , + " class." , + ] { } make $description ; : $list ( content -- ) - terpri* [ "- " format* print-element terpri* ] each ; + [ + [ + list-element-style [ print-element ] with-nesting* + ] ($block) + ] each ; : $errors ( content -- ) "Errors" $subheading print-element ; @@ -192,4 +189,5 @@ DEFER: help { { "x" "a complex number" } { "y" "a complex number" } } $values ; : $io-error + drop "Throws an error if the I/O operation fails." $errors ; diff --git a/library/help/stylesheet.factor b/library/help/stylesheet.factor index f438b61b54..02e70e1a56 100644 --- a/library/help/stylesheet.factor +++ b/library/help/stylesheet.factor @@ -50,3 +50,6 @@ USING: styles ; { border-color { 1 0 0 1 } } { border-width 5 } } ; + +: list-element-style + H{ { border-color { 0.8 0.8 0.8 1 } } { border-width 5 } } ; diff --git a/library/io/duplex-stream.factor b/library/io/duplex-stream.factor index 0d25450d73..9d296be3f7 100644 --- a/library/io/duplex-stream.factor +++ b/library/io/duplex-stream.factor @@ -26,9 +26,6 @@ M: duplex-stream stream-write M: duplex-stream stream-terpri duplex-stream-out stream-terpri ; -M: duplex-stream stream-terpri* - duplex-stream-out stream-terpri* ; - M: duplex-stream stream-format duplex-stream-out stream-format ; diff --git a/library/io/null-stream.factor b/library/io/null-stream.factor index d795f62280..c710d23816 100644 --- a/library/io/null-stream.factor +++ b/library/io/null-stream.factor @@ -12,7 +12,6 @@ M: f stream-read 2drop f ; M: f stream-write1 2drop ; M: f stream-write 2drop ; M: f stream-terpri drop ; -M: f stream-terpri* drop ; M: f stream-flush drop ; M: f stream-format 3drop ; diff --git a/library/io/plain-stream.factor b/library/io/plain-stream.factor index 85d47ed7a8..3074a616f3 100644 --- a/library/io/plain-stream.factor +++ b/library/io/plain-stream.factor @@ -6,7 +6,6 @@ TUPLE: plain-writer ; C: plain-writer ( stream -- stream ) [ set-delegate ] keep ; M: plain-writer stream-terpri CHAR: \n swap stream-write1 ; -M: plain-writer stream-terpri* stream-terpri ; M: plain-writer stream-format nip stream-write ; M: plain-writer with-nested-stream ( quot style stream -- ) - [ stdio set drop call ] with-scope ; + nip swap with-stream* ; diff --git a/library/io/stdio.factor b/library/io/stdio.factor index 34c7ea91e7..feef6c47ab 100644 --- a/library/io/stdio.factor +++ b/library/io/stdio.factor @@ -18,7 +18,6 @@ SYMBOL: stdio : flush ( -- ) stdio get stream-flush ; : terpri ( -- ) stdio get stream-terpri ; -: terpri* ( -- ) stdio get stream-terpri* ; : format ( string style -- ) stdio get stream-format ; : with-nesting ( style quot -- ) @@ -26,12 +25,11 @@ SYMBOL: stdio : print ( string -- ) stdio get stream-print ; -: with-stream ( stream quot -- ) - [ swap stdio set [ close ] cleanup ] with-scope ; inline - : with-stream* ( stream quot -- ) - [ swap stdio set [ close rethrow ] recover ] with-scope ; - inline + [ swap stdio set call ] with-scope ; inline + +: with-stream ( stream quot -- ) + swap [ [ close ] cleanup ] with-stream* ; inline SYMBOL: style-stack @@ -49,10 +47,10 @@ SYMBOL: style-stack : format* ( string -- ) current-style format ; -: bl ( -- ) H{ { word-break t } } [ " " format* ] with-style ; +: bl ( -- ) " " format* ; -: with-nesting* ( quot -- ) - current-style swap with-nesting ; inline +: with-nesting* ( style quot -- ) + swap [ current-style swap with-nesting ] with-style ; inline : write-object ( object quot -- ) >r presented associate r> with-style ; @@ -61,7 +59,7 @@ SYMBOL: style-stack [ format* ] write-object ; : write-outliner ( content caption -- ) - >r outline associate r> with-nesting terpri ; + >r outline associate r> with-nesting* ; : simple-outliner ( string object content -- ) [ simple-object ] write-outliner ; diff --git a/library/io/stdio.facts b/library/io/stdio.facts index 96f20371bf..1a1359ad69 100644 --- a/library/io/stdio.facts +++ b/library/io/stdio.facts @@ -45,10 +45,6 @@ HELP: terpri "( -- )" { $contract "Writes a line terminator to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } $io-error ; -HELP: terpri* "( -- )" -{ $contract "Writes a line terminator to the " { $link stdio } " stream, unless the stream is already positioned at the start of a line, in which case this word does nothing. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } -$io-error ; - HELP: format "( str style -- )" { $values { "str" "a string" } { "style" "a hashtable" } } { $contract "Writes formatted text to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } @@ -73,7 +69,8 @@ HELP: with-stream "( stream quot -- )" HELP: with-stream* "( stream quot -- )" { $values { "stream" "an input or output stream" } { "quot" "a quotation" } } -{ $description "Calls the quotation in a new dynamic scope, with the " { $link stdio } " variable rebound to " { $snippet "stream" } ". The stream is closed if the quotation throws an error, however it is " { $emphasis "not" } " closed if the quotation returns without incident." } +{ $description "Calls the quotation in a new dynamic scope, with the " { $link stdio } " variable rebound to " { $snippet "stream" } "." } +{ $notes "This word differs from " { $link with-stream } " in that if an error is thrown while the quotation is executing, the stream is " { $emphasis "not" } " closed." } { $see-also with-stream } ; HELP: style-stack f diff --git a/library/io/stream.factor b/library/io/stream.factor index d8395c9d3c..3c6733b77c 100644 --- a/library/io/stream.factor +++ b/library/io/stream.factor @@ -13,7 +13,6 @@ GENERIC: stream-write1 ( char stream -- ) GENERIC: stream-write ( string stream -- ) GENERIC: stream-flush ( stream -- ) GENERIC: stream-terpri ( stream -- ) -GENERIC: stream-terpri* ( stream -- ) GENERIC: stream-format ( string style stream -- ) GENERIC: with-nested-stream ( quot style stream -- ) diff --git a/library/io/stream.facts b/library/io/stream.facts index de9afeeadd..6a90108aac 100644 --- a/library/io/stream.facts +++ b/library/io/stream.facts @@ -47,11 +47,6 @@ HELP: stream-terpri "( stream -- )" { $contract "Writes a line terminator. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } $io-error ; -HELP: stream-terpri* "( stream -- )" -{ $values { "stream" "an output stream" } } -{ $contract "Writes a line terminator unless the stream is already positioned at the start of a line, in which case this word does nothing. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } -$io-error ; - HELP: stream-format "( str style stream -- )" { $values { "str" "a string" } { "style" "a hashtable" } { "stream" "an output stream" } } { $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." diff --git a/library/io/string-streams.factor b/library/io/string-streams.factor index 6dcc7207b2..10aef0ca9d 100644 --- a/library/io/string-streams.factor +++ b/library/io/string-streams.factor @@ -13,9 +13,8 @@ M: sbuf stream-flush drop ; 512 ; : string-out ( quot -- str ) - [ - stdio set call stdio get >string - ] with-scope ; inline + [ call stdio get >string ] with-stream* ; + inline ! Reversed string buffers support the stream input protocol. M: sbuf stream-read1 ( sbuf -- char/f ) diff --git a/library/io/styles.factor b/library/io/styles.factor index d3df55707d..8adbaed138 100644 --- a/library/io/styles.factor +++ b/library/io/styles.factor @@ -15,7 +15,6 @@ SYMBOL: font-size SYMBOL: font-style SYMBOL: presented SYMBOL: file -SYMBOL: word-break ! Paragraph styles SYMBOL: page-color diff --git a/library/io/styles.facts b/library/io/styles.facts index 77b371444b..44890187bc 100644 --- a/library/io/styles.facts +++ b/library/io/styles.facts @@ -62,10 +62,6 @@ HELP: presented f HELP: file f { $description "Character style. A pathname associated with the text. In the Factor HTTP server, this is rendered as a link to this path on the server." } ; -HELP: word-break f -{ $description "Character style. Denotes that this text is a point in the text where the line can be wrapped." } -{ $see-also bl } ; - HELP: page-color f { $description "Paragraph style. Background color of the paragraph block, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." } { $examples diff --git a/library/tools/describe.factor b/library/tools/describe.factor index 5c69cb5650..83799be830 100644 --- a/library/tools/describe.factor +++ b/library/tools/describe.factor @@ -79,13 +79,14 @@ DEFER: describe : sheet. ( sheet -- ) dup format-sheet swap peek - [ dup [ describe ] curry simple-outliner ] 2each ; + [ dup [ describe ] curry simple-outliner terpri ] 2each ; : describe ( object -- ) dup summary print sheet sheet. ; : sequence-outliner ( seq quot -- | quot: obj -- ) swap [ - [ unparse-short ] keep rot dupd curry simple-outliner + [ unparse-short ] keep rot dupd curry + simple-outliner terpri ] each-with ; : words. ( vocab -- ) diff --git a/library/ui/panes.factor b/library/ui/panes.factor index 1a415597af..c7d3d754ed 100644 --- a/library/ui/panes.factor +++ b/library/ui/panes.factor @@ -99,10 +99,6 @@ M: pane stream-terpri ( pane -- ) over pane-output add-incremental prepare-line ; -M: pane stream-terpri* ( pane -- ) - dup pane-current gadget-children empty? - [ dup stream-terpri ] unless drop ; - : pane-write ( pane seq -- ) [ over pane-current stream-write ] [ dup stream-terpri ] interleave drop ; @@ -139,11 +135,14 @@ M: pane stream-format ( string style pane -- ) M: pane stream-close ( pane -- ) drop ; +: ?terpri + dup pane-current gadget-children empty? + [ dup stream-terpri ] unless drop ; + : with-pane ( pane quot -- ) #! Clear the pane and run the quotation in a scope with #! stdio set to the pane. - over pane-clear over >r with-stream* - r> stream-terpri* ; inline + over pane-clear over >r with-stream* r> ?terpri ; inline : make-pane ( quot -- pane ) #! Execute the quotation with output to an output-only pane. diff --git a/library/ui/paragraphs.factor b/library/ui/paragraphs.factor index 168afe6425..89c309d572 100644 --- a/library/ui/paragraphs.factor +++ b/library/ui/paragraphs.factor @@ -5,7 +5,8 @@ namespaces sequences ; ! A word break gadget TUPLE: word-break-gadget ; -C: word-break-gadget ( gadget -- gadget ) [ set-delegate ] keep ; +C: word-break-gadget ( gadget -- gadget ) + [ set-delegate ] keep ; ! A gadget that arranges its children in a word-wrap style. TUPLE: paragraph margin ; diff --git a/library/ui/presentations.factor b/library/ui/presentations.factor index d7025b371a..123ab75918 100644 --- a/library/ui/presentations.factor +++ b/library/ui/presentations.factor @@ -5,18 +5,6 @@ USING: arrays gadgets gadgets-borders gadgets-labels gadgets-layouts gadgets-outliner gadgets-panes hashtables io kernel sequences strings styles ; -! Utility pseudo-stream for implementation of panes - -UNION: gadget-stream pack paragraph ; - -M: gadget-stream stream-close ( stream -- ) drop ; - -M: gadget-stream stream-write ( string stream -- ) - over empty? [ 2drop ] [ >r