From 971e84482b26f229d62c64735283cedba0a4592f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 29 Jan 2008 22:18:25 -0800 Subject: [PATCH 01/57] Add no-op parsing support for OpenGL fallback function names --- extra/opengl/gl/gl.factor | 465 ++++++++++++------------- extra/opengl/gl/unix/unix.factor | 9 +- extra/opengl/gl/windows/windows.factor | 1 + 3 files changed, 238 insertions(+), 237 deletions(-) diff --git a/extra/opengl/gl/gl.factor b/extra/opengl/gl/gl.factor index 071fbc45e7..13a6232125 100644 --- a/extra/opengl/gl/gl.factor +++ b/extra/opengl/gl/gl.factor @@ -1123,12 +1123,8 @@ FUNCTION: void glPopName ( ) ; ! OpenGL extension functions - - - ! OpenGL 1.2 - : GL_SMOOTH_POINT_SIZE_RANGE HEX: 0B12 ; inline : GL_SMOOTH_POINT_SIZE_GRANULARITY HEX: 0B13 ; inline : GL_SMOOTH_LINE_WIDTH_RANGE HEX: 0B22 ; inline @@ -1171,10 +1167,10 @@ FUNCTION: void glPopName ( ) ; : GL_ALIASED_POINT_SIZE_RANGE HEX: 846D ; inline : GL_ALIASED_LINE_WIDTH_RANGE HEX: 846E ; inline -GL-FUNCTION: void glCopyTexSubImage3D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLint x, GLint y, GLsizei width, GLsizei height ) ; -GL-FUNCTION: void glDrawRangeElements ( GLenum mode, GLuint start, GLuint end, GLsizei count, GLenum type, GLvoid* indices ) ; -GL-FUNCTION: void glTexImage3D ( GLenum target, GLint level, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLenum format, GLenum type, GLvoid* pixels ) ; -GL-FUNCTION: void glTexSubImage3D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, GLvoid* pixels ) ; +GL-FUNCTION: void glCopyTexSubImage3D { glCopyTexSubImage3DEXT } ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLint x, GLint y, GLsizei width, GLsizei height ) ; +GL-FUNCTION: void glDrawRangeElements { glDrawRangeElementsEXT } ( GLenum mode, GLuint start, GLuint end, GLsizei count, GLenum type, GLvoid* indices ) ; +GL-FUNCTION: void glTexImage3D { glTexImage3DEXT } ( GLenum target, GLint level, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLenum format, GLenum type, GLvoid* pixels ) ; +GL-FUNCTION: void glTexSubImage3D { glTexSubImage3DEXT } ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, GLvoid* pixels ) ; ! OpenGL 1.3 @@ -1277,52 +1273,52 @@ GL-FUNCTION: void glTexSubImage3D ( GLenum target, GLint level, GLint xoffset, G : GL_DOT3_RGBA HEX: 86AF ; inline : GL_MULTISAMPLE_BIT HEX: 20000000 ; inline -GL-FUNCTION: void glActiveTexture ( GLenum texture ) ; -GL-FUNCTION: void glClientActiveTexture ( GLenum texture ) ; -GL-FUNCTION: void glCompressedTexImage1D ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLint border, GLsizei imageSize, GLvoid* data ) ; -GL-FUNCTION: void glCompressedTexImage2D ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLsizei height, GLint border, GLsizei imageSize, GLvoid* data ) ; -GL-FUNCTION: void glCompressedTexImage3D ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLsizei imageSize, GLvoid* data ) ; -GL-FUNCTION: void glCompressedTexSubImage1D ( GLenum target, GLint level, GLint xoffset, GLsizei width, GLenum format, GLsizei imageSize, GLvoid* data ) ; -GL-FUNCTION: void glCompressedTexSubImage2D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLsizei width, GLsizei height, GLenum format, GLsizei imageSize, GLvoid* data ) ; -GL-FUNCTION: void glCompressedTexSubImage3D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLsizei imageSize, GLvoid* data ) ; -GL-FUNCTION: void glGetCompressedTexImage ( GLenum target, GLint lod, GLvoid* img ) ; -GL-FUNCTION: void glLoadTransposeMatrixd ( GLdouble m[16] ) ; -GL-FUNCTION: void glLoadTransposeMatrixf ( GLfloat m[16] ) ; -GL-FUNCTION: void glMultTransposeMatrixd ( GLdouble m[16] ) ; -GL-FUNCTION: void glMultTransposeMatrixf ( GLfloat m[16] ) ; -GL-FUNCTION: void glMultiTexCoord1d ( GLenum target, GLdouble s ) ; -GL-FUNCTION: void glMultiTexCoord1dv ( GLenum target, GLdouble* v ) ; -GL-FUNCTION: void glMultiTexCoord1f ( GLenum target, GLfloat s ) ; -GL-FUNCTION: void glMultiTexCoord1fv ( GLenum target, GLfloat* v ) ; -GL-FUNCTION: void glMultiTexCoord1i ( GLenum target, GLint s ) ; -GL-FUNCTION: void glMultiTexCoord1iv ( GLenum target, GLint* v ) ; -GL-FUNCTION: void glMultiTexCoord1s ( GLenum target, GLshort s ) ; -GL-FUNCTION: void glMultiTexCoord1sv ( GLenum target, GLshort* v ) ; -GL-FUNCTION: void glMultiTexCoord2d ( GLenum target, GLdouble s, GLdouble t ) ; -GL-FUNCTION: void glMultiTexCoord2dv ( GLenum target, GLdouble* v ) ; -GL-FUNCTION: void glMultiTexCoord2f ( GLenum target, GLfloat s, GLfloat t ) ; -GL-FUNCTION: void glMultiTexCoord2fv ( GLenum target, GLfloat* v ) ; -GL-FUNCTION: void glMultiTexCoord2i ( GLenum target, GLint s, GLint t ) ; -GL-FUNCTION: void glMultiTexCoord2iv ( GLenum target, GLint* v ) ; -GL-FUNCTION: void glMultiTexCoord2s ( GLenum target, GLshort s, GLshort t ) ; -GL-FUNCTION: void glMultiTexCoord2sv ( GLenum target, GLshort* v ) ; -GL-FUNCTION: void glMultiTexCoord3d ( GLenum target, GLdouble s, GLdouble t, GLdouble r ) ; -GL-FUNCTION: void glMultiTexCoord3dv ( GLenum target, GLdouble* v ) ; -GL-FUNCTION: void glMultiTexCoord3f ( GLenum target, GLfloat s, GLfloat t, GLfloat r ) ; -GL-FUNCTION: void glMultiTexCoord3fv ( GLenum target, GLfloat* v ) ; -GL-FUNCTION: void glMultiTexCoord3i ( GLenum target, GLint s, GLint t, GLint r ) ; -GL-FUNCTION: void glMultiTexCoord3iv ( GLenum target, GLint* v ) ; -GL-FUNCTION: void glMultiTexCoord3s ( GLenum target, GLshort s, GLshort t, GLshort r ) ; -GL-FUNCTION: void glMultiTexCoord3sv ( GLenum target, GLshort* v ) ; -GL-FUNCTION: void glMultiTexCoord4d ( GLenum target, GLdouble s, GLdouble t, GLdouble r, GLdouble q ) ; -GL-FUNCTION: void glMultiTexCoord4dv ( GLenum target, GLdouble* v ) ; -GL-FUNCTION: void glMultiTexCoord4f ( GLenum target, GLfloat s, GLfloat t, GLfloat r, GLfloat q ) ; -GL-FUNCTION: void glMultiTexCoord4fv ( GLenum target, GLfloat* v ) ; -GL-FUNCTION: void glMultiTexCoord4i ( GLenum target, GLint s, GLint t, GLint r, GLint q ) ; -GL-FUNCTION: void glMultiTexCoord4iv ( GLenum target, GLint* v ) ; -GL-FUNCTION: void glMultiTexCoord4s ( GLenum target, GLshort s, GLshort t, GLshort r, GLshort q ) ; -GL-FUNCTION: void glMultiTexCoord4sv ( GLenum target, GLshort* v ) ; -GL-FUNCTION: void glSampleCoverage ( GLclampf value, GLboolean invert ) ; +GL-FUNCTION: void glActiveTexture { glActiveTextureARB }( GLenum texture ) ; +GL-FUNCTION: void glClientActiveTexture { glClientActiveTextureARB } ( GLenum texture ) ; +GL-FUNCTION: void glCompressedTexImage1D { glCompressedTexImage1DARB } ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLint border, GLsizei imageSize, GLvoid* data ) ; +GL-FUNCTION: void glCompressedTexImage2D { glCompressedTexImage2DARB } ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLsizei height, GLint border, GLsizei imageSize, GLvoid* data ) ; +GL-FUNCTION: void glCompressedTexImage3D { glCompressedTexImage2DARB } ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLsizei imageSize, GLvoid* data ) ; +GL-FUNCTION: void glCompressedTexSubImage1D { glCompressedTexSubImage1DARB } ( GLenum target, GLint level, GLint xoffset, GLsizei width, GLenum format, GLsizei imageSize, GLvoid* data ) ; +GL-FUNCTION: void glCompressedTexSubImage2D { glCompressedTexSubImage2DARB } ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLsizei width, GLsizei height, GLenum format, GLsizei imageSize, GLvoid* data ) ; +GL-FUNCTION: void glCompressedTexSubImage3D { glCompressedTexSubImage3DARB } ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLsizei imageSize, GLvoid* data ) ; +GL-FUNCTION: void glGetCompressedTexImage { glGetCompressedTexImageARB } ( GLenum target, GLint lod, GLvoid* img ) ; +GL-FUNCTION: void glLoadTransposeMatrixd { glLoadTransposeMatrixdARB } ( GLdouble m[16] ) ; +GL-FUNCTION: void glLoadTransposeMatrixf { glLoadTransposeMatrixfARB } ( GLfloat m[16] ) ; +GL-FUNCTION: void glMultTransposeMatrixd { glMultTransposeMatrixdARB } ( GLdouble m[16] ) ; +GL-FUNCTION: void glMultTransposeMatrixf { glMultTransposeMatrixfARB } ( GLfloat m[16] ) ; +GL-FUNCTION: void glMultiTexCoord1d { glMultiTexCoord1dARB } ( GLenum target, GLdouble s ) ; +GL-FUNCTION: void glMultiTexCoord1dv { glMultiTexCoord1dvARB } ( GLenum target, GLdouble* v ) ; +GL-FUNCTION: void glMultiTexCoord1f { glMultiTexCoord1fARB } ( GLenum target, GLfloat s ) ; +GL-FUNCTION: void glMultiTexCoord1fv { glMultiTexCoord1fvARB } ( GLenum target, GLfloat* v ) ; +GL-FUNCTION: void glMultiTexCoord1i { glMultiTexCoord1iARB } ( GLenum target, GLint s ) ; +GL-FUNCTION: void glMultiTexCoord1iv { glMultiTexCoord1ivARB } ( GLenum target, GLint* v ) ; +GL-FUNCTION: void glMultiTexCoord1s { glMultiTexCoord1sARB } ( GLenum target, GLshort s ) ; +GL-FUNCTION: void glMultiTexCoord1sv { glMultiTexCoord1svARB } ( GLenum target, GLshort* v ) ; +GL-FUNCTION: void glMultiTexCoord2d { glMultiTexCoord2dARB } ( GLenum target, GLdouble s, GLdouble t ) ; +GL-FUNCTION: void glMultiTexCoord2dv { glMultiTexCoord2dvARB } ( GLenum target, GLdouble* v ) ; +GL-FUNCTION: void glMultiTexCoord2f { glMultiTexCoord2fARB } ( GLenum target, GLfloat s, GLfloat t ) ; +GL-FUNCTION: void glMultiTexCoord2fv { glMultiTexCoord2fvARB } ( GLenum target, GLfloat* v ) ; +GL-FUNCTION: void glMultiTexCoord2i { glMultiTexCoord2iARB } ( GLenum target, GLint s, GLint t ) ; +GL-FUNCTION: void glMultiTexCoord2iv { glMultiTexCoord2ivARB } ( GLenum target, GLint* v ) ; +GL-FUNCTION: void glMultiTexCoord2s { glMultiTexCoord2sARB } ( GLenum target, GLshort s, GLshort t ) ; +GL-FUNCTION: void glMultiTexCoord2sv { glMultiTexCoord2svARB } ( GLenum target, GLshort* v ) ; +GL-FUNCTION: void glMultiTexCoord3d { glMultiTexCoord3dARB } ( GLenum target, GLdouble s, GLdouble t, GLdouble r ) ; +GL-FUNCTION: void glMultiTexCoord3dv { glMultiTexCoord3dvARB } ( GLenum target, GLdouble* v ) ; +GL-FUNCTION: void glMultiTexCoord3f { glMultiTexCoord3fARB } ( GLenum target, GLfloat s, GLfloat t, GLfloat r ) ; +GL-FUNCTION: void glMultiTexCoord3fv { glMultiTexCoord3fvARB } ( GLenum target, GLfloat* v ) ; +GL-FUNCTION: void glMultiTexCoord3i { glMultiTexCoord3iARB } ( GLenum target, GLint s, GLint t, GLint r ) ; +GL-FUNCTION: void glMultiTexCoord3iv { glMultiTexCoord3ivARB } ( GLenum target, GLint* v ) ; +GL-FUNCTION: void glMultiTexCoord3s { glMultiTexCoord3sARB } ( GLenum target, GLshort s, GLshort t, GLshort r ) ; +GL-FUNCTION: void glMultiTexCoord3sv { glMultiTexCoord3svARB } ( GLenum target, GLshort* v ) ; +GL-FUNCTION: void glMultiTexCoord4d { glMultiTexCoord4dARB } ( GLenum target, GLdouble s, GLdouble t, GLdouble r, GLdouble q ) ; +GL-FUNCTION: void glMultiTexCoord4dv { glMultiTexCoord4dvARB } ( GLenum target, GLdouble* v ) ; +GL-FUNCTION: void glMultiTexCoord4f { glMultiTexCoord4fARB } ( GLenum target, GLfloat s, GLfloat t, GLfloat r, GLfloat q ) ; +GL-FUNCTION: void glMultiTexCoord4fv { glMultiTexCoord4fvARB } ( GLenum target, GLfloat* v ) ; +GL-FUNCTION: void glMultiTexCoord4i { glMultiTexCoord4iARB } ( GLenum target, GLint s, GLint t, GLint r, GLint q ) ; +GL-FUNCTION: void glMultiTexCoord4iv { glMultiTexCoord4ivARB } ( GLenum target, GLint* v ) ; +GL-FUNCTION: void glMultiTexCoord4s { glMultiTexCoord4sARB } ( GLenum target, GLshort s, GLshort t, GLshort r, GLshort q ) ; +GL-FUNCTION: void glMultiTexCoord4sv { glMultiTexCoord4svARB } ( GLenum target, GLshort* v ) ; +GL-FUNCTION: void glSampleCoverage { glSampleCoverageARB } ( GLclampf value, GLboolean invert ) ; ! OpenGL 1.4 @@ -1368,52 +1364,51 @@ GL-FUNCTION: void glSampleCoverage ( GLclampf value, GLboolean invert ) ; : GL_TEXTURE_COMPARE_FUNC HEX: 884D ; inline : GL_COMPARE_R_TO_TEXTURE HEX: 884E ; inline -GL-FUNCTION: void glBlendColor ( GLclampf red, GLclampf green, GLclampf blue, GLclampf alpha ) ; -GL-FUNCTION: void glBlendEquation ( GLenum mode ) ; -GL-FUNCTION: void glBlendFuncSeparate ( GLenum sfactorRGB, GLenum dfactorRGB, GLenum sfactorAlpha, GLenum dfactorAlpha ) ; -GL-FUNCTION: void glFogCoordPointer ( GLenum type, GLsizei stride, GLvoid* pointer ) ; -GL-FUNCTION: void glFogCoordd ( GLdouble coord ) ; -GL-FUNCTION: void glFogCoorddv ( GLdouble* coord ) ; -GL-FUNCTION: void glFogCoordf ( GLfloat coord ) ; -GL-FUNCTION: void glFogCoordfv ( GLfloat* coord ) ; -GL-FUNCTION: void glMultiDrawArrays ( GLenum mode, GLint* first, GLsizei* count, GLsizei primcount ) ; -GL-FUNCTION: void glMultiDrawElements ( GLenum mode, GLsizei* count, GLenum type, GLvoid** indices, GLsizei primcount ) ; -GL-FUNCTION: void glPointParameterf ( GLenum pname, GLfloat param ) ; -GL-FUNCTION: void glPointParameterfv ( GLenum pname, GLfloat* params ) ; -GL-FUNCTION: void glSecondaryColor3b ( GLbyte red, GLbyte green, GLbyte blue ) ; -GL-FUNCTION: void glSecondaryColor3bv ( GLbyte* v ) ; -GL-FUNCTION: void glSecondaryColor3d ( GLdouble red, GLdouble green, GLdouble blue ) ; -GL-FUNCTION: void glSecondaryColor3dv ( GLdouble* v ) ; -GL-FUNCTION: void glSecondaryColor3f ( GLfloat red, GLfloat green, GLfloat blue ) ; -GL-FUNCTION: void glSecondaryColor3fv ( GLfloat* v ) ; -GL-FUNCTION: void glSecondaryColor3i ( GLint red, GLint green, GLint blue ) ; -GL-FUNCTION: void glSecondaryColor3iv ( GLint* v ) ; -GL-FUNCTION: void glSecondaryColor3s ( GLshort red, GLshort green, GLshort blue ) ; -GL-FUNCTION: void glSecondaryColor3sv ( GLshort* v ) ; -GL-FUNCTION: void glSecondaryColor3ub ( GLubyte red, GLubyte green, GLubyte blue ) ; -GL-FUNCTION: void glSecondaryColor3ubv ( GLubyte* v ) ; -GL-FUNCTION: void glSecondaryColor3ui ( GLuint red, GLuint green, GLuint blue ) ; -GL-FUNCTION: void glSecondaryColor3uiv ( GLuint* v ) ; -GL-FUNCTION: void glSecondaryColor3us ( GLushort red, GLushort green, GLushort blue ) ; -GL-FUNCTION: void glSecondaryColor3usv ( GLushort* v ) ; -GL-FUNCTION: void glSecondaryColorPointer ( GLint size, GLenum type, GLsizei stride, GLvoid* pointer ) ; -GL-FUNCTION: void glWindowPos2d ( GLdouble x, GLdouble y ) ; -GL-FUNCTION: void glWindowPos2dv ( GLdouble* p ) ; -GL-FUNCTION: void glWindowPos2f ( GLfloat x, GLfloat y ) ; -GL-FUNCTION: void glWindowPos2fv ( GLfloat* p ) ; -GL-FUNCTION: void glWindowPos2i ( GLint x, GLint y ) ; -GL-FUNCTION: void glWindowPos2iv ( GLint* p ) ; -GL-FUNCTION: void glWindowPos2s ( GLshort x, GLshort y ) ; -GL-FUNCTION: void glWindowPos2sv ( GLshort* p ) ; -GL-FUNCTION: void glWindowPos3d ( GLdouble x, GLdouble y, GLdouble z ) ; -GL-FUNCTION: void glWindowPos3dv ( GLdouble* p ) ; -GL-FUNCTION: void glWindowPos3f ( GLfloat x, GLfloat y, GLfloat z ) ; -GL-FUNCTION: void glWindowPos3fv ( GLfloat* p ) ; -GL-FUNCTION: void glWindowPos3i ( GLint x, GLint y, GLint z ) ; -GL-FUNCTION: void glWindowPos3iv ( GLint* p ) ; -GL-FUNCTION: void glWindowPos3s ( GLshort x, GLshort y, GLshort z ) ; -GL-FUNCTION: void glWindowPos3sv ( GLshort* p ) ; - +GL-FUNCTION: void glBlendColor { glBlendColorEXT } ( GLclampf red, GLclampf green, GLclampf blue, GLclampf alpha ) ; +GL-FUNCTION: void glBlendEquation { glBlendEquationEXT }( GLenum mode ) ; +GL-FUNCTION: void glBlendFuncSeparate { glBlendFuncSeparateEXT } ( GLenum sfactorRGB, GLenum dfactorRGB, GLenum sfactorAlpha, GLenum dfactorAlpha ) ; +GL-FUNCTION: void glFogCoordPointer { glFogCoordPointerEXT } ( GLenum type, GLsizei stride, GLvoid* pointer ) ; +GL-FUNCTION: void glFogCoordd { glFogCoorddEXT } ( GLdouble coord ) ; +GL-FUNCTION: void glFogCoorddv { glFogCoorddvEXT } ( GLdouble* coord ) ; +GL-FUNCTION: void glFogCoordf { glFogCoordfEXT } ( GLfloat coord ) ; +GL-FUNCTION: void glFogCoordfv { glFogCoordfvEXT } ( GLfloat* coord ) ; +GL-FUNCTION: void glMultiDrawArrays { glMultiDrawArraysEXT } ( GLenum mode, GLint* first, GLsizei* count, GLsizei primcount ) ; +GL-FUNCTION: void glMultiDrawElements { glMultiDrawElementsEXT } ( GLenum mode, GLsizei* count, GLenum type, GLvoid** indices, GLsizei primcount ) ; +GL-FUNCTION: void glPointParameterf { glPointParameterfARB } ( GLenum pname, GLfloat param ) ; +GL-FUNCTION: void glPointParameterfv { glPointParameterfvARB } ( GLenum pname, GLfloat* params ) ; +GL-FUNCTION: void glSecondaryColor3b { glSecondaryColor3bEXT } ( GLbyte red, GLbyte green, GLbyte blue ) ; +GL-FUNCTION: void glSecondaryColor3bv { glSecondaryColor3bvEXT } ( GLbyte* v ) ; +GL-FUNCTION: void glSecondaryColor3d { glSecondaryColor3dEXT } ( GLdouble red, GLdouble green, GLdouble blue ) ; +GL-FUNCTION: void glSecondaryColor3dv { glSecondaryColor3dvEXT } ( GLdouble* v ) ; +GL-FUNCTION: void glSecondaryColor3f { glSecondaryColor3fEXT } ( GLfloat red, GLfloat green, GLfloat blue ) ; +GL-FUNCTION: void glSecondaryColor3fv { glSecondaryColor3fvEXT } ( GLfloat* v ) ; +GL-FUNCTION: void glSecondaryColor3i { glSecondaryColor3iEXT } ( GLint red, GLint green, GLint blue ) ; +GL-FUNCTION: void glSecondaryColor3iv { glSecondaryColor3ivEXT } ( GLint* v ) ; +GL-FUNCTION: void glSecondaryColor3s { glSecondaryColor3sEXT } ( GLshort red, GLshort green, GLshort blue ) ; +GL-FUNCTION: void glSecondaryColor3sv { glSecondaryColor3svEXT } ( GLshort* v ) ; +GL-FUNCTION: void glSecondaryColor3ub { glSecondaryColor3ubEXT } ( GLubyte red, GLubyte green, GLubyte blue ) ; +GL-FUNCTION: void glSecondaryColor3ubv { glSecondaryColor3ubvEXT } ( GLubyte* v ) ; +GL-FUNCTION: void glSecondaryColor3ui { glSecondaryColor3uiEXT } ( GLuint red, GLuint green, GLuint blue ) ; +GL-FUNCTION: void glSecondaryColor3uiv { glSecondaryColor3uivEXT } ( GLuint* v ) ; +GL-FUNCTION: void glSecondaryColor3us { glSecondaryColor3usEXT } ( GLushort red, GLushort green, GLushort blue ) ; +GL-FUNCTION: void glSecondaryColor3usv { glSecondaryColor3usvEXT } ( GLushort* v ) ; +GL-FUNCTION: void glSecondaryColorPointer { glSecondaryColorPointerEXT } ( GLint size, GLenum type, GLsizei stride, GLvoid* pointer ) ; +GL-FUNCTION: void glWindowPos2d { glWindowPos2dARB } ( GLdouble x, GLdouble y ) ; +GL-FUNCTION: void glWindowPos2dv { glWindowPos2dvARB } ( GLdouble* p ) ; +GL-FUNCTION: void glWindowPos2f { glWindowPos2fARB } ( GLfloat x, GLfloat y ) ; +GL-FUNCTION: void glWindowPos2fv { glWindowPos2fvARB } ( GLfloat* p ) ; +GL-FUNCTION: void glWindowPos2i { glWindowPos2iARB } ( GLint x, GLint y ) ; +GL-FUNCTION: void glWindowPos2iv { glWindowPos2ivARB } ( GLint* p ) ; +GL-FUNCTION: void glWindowPos2s { glWindowPos2sARB } ( GLshort x, GLshort y ) ; +GL-FUNCTION: void glWindowPos2sv { glWindowPos2svARB } ( GLshort* p ) ; +GL-FUNCTION: void glWindowPos3d { glWindowPos3dARB } ( GLdouble x, GLdouble y, GLdouble z ) ; +GL-FUNCTION: void glWindowPos3dv { glWindowPos3dvARB } ( GLdouble* p ) ; +GL-FUNCTION: void glWindowPos3f { glWindowPos3fARB } ( GLfloat x, GLfloat y, GLfloat z ) ; +GL-FUNCTION: void glWindowPos3fv { glWindowPos3fvARB } ( GLfloat* p ) ; +GL-FUNCTION: void glWindowPos3i { glWindowPos3iARB } ( GLint x, GLint y, GLint z ) ; +GL-FUNCTION: void glWindowPos3iv { glWindowPos3ivARB } ( GLint* p ) ; +GL-FUNCTION: void glWindowPos3s { glWindowPos3sARB } ( GLshort x, GLshort y, GLshort z ) ; +GL-FUNCTION: void glWindowPos3sv { glWindowPos3svARB } ( GLshort* p ) ; ! OpenGL 1.5 @@ -1471,25 +1466,25 @@ GL-FUNCTION: void glWindowPos3sv ( GLshort* p ) ; TYPEDEF: ptrdiff_t GLsizeiptr TYPEDEF: ptrdiff_t GLintptr -GL-FUNCTION: void glBeginQuery ( GLenum target, GLuint id ) ; -GL-FUNCTION: void glBindBuffer ( GLenum target, GLuint buffer ) ; -GL-FUNCTION: void glBufferData ( GLenum target, GLsizeiptr size, GLvoid* data, GLenum usage ) ; -GL-FUNCTION: void glBufferSubData ( GLenum target, GLintptr offset, GLsizeiptr size, GLvoid* data ) ; -GL-FUNCTION: void glDeleteBuffers ( GLsizei n, GLuint* buffers ) ; -GL-FUNCTION: void glDeleteQueries ( GLsizei n, GLuint* ids ) ; -GL-FUNCTION: void glEndQuery ( GLenum target ) ; -GL-FUNCTION: void glGenBuffers ( GLsizei n, GLuint* buffers ) ; -GL-FUNCTION: void glGenQueries ( GLsizei n, GLuint* ids ) ; -GL-FUNCTION: void glGetBufferParameteriv ( GLenum target, GLenum pname, GLint* params ) ; -GL-FUNCTION: void glGetBufferPointerv ( GLenum target, GLenum pname, GLvoid** params ) ; -GL-FUNCTION: void glGetBufferSubData ( GLenum target, GLintptr offset, GLsizeiptr size, GLvoid* data ) ; -GL-FUNCTION: void glGetQueryObjectiv ( GLuint id, GLenum pname, GLint* params ) ; -GL-FUNCTION: void glGetQueryObjectuiv ( GLuint id, GLenum pname, GLuint* params ) ; -GL-FUNCTION: void glGetQueryiv ( GLenum target, GLenum pname, GLint* params ) ; -GL-FUNCTION: GLboolean glIsBuffer ( GLuint buffer ) ; -GL-FUNCTION: GLboolean glIsQuery ( GLuint id ) ; -GL-FUNCTION: GLvoid* glMapBuffer ( GLenum target, GLenum access ) ; -GL-FUNCTION: GLboolean glUnmapBuffer ( GLenum target ) ; +GL-FUNCTION: void glBeginQuery { glBeginQueryARB }( GLenum target, GLuint id ) ; +GL-FUNCTION: void glBindBuffer { glBindBufferARB } ( GLenum target, GLuint buffer ) ; +GL-FUNCTION: void glBufferData { glBufferDataARB } ( GLenum target, GLsizeiptr size, GLvoid* data, GLenum usage ) ; +GL-FUNCTION: void glBufferSubData { glBufferSubDataARB } ( GLenum target, GLintptr offset, GLsizeiptr size, GLvoid* data ) ; +GL-FUNCTION: void glDeleteBuffers { glDeleteBuffersARB } ( GLsizei n, GLuint* buffers ) ; +GL-FUNCTION: void glDeleteQueries { glDeleteQueriesARB } ( GLsizei n, GLuint* ids ) ; +GL-FUNCTION: void glEndQuery { glEndQueryARB } ( GLenum target ) ; +GL-FUNCTION: void glGenBuffers { glGenBuffersARB } ( GLsizei n, GLuint* buffers ) ; +GL-FUNCTION: void glGenQueries { glGenQueriesARB } ( GLsizei n, GLuint* ids ) ; +GL-FUNCTION: void glGetBufferParameteriv { glGetBufferParameterivARB } ( GLenum target, GLenum pname, GLint* params ) ; +GL-FUNCTION: void glGetBufferPointerv { glGetBufferPointervARB } ( GLenum target, GLenum pname, GLvoid** params ) ; +GL-FUNCTION: void glGetBufferSubData { glGetBufferSubDataARB } ( GLenum target, GLintptr offset, GLsizeiptr size, GLvoid* data ) ; +GL-FUNCTION: void glGetQueryObjectiv { glGetQueryObjectivARB } ( GLuint id, GLenum pname, GLint* params ) ; +GL-FUNCTION: void glGetQueryObjectuiv { glGetQueryObjectuivARB } ( GLuint id, GLenum pname, GLuint* params ) ; +GL-FUNCTION: void glGetQueryiv { glGetQueryivARB } ( GLenum target, GLenum pname, GLint* params ) ; +GL-FUNCTION: GLboolean glIsBuffer { glIsBufferARB } ( GLuint buffer ) ; +GL-FUNCTION: GLboolean glIsQuery { glIsQueryARB } ( GLuint id ) ; +GL-FUNCTION: GLvoid* glMapBuffer { glMapBufferARB } ( GLenum target, GLenum access ) ; +GL-FUNCTION: GLboolean glUnmapBuffer { glUnmapBufferARB } ( GLenum target ) ; ! OpenGL 2.0 @@ -1583,99 +1578,99 @@ GL-FUNCTION: GLboolean glUnmapBuffer ( GLenum target ) ; TYPEDEF: char GLchar -GL-FUNCTION: void glAttachShader ( GLuint program, GLuint shader ) ; -GL-FUNCTION: void glBindAttribLocation ( GLuint program, GLuint index, GLchar* name ) ; -GL-FUNCTION: void glBlendEquationSeparate ( GLenum modeRGB, GLenum modeAlpha ) ; -GL-FUNCTION: void glCompileShader ( GLuint shader ) ; -GL-FUNCTION: GLuint glCreateProgram ( ) ; -GL-FUNCTION: GLuint glCreateShader ( GLenum type ) ; -GL-FUNCTION: void glDeleteProgram ( GLuint program ) ; -GL-FUNCTION: void glDeleteShader ( GLuint shader ) ; -GL-FUNCTION: void glDetachShader ( GLuint program, GLuint shader ) ; -GL-FUNCTION: void glDisableVertexAttribArray ( GLuint index ) ; -GL-FUNCTION: void glDrawBuffers ( GLsizei n, GLenum* bufs ) ; -GL-FUNCTION: void glEnableVertexAttribArray ( GLuint index ) ; -GL-FUNCTION: void glGetActiveAttrib ( GLuint program, GLuint index, GLsizei maxLength, GLsizei* length, GLint* size, GLenum* type, GLchar* name ) ; -GL-FUNCTION: void glGetActiveUniform ( GLuint program, GLuint index, GLsizei maxLength, GLsizei* length, GLint* size, GLenum* type, GLchar* name ) ; -GL-FUNCTION: void glGetAttachedShaders ( GLuint program, GLsizei maxCount, GLsizei* count, GLuint* shaders ) ; -GL-FUNCTION: GLint glGetAttribLocation ( GLuint program, GLchar* name ) ; -GL-FUNCTION: void glGetProgramInfoLog ( GLuint program, GLsizei bufSize, GLsizei* length, GLchar* infoLog ) ; -GL-FUNCTION: void glGetProgramiv ( GLuint program, GLenum pname, GLint* param ) ; -GL-FUNCTION: void glGetShaderInfoLog ( GLuint shader, GLsizei bufSize, GLsizei* length, GLchar* infoLog ) ; -GL-FUNCTION: void glGetShaderSource ( GLint obj, GLsizei maxLength, GLsizei* length, GLchar* source ) ; -GL-FUNCTION: void glGetShaderiv ( GLuint shader, GLenum pname, GLint* param ) ; -GL-FUNCTION: GLint glGetUniformLocation ( GLint programObj, GLchar* name ) ; -GL-FUNCTION: void glGetUniformfv ( GLuint program, GLint location, GLfloat* params ) ; -GL-FUNCTION: void glGetUniformiv ( GLuint program, GLint location, GLint* params ) ; -GL-FUNCTION: void glGetVertexAttribPointerv ( GLuint index, GLenum pname, GLvoid** pointer ) ; -GL-FUNCTION: void glGetVertexAttribdv ( GLuint index, GLenum pname, GLdouble* params ) ; -GL-FUNCTION: void glGetVertexAttribfv ( GLuint index, GLenum pname, GLfloat* params ) ; -GL-FUNCTION: void glGetVertexAttribiv ( GLuint index, GLenum pname, GLint* params ) ; -GL-FUNCTION: GLboolean glIsProgram ( GLuint program ) ; -GL-FUNCTION: GLboolean glIsShader ( GLuint shader ) ; -GL-FUNCTION: void glLinkProgram ( GLuint program ) ; -GL-FUNCTION: void glShaderSource ( GLuint shader, GLsizei count, GLchar** strings, GLint* lengths ) ; -GL-FUNCTION: void glStencilFuncSeparate ( GLenum frontfunc, GLenum backfunc, GLint ref, GLuint mask ) ; -GL-FUNCTION: void glStencilMaskSeparate ( GLenum face, GLuint mask ) ; -GL-FUNCTION: void glStencilOpSeparate ( GLenum face, GLenum sfail, GLenum dpfail, GLenum dppass ) ; -GL-FUNCTION: void glUniform1f ( GLint location, GLfloat v0 ) ; -GL-FUNCTION: void glUniform1fv ( GLint location, GLsizei count, GLfloat* value ) ; -GL-FUNCTION: void glUniform1i ( GLint location, GLint v0 ) ; -GL-FUNCTION: void glUniform1iv ( GLint location, GLsizei count, GLint* value ) ; -GL-FUNCTION: void glUniform2f ( GLint location, GLfloat v0, GLfloat v1 ) ; -GL-FUNCTION: void glUniform2fv ( GLint location, GLsizei count, GLfloat* value ) ; -GL-FUNCTION: void glUniform2i ( GLint location, GLint v0, GLint v1 ) ; -GL-FUNCTION: void glUniform2iv ( GLint location, GLsizei count, GLint* value ) ; -GL-FUNCTION: void glUniform3f ( GLint location, GLfloat v0, GLfloat v1, GLfloat v2 ) ; -GL-FUNCTION: void glUniform3fv ( GLint location, GLsizei count, GLfloat* value ) ; -GL-FUNCTION: void glUniform3i ( GLint location, GLint v0, GLint v1, GLint v2 ) ; -GL-FUNCTION: void glUniform3iv ( GLint location, GLsizei count, GLint* value ) ; -GL-FUNCTION: void glUniform4f ( GLint location, GLfloat v0, GLfloat v1, GLfloat v2, GLfloat v3 ) ; -GL-FUNCTION: void glUniform4fv ( GLint location, GLsizei count, GLfloat* value ) ; -GL-FUNCTION: void glUniform4i ( GLint location, GLint v0, GLint v1, GLint v2, GLint v3 ) ; -GL-FUNCTION: void glUniform4iv ( GLint location, GLsizei count, GLint* value ) ; -GL-FUNCTION: void glUniformMatrix2fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; -GL-FUNCTION: void glUniformMatrix3fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; -GL-FUNCTION: void glUniformMatrix4fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; -GL-FUNCTION: void glUseProgram ( GLuint program ) ; -GL-FUNCTION: void glValidateProgram ( GLuint program ) ; -GL-FUNCTION: void glVertexAttrib1d ( GLuint index, GLdouble x ) ; -GL-FUNCTION: void glVertexAttrib1dv ( GLuint index, GLdouble* v ) ; -GL-FUNCTION: void glVertexAttrib1f ( GLuint index, GLfloat x ) ; -GL-FUNCTION: void glVertexAttrib1fv ( GLuint index, GLfloat* v ) ; -GL-FUNCTION: void glVertexAttrib1s ( GLuint index, GLshort x ) ; -GL-FUNCTION: void glVertexAttrib1sv ( GLuint index, GLshort* v ) ; -GL-FUNCTION: void glVertexAttrib2d ( GLuint index, GLdouble x, GLdouble y ) ; -GL-FUNCTION: void glVertexAttrib2dv ( GLuint index, GLdouble* v ) ; -GL-FUNCTION: void glVertexAttrib2f ( GLuint index, GLfloat x, GLfloat y ) ; -GL-FUNCTION: void glVertexAttrib2fv ( GLuint index, GLfloat* v ) ; -GL-FUNCTION: void glVertexAttrib2s ( GLuint index, GLshort x, GLshort y ) ; -GL-FUNCTION: void glVertexAttrib2sv ( GLuint index, GLshort* v ) ; -GL-FUNCTION: void glVertexAttrib3d ( GLuint index, GLdouble x, GLdouble y, GLdouble z ) ; -GL-FUNCTION: void glVertexAttrib3dv ( GLuint index, GLdouble* v ) ; -GL-FUNCTION: void glVertexAttrib3f ( GLuint index, GLfloat x, GLfloat y, GLfloat z ) ; -GL-FUNCTION: void glVertexAttrib3fv ( GLuint index, GLfloat* v ) ; -GL-FUNCTION: void glVertexAttrib3s ( GLuint index, GLshort x, GLshort y, GLshort z ) ; -GL-FUNCTION: void glVertexAttrib3sv ( GLuint index, GLshort* v ) ; -GL-FUNCTION: void glVertexAttrib4Nbv ( GLuint index, GLbyte* v ) ; -GL-FUNCTION: void glVertexAttrib4Niv ( GLuint index, GLint* v ) ; -GL-FUNCTION: void glVertexAttrib4Nsv ( GLuint index, GLshort* v ) ; -GL-FUNCTION: void glVertexAttrib4Nub ( GLuint index, GLubyte x, GLubyte y, GLubyte z, GLubyte w ) ; -GL-FUNCTION: void glVertexAttrib4Nubv ( GLuint index, GLubyte* v ) ; -GL-FUNCTION: void glVertexAttrib4Nuiv ( GLuint index, GLuint* v ) ; -GL-FUNCTION: void glVertexAttrib4Nusv ( GLuint index, GLushort* v ) ; -GL-FUNCTION: void glVertexAttrib4bv ( GLuint index, GLbyte* v ) ; -GL-FUNCTION: void glVertexAttrib4d ( GLuint index, GLdouble x, GLdouble y, GLdouble z, GLdouble w ) ; -GL-FUNCTION: void glVertexAttrib4dv ( GLuint index, GLdouble* v ) ; -GL-FUNCTION: void glVertexAttrib4f ( GLuint index, GLfloat x, GLfloat y, GLfloat z, GLfloat w ) ; -GL-FUNCTION: void glVertexAttrib4fv ( GLuint index, GLfloat* v ) ; -GL-FUNCTION: void glVertexAttrib4iv ( GLuint index, GLint* v ) ; -GL-FUNCTION: void glVertexAttrib4s ( GLuint index, GLshort x, GLshort y, GLshort z, GLshort w ) ; -GL-FUNCTION: void glVertexAttrib4sv ( GLuint index, GLshort* v ) ; -GL-FUNCTION: void glVertexAttrib4ubv ( GLuint index, GLubyte* v ) ; -GL-FUNCTION: void glVertexAttrib4uiv ( GLuint index, GLuint* v ) ; -GL-FUNCTION: void glVertexAttrib4usv ( GLuint index, GLushort* v ) ; -GL-FUNCTION: void glVertexAttribPointer ( GLuint index, GLint size, GLenum type, GLboolean normalized, GLsizei stride, GLvoid* pointer ) ; +GL-FUNCTION: void glAttachShader { glAttachObjectARB } ( GLuint program, GLuint shader ) ; +GL-FUNCTION: void glBindAttribLocation { glBindAttribLocationARB } ( GLuint program, GLuint index, GLchar* name ) ; +GL-FUNCTION: void glBlendEquationSeparate { glBlendEquationSeparateEXT } ( GLenum modeRGB, GLenum modeAlpha ) ; +GL-FUNCTION: void glCompileShader { glCompileShaderARB } ( GLuint shader ) ; +GL-FUNCTION: GLuint glCreateProgram { glCreateProgramObjectARB } ( ) ; +GL-FUNCTION: GLuint glCreateShader { glCreateShaderObjectARB } ( GLenum type ) ; +GL-FUNCTION: void glDeleteProgram { glDeleteObjectARB } ( GLuint program ) ; +GL-FUNCTION: void glDeleteShader { glDeleteObjectARB } ( GLuint shader ) ; +GL-FUNCTION: void glDetachShader { glDetachObjectARB } ( GLuint program, GLuint shader ) ; +GL-FUNCTION: void glDisableVertexAttribArray { glDisableVertexAttribArrayARB } ( GLuint index ) ; +GL-FUNCTION: void glDrawBuffers { glDrawBuffersARB glDrawBuffersATI } ( GLsizei n, GLenum* bufs ) ; +GL-FUNCTION: void glEnableVertexAttribArray { glEnableVertexAttribArrayARB } ( GLuint index ) ; +GL-FUNCTION: void glGetActiveAttrib { glGetActiveAttribARB } ( GLuint program, GLuint index, GLsizei maxLength, GLsizei* length, GLint* size, GLenum* type, GLchar* name ) ; +GL-FUNCTION: void glGetActiveUniform { glGetActiveUniformARB } ( GLuint program, GLuint index, GLsizei maxLength, GLsizei* length, GLint* size, GLenum* type, GLchar* name ) ; +GL-FUNCTION: void glGetAttachedShaders { glGetAttachedObjectsARB } ( GLuint program, GLsizei maxCount, GLsizei* count, GLuint* shaders ) ; +GL-FUNCTION: GLint glGetAttribLocation { glGetAttribLocationARB } ( GLuint program, GLchar* name ) ; +GL-FUNCTION: void glGetProgramInfoLog { glGetInfoLogARB } ( GLuint program, GLsizei bufSize, GLsizei* length, GLchar* infoLog ) ; +GL-FUNCTION: void glGetProgramiv { glGetObjectParameterivARB } ( GLuint program, GLenum pname, GLint* param ) ; +GL-FUNCTION: void glGetShaderInfoLog { glGetInfoLogARB } ( GLuint shader, GLsizei bufSize, GLsizei* length, GLchar* infoLog ) ; +GL-FUNCTION: void glGetShaderSource { glGetShaderSourceARB } ( GLint obj, GLsizei maxLength, GLsizei* length, GLchar* source ) ; +GL-FUNCTION: void glGetShaderiv { glGetObjectParameterivARB } ( GLuint shader, GLenum pname, GLint* param ) ; +GL-FUNCTION: GLint glGetUniformLocation { glGetUniformLocationARB } ( GLint programObj, GLchar* name ) ; +GL-FUNCTION: void glGetUniformfv { glGetUniformfvARB } ( GLuint program, GLint location, GLfloat* params ) ; +GL-FUNCTION: void glGetUniformiv { glGetUniformivARB } ( GLuint program, GLint location, GLint* params ) ; +GL-FUNCTION: void glGetVertexAttribPointerv { glGetVertexAttribPointervARB } ( GLuint index, GLenum pname, GLvoid** pointer ) ; +GL-FUNCTION: void glGetVertexAttribdv { glGetVertexAttribdvARB } ( GLuint index, GLenum pname, GLdouble* params ) ; +GL-FUNCTION: void glGetVertexAttribfv { glGetVertexAttribfvARB } ( GLuint index, GLenum pname, GLfloat* params ) ; +GL-FUNCTION: void glGetVertexAttribiv { glGetVertexAttribivARB } ( GLuint index, GLenum pname, GLint* params ) ; +GL-FUNCTION: GLboolean glIsProgram { glIsProgramARB } ( GLuint program ) ; +GL-FUNCTION: GLboolean glIsShader { glIsShaderARB }( GLuint shader ) ; +GL-FUNCTION: void glLinkProgram { glLinkProgramARB } ( GLuint program ) ; +GL-FUNCTION: void glShaderSource { glShaderSourceARB } ( GLuint shader, GLsizei count, GLchar** strings, GLint* lengths ) ; +GL-FUNCTION: void glStencilFuncSeparate { glStencilFuncSeparateATI } ( GLenum frontfunc, GLenum backfunc, GLint ref, GLuint mask ) ; +GL-FUNCTION: void glStencilMaskSeparate { } ( GLenum face, GLuint mask ) ; +GL-FUNCTION: void glStencilOpSeparate { glStencilOpSeparateATI } ( GLenum face, GLenum sfail, GLenum dpfail, GLenum dppass ) ; +GL-FUNCTION: void glUniform1f { glUniform1fARB } ( GLint location, GLfloat v0 ) ; +GL-FUNCTION: void glUniform1fv { glUniform1fvARB } ( GLint location, GLsizei count, GLfloat* value ) ; +GL-FUNCTION: void glUniform1i { glUniform1iARB } ( GLint location, GLint v0 ) ; +GL-FUNCTION: void glUniform1iv { glUniform1ivARB } ( GLint location, GLsizei count, GLint* value ) ; +GL-FUNCTION: void glUniform2f { glUniform2fARB } ( GLint location, GLfloat v0, GLfloat v1 ) ; +GL-FUNCTION: void glUniform2fv { glUniform2fvARB } ( GLint location, GLsizei count, GLfloat* value ) ; +GL-FUNCTION: void glUniform2i { glUniform2iARB } ( GLint location, GLint v0, GLint v1 ) ; +GL-FUNCTION: void glUniform2iv { glUniform2ivARB } ( GLint location, GLsizei count, GLint* value ) ; +GL-FUNCTION: void glUniform3f { glUniform3fARB } ( GLint location, GLfloat v0, GLfloat v1, GLfloat v2 ) ; +GL-FUNCTION: void glUniform3fv { glUniform3fvARB } ( GLint location, GLsizei count, GLfloat* value ) ; +GL-FUNCTION: void glUniform3i { glUniform3iARB } ( GLint location, GLint v0, GLint v1, GLint v2 ) ; +GL-FUNCTION: void glUniform3iv { glUniform3ivARB } ( GLint location, GLsizei count, GLint* value ) ; +GL-FUNCTION: void glUniform4f { glUniform4fARB } ( GLint location, GLfloat v0, GLfloat v1, GLfloat v2, GLfloat v3 ) ; +GL-FUNCTION: void glUniform4fv { glUniform4fvARB } ( GLint location, GLsizei count, GLfloat* value ) ; +GL-FUNCTION: void glUniform4i { glUniform4iARB } ( GLint location, GLint v0, GLint v1, GLint v2, GLint v3 ) ; +GL-FUNCTION: void glUniform4iv { glUniform4ivARB } ( GLint location, GLsizei count, GLint* value ) ; +GL-FUNCTION: void glUniformMatrix2fv { glUniformMatrix2fvARB } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUniformMatrix3fv { glUniformMatrix3fvARB } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUniformMatrix4fv { glUniformMatrix4fvARB } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUseProgram { glUseProgramObjectARB } ( GLuint program ) ; +GL-FUNCTION: void glValidateProgram { glValidateProgramARB } ( GLuint program ) ; +GL-FUNCTION: void glVertexAttrib1d { glVertexAttrib1dARB } ( GLuint index, GLdouble x ) ; +GL-FUNCTION: void glVertexAttrib1dv { glVertexAttrib1dvARB } ( GLuint index, GLdouble* v ) ; +GL-FUNCTION: void glVertexAttrib1f { glVertexAttrib1fARB } ( GLuint index, GLfloat x ) ; +GL-FUNCTION: void glVertexAttrib1fv { glVertexAttrib1fvARB } ( GLuint index, GLfloat* v ) ; +GL-FUNCTION: void glVertexAttrib1s { glVertexAttrib1sARB } ( GLuint index, GLshort x ) ; +GL-FUNCTION: void glVertexAttrib1sv { glVertexAttrib1svARB } ( GLuint index, GLshort* v ) ; +GL-FUNCTION: void glVertexAttrib2d { glVertexAttrib2dARB } ( GLuint index, GLdouble x, GLdouble y ) ; +GL-FUNCTION: void glVertexAttrib2dv { glVertexAttrib2dvARB } ( GLuint index, GLdouble* v ) ; +GL-FUNCTION: void glVertexAttrib2f { glVertexAttrib2fARB } ( GLuint index, GLfloat x, GLfloat y ) ; +GL-FUNCTION: void glVertexAttrib2fv { glVertexAttrib2fvARB } ( GLuint index, GLfloat* v ) ; +GL-FUNCTION: void glVertexAttrib2s { glVertexAttrib2sARB } ( GLuint index, GLshort x, GLshort y ) ; +GL-FUNCTION: void glVertexAttrib2sv { glVertexAttrib2svARB } ( GLuint index, GLshort* v ) ; +GL-FUNCTION: void glVertexAttrib3d { glVertexAttrib3dARB } ( GLuint index, GLdouble x, GLdouble y, GLdouble z ) ; +GL-FUNCTION: void glVertexAttrib3dv { glVertexAttrib3dvARB } ( GLuint index, GLdouble* v ) ; +GL-FUNCTION: void glVertexAttrib3f { glVertexAttrib3fARB } ( GLuint index, GLfloat x, GLfloat y, GLfloat z ) ; +GL-FUNCTION: void glVertexAttrib3fv { glVertexAttrib3fvARB } ( GLuint index, GLfloat* v ) ; +GL-FUNCTION: void glVertexAttrib3s { glVertexAttrib3sARB } ( GLuint index, GLshort x, GLshort y, GLshort z ) ; +GL-FUNCTION: void glVertexAttrib3sv { glVertexAttrib3svARB } ( GLuint index, GLshort* v ) ; +GL-FUNCTION: void glVertexAttrib4Nbv { glVertexAttrib4NbvARB } ( GLuint index, GLbyte* v ) ; +GL-FUNCTION: void glVertexAttrib4Niv { glVertexAttrib4NivARB } ( GLuint index, GLint* v ) ; +GL-FUNCTION: void glVertexAttrib4Nsv { glVertexAttrib4NsvARB } ( GLuint index, GLshort* v ) ; +GL-FUNCTION: void glVertexAttrib4Nub { glVertexAttrib4NubARB } ( GLuint index, GLubyte x, GLubyte y, GLubyte z, GLubyte w ) ; +GL-FUNCTION: void glVertexAttrib4Nubv { glVertexAttrib4NubvARB } ( GLuint index, GLubyte* v ) ; +GL-FUNCTION: void glVertexAttrib4Nuiv { glVertexAttrib4NuivARB } ( GLuint index, GLuint* v ) ; +GL-FUNCTION: void glVertexAttrib4Nusv { glVertexAttrib4NusvARB } ( GLuint index, GLushort* v ) ; +GL-FUNCTION: void glVertexAttrib4bv { glVertexAttrib4bvARB } ( GLuint index, GLbyte* v ) ; +GL-FUNCTION: void glVertexAttrib4d { glVertexAttrib4dARB } ( GLuint index, GLdouble x, GLdouble y, GLdouble z, GLdouble w ) ; +GL-FUNCTION: void glVertexAttrib4dv { glVertexAttrib4dvARB } ( GLuint index, GLdouble* v ) ; +GL-FUNCTION: void glVertexAttrib4f { glVertexAttrib4fARB } ( GLuint index, GLfloat x, GLfloat y, GLfloat z, GLfloat w ) ; +GL-FUNCTION: void glVertexAttrib4fv { glVertexAttrib4fvARB } ( GLuint index, GLfloat* v ) ; +GL-FUNCTION: void glVertexAttrib4iv { glVertexAttrib4ivARB } ( GLuint index, GLint* v ) ; +GL-FUNCTION: void glVertexAttrib4s { glVertexAttrib4sARB } ( GLuint index, GLshort x, GLshort y, GLshort z, GLshort w ) ; +GL-FUNCTION: void glVertexAttrib4sv { glVertexAttrib4svARB } ( GLuint index, GLshort* v ) ; +GL-FUNCTION: void glVertexAttrib4ubv { glVertexAttrib4ubvARB } ( GLuint index, GLubyte* v ) ; +GL-FUNCTION: void glVertexAttrib4uiv { glVertexAttrib4uivARB } ( GLuint index, GLuint* v ) ; +GL-FUNCTION: void glVertexAttrib4usv { glVertexAttrib4usvARB } ( GLuint index, GLushort* v ) ; +GL-FUNCTION: void glVertexAttribPointer { glVertexAttribPointerARB } ( GLuint index, GLint size, GLenum type, GLboolean normalized, GLsizei stride, GLvoid* pointer ) ; ! OpenGL 2.1 @@ -1699,12 +1694,12 @@ GL-FUNCTION: void glVertexAttribPointer ( GLuint index, GLint size, GLenum type, : GL_COMPRESSED_SLUMINANCE HEX: 8C4A ; inline : GL_COMPRESSED_SLUMINANCE_ALPHA HEX: 8C4B ; inline -GL-FUNCTION: void glUniformMatrix2x3fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; -GL-FUNCTION: void glUniformMatrix2x4fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; -GL-FUNCTION: void glUniformMatrix3x2fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; -GL-FUNCTION: void glUniformMatrix3x4fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; -GL-FUNCTION: void glUniformMatrix4x2fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; -GL-FUNCTION: void glUniformMatrix4x3fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUniformMatrix2x3fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUniformMatrix2x4fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUniformMatrix3x2fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUniformMatrix3x4fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUniformMatrix4x2fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUniformMatrix4x3fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; ! GL_EXT_framebuffer_object @@ -1762,23 +1757,23 @@ GL-FUNCTION: void glUniformMatrix4x3fv ( GLint location, GLsizei count, GLboolea : GL_RENDERBUFFER_DEPTH_SIZE_EXT HEX: 8D54 ; inline : GL_RENDERBUFFER_STENCIL_SIZE_EXT HEX: 8D55 ; inline -GL-FUNCTION: void glBindFramebufferEXT ( GLenum target, GLuint framebuffer ) ; -GL-FUNCTION: void glBindRenderbufferEXT ( GLenum target, GLuint renderbuffer ) ; -GL-FUNCTION: GLenum glCheckFramebufferStatusEXT ( GLenum target ) ; -GL-FUNCTION: void glDeleteFramebuffersEXT ( GLsizei n, GLuint* framebuffers ) ; -GL-FUNCTION: void glDeleteRenderbuffersEXT ( GLsizei n, GLuint* renderbuffers ) ; -GL-FUNCTION: void glFramebufferRenderbufferEXT ( GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer ) ; -GL-FUNCTION: void glFramebufferTexture1DEXT ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ; -GL-FUNCTION: void glFramebufferTexture2DEXT ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ; -GL-FUNCTION: void glFramebufferTexture3DEXT ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level, GLint zoffset ) ; -GL-FUNCTION: void glGenFramebuffersEXT ( GLsizei n, GLuint* framebuffers ) ; -GL-FUNCTION: void glGenRenderbuffersEXT ( GLsizei n, GLuint* renderbuffers ) ; -GL-FUNCTION: void glGenerateMipmapEXT ( GLenum target ) ; -GL-FUNCTION: void glGetFramebufferAttachmentParameterivEXT ( GLenum target, GLenum attachment, GLenum pname, GLint* params ) ; -GL-FUNCTION: void glGetRenderbufferParameterivEXT ( GLenum target, GLenum pname, GLint* params ) ; -GL-FUNCTION: GLboolean glIsFramebufferEXT ( GLuint framebuffer ) ; -GL-FUNCTION: GLboolean glIsRenderbufferEXT ( GLuint renderbuffer ) ; -GL-FUNCTION: void glRenderbufferStorageEXT ( GLenum target, GLenum internalformat, GLsizei width, GLsizei height ) ; +GL-FUNCTION: void glBindFramebufferEXT { } ( GLenum target, GLuint framebuffer ) ; +GL-FUNCTION: void glBindRenderbufferEXT { } ( GLenum target, GLuint renderbuffer ) ; +GL-FUNCTION: GLenum glCheckFramebufferStatusEXT { } ( GLenum target ) ; +GL-FUNCTION: void glDeleteFramebuffersEXT { } ( GLsizei n, GLuint* framebuffers ) ; +GL-FUNCTION: void glDeleteRenderbuffersEXT { } ( GLsizei n, GLuint* renderbuffers ) ; +GL-FUNCTION: void glFramebufferRenderbufferEXT { } ( GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer ) ; +GL-FUNCTION: void glFramebufferTexture1DEXT { } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ; +GL-FUNCTION: void glFramebufferTexture2DEXT { } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ; +GL-FUNCTION: void glFramebufferTexture3DEXT { } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level, GLint zoffset ) ; +GL-FUNCTION: void glGenFramebuffersEXT { } ( GLsizei n, GLuint* framebuffers ) ; +GL-FUNCTION: void glGenRenderbuffersEXT { } ( GLsizei n, GLuint* renderbuffers ) ; +GL-FUNCTION: void glGenerateMipmapEXT { } ( GLenum target ) ; +GL-FUNCTION: void glGetFramebufferAttachmentParameterivEXT { } ( GLenum target, GLenum attachment, GLenum pname, GLint* params ) ; +GL-FUNCTION: void glGetRenderbufferParameterivEXT { } ( GLenum target, GLenum pname, GLint* params ) ; +GL-FUNCTION: GLboolean glIsFramebufferEXT { } ( GLuint framebuffer ) ; +GL-FUNCTION: GLboolean glIsRenderbufferEXT { } ( GLuint renderbuffer ) ; +GL-FUNCTION: void glRenderbufferStorageEXT { } ( GLenum target, GLenum internalformat, GLsizei width, GLsizei height ) ; ! GL_ARB_texture_float diff --git a/extra/opengl/gl/unix/unix.factor b/extra/opengl/gl/unix/unix.factor index 16cd38f92f..2ee4558a5e 100644 --- a/extra/opengl/gl/unix/unix.factor +++ b/extra/opengl/gl/unix/unix.factor @@ -1,5 +1,10 @@ -USING: alien.syntax kernel syntax words ; +USING: alien.syntax alien.syntax.private kernel + namespaces parser sequences syntax words ; IN: opengl.gl.unix -: GL-FUNCTION: POSTPONE: FUNCTION: ; parsing +: GL-FUNCTION: + scan "c-library" get scan + scan drop "}" parse-tokens drop + ";" parse-tokens [ "()" subseq? not ] subset + define-function ; parsing diff --git a/extra/opengl/gl/windows/windows.factor b/extra/opengl/gl/windows/windows.factor index 186f17206c..fc0bca00bb 100755 --- a/extra/opengl/gl/windows/windows.factor +++ b/extra/opengl/gl/windows/windows.factor @@ -29,6 +29,7 @@ PRIVATE> scan scan dup gl-function-number [ gl-function-pointer ] 2curry swap + scan drop "}" parse-tokens drop ";" parse-tokens [ "()" subseq? not ] subset define-indirect ; parsing From 0c1b63c5f2f06880cc6ddfad1ecc4f1487e7bb28 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 4 Feb 2008 17:42:35 -0800 Subject: [PATCH 02/57] Fix typo in the float-vector docs --- core/float-vectors/float-vectors-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/float-vectors/float-vectors-docs.factor b/core/float-vectors/float-vectors-docs.factor index f0901fd46f..ef0645a0af 100755 --- a/core/float-vectors/float-vectors-docs.factor +++ b/core/float-vectors/float-vectors-docs.factor @@ -12,7 +12,7 @@ $nl { $subsection >float-vector } { $subsection } "If you don't care about initial capacity, a more elegant way to create a new float vector is to write:" -{ $code "BV{ } clone" } ; +{ $code "FV{ } clone" } ; ABOUT: "float-vectors" From a4a3ea3fa47defbf5de013dc9e27bced28f54c5c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 7 Feb 2008 22:24:51 -0800 Subject: [PATCH 03/57] Fix typos in opengl fallback function lists --- extra/opengl/gl/gl.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/opengl/gl/gl.factor b/extra/opengl/gl/gl.factor index f2de019348..5b3dade851 100644 --- a/extra/opengl/gl/gl.factor +++ b/extra/opengl/gl/gl.factor @@ -1365,7 +1365,7 @@ GL-FUNCTION: void glSampleCoverage { glSampleCoverageARB } ( GLclampf value, GLb : GL_COMPARE_R_TO_TEXTURE HEX: 884E ; inline GL-FUNCTION: void glBlendColor { glBlendColorEXT } ( GLclampf red, GLclampf green, GLclampf blue, GLclampf alpha ) ; -GL-FUNCTION: void glBlendEquation { glBlendEquationEXT }( GLenum mode ) ; +GL-FUNCTION: void glBlendEquation { glBlendEquationEXT } ( GLenum mode ) ; GL-FUNCTION: void glBlendFuncSeparate { glBlendFuncSeparateEXT } ( GLenum sfactorRGB, GLenum dfactorRGB, GLenum sfactorAlpha, GLenum dfactorAlpha ) ; GL-FUNCTION: void glFogCoordPointer { glFogCoordPointerEXT } ( GLenum type, GLsizei stride, GLvoid* pointer ) ; GL-FUNCTION: void glFogCoordd { glFogCoorddEXT } ( GLdouble coord ) ; @@ -1466,7 +1466,7 @@ GL-FUNCTION: void glWindowPos3sv { glWindowPos3svARB } ( GLshort* p ) ; TYPEDEF: ptrdiff_t GLsizeiptr TYPEDEF: ptrdiff_t GLintptr -GL-FUNCTION: void glBeginQuery { glBeginQueryARB }( GLenum target, GLuint id ) ; +GL-FUNCTION: void glBeginQuery { glBeginQueryARB } ( GLenum target, GLuint id ) ; GL-FUNCTION: void glBindBuffer { glBindBufferARB } ( GLenum target, GLuint buffer ) ; GL-FUNCTION: void glBufferData { glBufferDataARB } ( GLenum target, GLsizeiptr size, GLvoid* data, GLenum usage ) ; GL-FUNCTION: void glBufferSubData { glBufferSubDataARB } ( GLenum target, GLintptr offset, GLsizeiptr size, GLvoid* data ) ; From c906d26b131882a8d6826216c320b8b834681da0 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 7 Feb 2008 22:43:05 -0800 Subject: [PATCH 04/57] Do dynamic lookup of OpenGL 1.2+ functions on all platforms. Use fallback extension names when the official name is not available, e.g., if glUseProgram is missing try glUseProgramObjectARB instead --- extra/hash2/hash2-docs.factor | 2 +- extra/opengl/gl/extensions/extensions.factor | 46 ++++++++++++++++++++ extra/opengl/gl/gl.factor | 12 +++-- extra/opengl/gl/macosx/macosx.factor | 6 +++ extra/opengl/gl/unix/unix.factor | 12 ++--- extra/opengl/gl/windows/windows.factor | 37 ++-------------- extra/sequences/lib/lib.factor | 13 +++++- extra/x11/glx/glx.factor | 2 +- 8 files changed, 79 insertions(+), 51 deletions(-) create mode 100644 extra/opengl/gl/extensions/extensions.factor create mode 100644 extra/opengl/gl/macosx/macosx.factor diff --git a/extra/hash2/hash2-docs.factor b/extra/hash2/hash2-docs.factor index 5bcbb7cc11..b3e1a53cea 100644 --- a/extra/hash2/hash2-docs.factor +++ b/extra/hash2/hash2-docs.factor @@ -1,7 +1,7 @@ USING: help.syntax help.markup ; IN: hash2 -ARTICLE: { "hash2" "intro" } +ARTICLE: { "hash2" "intro" } "hash2 Vocabulary" "The hash2 vocabulary specifies a simple minimal datastructure for hash tables with two integers as keys. These hash tables are fixed size and do not conform to the associative mapping protocol. Words used in creating and manipulating these hash tables include:" { $subsection } { $subsection hash2 } diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor new file mode 100644 index 0000000000..e05e3a1af5 --- /dev/null +++ b/extra/opengl/gl/extensions/extensions.factor @@ -0,0 +1,46 @@ +USING: alien alien.syntax combinators kernel parser sequences +system words namespaces hashtables init math arrays assocs +sequences.lib continuations ; +<< { + { [ windows? ] [ "opengl.gl.windows" ] } + { [ macosx? ] [ "opengl.gl.macosx" ] } + { [ unix? ] [ "opengl.gl.unix" ] } + { [ t ] [ "Unknown OpenGL platform" throw ] } +} cond use+ >> +IN: opengl.gl.extensions + +SYMBOL: +gl-function-number-counter+ +SYMBOL: +gl-function-pointers+ + +: reset-gl-function-number-counter ( -- ) + 0 +gl-function-number-counter+ set-global ; +: reset-gl-function-pointers ( -- ) + 100 +gl-function-pointers+ set-global ; + +[ reset-gl-function-pointers ] "opengl.gl init hook" add-init-hook +reset-gl-function-pointers +reset-gl-function-number-counter + +: gl-function-number ( -- n ) + +gl-function-number-counter+ get-global + dup 1+ +gl-function-number-counter+ set-global ; + +: gl-function-pointer ( names n -- funptr ) + gl-function-context 2array dup +gl-function-pointers+ get-global at + [ 2nip ] [ + >r [ gl-function-address ] attempt-each + dup [ "OpenGL function not available" throw ] unless + dup r> + +gl-function-pointers+ get-global set-at + ] if* ; + +: GL-FUNCTION: + gl-function-calling-convention + scan + scan dup + scan drop "}" parse-tokens swap add* + gl-function-number + [ gl-function-pointer ] 2curry swap + ";" parse-tokens [ "()" subseq? not ] subset + define-indirect + ; parsing diff --git a/extra/opengl/gl/gl.factor b/extra/opengl/gl/gl.factor index 5b3dade851..59b2422d73 100644 --- a/extra/opengl/gl/gl.factor +++ b/extra/opengl/gl/gl.factor @@ -3,8 +3,8 @@ ! This file is based on the gl.h that comes with xorg-x11 6.8.2 -USING: alien alien.syntax kernel parser sequences system words ; -<< windows? "opengl.gl.windows" "opengl.gl.unix" ? use+ >> +USING: alien alien.syntax combinators kernel parser sequences +system words opengl.gl.extensions ; IN: opengl.gl @@ -1119,9 +1119,7 @@ FUNCTION: void glLoadName ( GLuint name ) ; FUNCTION: void glPushName ( GLuint name ) ; FUNCTION: void glPopName ( ) ; - -! OpenGL extension functions - +<< reset-gl-function-number-counter >> ! OpenGL 1.2 @@ -1273,7 +1271,7 @@ GL-FUNCTION: void glTexSubImage3D { glTexSubImage3DEXT } ( GLenum target, GLint : GL_DOT3_RGBA HEX: 86AF ; inline : GL_MULTISAMPLE_BIT HEX: 20000000 ; inline -GL-FUNCTION: void glActiveTexture { glActiveTextureARB }( GLenum texture ) ; +GL-FUNCTION: void glActiveTexture { glActiveTextureARB } ( GLenum texture ) ; GL-FUNCTION: void glClientActiveTexture { glClientActiveTextureARB } ( GLenum texture ) ; GL-FUNCTION: void glCompressedTexImage1D { glCompressedTexImage1DARB } ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLint border, GLsizei imageSize, GLvoid* data ) ; GL-FUNCTION: void glCompressedTexImage2D { glCompressedTexImage2DARB } ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLsizei height, GLint border, GLsizei imageSize, GLvoid* data ) ; @@ -1607,7 +1605,7 @@ GL-FUNCTION: void glGetVertexAttribdv { glGetVertexAttribdvARB } ( GLuint index, GL-FUNCTION: void glGetVertexAttribfv { glGetVertexAttribfvARB } ( GLuint index, GLenum pname, GLfloat* params ) ; GL-FUNCTION: void glGetVertexAttribiv { glGetVertexAttribivARB } ( GLuint index, GLenum pname, GLint* params ) ; GL-FUNCTION: GLboolean glIsProgram { glIsProgramARB } ( GLuint program ) ; -GL-FUNCTION: GLboolean glIsShader { glIsShaderARB }( GLuint shader ) ; +GL-FUNCTION: GLboolean glIsShader { glIsShaderARB } ( GLuint shader ) ; GL-FUNCTION: void glLinkProgram { glLinkProgramARB } ( GLuint program ) ; GL-FUNCTION: void glShaderSource { glShaderSourceARB } ( GLuint shader, GLsizei count, GLchar** strings, GLint* lengths ) ; GL-FUNCTION: void glStencilFuncSeparate { glStencilFuncSeparateATI } ( GLenum frontfunc, GLenum backfunc, GLint ref, GLuint mask ) ; diff --git a/extra/opengl/gl/macosx/macosx.factor b/extra/opengl/gl/macosx/macosx.factor new file mode 100644 index 0000000000..3d4cb6ae93 --- /dev/null +++ b/extra/opengl/gl/macosx/macosx.factor @@ -0,0 +1,6 @@ +USING: kernel alien ; +IN: opengl.gl.macosx + +: gl-function-context ( -- context ) 0 ; inline +: gl-function-address ( name -- address ) "gl" load-library dlsym ; inline +: gl-function-calling-convention ( -- str ) "cdecl" ; inline diff --git a/extra/opengl/gl/unix/unix.factor b/extra/opengl/gl/unix/unix.factor index 2ee4558a5e..d36e4a2906 100644 --- a/extra/opengl/gl/unix/unix.factor +++ b/extra/opengl/gl/unix/unix.factor @@ -1,10 +1,6 @@ -USING: alien.syntax alien.syntax.private kernel - namespaces parser sequences syntax words ; - +USING: kernel x11.glx ; IN: opengl.gl.unix -: GL-FUNCTION: - scan "c-library" get scan - scan drop "}" parse-tokens drop - ";" parse-tokens [ "()" subseq? not ] subset - define-function ; parsing +: gl-function-context ( -- context ) glXGetCurrentContext ; inline +: gl-function-address ( name -- address ) glXGetProcAddress ; inline +: gl-function-calling-convention ( -- str ) "cdecl" ; inline diff --git a/extra/opengl/gl/windows/windows.factor b/extra/opengl/gl/windows/windows.factor index fc0bca00bb..cc59167539 100755 --- a/extra/opengl/gl/windows/windows.factor +++ b/extra/opengl/gl/windows/windows.factor @@ -1,35 +1,6 @@ -USING: alien alien.syntax arrays assocs hashtables init kernel - libc math namespaces parser sequences syntax system vectors - windows.opengl32 ; - +USING: kernel windows.opengl32 ; IN: opengl.gl.windows - gl-function-pointers set ] "opengl.gl.windows init hook" add-init-hook - -: gl-function-number ( -- n ) - gl-function-number-counter get - dup 1+ gl-function-number-counter set ; - -: gl-function-pointer ( name n -- funptr ) - wglGetCurrentContext 2array dup gl-function-pointers get at - [ -rot 2drop ] - [ >r wglGetProcAddress dup r> gl-function-pointers get set-at ] - if* ; - -PRIVATE> - -: GL-FUNCTION: - "stdcall" - scan - scan - dup gl-function-number [ gl-function-pointer ] 2curry swap - scan drop "}" parse-tokens drop - ";" parse-tokens [ "()" subseq? not ] subset - define-indirect - ; parsing +: gl-function-context ( -- context ) wglGetCurrentContext alien-address ; inline +: gl-function-address ( name -- address ) wglGetProcAddress ; inline +: gl-function-calling-convention ( -- str ) "stdcall" ; inline diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index d89c5eec89..b761bf957f 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -1,6 +1,6 @@ USING: combinators.lib kernel sequences math namespaces assocs random sequences.private shuffle math.functions mirrors -arrays math.parser sorting strings ascii ; +arrays math.parser math.private sorting strings ascii ; IN: sequences.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -153,3 +153,14 @@ PRIVATE> [ = [ ] [ drop f ] if ] curry 2map [ ] subset ; + + + +: attempt-each ( seq quot -- result ) + (each) iterate-prep (attempt-each-integer) ; inline \ No newline at end of file diff --git a/extra/x11/glx/glx.factor b/extra/x11/glx/glx.factor index 2b1d05e2e4..becf6fad28 100644 --- a/extra/x11/glx/glx.factor +++ b/extra/x11/glx/glx.factor @@ -42,7 +42,7 @@ FUNCTION: GLXContext glXCreateContext ( Display* dpy, XVisualInfo* vis, GLXConte 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: int glXGetConfig ( Display* dpy, XVisualInfo* vis, int attrib, int* value ) ; FUNCTION: GLXContext glXGetCurrentContext ( ) ; FUNCTION: GLXDrawable glXGetCurrentDrawable ( ) ; FUNCTION: bool glXIsDirect ( Display* dpy, GLXContext ctx ) ; From aa7f8399487a1078670dcc577af94c6ef0545993 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 Feb 2008 17:32:02 -0800 Subject: [PATCH 05/57] Have glXGetProcAddress fall back to glXGetProcAddressARB if not present --- extra/x11/glx/glx.factor | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/extra/x11/glx/glx.factor b/extra/x11/glx/glx.factor index becf6fad28..9107c2d394 100644 --- a/extra/x11/glx/glx.factor +++ b/extra/x11/glx/glx.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! based on glx.h from xfree86, and some of glxtokens.h -USING: alien alien.c-types alien.syntax x11.xlib -namespaces kernel sequences ; +USING: alien alien.c-types alien.syntax alien.syntax.private x11.xlib +namespaces kernel sequences parser words ; IN: x11.glx LIBRARY: glx @@ -78,6 +78,15 @@ 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 +! Fall back to the extension function glXGetProcAddressARB if necessary +<< "glx" load-library "glXGetProcAddress" dlsym + [ "void*" "glx" "glXGetProcAddress" { "char*" "procname" } define-function ] + [ + "void*" "glx" "glXGetProcAddressARB" { "char*" "procname" } define-function + "glXGetProcAddress" create-in [ glXGetProcAddressARB ] define make-inline + ] + if >> + FUNCTION: void* glXGetProcAddress ( char* procname ) ; ! GLX Events From eefa95ad25fa90e643dda6e42b156516a5039d97 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 Feb 2008 18:00:29 -0800 Subject: [PATCH 06/57] Remove useless alien-address call from opengl.gl.windows --- extra/opengl/gl/windows/windows.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/opengl/gl/windows/windows.factor b/extra/opengl/gl/windows/windows.factor index cc59167539..8f48f60d3c 100755 --- a/extra/opengl/gl/windows/windows.factor +++ b/extra/opengl/gl/windows/windows.factor @@ -1,6 +1,6 @@ USING: kernel windows.opengl32 ; IN: opengl.gl.windows -: gl-function-context ( -- context ) wglGetCurrentContext alien-address ; inline +: gl-function-context ( -- context ) wglGetCurrentContext ; inline : gl-function-address ( name -- address ) wglGetProcAddress ; inline : gl-function-calling-convention ( -- str ) "stdcall" ; inline From 890c5702da91f4994b9547a9662922f553fe95ec Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 Feb 2008 18:18:44 -0800 Subject: [PATCH 07/57] On second thought, no point in being clever with glXGetProcAddress. Just always use glXGetProcAddressARB, which should always be available on any GLX implementation with any extension support --- extra/opengl/gl/unix/unix.factor | 2 +- extra/x11/glx/glx.factor | 12 +++--------- 2 files changed, 4 insertions(+), 10 deletions(-) diff --git a/extra/opengl/gl/unix/unix.factor b/extra/opengl/gl/unix/unix.factor index d36e4a2906..3352b18350 100644 --- a/extra/opengl/gl/unix/unix.factor +++ b/extra/opengl/gl/unix/unix.factor @@ -2,5 +2,5 @@ USING: kernel x11.glx ; IN: opengl.gl.unix : gl-function-context ( -- context ) glXGetCurrentContext ; inline -: gl-function-address ( name -- address ) glXGetProcAddress ; inline +: gl-function-address ( name -- address ) glXGetProcAddressARB ; inline : gl-function-calling-convention ( -- str ) "cdecl" ; inline diff --git a/extra/x11/glx/glx.factor b/extra/x11/glx/glx.factor index 9107c2d394..a8608235f2 100644 --- a/extra/x11/glx/glx.factor +++ b/extra/x11/glx/glx.factor @@ -78,17 +78,11 @@ 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 -! Fall back to the extension function glXGetProcAddressARB if necessary -<< "glx" load-library "glXGetProcAddress" dlsym - [ "void*" "glx" "glXGetProcAddress" { "char*" "procname" } define-function ] - [ - "void*" "glx" "glXGetProcAddressARB" { "char*" "procname" } define-function - "glXGetProcAddress" create-in [ glXGetProcAddressARB ] define make-inline - ] - if >> - FUNCTION: void* glXGetProcAddress ( char* procname ) ; +! GLX_ARB_get_proc_address extension +FUNCTION: void* glXGetProcAddressARB ( char* procname ) ; + ! GLX Events ! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks From 55f29c69df6a096b63468c933c01ef2f6af13232 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sun, 10 Feb 2008 23:53:20 -0800 Subject: [PATCH 08/57] Changed set-fullscreen? to take a gadget instead of a world, moved it into the ui vocab. Moved fullscreen docs into the ui vocab. --- extra/ui/backend/backend.factor | 4 ++-- extra/ui/cocoa/cocoa.factor | 4 ++-- extra/ui/gadgets/worlds/worlds-docs.factor | 9 --------- extra/ui/ui-docs.factor | 10 ++++++++++ extra/ui/ui.factor | 6 ++++++ 5 files changed, 20 insertions(+), 13 deletions(-) diff --git a/extra/ui/backend/backend.factor b/extra/ui/backend/backend.factor index cc1f5f7d05..2334c7602b 100755 --- a/extra/ui/backend/backend.factor +++ b/extra/ui/backend/backend.factor @@ -7,9 +7,9 @@ SYMBOL: ui-backend HOOK: set-title ui-backend ( string world -- ) -HOOK: set-fullscreen? ui-backend ( ? world -- ) +HOOK: set-fullscreen* ui-backend ( ? world -- ) -HOOK: fullscreen? ui-backend ( world -- ? ) +HOOK: fullscreen* ui-backend ( world -- ? ) HOOK: (open-window) ui-backend ( world -- ) diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 184e6fd856..06de1d81fb 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -59,10 +59,10 @@ M: cocoa-ui-backend set-title ( string world -- ) : exit-fullscreen ( world -- ) world-handle first f -> exitFullScreenModeWithOptions: ; -M: cocoa-ui-backend set-fullscreen? ( ? world -- ) +M: cocoa-ui-backend set-fullscreen* ( ? world -- ) swap [ enter-fullscreen ] [ exit-fullscreen ] if ; -M: cocoa-ui-backend fullscreen? ( world -- ? ) +M: cocoa-ui-backend fullscreen* ( world -- ? ) world-handle first -> isInFullScreenMode zero? not ; : auto-position ( world -- ) diff --git a/extra/ui/gadgets/worlds/worlds-docs.factor b/extra/ui/gadgets/worlds/worlds-docs.factor index 8a64750751..a47717329d 100755 --- a/extra/ui/gadgets/worlds/worlds-docs.factor +++ b/extra/ui/gadgets/worlds/worlds-docs.factor @@ -13,15 +13,6 @@ HELP: set-title { $description "Sets the title bar of the native window containing the world." } { $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ; -HELP: set-fullscreen? -{ $values { "?" "a boolean" } { "world" world } } -{ $description "Sets and unsets fullscreen mode for the world." } -{ $notes "Find a world using " { $link find-world } "." } ; - -HELP: fullscreen? -{ $values { "world" world } { "?" "a boolean" } } -{ $description "Queries the world to see if it is running in fullscreen mode." } ; - HELP: raise-window { $values { "world" world } } { $description "Makes the native window containing the given world the front-most window." } diff --git a/extra/ui/ui-docs.factor b/extra/ui/ui-docs.factor index 651a12c737..5d87e40d94 100755 --- a/extra/ui/ui-docs.factor +++ b/extra/ui/ui-docs.factor @@ -14,6 +14,16 @@ HELP: open-window { $values { "gadget" gadget } { "title" string } } { $description "Opens a native window with the specified title." } ; +HELP: set-fullscreen? +{ $values { "?" "a boolean" } { "gadget" gadget } } +{ $description "Sets and unsets fullscreen mode for the gadget's world." } ; + +HELP: fullscreen? +{ $values { "gadget" gadget } { "?" "a boolean" } } +{ $description "Queries the gadget's world to see if it is running in fullscreen mode." } ; + +{ fullscreen? set-fullscreen? } related-words + HELP: find-window { $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } } { $description "Finds a native window whose world satisfies the quotation, outputting " { $link f } " if no such world could be found. The front-most native window is checked first." } ; diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index 774d84ff3d..c214eee8d5 100755 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -145,6 +145,12 @@ SYMBOL: ui-hook >r [ 1 track, ] { 0 1 } make-track r> f open-world-window ; +: set-fullscreen? ( ? gadget -- ) + find-world set-fullscreen* ; + +: fullscreen? ( gadget -- ? ) + find-world fullscreen* ; + HOOK: close-window ui-backend ( gadget -- ) M: object close-window From 3906f1c9f5eaa0bd0a7fc7c6d481c401f80454cc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 13:39:43 -0600 Subject: [PATCH 09/57] add drop table fix up unit tests --- extra/db/sqlite/sqlite.factor | 6 +++++- extra/db/tuples/tuples-tests.factor | 20 ++++++++++++++------ extra/db/tuples/tuples.factor | 5 ++++- 3 files changed, 23 insertions(+), 8 deletions(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 0f4529763a..093dac9d1a 100644 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -84,6 +84,11 @@ M: sqlite-db create-sql ( columns table -- sql ) ] interleave ")" % ] "" make ; +M: sqlite-db drop-sql ( table -- sql ) + [ + "drop table " % % + ] "" make ; + M: sqlite-db insert-sql* ( columns table -- sql ) [ "insert into " % @@ -109,7 +114,6 @@ M: sqlite-db update-sql* ( columns table -- sql ) M: sqlite-db delete-sql* ( columns table -- sql ) [ - break "delete from " % % " where " % diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 7fc6fd3b97..dcf27841cf 100644 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,4 +1,5 @@ -USING: io.files kernel tools.test db db.sqlite db.tuples ; +USING: io.files kernel tools.test db db.sqlite db.tuples +db.types continuations namespaces ; IN: temporary TUPLE: person the-id the-name the-number ; @@ -13,16 +14,23 @@ person "PERSON" } define-persistent +SYMBOL: the-person + : test-tuples ( -- ) - f "billy" 100 person construct-boa dup insert-tuple + [ person drop-table ] [ ] recover + person create-table + f "billy" 100 person construct-boa + the-person set + + [ ] [ the-person get insert-tuple ] unit-test - [ 1 ] [ dup person-id ] unit-test + [ 1 ] [ the-person get person-the-id ] unit-test - 200 over set-person-the-number + 200 the-person get set-person-the-number - [ ] [ dup update-tuple ] unit-test + [ ] [ the-person get update-tuple ] unit-test - [ ] [ delete-tuple ] unit-test ; + [ ] [ the-person get delete-tuple ] unit-test ; : test-sqlite ( -- ) "tuples-test.db" resource-path [ diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index c08f359d5e..c9faaf710c 100644 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -49,7 +49,7 @@ IN: db.tuples [ ] 3compose cache nip ; inline HOOK: create-sql db ( columns table -- sql ) -HOOK: drop-sql db ( columns table -- sql ) +HOOK: drop-sql db ( table -- sql ) HOOK: insert-sql* db ( columns table -- sql ) HOOK: update-sql* db ( columns table -- sql ) HOOK: delete-sql* db ( columns table -- sql ) @@ -80,6 +80,9 @@ HOOK: tuple>params db ( columns tuple -- obj ) : create-table ( class -- ) dup db-columns swap db-table create-sql sql-command ; +: drop-table ( class -- ) + db-table drop-sql sql-command ; + : insert-tuple ( tuple -- ) [ [ maybe-remove-id ] [ insert-sql ] do-tuple-statement From 98d8621ac1997b104809cabb66b4b3effe9ea2d4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 13:50:29 -0600 Subject: [PATCH 10/57] First class compose, curry is now a tuple class --- core/bootstrap/layouts/layouts.factor | 7 +- core/bootstrap/primitives.factor | 52 ++- core/continuations/continuations.factor | 2 +- core/inference/known-words/known-words.factor | 345 +++++++++--------- core/inference/transforms/transforms.factor | 2 - core/kernel/kernel-docs.factor | 2 +- core/kernel/kernel.factor | 15 +- core/optimizer/known-words/known-words.factor | 5 + core/prettyprint/backend/backend.factor | 3 + core/quotations/quotations.factor | 30 +- core/threads/threads.factor | 2 +- core/vocabs/loader/loader.factor | 3 +- core/words/words.factor | 2 +- .../interpreter/interpreter-tests.factor | 3 + extra/tools/interpreter/interpreter.factor | 2 +- vm/alien.c | 11 +- vm/data_gc.c | 2 - vm/errors.c | 3 +- vm/layouts.h | 5 +- vm/primitives.c | 2 - vm/quotations.c | 44 --- vm/quotations.h | 3 - 22 files changed, 270 insertions(+), 275 deletions(-) mode change 100644 => 100755 core/threads/threads.factor mode change 100644 => 100755 extra/tools/interpreter/interpreter-tests.factor diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index 9c0d6b9838..e15a7b4d7c 100755 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math words kernel alien byte-arrays hashtables vectors strings sbufs arrays bit-arrays @@ -8,7 +8,7 @@ BIN: 111 tag-mask set 8 num-tags set 3 tag-bits set -20 num-types set +19 num-types set H{ { fixnum BIN: 000 } @@ -27,11 +27,10 @@ tag-numbers get H{ { float-array 10 } { callstack 11 } { string 12 } - { curry 13 } + { bit-array 13 } { quotation 14 } { dll 15 } { alien 16 } { word 17 } { byte-array 18 } - { bit-array 19 } } union type-numbers set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 967840a3dc..66ede8b054 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -295,23 +295,6 @@ define-builtin "float-array?" "float-arrays" create { } define-builtin -"curry" "kernel" create -"curry?" "kernel" create -{ - { - { "object" "kernel" } - "obj" - { "curry-obj" "kernel" } - f - } - { - { "object" "kernel" } - "obj" - { "curry-quot" "kernel" } - f - } -} define-builtin - "callstack" "kernel" create "callstack?" "kernel" create { } define-builtin @@ -440,14 +423,44 @@ builtins get num-tags get tail f union-class define-class } } define-tuple-class +"curry" "kernel" create +{ + { + { "object" "kernel" } + "obj" + { "curry-obj" "kernel" } + f + } { + { "object" "kernel" } + "quot" + { "curry-quot" "kernel" } + f + } +} define-tuple-class + +"compose" "kernel" create +{ + { + { "object" "kernel" } + "first" + { "compose-first" "kernel" } + f + } { + { "object" "kernel" } + "second" + { "compose-second" "kernel" } + f + } +} define-tuple-class + ! Primitive words : make-primitive ( word vocab n -- ) - >r create dup reset-word r> [ do-primitive ] curry [ ] like define ; + >r create dup reset-word r> + [ do-primitive ] curry [ ] like define ; { { "(execute)" "words.private" } { "(call)" "kernel.private" } - { "uncurry" "kernel.private" } { "bignum>fixnum" "math.private" } { "float>fixnum" "math.private" } { "fixnum>bignum" "math.private" } @@ -622,7 +635,6 @@ builtins get num-tags get tail f union-class define-class { "become" "kernel.private" } { "(sleep)" "threads.private" } { "" "float-arrays" } - { "curry" "kernel" } { "" "tuples.private" } { "class-hash" "kernel.private" } { "callstack>array" "kernel" } diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index b6ca056691..81f78f491d 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -98,7 +98,7 @@ PRIVATE> : continue-with ( obj continuation -- ) [ walker-hook [ >r 2array r> ] when* (continue-with) - ] 2curry (throw) ; + ] 2 (throw) ; : continue ( continuation -- ) f swap continue-with ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index a1887e206b..f92987f15f 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -126,15 +126,11 @@ M: object infer-call pop-d pop-d swap push-d ] "infer" set-word-prop -\ curry { object object } { curry } "inferred-effect" set-word-prop - \ compose [ 2 ensure-values pop-d pop-d swap push-d ] "infer" set-word-prop -\ compose { object object } { curry } "inferred-effect" set-word-prop - ! Variadic tuple constructor \ [ \ @@ -142,457 +138,460 @@ M: object infer-call make-call-node ] "infer" set-word-prop -! We need this for default-output-classes -\ 2 { tuple } "inferred-effect" set-word-prop - ! Non-standard control flow -\ (throw) { callable } { } -t over set-effect-terminated? -"inferred-effect" set-word-prop +\ (throw) [ + \ (throw) + peek-d value-literal 2 + { } + t over set-effect-terminated? + make-call-node +] "infer" set-word-prop + +: set-primitive-effect ( word effect -- ) + dupd [ make-call-node ] 2curry "infer" set-word-prop ; ! Stack effects for all primitives -\ fixnum< { fixnum fixnum } { object } "inferred-effect" set-word-prop +\ fixnum< { fixnum fixnum } { object } set-primitive-effect \ fixnum< make-foldable -\ fixnum<= { fixnum fixnum } { object } "inferred-effect" set-word-prop +\ fixnum<= { fixnum fixnum } { object } set-primitive-effect \ fixnum<= make-foldable -\ fixnum> { fixnum fixnum } { object } "inferred-effect" set-word-prop +\ fixnum> { fixnum fixnum } { object } set-primitive-effect \ fixnum> make-foldable -\ fixnum>= { fixnum fixnum } { object } "inferred-effect" set-word-prop +\ fixnum>= { fixnum fixnum } { object } set-primitive-effect \ fixnum>= make-foldable -\ eq? { object object } { object } "inferred-effect" set-word-prop +\ eq? { object object } { object } set-primitive-effect \ eq? make-foldable -\ rehash-string { string } { } "inferred-effect" set-word-prop +\ rehash-string { string } { } set-primitive-effect -\ bignum>fixnum { bignum } { fixnum } "inferred-effect" set-word-prop +\ bignum>fixnum { bignum } { fixnum } set-primitive-effect \ bignum>fixnum make-foldable -\ float>fixnum { float } { fixnum } "inferred-effect" set-word-prop +\ float>fixnum { float } { fixnum } set-primitive-effect \ bignum>fixnum make-foldable -\ fixnum>bignum { fixnum } { bignum } "inferred-effect" set-word-prop +\ fixnum>bignum { fixnum } { bignum } set-primitive-effect \ fixnum>bignum make-foldable -\ float>bignum { float } { bignum } "inferred-effect" set-word-prop +\ float>bignum { float } { bignum } set-primitive-effect \ float>bignum make-foldable -\ fixnum>float { fixnum } { float } "inferred-effect" set-word-prop +\ fixnum>float { fixnum } { float } set-primitive-effect \ fixnum>float make-foldable -\ bignum>float { bignum } { float } "inferred-effect" set-word-prop +\ bignum>float { bignum } { float } set-primitive-effect \ bignum>float make-foldable -\ { integer integer } { ratio } "inferred-effect" set-word-prop +\ { integer integer } { ratio } set-primitive-effect \ make-foldable -\ string>float { string } { float } "inferred-effect" set-word-prop +\ string>float { string } { float } set-primitive-effect \ string>float make-foldable -\ float>string { float } { string } "inferred-effect" set-word-prop +\ float>string { float } { string } set-primitive-effect \ float>string make-foldable -\ float>bits { real } { integer } "inferred-effect" set-word-prop +\ float>bits { real } { integer } set-primitive-effect \ float>bits make-foldable -\ double>bits { real } { integer } "inferred-effect" set-word-prop +\ double>bits { real } { integer } set-primitive-effect \ double>bits make-foldable -\ bits>float { integer } { float } "inferred-effect" set-word-prop +\ bits>float { integer } { float } set-primitive-effect \ bits>float make-foldable -\ bits>double { integer } { float } "inferred-effect" set-word-prop +\ bits>double { integer } { float } set-primitive-effect \ bits>double make-foldable -\ { real real } { complex } "inferred-effect" set-word-prop +\ { real real } { complex } set-primitive-effect \ make-foldable -\ fixnum+ { fixnum fixnum } { integer } "inferred-effect" set-word-prop +\ fixnum+ { fixnum fixnum } { integer } set-primitive-effect \ fixnum+ make-foldable -\ fixnum+fast { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum+fast { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum+fast make-foldable -\ fixnum- { fixnum fixnum } { integer } "inferred-effect" set-word-prop +\ fixnum- { fixnum fixnum } { integer } set-primitive-effect \ fixnum- make-foldable -\ fixnum-fast { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-fast { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-fast make-foldable -\ fixnum* { fixnum fixnum } { integer } "inferred-effect" set-word-prop +\ fixnum* { fixnum fixnum } { integer } set-primitive-effect \ fixnum* make-foldable -\ fixnum*fast { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum*fast { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum*fast make-foldable -\ fixnum/i { fixnum fixnum } { integer } "inferred-effect" set-word-prop +\ fixnum/i { fixnum fixnum } { integer } set-primitive-effect \ fixnum/i make-foldable -\ fixnum-mod { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-mod { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-mod make-foldable -\ fixnum/mod { fixnum fixnum } { integer fixnum } "inferred-effect" set-word-prop +\ fixnum/mod { fixnum fixnum } { integer fixnum } set-primitive-effect \ fixnum/mod make-foldable -\ fixnum-bitand { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-bitand { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-bitand make-foldable -\ fixnum-bitor { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-bitor { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-bitor make-foldable -\ fixnum-bitxor { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-bitxor { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-bitxor make-foldable -\ fixnum-bitnot { fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-bitnot { fixnum } { fixnum } set-primitive-effect \ fixnum-bitnot make-foldable -\ fixnum-shift { fixnum fixnum } { integer } "inferred-effect" set-word-prop +\ fixnum-shift { fixnum fixnum } { integer } set-primitive-effect \ fixnum-shift make-foldable -\ fixnum-shift-fast { fixnum fixnum } { fixnum } "inferred-effect" set-word-prop +\ fixnum-shift-fast { fixnum fixnum } { fixnum } set-primitive-effect \ fixnum-shift-fast make-foldable -\ bignum= { bignum bignum } { object } "inferred-effect" set-word-prop +\ bignum= { bignum bignum } { object } set-primitive-effect \ bignum= make-foldable -\ bignum+ { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum+ { bignum bignum } { bignum } set-primitive-effect \ bignum+ make-foldable -\ bignum- { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum- { bignum bignum } { bignum } set-primitive-effect \ bignum- make-foldable -\ bignum* { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum* { bignum bignum } { bignum } set-primitive-effect \ bignum* make-foldable -\ bignum/i { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum/i { bignum bignum } { bignum } set-primitive-effect \ bignum/i make-foldable -\ bignum-mod { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-mod { bignum bignum } { bignum } set-primitive-effect \ bignum-mod make-foldable -\ bignum/mod { bignum bignum } { bignum bignum } "inferred-effect" set-word-prop +\ bignum/mod { bignum bignum } { bignum bignum } set-primitive-effect \ bignum/mod make-foldable -\ bignum-bitand { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-bitand { bignum bignum } { bignum } set-primitive-effect \ bignum-bitand make-foldable -\ bignum-bitor { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-bitor { bignum bignum } { bignum } set-primitive-effect \ bignum-bitor make-foldable -\ bignum-bitxor { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-bitxor { bignum bignum } { bignum } set-primitive-effect \ bignum-bitxor make-foldable -\ bignum-bitnot { bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-bitnot { bignum } { bignum } set-primitive-effect \ bignum-bitnot make-foldable -\ bignum-shift { bignum bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-shift { bignum bignum } { bignum } set-primitive-effect \ bignum-shift make-foldable -\ bignum< { bignum bignum } { object } "inferred-effect" set-word-prop +\ bignum< { bignum bignum } { object } set-primitive-effect \ bignum< make-foldable -\ bignum<= { bignum bignum } { object } "inferred-effect" set-word-prop +\ bignum<= { bignum bignum } { object } set-primitive-effect \ bignum<= make-foldable -\ bignum> { bignum bignum } { object } "inferred-effect" set-word-prop +\ bignum> { bignum bignum } { object } set-primitive-effect \ bignum> make-foldable -\ bignum>= { bignum bignum } { object } "inferred-effect" set-word-prop +\ bignum>= { bignum bignum } { object } set-primitive-effect \ bignum>= make-foldable -\ bignum-bit? { bignum integer } { object } "inferred-effect" set-word-prop +\ bignum-bit? { bignum integer } { object } set-primitive-effect \ bignum-bit? make-foldable -\ bignum-log2 { bignum } { bignum } "inferred-effect" set-word-prop +\ bignum-log2 { bignum } { bignum } set-primitive-effect \ bignum-log2 make-foldable -\ byte-array>bignum { byte-array } { bignum } "inferred-effect" set-word-prop +\ byte-array>bignum { byte-array } { bignum } set-primitive-effect \ byte-array>bignum make-foldable -\ float= { float float } { object } "inferred-effect" set-word-prop +\ float= { float float } { object } set-primitive-effect \ float= make-foldable -\ float+ { float float } { float } "inferred-effect" set-word-prop +\ float+ { float float } { float } set-primitive-effect \ float+ make-foldable -\ float- { float float } { float } "inferred-effect" set-word-prop +\ float- { float float } { float } set-primitive-effect \ float- make-foldable -\ float* { float float } { float } "inferred-effect" set-word-prop +\ float* { float float } { float } set-primitive-effect \ float* make-foldable -\ float/f { float float } { float } "inferred-effect" set-word-prop +\ float/f { float float } { float } set-primitive-effect \ float/f make-foldable -\ float< { float float } { object } "inferred-effect" set-word-prop +\ float< { float float } { object } set-primitive-effect \ float< make-foldable -\ float-mod { float float } { float } "inferred-effect" set-word-prop +\ float-mod { float float } { float } set-primitive-effect \ float-mod make-foldable -\ float<= { float float } { object } "inferred-effect" set-word-prop +\ float<= { float float } { object } set-primitive-effect \ float<= make-foldable -\ float> { float float } { object } "inferred-effect" set-word-prop +\ float> { float float } { object } set-primitive-effect \ float> make-foldable -\ float>= { float float } { object } "inferred-effect" set-word-prop +\ float>= { float float } { object } set-primitive-effect \ float>= make-foldable -\ { object object } { word } "inferred-effect" set-word-prop +\ { object object } { word } set-primitive-effect \ make-flushable -\ word-xt { word } { integer } "inferred-effect" set-word-prop +\ word-xt { word } { integer } set-primitive-effect \ word-xt make-flushable -\ getenv { fixnum } { object } "inferred-effect" set-word-prop +\ getenv { fixnum } { object } set-primitive-effect \ getenv make-flushable -\ setenv { object fixnum } { } "inferred-effect" set-word-prop +\ setenv { object fixnum } { } set-primitive-effect -\ (stat) { string } { object object object object } "inferred-effect" set-word-prop +\ (stat) { string } { object object object object } set-primitive-effect -\ (directory) { string } { array } "inferred-effect" set-word-prop +\ (directory) { string } { array } set-primitive-effect -\ data-gc { } { } "inferred-effect" set-word-prop +\ data-gc { } { } set-primitive-effect -\ code-gc { } { } "inferred-effect" set-word-prop +\ code-gc { } { } set-primitive-effect -\ gc-time { } { integer } "inferred-effect" set-word-prop +\ gc-time { } { integer } set-primitive-effect -\ save-image { string } { } "inferred-effect" set-word-prop +\ save-image { string } { } set-primitive-effect -\ save-image-and-exit { string } { } "inferred-effect" set-word-prop +\ save-image-and-exit { string } { } set-primitive-effect \ exit { integer } { } t over set-effect-terminated? -"inferred-effect" set-word-prop +set-primitive-effect -\ data-room { } { integer array } "inferred-effect" set-word-prop +\ data-room { } { integer array } set-primitive-effect \ data-room make-flushable -\ code-room { } { integer integer } "inferred-effect" set-word-prop +\ code-room { } { integer integer } set-primitive-effect \ code-room make-flushable -\ os-env { string } { object } "inferred-effect" set-word-prop +\ os-env { string } { object } set-primitive-effect -\ millis { } { integer } "inferred-effect" set-word-prop +\ millis { } { integer } set-primitive-effect \ millis make-flushable -\ type { object } { fixnum } "inferred-effect" set-word-prop +\ type { object } { fixnum } set-primitive-effect \ type make-foldable -\ tag { object } { fixnum } "inferred-effect" set-word-prop +\ tag { object } { fixnum } set-primitive-effect \ tag make-foldable -\ class-hash { object } { fixnum } "inferred-effect" set-word-prop +\ class-hash { object } { fixnum } set-primitive-effect \ class-hash make-foldable -\ cwd { } { string } "inferred-effect" set-word-prop +\ cwd { } { string } set-primitive-effect -\ cd { string } { } "inferred-effect" set-word-prop +\ cd { string } { } set-primitive-effect -\ dlopen { string } { dll } "inferred-effect" set-word-prop +\ dlopen { string } { dll } set-primitive-effect -\ dlsym { string object } { c-ptr } "inferred-effect" set-word-prop +\ dlsym { string object } { c-ptr } set-primitive-effect -\ dlclose { dll } { } "inferred-effect" set-word-prop +\ dlclose { dll } { } set-primitive-effect -\ { integer } { byte-array } "inferred-effect" set-word-prop +\ { integer } { byte-array } set-primitive-effect \ make-flushable -\ { integer } { bit-array } "inferred-effect" set-word-prop +\ { integer } { bit-array } set-primitive-effect \ make-flushable -\ { integer float } { float-array } "inferred-effect" set-word-prop +\ { integer float } { float-array } set-primitive-effect \ make-flushable -\ { integer c-ptr } { c-ptr } "inferred-effect" set-word-prop +\ { integer c-ptr } { c-ptr } set-primitive-effect \ make-flushable -\ alien-signed-cell { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-cell { c-ptr integer } { integer } set-primitive-effect \ alien-signed-cell make-flushable -\ set-alien-signed-cell { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-signed-cell { integer c-ptr integer } { } set-primitive-effect -\ alien-unsigned-cell { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-cell { c-ptr integer } { integer } set-primitive-effect \ alien-unsigned-cell make-flushable -\ set-alien-unsigned-cell { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-unsigned-cell { integer c-ptr integer } { } set-primitive-effect -\ alien-signed-8 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-8 { c-ptr integer } { integer } set-primitive-effect \ alien-signed-8 make-flushable -\ set-alien-signed-8 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-signed-8 { integer c-ptr integer } { } set-primitive-effect -\ alien-unsigned-8 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-8 { c-ptr integer } { integer } set-primitive-effect \ alien-unsigned-8 make-flushable -\ set-alien-unsigned-8 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-unsigned-8 { integer c-ptr integer } { } set-primitive-effect -\ alien-signed-4 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-4 { c-ptr integer } { integer } set-primitive-effect \ alien-signed-4 make-flushable -\ set-alien-signed-4 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-signed-4 { integer c-ptr integer } { } set-primitive-effect -\ alien-unsigned-4 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-4 { c-ptr integer } { integer } set-primitive-effect \ alien-unsigned-4 make-flushable -\ set-alien-unsigned-4 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-unsigned-4 { integer c-ptr integer } { } set-primitive-effect -\ alien-signed-2 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-signed-2 { c-ptr integer } { fixnum } set-primitive-effect \ alien-signed-2 make-flushable -\ set-alien-signed-2 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-signed-2 { integer c-ptr integer } { } set-primitive-effect -\ alien-unsigned-2 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-unsigned-2 { c-ptr integer } { fixnum } set-primitive-effect \ alien-unsigned-2 make-flushable -\ set-alien-unsigned-2 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-unsigned-2 { integer c-ptr integer } { } set-primitive-effect -\ alien-signed-1 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-signed-1 { c-ptr integer } { fixnum } set-primitive-effect \ alien-signed-1 make-flushable -\ set-alien-signed-1 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-signed-1 { integer c-ptr integer } { } set-primitive-effect -\ alien-unsigned-1 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-unsigned-1 { c-ptr integer } { fixnum } set-primitive-effect \ alien-unsigned-1 make-flushable -\ set-alien-unsigned-1 { integer c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-unsigned-1 { integer c-ptr integer } { } set-primitive-effect -\ alien-float { c-ptr integer } { float } "inferred-effect" set-word-prop +\ alien-float { c-ptr integer } { float } set-primitive-effect \ alien-float make-flushable -\ set-alien-float { float c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-float { float c-ptr integer } { } set-primitive-effect -\ alien-double { c-ptr integer } { float } "inferred-effect" set-word-prop +\ alien-double { c-ptr integer } { float } set-primitive-effect \ alien-double make-flushable -\ set-alien-double { float c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-double { float c-ptr integer } { } set-primitive-effect -\ alien-cell { c-ptr integer } { simple-c-ptr } "inferred-effect" set-word-prop +\ alien-cell { c-ptr integer } { simple-c-ptr } set-primitive-effect \ alien-cell make-flushable -\ set-alien-cell { c-ptr c-ptr integer } { } "inferred-effect" set-word-prop +\ set-alien-cell { c-ptr c-ptr integer } { } set-primitive-effect -\ alien>char-string { c-ptr } { string } "inferred-effect" set-word-prop +\ alien>char-string { c-ptr } { string } set-primitive-effect \ alien>char-string make-flushable -\ string>char-alien { string } { byte-array } "inferred-effect" set-word-prop +\ string>char-alien { string } { byte-array } set-primitive-effect \ string>char-alien make-flushable -\ alien>u16-string { c-ptr } { string } "inferred-effect" set-word-prop +\ alien>u16-string { c-ptr } { string } set-primitive-effect \ alien>u16-string make-flushable -\ string>u16-alien { string } { byte-array } "inferred-effect" set-word-prop +\ string>u16-alien { string } { byte-array } set-primitive-effect \ string>u16-alien make-flushable -\ alien-address { alien } { integer } "inferred-effect" set-word-prop +\ alien-address { alien } { integer } set-primitive-effect \ alien-address make-flushable -\ slot { object fixnum } { object } "inferred-effect" set-word-prop +\ slot { object fixnum } { object } set-primitive-effect \ slot make-flushable -\ set-slot { object object fixnum } { } "inferred-effect" set-word-prop +\ set-slot { object object fixnum } { } set-primitive-effect -\ string-nth { fixnum string } { fixnum } "inferred-effect" set-word-prop +\ string-nth { fixnum string } { fixnum } set-primitive-effect \ string-nth make-flushable -\ set-string-nth { fixnum fixnum string } { } "inferred-effect" set-word-prop +\ set-string-nth { fixnum fixnum string } { } set-primitive-effect -\ resize-array { integer array } { array } "inferred-effect" set-word-prop +\ resize-array { integer array } { array } set-primitive-effect \ resize-array make-flushable -\ resize-byte-array { integer byte-array } { byte-array } "inferred-effect" set-word-prop +\ resize-byte-array { integer byte-array } { byte-array } set-primitive-effect \ resize-byte-array make-flushable -\ resize-bit-array { integer bit-array } { bit-array } "inferred-effect" set-word-prop +\ resize-bit-array { integer bit-array } { bit-array } set-primitive-effect \ resize-bit-array make-flushable -\ resize-float-array { integer float-array } { float-array } "inferred-effect" set-word-prop +\ resize-float-array { integer float-array } { float-array } set-primitive-effect \ resize-float-array make-flushable -\ resize-string { integer string } { string } "inferred-effect" set-word-prop +\ resize-string { integer string } { string } set-primitive-effect \ resize-string make-flushable -\ { integer object } { array } "inferred-effect" set-word-prop +\ { integer object } { array } set-primitive-effect \ make-flushable -\ begin-scan { } { } "inferred-effect" set-word-prop +\ begin-scan { } { } set-primitive-effect -\ next-object { } { object } "inferred-effect" set-word-prop +\ next-object { } { object } set-primitive-effect -\ end-scan { } { } "inferred-effect" set-word-prop +\ end-scan { } { } set-primitive-effect -\ size { object } { fixnum } "inferred-effect" set-word-prop +\ size { object } { fixnum } set-primitive-effect \ size make-flushable -\ die { } { } "inferred-effect" set-word-prop +\ die { } { } set-primitive-effect -\ fopen { string string } { alien } "inferred-effect" set-word-prop +\ fopen { string string } { alien } set-primitive-effect -\ fgetc { alien } { object } "inferred-effect" set-word-prop +\ fgetc { alien } { object } set-primitive-effect -\ fwrite { string alien } { } "inferred-effect" set-word-prop +\ fwrite { string alien } { } set-primitive-effect -\ fread { integer string } { object } "inferred-effect" set-word-prop +\ fread { integer string } { object } set-primitive-effect -\ fflush { alien } { } "inferred-effect" set-word-prop +\ fflush { alien } { } set-primitive-effect -\ fclose { alien } { } "inferred-effect" set-word-prop +\ fclose { alien } { } set-primitive-effect -\ expired? { object } { object } "inferred-effect" set-word-prop +\ expired? { object } { object } set-primitive-effect \ expired? make-flushable -\ { object } { wrapper } "inferred-effect" set-word-prop +\ { object } { wrapper } set-primitive-effect \ make-foldable -\ (clone) { object } { object } "inferred-effect" set-word-prop +\ (clone) { object } { object } set-primitive-effect \ (clone) make-flushable -\ { integer integer } { string } "inferred-effect" set-word-prop +\ { integer integer } { string } set-primitive-effect \ make-flushable -\ array>quotation { array } { quotation } "inferred-effect" set-word-prop +\ array>quotation { array } { quotation } set-primitive-effect \ array>quotation make-flushable -\ quotation-xt { quotation } { integer } "inferred-effect" set-word-prop +\ quotation-xt { quotation } { integer } set-primitive-effect \ quotation-xt make-flushable -\ { word integer } { quotation } "inferred-effect" set-word-prop +\ { word integer } { quotation } set-primitive-effect \ make-flushable -\ (>tuple) { array } { tuple } "inferred-effect" set-word-prop +\ (>tuple) { array } { tuple } set-primitive-effect \ (>tuple) make-flushable -\ tuple>array { tuple } { array } "inferred-effect" set-word-prop +\ tuple>array { tuple } { array } set-primitive-effect \ tuple>array make-flushable -\ datastack { } { array } "inferred-effect" set-word-prop +\ datastack { } { array } set-primitive-effect \ datastack make-flushable -\ retainstack { } { array } "inferred-effect" set-word-prop +\ retainstack { } { array } set-primitive-effect \ retainstack make-flushable -\ callstack { } { callstack } "inferred-effect" set-word-prop +\ callstack { } { callstack } set-primitive-effect \ callstack make-flushable -\ callstack>array { callstack } { array } "inferred-effect" set-word-prop +\ callstack>array { callstack } { array } set-primitive-effect \ callstack>array make-flushable -\ (sleep) { integer } { } "inferred-effect" set-word-prop +\ (sleep) { integer } { } set-primitive-effect -\ become { array array } { } "inferred-effect" set-word-prop +\ become { array array } { } set-primitive-effect -\ innermost-frame-quot { callstack } { quotation } "inferred-effect" set-word-prop +\ innermost-frame-quot { callstack } { quotation } set-primitive-effect -\ innermost-frame-scan { callstack } { fixnum } "inferred-effect" set-word-prop +\ innermost-frame-scan { callstack } { fixnum } set-primitive-effect -\ set-innermost-frame-quot { quotation callstack } { } "inferred-effect" set-word-prop +\ set-innermost-frame-quot { quotation callstack } { } set-primitive-effect -\ (os-envs) { } { array } "inferred-effect" set-word-prop +\ (os-envs) { } { array } set-primitive-effect \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index b1b56ca1a1..7faeefc3d6 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -93,5 +93,3 @@ M: duplicated-slots-error summary \ construct-empty 1 1 make-call-node ] if ] "infer" set-word-prop - -\ construct-empty 1 1 "inferred-effect" set-word-prop diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 2920122ec2..c828fcb0e9 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -532,7 +532,7 @@ HELP: compose "compose call" "append call" } - "However, " { $link compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations." + "However, " { $link compose } " runs in constant time, and the optimizing compiler is able to compile code which calls composed quotations." } ; HELP: 3compose diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 8d639aff78..d1f3af4779 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -17,8 +17,7 @@ IN: kernel : clear ( -- ) { } set-datastack ; ! Combinators - -: call ( callable -- ) uncurry (call) ; +GENERIC: call ( callable -- ) DEFER: if @@ -71,6 +70,10 @@ DEFER: if [ 2nip call ] if ; inline ! Quotation building +USE: tuples.private + +: curry ( obj quot -- curry ) + \ curry 4 ; : 2curry ( obj1 obj2 quot -- curry ) curry curry ; inline @@ -82,12 +85,10 @@ DEFER: if swapd [ swapd call ] 2curry ; inline : compose ( quot1 quot2 -- curry ) - ! Not inline because this is treated as a primitive by - ! the compiler - [ slip call ] 2curry ; + \ compose 4 ; : 3compose ( quot1 quot2 quot3 -- curry ) - [ 2slip slip call ] 3curry ; inline + compose compose ; inline ! Object protocol @@ -156,7 +157,7 @@ GENERIC: construct-boa ( ... class -- tuple ) ! Error handling -- defined early so that other files can ! throw errors before continuations are loaded -: throw ( error -- * ) 5 getenv [ die ] or curry (throw) ; +: throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ; pprint-sequence ; M: bit-vector >pprint-sequence ; M: byte-vector >pprint-sequence ; M: float-vector >pprint-sequence ; +M: curry >pprint-sequence ; +M: compose >pprint-sequence ; M: hashtable >pprint-sequence >alist ; M: tuple >pprint-sequence tuple>array ; M: wrapper >pprint-sequence wrapped 1array ; diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 64bf472704..65c6da2b06 100755 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -1,13 +1,20 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays sequences sequences.private -kernel kernel.private math assocs quotations.private ; +kernel kernel.private math assocs quotations.private +slots.private ; IN: quotations +M: quotation call (call) ; + +M: curry call dup 4 slot swap 5 slot call ; + +M: compose call dup 4 slot swap 5 slot slip call ; + M: wrapper equal? over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ; -UNION: callable quotation curry ; +UNION: callable quotation curry compose ; M: callable equal? over callable? [ sequence= ] [ 2drop f ] if ; @@ -19,7 +26,7 @@ M: quotation nth-unsafe quotation-array nth-unsafe ; : >quotation ( seq -- quot ) >array array>quotation ; inline -M: quotation like drop dup quotation? [ >quotation ] unless ; +M: callable like drop dup quotation? [ >quotation ] unless ; INSTANCE: quotation immutable-sequence @@ -40,6 +47,17 @@ M: curry nth >r 1- r> curry-quot nth ] if ; -M: curry like drop dup callable? [ >quotation ] unless ; - INSTANCE: curry immutable-sequence + +M: compose length + dup compose-first length + swap compose-second length + ; + +M: compose nth + 2dup compose-first length < [ + compose-first + ] [ + [ compose-first length - ] keep compose-second + ] if nth ; + +INSTANCE: compose immutable-sequence diff --git a/core/threads/threads.factor b/core/threads/threads.factor old mode 100644 new mode 100755 index ee136654df..c4e159742a --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -49,7 +49,7 @@ PRIVATE> V{ } set-catchstack { } set-retainstack [ [ print-error ] recover stop ] call-clear - ] (throw) + ] 1 (throw) ] curry callcc0 ; alien = delegate; + + if(type_of(delegate) == ALIEN_TYPE) + { + F_ALIEN *delegate_alien = untag_object(delegate); + displacement += delegate_alien->displacement; + alien->alien = F; + } + else + alien->alien = delegate; + alien->displacement = displacement; alien->expired = F; return tag_object(alien); diff --git a/vm/data_gc.c b/vm/data_gc.c index 601a677920..342bbb6af4 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -189,8 +189,6 @@ CELL unaligned_object_size(CELL pointer) return sizeof(F_ALIEN); case WRAPPER_TYPE: return sizeof(F_WRAPPER); - case CURRY_TYPE: - return sizeof(F_CURRY); case CALLSTACK_TYPE: return callstack_size( untag_fixnum_fast(((F_CALLSTACK *)pointer)->length)); diff --git a/vm/errors.c b/vm/errors.c index 966fbe353d..27158cbf44 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -137,12 +137,11 @@ void misc_signal_handler_impl(void) DEFINE_PRIMITIVE(throw) { - uncurry(dpop()); + dpop(); throw_impl(dpop(),stack_chain->callstack_top); } DEFINE_PRIMITIVE(call_clear) { - uncurry(dpop()); throw_impl(dpop(),stack_chain->callstack_bottom); } diff --git a/vm/layouts.h b/vm/layouts.h index ef6fb3d4ac..5ed7c83df2 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -52,15 +52,14 @@ typedef signed long long s64; #define FLOAT_ARRAY_TYPE 10 #define CALLSTACK_TYPE 11 #define STRING_TYPE 12 -#define CURRY_TYPE 13 +#define BIT_ARRAY_TYPE 13 #define QUOTATION_TYPE 14 #define DLL_TYPE 15 #define ALIEN_TYPE 16 #define WORD_TYPE 17 #define BYTE_ARRAY_TYPE 18 -#define BIT_ARRAY_TYPE 19 -#define TYPE_COUNT 20 +#define TYPE_COUNT 19 INLINE bool immediate_p(CELL obj) { diff --git a/vm/primitives.c b/vm/primitives.c index dc7333c667..5699f90fda 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -3,7 +3,6 @@ void *primitives[] = { primitive_execute, primitive_call, - primitive_uncurry, primitive_bignum_to_fixnum, primitive_float_to_fixnum, primitive_fixnum_to_bignum, @@ -178,7 +177,6 @@ void *primitives[] = { primitive_become, primitive_sleep, primitive_float_array, - primitive_curry, primitive_tuple_boa, primitive_class_hash, primitive_callstack_to_array, diff --git a/vm/quotations.c b/vm/quotations.c index 536d5d7d5a..c3b50dbd47 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -350,50 +350,6 @@ F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack) return quot; } -DEFINE_PRIMITIVE(curry) -{ - F_CURRY *curry; - - switch(type_of(dpeek())) - { - case QUOTATION_TYPE: - case CURRY_TYPE: - curry = allot_object(CURRY_TYPE,sizeof(F_CURRY)); - curry->quot = dpop(); - curry->obj = dpop(); - dpush(tag_object(curry)); - break; - default: - type_error(QUOTATION_TYPE,dpeek()); - break; - } -} - -void uncurry(CELL obj) -{ - F_CURRY *curry; - - switch(type_of(obj)) - { - case QUOTATION_TYPE: - dpush(obj); - break; - case CURRY_TYPE: - curry = untag_object(obj); - dpush(curry->obj); - uncurry(curry->quot); - break; - default: - type_error(QUOTATION_TYPE,obj); - break; - } -} - -DEFINE_PRIMITIVE(uncurry) -{ - uncurry(dpop()); -} - /* push a new quotation on the stack */ DEFINE_PRIMITIVE(array_to_quotation) { diff --git a/vm/quotations.h b/vm/quotations.h index d975d9e0f5..0845957c0b 100755 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -2,8 +2,5 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code); void jit_compile(CELL quot, bool relocate); F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack); F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset); -void uncurry(CELL obj); -DECLARE_PRIMITIVE(curry); DECLARE_PRIMITIVE(array_to_quotation); DECLARE_PRIMITIVE(quotation_xt); -DECLARE_PRIMITIVE(uncurry); From 1598255151dd3ea4bb39ddd677da03750b886eb1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 14:19:36 -0600 Subject: [PATCH 11/57] Add Eduardo-style setters --- extra/new-slots/new-slots.factor | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/extra/new-slots/new-slots.factor b/extra/new-slots/new-slots.factor index 0f411f3e88..4edd4239fa 100755 --- a/extra/new-slots/new-slots.factor +++ b/extra/new-slots/new-slots.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: effects words kernel sequences slots slots.private -assocs parser mirrors namespaces math vocabs ; +assocs parser mirrors namespaces math vocabs tuples ; IN: new-slots : create-accessor ( name effect -- word ) @@ -19,11 +19,21 @@ IN: new-slots : writer-effect T{ effect f { "value" "object" } { } } ; inline : writer-word ( name -- word ) - ">>" swap append writer-effect create-accessor ; + "(>>" swap ")" 3append writer-effect create-accessor ; : define-writer ( class slot name -- ) writer-word [ set-slot ] define-slot-word ; +: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline + +: setter-word ( name -- word ) + ">>" swap append setter-effect create-accessor ; + +: define-setter ( name -- ) + dup setter-word dup deferred? [ + [ \ over , swap writer-word , ] [ ] make define-inline + ] [ 2drop ] if ; + : changer-effect T{ effect f { "object" "quot" } } ; inline : changer-word ( name -- word ) @@ -40,12 +50,18 @@ IN: new-slots ] [ 2drop ] if ; : define-new-slot ( class slot name -- ) - dup define-changer 3dup define-reader define-writer ; + dup define-changer + dup define-setter + 3dup define-reader + define-writer ; : define-new-slots ( tuple-class -- ) [ "slot-names" word-prop >alist ] keep [ swap first2 >r 4 + r> define-new-slot ] curry each ; -: NEW-SLOTS: scan-word define-new-slots ; parsing +: TUPLE: + CREATE-CLASS + dup ";" parse-tokens define-tuple-class + define-new-slots ; parsing "accessors" create-vocab drop From 4daa1943d89d649ffbcbb7ee8d6d98cc411dadda Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 14:19:47 -0600 Subject: [PATCH 12/57] Fixing unit tests --- core/optimizer/def-use/def-use-tests.factor | 2 +- core/optimizer/optimizer-tests.factor | 4 ++-- core/parser/parser.factor | 1 + core/prettyprint/backend/backend.factor | 1 + core/quotations/quotations-tests.factor | 2 +- core/vocabs/vocabs.factor | 7 +++---- extra/combinators/lib/lib-tests.factor | 11 ----------- extra/sequences/lib/lib-tests.factor | 15 ++++++++++++++- extra/tools/browser/browser-tests.factor | 2 -- 9 files changed, 23 insertions(+), 22 deletions(-) mode change 100644 => 100755 core/optimizer/def-use/def-use-tests.factor mode change 100644 => 100755 core/quotations/quotations-tests.factor mode change 100644 => 100755 extra/sequences/lib/lib-tests.factor mode change 100644 => 100755 extra/tools/browser/browser-tests.factor diff --git a/core/optimizer/def-use/def-use-tests.factor b/core/optimizer/def-use/def-use-tests.factor old mode 100644 new mode 100755 index afe0857463..815c564109 --- a/core/optimizer/def-use/def-use-tests.factor +++ b/core/optimizer/def-use/def-use-tests.factor @@ -8,7 +8,7 @@ namespaces assocs kernel sequences math tools.test words ; ] unit-test : kill-set ( quot -- seq ) - dataflow compute-def-use dead-literals keys + dataflow compute-def-use compute-dead-literals keys [ value-literal ] map ; : subset? [ member? ] curry all? ; diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 232eb5a83a..8f30abd09f 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -288,10 +288,10 @@ TUPLE: silly-tuple a b ; [ t ] [ \ node-successor-f-bug compiled? ] unit-test -: construct-empty-bug construct-empty ; - [ ] [ [ construct-empty ] dataflow optimize drop ] unit-test +[ ] [ [ ] dataflow optimize drop ] unit-test + ! Make sure we have sane heuristics : should-inline? method method-word flat-length 10 <= ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 7dee5e2212..1bd7979a0c 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -107,6 +107,7 @@ M: bad-escape summary drop "Bad escape code" ; : escape ( escape -- ch ) H{ + { CHAR: a CHAR: \a } { CHAR: e CHAR: \e } { CHAR: n CHAR: \n } { CHAR: r CHAR: \r } diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index 3c8df2c19a..d1364a5986 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -58,6 +58,7 @@ M: f pprint* drop \ f pprint-word ; ! Strings : ch>ascii-escape ( ch -- str ) H{ + { CHAR: \a CHAR: a } { CHAR: \e CHAR: e } { CHAR: \n CHAR: n } { CHAR: \r CHAR: r } diff --git a/core/quotations/quotations-tests.factor b/core/quotations/quotations-tests.factor old mode 100644 new mode 100755 index d357fb70ff..90ba150a41 --- a/core/quotations/quotations-tests.factor +++ b/core/quotations/quotations-tests.factor @@ -15,4 +15,4 @@ IN: temporary [ [ "hi" ] ] [ "hi" 1quotation ] unit-test -[ 1 \ + curry ] must-fail +! [ 1 \ + curry ] must-fail diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 0717a6729c..1158d60951 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -85,7 +85,8 @@ SYMBOL: load-vocab-hook TUPLE: vocab-link name root ; -C: vocab-link +: ( name root -- vocab-link ) + [ dup vocab-root ] unless* vocab-link construct-boa ; M: vocab-link equal? over vocab-link? @@ -103,9 +104,7 @@ M: vocab >vocab-link drop ; M: vocab-link >vocab-link drop ; M: string >vocab-link - over vocab dup [ 2nip ] [ - drop [ dup vocab-root ] unless* - ] if ; + over vocab dup [ 2nip ] [ drop ] if ; UNION: vocab-spec vocab vocab-link ; diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index 24d70a86c6..5012d9280b 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -4,11 +4,7 @@ IN: temporary [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test [ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test -[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test -[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test -[ 328350 ] [ 100 [ sq ] sigma ] unit-test -[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test { 6 2 } [ 1 2 [ 5 + ] dip ] unit-test { 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test @@ -17,11 +13,6 @@ IN: temporary [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test -[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer -{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test -{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test -[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer -{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test [ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test [ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test [ [ sq ] 3apply ] must-infer @@ -55,5 +46,3 @@ IN: temporary [ dup array? ] [ dup vector? ] [ dup float? ] } || nip ] unit-test - -[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor old mode 100644 new mode 100755 index d0bc0a9e52..13e2919fd2 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -1,5 +1,5 @@ USING: arrays kernel sequences sequences.lib math -math.functions tools.test strings ; +math.functions tools.test strings math.ranges ; [ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test [ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test @@ -53,3 +53,16 @@ math.functions tools.test strings ; [ 2 ] [ { 1 2 3 } ?second ] unit-test [ 3 ] [ { 1 2 3 } ?third ] unit-test [ f ] [ { 1 2 3 } ?fourth ] unit-test + +[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test +[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test +[ 328350 ] [ 100 [ sq ] sigma ] unit-test + +[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer +{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test +{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test +[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer +{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test +[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test + +[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test diff --git a/extra/tools/browser/browser-tests.factor b/extra/tools/browser/browser-tests.factor old mode 100644 new mode 100755 index 4b3f1d5a6d..fc7960e475 --- a/extra/tools/browser/browser-tests.factor +++ b/extra/tools/browser/browser-tests.factor @@ -1,6 +1,4 @@ IN: temporary USING: tools.browser tools.test help.markup ; -[ t ] [ "resource:core" "kernel" vocab-dir? ] unit-test - [ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test From 1db4c9cc8a9369c0d3ef2fcf9c618cb732d6ec3b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 14:51:20 -0600 Subject: [PATCH 13/57] Fix type inference regression --- core/inference/class/class.factor | 16 +++++----------- core/inference/known-words/known-words.factor | 1 + 2 files changed, 6 insertions(+), 11 deletions(-) diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 3555725c1f..690571de98 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -185,20 +185,14 @@ M: pair constraint-satisfied? [ swap predicate-constraints ] [ 2drop ] if ] if* ; -: default-output-classes ( word -- classes ) - "inferred-effect" word-prop { - { [ dup not ] [ drop f ] } - { [ dup effect-out [ class? ] all? not ] [ drop f ] } - { [ t ] [ effect-out ] } - } cond ; - : compute-output-classes ( node word -- classes intervals ) - dup node-param "output-classes" word-prop dup - [ call ] [ 2drop f f ] if ; + dup node-param "output-classes" word-prop + dup [ call ] [ 2drop f f ] if ; : output-classes ( node -- classes intervals ) - dup compute-output-classes - >r [ ] [ node-param default-output-classes ] ?if r> ; + dup compute-output-classes >r + [ ] [ node-param "default-output-classes" word-prop ] ?if + r> ; M: #call infer-classes-before dup compute-constraints diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index f92987f15f..e6479d0c6a 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -147,6 +147,7 @@ M: object infer-call ] "infer" set-word-prop : set-primitive-effect ( word effect -- ) + 2dup effect-out "default-output-classes" set-word-prop dupd [ make-call-node ] 2curry "infer" set-word-prop ; ! Stack effects for all primitives From 46694f2f90de3aff8c089f63a00cf41276dadec9 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 11 Feb 2008 14:59:02 -0600 Subject: [PATCH 14/57] builder: move to build-loop model --- extra/builder/builder.factor | 46 ++++++++++++++++++++++++------------ 1 file changed, 31 insertions(+), 15 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index a17afb9d55..bb83fcf3f8 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,5 +1,5 @@ -USING: kernel io io.files io.launcher io.sockets hashtables +USING: kernel io io.files io.launcher io.sockets hashtables math threads system continuations namespaces sequences splitting math.parser prettyprint tools.time calendar bake vars http.client combinators bootstrap.image bootstrap.image.download @@ -95,9 +95,10 @@ VAR: stamp stamp> make-directory stamp> cd ; -: record-git-id ( -- ) - { "git" "show" } [ readln ] with-stream " " split second - "../git-id" log-object ; +: git-id ( -- id ) + { "git" "show" } [ readln ] with-stream " " split second ; + +: record-git-id ( -- ) git-id "../git-id" log-object ; : make-clean ( -- desc ) { "make" "clean" } ; @@ -113,7 +114,8 @@ VAR: stamp [ my-arch download-image ] [ ] [ "builder: image download" email-string ] - cleanup ; + cleanup + flush ; : bootstrap ( -- desc ) `{ @@ -135,12 +137,6 @@ SYMBOL: build-status : build ( -- ) - "running" build-status set-global - - "/builds/factor" cd - - git-pull "git pull error" run-or-notify - enter-build-dir git-clone "git clone error" run-or-notify @@ -165,10 +161,30 @@ SYMBOL: build-status "../failing-tests" exists? [ "failing tests" "../failing-tests" email-file ] - when - - "ready" build-status set-global ; + when ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -MAIN: build \ No newline at end of file +: minutes>ms ( min -- ms ) 60 * 1000 * ; + +: updates-available? ( -- ? ) + git-id + git-pull run-process drop + git-id + = not ; + +: build-loop ( -- ) + [ + "/builds/factor" cd + updates-available? + [ build ] + when + ] + [ drop ] + recover + 5 minutes>ms sleep + build-loop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: build-loop \ No newline at end of file From 7fa7ed962f3c0f0e490f95926e6b686c1bf1cfa5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 15:28:09 -0600 Subject: [PATCH 15/57] Fix prettyprinting of invalid curries and tuples --- core/prettyprint/backend/backend.factor | 13 ++++++++++++- core/prettyprint/prettyprint-tests.factor | 4 ++++ 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index d1364a5986..226595aa4d 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -182,9 +182,20 @@ M: tuple pprint-narrow? drop t ; >pprint-sequence pprint-elements block> r> pprint-word block> ] check-recursion ; - + M: object pprint* pprint-object ; +M: curry pprint* + dup curry-quot callable? [ pprint-object ] [ + "( invalid curry )" swap present-text + ] if ; + +M: compose pprint* + dup compose-first over compose-second [ callable? ] both? + [ pprint-object ] [ + "( invalid compose )" swap present-text + ] if ; + M: wrapper pprint* dup wrapped word? [ diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 5907c22686..a7e087ffad 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -321,3 +321,7 @@ unit-test [ [ 2 . ] ] [ [ 2 \ break (step-into) . ] (remove-breakpoints) ] unit-test + +[ ] [ 1 \ + curry unparse drop ] unit-test + +[ ] [ 1 \ + compose unparse drop ] unit-test From c6be6bcfdf076fc95e7b065b1dfc49137e3fea60 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 15:53:42 -0600 Subject: [PATCH 16/57] New sockets benchmark --- extra/benchmark/sockets/sockets.factor | 29 ++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100755 extra/benchmark/sockets/sockets.factor diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor new file mode 100755 index 0000000000..876ff0b61d --- /dev/null +++ b/extra/benchmark/sockets/sockets.factor @@ -0,0 +1,29 @@ +USING: io.sockets io.server io kernel math threads debugger +concurrency tools.time prettyprint ; +IN: benchmark.sockets + +: simple-server ( -- ) + 7777 local-server "simple-server" [ + 10 [ read1 write1 flush ] times + ] with-server ; + +: simple-client ( -- ) + "localhost" 7777 [ + 10 [ CHAR: a dup write1 flush read1 assert= ] times + ] with-stream ; + +: socket-benchmark ( n -- ) + dup pprint " clients: " write + [ simple-server ] in-thread + yield yield + [ drop simple-client ] parallel-each ; + +: socket-benchmarks + [ 10 socket-benchmark ] time + [ 20 socket-benchmark ] time + [ 40 socket-benchmark ] time + [ 80 socket-benchmark ] time + [ 160 socket-benchmark ] time + [ 320 socket-benchmark ] time ; + +MAIN: socket-benchmarks From 80c9fe3c83b5890fe14cc7b499a268299e8b26ca Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 16:10:03 -0600 Subject: [PATCH 17/57] Add stop-server word --- extra/io/server/server.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index a23984c207..5cb5aa5592 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -26,8 +26,10 @@ LOG: accepted-connection NOTICE : server-loop ( server quot -- ) [ accept-loop ] curry with-disposal ; inline +SYMBOL: servers + : spawn-server ( addrspec quot -- ) - >r r> server-loop ; inline + >r dup servers get push r> server-loop ; inline \ spawn-server NOTICE add-error-logging @@ -39,9 +41,13 @@ LOG: accepted-connection NOTICE : with-server ( seq service quot -- ) [ + V{ } clone servers set [ spawn-server ] curry concurrency:parallel-each ] curry with-logging ; inline +: stop-server ( -- ) + servers get [ dispose ] each ; + : received-datagram ( addrspec -- ) drop ; \ received-datagram NOTICE add-input-logging From 5c0374ce3251f4145bab54bad89a136880a53c95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 16:10:11 -0600 Subject: [PATCH 18/57] Improved sockets benchmark --- extra/benchmark/sockets/sockets.factor | 38 ++++++++++++++++++-------- 1 file changed, 26 insertions(+), 12 deletions(-) diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 876ff0b61d..e8efc11c32 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -3,27 +3,41 @@ concurrency tools.time prettyprint ; IN: benchmark.sockets : simple-server ( -- ) - 7777 local-server "simple-server" [ - 10 [ read1 write1 flush ] times + 7777 local-server "benchmark.sockets" [ + read1 CHAR: x = [ + stop-server + ] [ + 20 [ read1 write1 flush ] times + ] if ] with-server ; : simple-client ( -- ) "localhost" 7777 [ - 10 [ CHAR: a dup write1 flush read1 assert= ] times + CHAR: b write1 flush + 20 [ CHAR: a dup write1 flush read1 assert= ] times + ] with-stream ; + +: stop-server ( -- ) + "localhost" 7777 [ + CHAR: x write1 ] with-stream ; : socket-benchmark ( n -- ) dup pprint " clients: " write - [ simple-server ] in-thread - yield yield - [ drop simple-client ] parallel-each ; + [ + [ simple-server ] in-thread + 100 sleep + [ drop simple-client ] parallel-each + stop-server + yield yield + ] time ; : socket-benchmarks - [ 10 socket-benchmark ] time - [ 20 socket-benchmark ] time - [ 40 socket-benchmark ] time - [ 80 socket-benchmark ] time - [ 160 socket-benchmark ] time - [ 320 socket-benchmark ] time ; + 10 socket-benchmark + 20 socket-benchmark + 40 socket-benchmark + 80 socket-benchmark + 160 socket-benchmark + 320 socket-benchmark ; MAIN: socket-benchmarks From bacc5dc61075198363019d88daa7d920960fde33 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 16:19:10 -0600 Subject: [PATCH 19/57] Fix factor.sh for NetBSD --- misc/Factor.tmbundle/Commands/Eval Selection | 0 misc/Factor.tmbundle/Commands/Run Selection | 0 misc/factor.sh | 59 +++++++++++--------- 3 files changed, 33 insertions(+), 26 deletions(-) create mode 100644 misc/Factor.tmbundle/Commands/Eval Selection create mode 100644 misc/Factor.tmbundle/Commands/Run Selection diff --git a/misc/Factor.tmbundle/Commands/Eval Selection b/misc/Factor.tmbundle/Commands/Eval Selection new file mode 100644 index 0000000000..e69de29bb2 diff --git a/misc/Factor.tmbundle/Commands/Run Selection b/misc/Factor.tmbundle/Commands/Run Selection new file mode 100644 index 0000000000..e69de29bb2 diff --git a/misc/factor.sh b/misc/factor.sh index f0eb232821..5d7e7d0b94 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -1,4 +1,4 @@ -#!/bin/bash -e +#!/usr/bin/env bash # Programs returning != 0 will not cause script to exit set +e @@ -11,6 +11,9 @@ OS= ARCH= WORD= NO_UI= +GIT_PROTOCOL=${GIT_PROTOCOL:="git"} +GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"} + ensure_program_installed() { echo -n "Checking for $1..." @@ -51,6 +54,9 @@ check_installed_programs() { ensure_program_installed wget ensure_program_installed gcc ensure_program_installed make + case $OS in + netbsd) ensure_program_installed gmake;; + esac check_gcc_version } @@ -106,6 +112,7 @@ find_os() { *Darwin*) OS=macosx;; *linux*) OS=linux;; *Linux*) OS=linux;; + *NetBSD*) OS=netbsd;; esac } @@ -153,6 +160,8 @@ echo_build_info() { echo MAKE_TARGET=$MAKE_TARGET echo BOOT_IMAGE=$BOOT_IMAGE echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET + echo GIT_PROTOCOL=$GIT_PROTOCOL + echo GIT_URL=$GIT_URL } set_build_info() { @@ -188,22 +197,19 @@ find_build_info() { echo_build_info } +invoke_git() { + git $* + check_ret git +} + git_clone() { echo "Downloading the git repository from factorcode.org..." - git clone git://factorcode.org/git/factor.git - check_ret git + invoke_git clone $GIT_URL } git_pull_factorcode() { echo "Updating the git repository from factorcode.org..." - git pull git://factorcode.org/git/factor.git master - check_ret git -} - -http_git_pull_factorcode() { - echo "Updating the git repository from factorcode.org..." - git pull http://factorcode.org/git/factor.git master - check_ret git + invoke_git pull $GIT_URL master } cd_factor() { @@ -211,21 +217,28 @@ cd_factor() { check_ret cd } +invoke_make() { + case $OS in + netbsd) make='gmake';; + *) make='make';; + esac + $make $* + check_ret $make +} + make_clean() { - make clean - check_ret make + invoke_make clean } make_factor() { - make NO_UI=$NO_UI $MAKE_TARGET -j5 - check_ret make + invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5 } delete_boot_images() { echo "Deleting old images..." rm $BOOT_IMAGE > /dev/null 2>&1 rm $BOOT_IMAGE.* > /dev/null 2>&1 - rm staging.*.image > /dev/null 2>&1 + rm staging.*.image > /dev/null 2>&1 } get_boot_image() { @@ -257,8 +270,8 @@ maybe_download_dlls() { } get_config_info() { - check_installed_programs find_build_info + check_installed_programs check_libraries } @@ -285,13 +298,6 @@ update() { make_factor } -http_update() { - get_config_info - http_git_pull_factorcode - make_clean - make_factor -} - update_bootstrap() { delete_boot_images get_boot_image @@ -299,7 +305,7 @@ update_bootstrap() { } refresh_image() { - ./$FACTOR_BINARY -script -e="refresh-all save 0 USE: system exit" + ./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit" check_ret factor } @@ -316,6 +322,8 @@ install_libraries() { usage() { echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|wget-bootstrap" + echo "If you are behind a firewall, invoke as:" + echo "env GIT_PROTOCOL=http $0 " } case "$1" in @@ -324,7 +332,6 @@ case "$1" in self-update) update; make_boot_image; bootstrap;; quick-update) update; refresh_image ;; update) update; update_bootstrap ;; - http-update) http_update; update_bootstrap ;; bootstrap) get_config_info; bootstrap ;; wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;; *) usage ;; From 8db19c2ee5cb6e144d417084357d56a3631d1062 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:21:16 -0600 Subject: [PATCH 20/57] add ?first2 --- extra/sequences/lib/lib.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 048d63dc64..1d95f9fdf6 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -178,6 +178,10 @@ PRIVATE> : ?third ( seq -- third/f ) 2 swap ?nth ; inline : ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline +: ?first2 ( seq -- 1st/f 2nd/f ) dup ?first swap ?second ; inline +: ?first3 ( seq -- 1st/f 2nd/f 3rd/f ) dup ?first2 rot ?third ; inline +: ?first4 ( seq -- 1st/f 2nd/f 3rd/f 4th/f ) dup ?first3 roll ?fourth ; inline + : accumulator ( quot -- quot vec ) V{ } clone [ [ push ] curry compose ] keep ; From 0699bacf86e862dcc569c4fca0eff907c420d40d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:21:59 -0600 Subject: [PATCH 21/57] add money library --- extra/money/authors.txt | 2 ++ extra/money/money-tests.factor | 21 +++++++++++++++++++++ extra/money/money.factor | 29 +++++++++++++++++++++++++++++ extra/money/summary.txt | 1 + 4 files changed, 53 insertions(+) create mode 100644 extra/money/authors.txt create mode 100644 extra/money/money-tests.factor create mode 100644 extra/money/money.factor create mode 100644 extra/money/summary.txt diff --git a/extra/money/authors.txt b/extra/money/authors.txt new file mode 100644 index 0000000000..5674120196 --- /dev/null +++ b/extra/money/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Slava Pestov diff --git a/extra/money/money-tests.factor b/extra/money/money-tests.factor new file mode 100644 index 0000000000..19d6b6c2aa --- /dev/null +++ b/extra/money/money-tests.factor @@ -0,0 +1,21 @@ +USING: money parser tools.test ; +IN: temporary + +[ -1/10 ] [ DECIMAL: -.1 ] unit-test +[ -1/10 ] [ DECIMAL: -0.1 ] unit-test +[ -1/10 ] [ DECIMAL: -00.10 ] unit-test + +[ 0 ] [ DECIMAL: .0 ] unit-test +[ 0 ] [ DECIMAL: 0.0 ] unit-test +[ 0 ] [ DECIMAL: 0. ] unit-test +[ 0 ] [ DECIMAL: 0 ] unit-test +[ 1/10 ] [ DECIMAL: .1 ] unit-test +[ 1/10 ] [ DECIMAL: 0.1 ] unit-test +[ 1/10 ] [ DECIMAL: 00.10 ] unit-test + + + +[ "DECIMAL: ." eval ] must-fail +[ "DECIMAL: f" eval ] must-fail +[ "DECIMAL: 0.f" eval ] must-fail +[ "DECIMAL: f.0" eval ] must-fail diff --git a/extra/money/money.factor b/extra/money/money.factor new file mode 100644 index 0000000000..d742a3be5a --- /dev/null +++ b/extra/money/money.factor @@ -0,0 +1,29 @@ +USING: io kernel math math.functions math.parser parser +namespaces sequences splitting combinators continuations +sequences.lib ; +IN: money + +: dollars/cents ( dollars -- dollars cents ) + 100 * 100 /mod round ; + +: money. ( object -- ) + dollars/cents + [ + "$" % + swap number>string + 3 group "," join % + "." % number>string 2 48 pad-left % + ] "" make print ; + +TUPLE: not-a-decimal ; +: DECIMAL: + scan + "." split dup length 1 2 between? [ + T{ not-a-decimal } throw + ] unless + ?first2 + >r dup ?first CHAR: - = [ drop t "0" ] [ f swap ] if r> + [ dup empty? [ drop "0" ] when ] 2apply + dup length + >r [ string>number dup [ T{ not-a-decimal } throw ] unless ] 2apply r> + 10 swap ^ / + swap [ neg ] when parsed ; parsing diff --git a/extra/money/summary.txt b/extra/money/summary.txt new file mode 100644 index 0000000000..fcfaf151f6 --- /dev/null +++ b/extra/money/summary.txt @@ -0,0 +1 @@ +Utility for calculating money with rationals From 0e9ec0dd6a4a4c62ea3afcf99a36ce4f330cf150 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:27:22 -0600 Subject: [PATCH 22/57] Add taxes library --- extra/taxes/authors.txt | 1 + extra/taxes/summary.txt | 1 + extra/taxes/taxes-tests.factor | 98 +++++++++++++++++++++++ extra/taxes/taxes.factor | 140 +++++++++++++++++++++++++++++++++ 4 files changed, 240 insertions(+) create mode 100644 extra/taxes/authors.txt create mode 100644 extra/taxes/summary.txt create mode 100644 extra/taxes/taxes-tests.factor create mode 100644 extra/taxes/taxes.factor diff --git a/extra/taxes/authors.txt b/extra/taxes/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/taxes/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/taxes/summary.txt b/extra/taxes/summary.txt new file mode 100644 index 0000000000..e983139ccb --- /dev/null +++ b/extra/taxes/summary.txt @@ -0,0 +1 @@ +Calculate federal and state tax withholdings diff --git a/extra/taxes/taxes-tests.factor b/extra/taxes/taxes-tests.factor new file mode 100644 index 0000000000..4091156558 --- /dev/null +++ b/extra/taxes/taxes-tests.factor @@ -0,0 +1,98 @@ +USING: kernel money taxes tools.test ; +IN: temporary + +[ + 426 23 +] [ + 12000 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 426 23 +] [ + 12000 2008 3 t net biweekly + dollars/cents +] unit-test + +[ + 684 4 +] [ + 20000 2008 3 f net biweekly + dollars/cents +] unit-test + + + +[ + 804 58 +] [ + 24000 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 831 31 +] [ + 24000 2008 3 t net biweekly + dollars/cents +] unit-test + + +[ + 780 81 +] [ + 24000 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 818 76 +] [ + 24000 2008 3 t net biweekly + dollars/cents +] unit-test + + +[ + 2124 39 +] [ + 78250 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 2321 76 +] [ + 78250 2008 3 t net biweekly + dollars/cents +] unit-test + + +[ + 2612 63 +] [ + 100000 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 22244 52 +] [ + 1000000 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 578357 40 +] [ + 1000000 2008 3 f net + dollars/cents +] unit-test + +[ + 588325 41 +] [ + 1000000 2008 3 t net + dollars/cents +] unit-test diff --git a/extra/taxes/taxes.factor b/extra/taxes/taxes.factor new file mode 100644 index 0000000000..0f51d7ab6a --- /dev/null +++ b/extra/taxes/taxes.factor @@ -0,0 +1,140 @@ +USING: arrays assocs kernel math math.intervals namespaces +sequences combinators.lib money ; +IN: taxes + +: monthly ( x -- y ) 12 / ; +: semimonthly ( x -- y ) 24 / ; +: biweekly ( x -- y ) 26 / ; +: weekly ( x -- y ) 52 / ; +: daily ( x -- y ) 360 / ; + +! Each employee fills out a w4 +TUPLE: w4 year allowances married? ; +C: w4 + +: allowance ( -- x ) 3500 ; inline + +: calculate-w4-allowances ( w4 -- x ) + w4-allowances allowance * ; + +! Withhold: FICA, Medicare, Federal (FICA is social security) +: fica-tax-rate ( -- x ) DECIMAL: .062 ; inline + +! Base rate -- income over this rate is not taxed +TUPLE: fica-base-unknown ; +: fica-base-rate ( year -- x ) + H{ + { 2008 102000 } + { 2007 97500 } + } at* [ T{ fica-base-unknown } throw ] unless ; + +: fica-tax ( salary w4 -- x ) + w4-year fica-base-rate min fica-tax-rate * ; + +! Employer tax only, not withheld +: futa-tax-rate ( -- x ) DECIMAL: .062 ; inline + +! No base rate for medicare; all wages subject +: medicare-tax-rate ( -- x ) DECIMAL: .0145 ; inline +: medicare-tax ( salary w4 -- x ) drop medicare-tax-rate * ; + +MIXIN: collector +GENERIC: adjust-allowances ( salary w4 collector -- newsalary ) +GENERIC: withholding ( salary w4 collector -- x ) +GENERIC: net ( salary w4 collector -- x ) + +TUPLE: tax-table single married ; + +: ( single married class -- obj ) + >r tax-table construct-boa r> construct-delegate ; + +: tax-bracket-range dup second swap first - ; + +: tax-bracket ( tax salary triples -- tax salary ) + [ [ tax-bracket-range min ] keep third * + ] 2keep + tax-bracket-range [-] ; + +: tax ( salary triples -- x ) + 0 -rot [ tax-bracket ] each drop ; + +: marriage-table ( w4 tax-table -- triples ) + swap w4-married? + [ tax-table-married ] [ tax-table-single ] if ; + +: federal-tax ( salary w4 tax-table -- n ) + [ adjust-allowances ] 2keep marriage-table tax ; + +! http://www.irs.gov/pub/irs-pdf/p15.pdf +! Table 7 ANNUAL Payroll Period + +: federal-single ( -- triples ) + { + { 0 2650 DECIMAL: 0 } + { 2650 10300 DECIMAL: .10 } + { 10300 33960 DECIMAL: .15 } + { 33960 79725 DECIMAL: .25 } + { 79725 166500 DECIMAL: .28 } + { 166500 359650 DECIMAL: .33 } + { 359650 1/0. DECIMAL: .35 } + } ; + +: federal-married ( -- triples ) + { + { 0 8000 DECIMAL: 0 } + { 8000 23550 DECIMAL: .10 } + { 23550 72150 DECIMAL: .15 } + { 72150 137850 DECIMAL: .25 } + { 137850 207700 DECIMAL: .28 } + { 207700 365100 DECIMAL: .33 } + { 365100 1/0. DECIMAL: .35 } + } ; + +TUPLE: federal ; +INSTANCE: federal collector +: ( -- obj ) + federal-single federal-married federal ; + +M: federal adjust-allowances ( salary w4 collector -- newsalary ) + drop calculate-w4-allowances - ; + +M: federal withholding ( salary w4 tax-table -- x ) + [ federal-tax ] 3keep drop + [ fica-tax ] 2keep + medicare-tax + + ; + +M: federal net ( salary w4 collector -- x ) + >r dupd r> withholding - ; + +M: collector net ( salary w4 collector -- x ) + >r dupd r> + [ withholding ] 3keep + drop withholding + - ; + + +! Minnesota +: minnesota-single ( -- triples ) + { + { 0 1950 DECIMAL: 0 } + { 1950 23750 DECIMAL: .0535 } + { 23750 73540 DECIMAL: .0705 } + { 73540 1/0. DECIMAL: .0785 } + } ; + +: minnesota-married ( -- triples ) + { + { 0 7400 DECIMAL: 0 } + { 7400 39260 DECIMAL: .0535 } + { 39260 133980 DECIMAL: .0705 } + { 133980 1/0. DECIMAL: .0785 } + } ; + +TUPLE: minnesota ; +INSTANCE: minnesota collector +: ( -- obj ) + minnesota-single minnesota-married minnesota ; + +M: minnesota adjust-allowances ( salary w4 collector -- newsalary ) + drop calculate-w4-allowances - ; + +M: minnesota withholding ( salary w4 collector -- x ) + [ adjust-allowances ] 2keep marriage-table tax ; From 34c1170963820b19c728453d00c46ba870443b2a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:27:40 -0600 Subject: [PATCH 23/57] add a few utility words --- extra/html/parser/analyzer/analyzer.factor | 35 +++++++++------------- 1 file changed, 14 insertions(+), 21 deletions(-) diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index e4f11cd91e..dcfbd1e197 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,5 +1,5 @@ -USING: assocs html.parser kernel math sequences strings unicode.categories - unicode.case ; +USING: assocs html.parser kernel math sequences strings ascii +arrays shuffle unicode.case namespaces ; IN: html.parser.analyzer : remove-blank-text ( vector -- vector' ) @@ -65,28 +65,21 @@ IN: html.parser.analyzer [ tag-attributes "href" swap at ] map [ ] subset ; +: (find-all) ( n seq quot -- ) + 2dup >r >r find* [ + dupd 2array , 1+ r> r> (find-all) + ] [ + r> r> 3drop + ] if* ; +: find-all ( seq quot -- alist ) + [ 0 -rot (find-all) ] { } make ; -! : find-last-tag ( name vector -- index tag ) - ! [ - ! dup tag-matched? [ 2drop f ] [ tag-name = ] if - ! ] with find-last ; +: find-opening-tags-by-name ( name seq -- seq ) + [ [ tag-name = ] keep tag-closing? not and ] with find-all ; -! : find-last-tag* ( name n vector -- tag ) - ! 0 -rot find-last-tag ; +: href-contains? ( str tag -- ? ) + tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ; -! : find-matching-tag ( tag -- tag ) - ! dup tag-closing? [ - ! find-last-tag - ! ] [ - ! ] if ; - - -! clear "/Users/erg/web/fark.html" file-contents parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map ! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map -! clear "/Users/erg/web/hostels.html" file-contents parse-html "Currency" "name" pick find-first-attribute-key-value - -! clear "/Users/erg/web/hostels.html" file-contents parse-html -! "Currency" "name" pick find-first-attribute-key-value -! pick find-between remove-blank-text From a345d4fc37e8142b2c91f14c1fdae2c2e5bb15a5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:32:36 -0600 Subject: [PATCH 24/57] delete a couple files in misc/Factor.tmbundle --- .../Commands/Eval Selection:Line.tmCommand | 27 ------------------- .../Run Selection:Line in Listener.tmCommand | 27 ------------------- 2 files changed, 54 deletions(-) delete mode 100644 misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand delete mode 100644 misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand diff --git a/misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand b/misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand deleted file mode 100644 index 37867a2737..0000000000 --- a/misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand +++ /dev/null @@ -1,27 +0,0 @@ - - - - - beforeRunningCommand - nop - command - #!/usr/bin/env ruby - -require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor" -puts factor_eval(STDIN.read) - fallbackInput - line - input - selection - keyEquivalent - ^E - name - Eval Selection/Line - output - replaceSelectedText - scope - source.factor - uuid - 8E01DDAF-959B-4237-ADB9-C133A4ACCE90 - - diff --git a/misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand b/misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand deleted file mode 100644 index 5028bd8db3..0000000000 --- a/misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand +++ /dev/null @@ -1,27 +0,0 @@ - - - - - beforeRunningCommand - nop - command - #!/usr/bin/env ruby - -require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor" -factor_run(STDIN.read) - fallbackInput - line - input - selection - keyEquivalent - ^~e - name - Run Selection/Line in Listener - output - discard - scope - source.factor - uuid - 15A984BD-BC65-43E8-878A-267788C8DA70 - - From d976b114455c819363ffd9c7b350a9757aca40cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 16:44:13 -0600 Subject: [PATCH 25/57] Fix multiple reload issue --- core/vocabs/loader/loader.factor | 32 +++++++++++++++++++++++++++----- 1 file changed, 27 insertions(+), 5 deletions(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 50ae55f506..8e548b3043 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -160,13 +160,18 @@ SYMBOL: load-help? : load-failures. ( failures -- ) [ load-error. nl ] each ; +SYMBOL: blacklist + : require-all ( vocabs -- failures ) [ + V{ } clone blacklist set [ [ [ require ] - [ error-continuation get 3array , ] - recover + [ + over vocab-name blacklist get push + error-continuation get 3array , + ] recover ] each ] { } make ] with-compiler-errors ; @@ -182,7 +187,7 @@ SYMBOL: load-help? : refresh-all ( -- ) "" refresh ; GENERIC: (load-vocab) ( name -- vocab ) - +! M: vocab (load-vocab) dup vocab-root [ dup vocab-source-loaded? [ dup load-source ] unless @@ -195,8 +200,25 @@ M: string (load-vocab) M: vocab-link (load-vocab) vocab-name (load-vocab) ; -[ [ dup vocab [ ] [ ] ?if (load-vocab) ] with-compiler-errors ] -load-vocab-hook set-global +TUPLE: blacklisted-vocab name ; +! +: blacklisted-vocab ( name -- * ) + \ blacklisted-vocab construct-boa throw ; + +M: blacklisted-vocab error. + "This vocabulary depends on the " write + blacklisted-vocab-name write + " vocabulary which failed to load" print ; + +[ + dup vocab-name blacklist get member? [ + vocab-name blacklisted-vocab + ] [ + [ + dup vocab [ ] [ ] ?if (load-vocab) + ] with-compiler-errors + ] if +] load-vocab-hook set-global : vocab-where ( vocab -- loc ) vocab-source-path dup [ 1 2array ] when ; From 008da8a6baf32758726e55d4217008c1514b5e7b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:45:38 -0600 Subject: [PATCH 26/57] cleanup on aisle DECIMAL: --- extra/money/money.factor | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/extra/money/money.factor b/extra/money/money.factor index d742a3be5a..4058ee9e6a 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -12,18 +12,21 @@ IN: money "$" % swap number>string 3 group "," join % - "." % number>string 2 48 pad-left % + "." % number>string 2 CHAR: 0 pad-left % ] "" make print ; TUPLE: not-a-decimal ; -: DECIMAL: - scan - "." split dup length 1 2 between? [ - T{ not-a-decimal } throw - ] unless - ?first2 - >r dup ?first CHAR: - = [ drop t "0" ] [ f swap ] if r> + +: not-a-decimal ( -- * ) + T{ not-a-decimal } throw ; + +: parse-decimal ( str -- ratio ) + "." split1 + >r dup "-" head? [ drop t "0" ] [ f swap ] if r> [ dup empty? [ drop "0" ] when ] 2apply dup length - >r [ string>number dup [ T{ not-a-decimal } throw ] unless ] 2apply r> - 10 swap ^ / + swap [ neg ] when parsed ; parsing + >r [ string>number dup [ not-a-decimal ] unless ] 2apply r> + 10 swap ^ / + swap [ neg ] when ; + +: DECIMAL: + scan parse-decimal parsed ; parsing From a6ba0cb392217eb0a0fafbb76ab9308f72b6858f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 16:47:35 -0600 Subject: [PATCH 27/57] Clean up code a bit --- core/vocabs/loader/loader.factor | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 8e548b3043..5e8a5630b2 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -155,7 +155,6 @@ SYMBOL: load-help? dup first vocab-heading. dup second print-error drop ; - ! third "Traceback" swap write-object ; : load-failures. ( failures -- ) [ load-error. nl ] each ; @@ -166,14 +165,11 @@ SYMBOL: blacklist [ V{ } clone blacklist set [ - [ - [ require ] - [ - over vocab-name blacklist get push - error-continuation get 3array , - ] recover - ] each - ] { } make + [ require ] + [ >r vocab-name r> 2array blacklist get push ] + recover + ] each + blacklist get ] with-compiler-errors ; : do-refresh ( modified-sources modified-docs -- ) @@ -201,7 +197,7 @@ M: vocab-link (load-vocab) vocab-name (load-vocab) ; TUPLE: blacklisted-vocab name ; -! + : blacklisted-vocab ( name -- * ) \ blacklisted-vocab construct-boa throw ; @@ -211,7 +207,7 @@ M: blacklisted-vocab error. " vocabulary which failed to load" print ; [ - dup vocab-name blacklist get member? [ + dup vocab-name blacklist get key? [ vocab-name blacklisted-vocab ] [ [ From 41c85c7edc56d49aa11a04f7dd2891cd4e7085b3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 16:56:48 -0600 Subject: [PATCH 28/57] Structure alignment fixes --- core/cpu/ppc/ppc.factor | 4 ++++ core/cpu/x86/32/32.factor | 6 +++--- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/core/cpu/ppc/ppc.factor b/core/cpu/ppc/ppc.factor index 901b339d7e..75de49acda 100755 --- a/core/cpu/ppc/ppc.factor +++ b/core/cpu/ppc/ppc.factor @@ -13,3 +13,7 @@ namespaces alien.c-types kernel system combinators ; } cond T{ ppc-backend } compiler-backend set-global + +macosx? [ + 4 "double" c-type set-c-type-align +] when diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 4ed186d769..ecae55e69a 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -261,9 +261,9 @@ windows? [ cell "ulonglong" c-type set-c-type-align ] unless -macosx? [ - cell "double" c-type set-c-type-align -] when +windows? [ + 4 "double" c-type set-c-type-align +] unless T{ x86-backend f 4 } compiler-backend set-global From 3b6e6a1e1395497b4264be2c194c3f0f100fa155 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 17:19:27 -0600 Subject: [PATCH 29/57] add query>hash* to html.parser.analyzer --- extra/html/parser/analyzer/analyzer.factor | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index dcfbd1e197..fca15d9b07 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,5 +1,6 @@ USING: assocs html.parser kernel math sequences strings ascii -arrays shuffle unicode.case namespaces ; +arrays shuffle unicode.case namespaces splitting +http.server.responders ; IN: html.parser.analyzer : remove-blank-text ( vector -- vector' ) @@ -81,5 +82,14 @@ IN: html.parser.analyzer : href-contains? ( str tag -- ? ) tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ; +: query>hash* ( str -- hash ) + "?" split1 nip query>hash ; + ! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map +! clear "http://www.sailwx.info/shiptrack/cruiseships.phtml" http-get parse-html remove-blank-text +! "a" over find-opening-tags-by-name +! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-subset +! first first 8 + over nth +! tag-attributes "href" swap at query>hash* +! "lat" over at "lon" rot at From 0b9d1c5141cd666e74f8328b0e9c4e311b13bc62 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 18:11:29 -0600 Subject: [PATCH 30/57] add total collector to taxes --- extra/taxes/taxes.factor | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/extra/taxes/taxes.factor b/extra/taxes/taxes.factor index 0f51d7ab6a..2c5501c357 100644 --- a/extra/taxes/taxes.factor +++ b/extra/taxes/taxes.factor @@ -105,11 +105,6 @@ M: federal withholding ( salary w4 tax-table -- x ) M: federal net ( salary w4 collector -- x ) >r dupd r> withholding - ; -M: collector net ( salary w4 collector -- x ) - >r dupd r> - [ withholding ] 3keep - drop withholding + - ; - ! Minnesota : minnesota-single ( -- triples ) @@ -138,3 +133,15 @@ M: minnesota adjust-allowances ( salary w4 collector -- newsalary ) M: minnesota withholding ( salary w4 collector -- x ) [ adjust-allowances ] 2keep marriage-table tax ; + +TUPLE: total ; +INSTANCE: total collector + +! Totals +M: total net ( salary w4 collector -- x ) + >r dupd r> + [ withholding ] 3keep + drop withholding + - ; + +M: total withholding ( salary w4 collector -- x ) + >r >r dup r> r> net - ; From ecb28dc0292c3096c0f8b9d6c48b73bfc9670b12 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 11 Feb 2008 18:13:49 -0600 Subject: [PATCH 31/57] builder: Switching to single report model --- extra/builder/builder.factor | 146 +++++++++++++++++++++++++++++---- extra/builder/test/test.factor | 48 +++++++++-- 2 files changed, 172 insertions(+), 22 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index bb83fcf3f8..1783a36928 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -133,36 +133,154 @@ VAR: stamp ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SYMBOL: build-status +! SYMBOL: build-status -: build ( -- ) +! : build ( -- ) + +! enter-build-dir + +! git-clone "git clone error" run-or-notify + +! "factor" cd + +! record-git-id + +! make-clean "make clean error" run-or-notify + +! make-vm "vm compile error" "../compile-log" run-or-send-file + +! retrieve-boot-image + +! bootstrap "bootstrap error" "../boot-log" run-or-send-file + +! builder-test "builder.test fatal error" run-or-notify + +! "../load-everything-log" exists? +! [ "load-everything" "../load-everything-log" email-file ] +! when + +! "../failing-tests" exists? +! [ "failing tests" "../failing-tests" email-file ] +! when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: report + +: (build) ( -- ) enter-build-dir - - git-clone "git clone error" run-or-notify + + "report" report set + + report get [ "Build machine: " write host-name write nl ] with-stream* + + report get [ "Build directory: " write cwd write nl ] with-stream* + + [ git-clone try-process ] + [ + report get + [ "Builder fatal error: git clone failed" write nl ] + with-stream* + throw + ] + recover "factor" cd record-git-id - make-clean "make clean error" run-or-notify + make-clean run-process drop - make-vm "vm compile error" "../compile-log" run-or-send-file + [ make-vm try-process ] + [ + report get + [ + "Builder fatal error: vm compile error" write nl + "../compile-log" contents write + ] + with-stream* + throw + ] + recover - retrieve-boot-image + [ my-arch download-image ] + [ + report get + [ "Builder fatal error: image download" write nl ] + with-stream* + throw + ] + recover - bootstrap "bootstrap error" "../boot-log" run-or-send-file + [ bootstrap try-process ] + [ + report get + [ + "Bootstrap error" write nl + "../boot-log" contents write + ] + with-stream* + throw + ] + recover - builder-test "builder.test fatal error" run-or-notify - - "../load-everything-log" exists? - [ "load-everything" "../load-everything-log" email-file ] + [ builder-test try-process ] + [ + report get + [ + "Builder test error" write nl + "../load-everything-log" exists? + [ "../load-everything-log" contents write nl ] + when + "../test-all-log" exists? + [ "../test-all-log" contents write nl ] + when + ] + with-stream* + throw + ] + recover + + report get + [ + "Bootstrap time: " write + "../bootstrap-time" contents write nl + ] + with-stream* + + "../load-everything-vocabs" exists? + [ + report get + [ + "Did not pass load-everything: " write nl + "../load-everything-vocabs" contents write nl + ] + with-stream* + ] when - "../failing-tests" exists? - [ "failing tests" "../failing-tests" email-file ] + "../test-all-vocabs" exists? + [ + report get + [ + "Did not pass test-all: " write nl + "../test-all-vocabs" contents write nl + ] + with-stream* + ] when ; +: send-report ( -- ) + report get dispose + "report" "../report" email-file ; + +: build ( -- ) + [ (build) ] + [ drop ] + recover + send-report ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : minutes>ms ( min -- ms ) 60 * 1000 * ; diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index b77199c7c5..159fe02ad6 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -7,22 +7,54 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader IN: builder.test +: record-bootstrap-time ( -- ) + "../bootstrap-time" + [ bootstrap-time get . ] + with-stream ; + : try-everything* ( -- vocabs ) try-everything [ first vocab-link-name ] map ; +! : do-load ( -- ) +! [ try-everything* ] "../load-everything-time" log-runtime +! dup empty? +! [ drop ] +! [ "../load-everything-log" log-object ] +! if ; + : do-load ( -- ) - [ try-everything* ] "../load-everything-time" log-runtime + [ + "../load-everything-log" + [ try-everything* ] + with-stream + ] "../load-everything-time" log-runtime dup empty? [ drop ] - [ "../load-everything-log" log-object ] - if ; + [ "../load-everything-vocabs" log-object ] + if + "../load-everything-log" delete-file ; + +! : do-tests ( -- ) +! run-all-tests keys +! dup empty? +! [ drop ] +! [ "../failing-tests" log-object ] +! if ; : do-tests ( -- ) - run-all-tests keys + [ + "../test-all-log" + [ run-all-tests keys ] + with-stream + ] "../test-all-time" log-runtime dup empty? - [ drop ] - [ "../failing-tests" log-object ] - if ; + [ drop ] + [ "../test-all-vocabs" log-object ] + if + "../test-all-log" delete-file ; -: do-all ( -- ) do-load do-tests ; +: do-all ( -- ) + record-bootstrap-time + do-load + do-tests ; MAIN: do-all \ No newline at end of file From ad0b2cb08c22ecad37ada3e4135321e93f91bc66 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 11 Feb 2008 18:34:02 -0600 Subject: [PATCH 32/57] builder.test: fix using --- extra/builder/test/test.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index 159fe02ad6..dfe64b38d9 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -3,7 +3,8 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader io io.files tools.browser - tools.test ; + tools.test + bootstrap.stage2 ; IN: builder.test From fb13521418511c939609901d8a9dd9e0b8ecb260 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 11 Feb 2008 18:35:27 -0600 Subject: [PATCH 33/57] builder.test: more using fixes --- extra/builder/test/test.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index dfe64b38d9..6f87213096 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -1,7 +1,9 @@ -USING: kernel sequences assocs builder continuations vocabs vocabs.loader +USING: kernel namespaces sequences assocs builder continuations + vocabs vocabs.loader io io.files + prettyprint tools.browser tools.test bootstrap.stage2 ; From 3a4ae00e775c41f52405cf014c9b10b6e4c4a9cd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 18:35:34 -0600 Subject: [PATCH 34/57] fix a bug --- extra/taxes/taxes.factor | 17 ++++------------- 1 file changed, 4 insertions(+), 13 deletions(-) diff --git a/extra/taxes/taxes.factor b/extra/taxes/taxes.factor index 2c5501c357..d557feabfa 100644 --- a/extra/taxes/taxes.factor +++ b/extra/taxes/taxes.factor @@ -41,7 +41,6 @@ TUPLE: fica-base-unknown ; MIXIN: collector GENERIC: adjust-allowances ( salary w4 collector -- newsalary ) GENERIC: withholding ( salary w4 collector -- x ) -GENERIC: net ( salary w4 collector -- x ) TUPLE: tax-table single married ; @@ -102,9 +101,6 @@ M: federal withholding ( salary w4 tax-table -- x ) [ fica-tax ] 2keep medicare-tax + + ; -M: federal net ( salary w4 collector -- x ) - >r dupd r> withholding - ; - ! Minnesota : minnesota-single ( -- triples ) @@ -134,14 +130,9 @@ M: minnesota adjust-allowances ( salary w4 collector -- newsalary ) M: minnesota withholding ( salary w4 collector -- x ) [ adjust-allowances ] 2keep marriage-table tax ; -TUPLE: total ; -INSTANCE: total collector - -! Totals -M: total net ( salary w4 collector -- x ) - >r dupd r> +: employer-withhold ( salary w4 collector -- x ) [ withholding ] 3keep - drop withholding + - ; + dup federal? [ 3drop ] [ drop withholding + ] if ; -M: total withholding ( salary w4 collector -- x ) - >r >r dup r> r> net - ; +: net ( salary w4 collector -- x ) + >r dupd r> employer-withhold - ; From 9efaa4db6ab73d78f129c71ed95c468970213ede Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 11 Feb 2008 17:45:03 -0800 Subject: [PATCH 35/57] Add back the TextMate commands with Windows-friendly names --- misc/Factor.tmbundle/Commands/Eval Selection | 0 .../Commands/Eval Selection.tmCommand | 27 +++++++++++++++++++ misc/Factor.tmbundle/Commands/Run Selection | 0 .../Commands/Run Selection.tmCommand | 27 +++++++++++++++++++ 4 files changed, 54 insertions(+) delete mode 100644 misc/Factor.tmbundle/Commands/Eval Selection create mode 100644 misc/Factor.tmbundle/Commands/Eval Selection.tmCommand delete mode 100644 misc/Factor.tmbundle/Commands/Run Selection create mode 100644 misc/Factor.tmbundle/Commands/Run Selection.tmCommand diff --git a/misc/Factor.tmbundle/Commands/Eval Selection b/misc/Factor.tmbundle/Commands/Eval Selection deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/misc/Factor.tmbundle/Commands/Eval Selection.tmCommand b/misc/Factor.tmbundle/Commands/Eval Selection.tmCommand new file mode 100644 index 0000000000..d5b6dc6aa3 --- /dev/null +++ b/misc/Factor.tmbundle/Commands/Eval Selection.tmCommand @@ -0,0 +1,27 @@ + + + + + beforeRunningCommand + nop + command + #!/usr/bin/env ruby + +require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor" +puts factor_eval(STDIN.read) + fallbackInput + line + input + selection + keyEquivalent + ^E + name + Eval Selection + output + replaceSelectedText + scope + source.factor + uuid + 8E01DDAF-959B-4237-ADB9-C133A4ACCE90 + + diff --git a/misc/Factor.tmbundle/Commands/Run Selection b/misc/Factor.tmbundle/Commands/Run Selection deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/misc/Factor.tmbundle/Commands/Run Selection.tmCommand b/misc/Factor.tmbundle/Commands/Run Selection.tmCommand new file mode 100644 index 0000000000..f08bf006b9 --- /dev/null +++ b/misc/Factor.tmbundle/Commands/Run Selection.tmCommand @@ -0,0 +1,27 @@ + + + + + beforeRunningCommand + nop + command + #!/usr/bin/env ruby + +require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor" +factor_run(STDIN.read) + fallbackInput + line + input + selection + keyEquivalent + ^~e + name + Run Selection + output + discard + scope + source.factor + uuid + 15A984BD-BC65-43E8-878A-267788C8DA70 + + From b321d5a33da0afe37944e65ce71bcc92b015d11c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 11 Feb 2008 17:47:29 -0800 Subject: [PATCH 36/57] Add missing sequences.lib USE to bunny demo --- extra/bunny/model/model.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index b238bd8b99..1e14449ae1 100644 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -3,7 +3,7 @@ math.vectors math.matrices math.parser io io.files kernel opengl opengl.gl opengl.glu opengl.capabilities shuffle http.client vectors splitting tools.time system combinators combinators.lib combinators.cleave -float-arrays continuations namespaces ; +float-arrays continuations namespaces sequences.lib ; IN: bunny.model : numbers ( str -- seq ) From 11ff8c65492c0bc66aa91bb7950482788da32578 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 11 Feb 2008 21:17:42 -0600 Subject: [PATCH 37/57] builder: builder.server still references build-status --- extra/builder/builder.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 1783a36928..fa76f8ec3c 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -133,7 +133,7 @@ VAR: stamp ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! SYMBOL: build-status +SYMBOL: build-status ! : build ( -- ) From 8a25e9432c68a3b025232152191cc42fa933a491 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 11 Feb 2008 21:32:41 -0600 Subject: [PATCH 38/57] builder.test: recover from errors in do-load and do-tests --- extra/builder/test/test.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index 6f87213096..21734bf18c 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -57,7 +57,7 @@ IN: builder.test : do-all ( -- ) record-bootstrap-time - do-load - do-tests ; + [ do-load ] [ drop ] recover + [ do-tests ] [ drop ] recover ; MAIN: do-all \ No newline at end of file From cb76e4775cf4e595e12290a7ed549da7f7ec4ee3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 11 Feb 2008 22:22:49 -0600 Subject: [PATCH 39/57] builder.test: tweaks --- extra/builder/test/test.factor | 52 +++++++++++++++++++++------------- 1 file changed, 32 insertions(+), 20 deletions(-) diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index 21734bf18c..e401b689c4 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -15,26 +15,26 @@ IN: builder.test [ bootstrap-time get . ] with-stream ; -: try-everything* ( -- vocabs ) try-everything [ first vocab-link-name ] map ; +! : try-everything* ( -- vocabs ) try-everything [ first vocab-link-name ] map ; ! : do-load ( -- ) -! [ try-everything* ] "../load-everything-time" log-runtime +! [ +! "../load-everything-log" +! [ try-everything keys ] +! with-stream +! ] "../load-everything-time" log-runtime ! dup empty? ! [ drop ] -! [ "../load-everything-log" log-object ] -! if ; +! [ "../load-everything-vocabs" log-object ] +! if +! "../load-everything-log" delete-file ; : do-load ( -- ) - [ - "../load-everything-log" - [ try-everything* ] - with-stream - ] "../load-everything-time" log-runtime + [ try-everything keys ] "../load-everything-time" log-runtime dup empty? [ drop ] [ "../load-everything-vocabs" log-object ] - if - "../load-everything-log" delete-file ; + if ; ! : do-tests ( -- ) ! run-all-tests keys @@ -43,21 +43,33 @@ IN: builder.test ! [ "../failing-tests" log-object ] ! if ; +! : do-tests ( -- ) +! [ +! "../test-all-log" +! [ run-all-tests keys ] +! with-stream +! ] "../test-all-time" log-runtime +! dup empty? +! [ drop ] +! [ "../test-all-vocabs" log-object ] +! if +! "../test-all-log" delete-file ; + : do-tests ( -- ) - [ - "../test-all-log" - [ run-all-tests keys ] - with-stream - ] "../test-all-time" log-runtime + [ run-all-tests keys ] "../test-all-time" log-runtime dup empty? [ drop ] [ "../test-all-vocabs" log-object ] - if - "../test-all-log" delete-file ; + if ; + +! : do-all ( -- ) +! record-bootstrap-time +! [ do-load ] [ drop ] recover +! [ do-tests ] [ drop ] recover ; : do-all ( -- ) record-bootstrap-time - [ do-load ] [ drop ] recover - [ do-tests ] [ drop ] recover ; + do-load + do-tests ; MAIN: do-all \ No newline at end of file From 620a2ab7201ba8790c3507c0b700f8655b02d55f Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 11 Feb 2008 22:36:53 -0600 Subject: [PATCH 40/57] builder: more tweaks --- extra/builder/builder.factor | 10 +-------- extra/builder/test/test.factor | 38 ---------------------------------- 2 files changed, 1 insertion(+), 47 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index fa76f8ec3c..9c4c833182 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -228,15 +228,7 @@ SYMBOL: report [ builder-test try-process ] [ report get - [ - "Builder test error" write nl - "../load-everything-log" exists? - [ "../load-everything-log" contents write nl ] - when - "../test-all-log" exists? - [ "../test-all-log" contents write nl ] - when - ] + [ "Builder test error" write nl ] with-stream* throw ] diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index e401b689c4..0a5750a030 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -15,20 +15,6 @@ IN: builder.test [ bootstrap-time get . ] with-stream ; -! : try-everything* ( -- vocabs ) try-everything [ first vocab-link-name ] map ; - -! : do-load ( -- ) -! [ -! "../load-everything-log" -! [ try-everything keys ] -! with-stream -! ] "../load-everything-time" log-runtime -! dup empty? -! [ drop ] -! [ "../load-everything-vocabs" log-object ] -! if -! "../load-everything-log" delete-file ; - : do-load ( -- ) [ try-everything keys ] "../load-everything-time" log-runtime dup empty? @@ -36,25 +22,6 @@ IN: builder.test [ "../load-everything-vocabs" log-object ] if ; -! : do-tests ( -- ) -! run-all-tests keys -! dup empty? -! [ drop ] -! [ "../failing-tests" log-object ] -! if ; - -! : do-tests ( -- ) -! [ -! "../test-all-log" -! [ run-all-tests keys ] -! with-stream -! ] "../test-all-time" log-runtime -! dup empty? -! [ drop ] -! [ "../test-all-vocabs" log-object ] -! if -! "../test-all-log" delete-file ; - : do-tests ( -- ) [ run-all-tests keys ] "../test-all-time" log-runtime dup empty? @@ -62,11 +29,6 @@ IN: builder.test [ "../test-all-vocabs" log-object ] if ; -! : do-all ( -- ) -! record-bootstrap-time -! [ do-load ] [ drop ] recover -! [ do-tests ] [ drop ] recover ; - : do-all ( -- ) record-bootstrap-time do-load From 4f113394ec99aa373df3bf505e988d1a72971e2d Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 11 Feb 2008 23:42:21 -0600 Subject: [PATCH 41/57] builder: refactored --- extra/builder/builder.factor | 104 +++++++++++++---------------------- 1 file changed, 39 insertions(+), 65 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 9c4c833182..299175308f 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -167,24 +167,40 @@ SYMBOL: build-status SYMBOL: report +: >>>report ( quot -- ) report get swap with-stream* ; + +: file>>>report ( file -- ) [ contents write ] curry >>>report ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: run-or-report ( desc quot -- ) + [ [ try-process ] curry ] + [ [ >>>report throw ] curry ] + bi* + recover ; + +: run-or-report-file ( desc quot file -- ) + [ [ try-process ] curry ] + [ [ >>>report ] curry ] + [ [ file>>>report throw ] curry ] + tri* + compose + recover ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : (build) ( -- ) enter-build-dir "report" report set - report get [ "Build machine: " write host-name write nl ] with-stream* - - report get [ "Build directory: " write cwd write nl ] with-stream* - - [ git-clone try-process ] [ - report get - [ "Builder fatal error: git clone failed" write nl ] - with-stream* - throw - ] - recover + "Build machine: " write host-name write nl + "Build directory: " write cwd write nl + ] >>>report + + git-clone [ "Builder fatal error: git clone failed" write nl ] run-or-report "factor" cd @@ -192,74 +208,32 @@ SYMBOL: report make-clean run-process drop - [ make-vm try-process ] - [ - report get - [ - "Builder fatal error: vm compile error" write nl - "../compile-log" contents write - ] - with-stream* - throw - ] - recover + make-vm + [ "Builder fatal error: vm compile error" write nl ] + "../compile-log" + run-or-report-file [ my-arch download-image ] - [ - report get - [ "Builder fatal error: image download" write nl ] - with-stream* - throw - ] + [ [ "Builder fatal error: image download" write nl ] >>>report throw ] recover - [ bootstrap try-process ] - [ - report get - [ - "Bootstrap error" write nl - "../boot-log" contents write - ] - with-stream* - throw - ] - recover + bootstrap [ "Bootstrap error" write nl ] "../boot-log" run-or-report-file - [ builder-test try-process ] - [ - report get - [ "Builder test error" write nl ] - with-stream* - throw - ] - recover + builder-test [ "Builder test error" write nl ] run-or-report - report get - [ - "Bootstrap time: " write - "../bootstrap-time" contents write nl - ] - with-stream* + [ "Bootstrap time: " write ] >>>report "../bootstrap-time" file>>>report "../load-everything-vocabs" exists? [ - report get - [ - "Did not pass load-everything: " write nl - "../load-everything-vocabs" contents write nl - ] - with-stream* + [ "Did not pass load-everything: " write nl ] >>>report + "../load-everything-vocabs" file>>>report ] when "../test-all-vocabs" exists? [ - report get - [ - "Did not pass test-all: " write nl - "../test-all-vocabs" contents write nl - ] - with-stream* + [ "Did not pass test-all: " write nl ] >>>report + "../test-all-vocabs" file>>>report ] when ; From 27fb2270f0e9ad376304274f1625598cbbe1d008 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 12 Feb 2008 00:15:20 -0600 Subject: [PATCH 42/57] builder: tweaks --- extra/builder/builder.factor | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 299175308f..3e7efcc404 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,5 +1,5 @@ -USING: kernel io io.files io.launcher io.sockets hashtables math threads +USING: kernel parser io io.files io.launcher io.sockets hashtables math threads system continuations namespaces sequences splitting math.parser prettyprint tools.time calendar bake vars http.client combinators bootstrap.image bootstrap.image.download @@ -189,6 +189,13 @@ SYMBOL: report ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: ms>minutes ( ms -- minutes ) 1000.0 / 60 / ; + +: bootstrap-minutes ( -- ) + "../bootstrap-time" contents eval ms>minutes unparse ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : (build) ( -- ) enter-build-dir @@ -221,7 +228,8 @@ SYMBOL: report builder-test [ "Builder test error" write nl ] run-or-report - [ "Bootstrap time: " write ] >>>report "../bootstrap-time" file>>>report + [ "Bootstrap time: " write bootstrap-minutes write " minutes" write nl ] + >>>report "../load-everything-vocabs" exists? [ From af11e1673b4057b9b9b81900ba9ab9a1d0fd058b Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Mon, 11 Feb 2008 22:52:02 -0800 Subject: [PATCH 43/57] Implemented the set-fullscreen* hook for the x11 backend. I doubt that fullscreen* can be implemented for x11, so it might need to be removed or always return f. --- extra/ui/x11/x11.factor | 13 +++++++++++++ extra/x11/constants/constants.factor | 5 +++++ 2 files changed, 18 insertions(+) diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 62944500ef..6a0560cb28 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -217,6 +217,19 @@ M: x-clipboard paste-clipboard M: x11-ui-backend set-title ( string world -- ) world-handle x11-handle-window swap dpy get -rot 3dup set-title-old set-title-new ; + +M: x11-ui-backend set-fullscreen* ( ? world -- ) + world-handle x11-handle-window "XClientMessageEvent" + tuck set-XClientMessageEvent-window + swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? + over set-XClientMessageEvent-data0 + ClientMessage over set-XClientMessageEvent-type + dpy get over set-XClientMessageEvent-display + "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type + 32 over set-XClientMessageEvent-format + "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1 + >r dpy get root get 0 SubstructureNotifyMask r> XSendEvent drop ; + M: x11-ui-backend (open-window) ( world -- ) dup gadget-window diff --git a/extra/x11/constants/constants.factor b/extra/x11/constants/constants.factor index 367f40cebd..5781fdc806 100644 --- a/extra/x11/constants/constants.factor +++ b/extra/x11/constants/constants.factor @@ -402,3 +402,8 @@ TYPEDEF: uchar KeyCode : LSBFirst 0 ; : MSBFirst 1 ; +! ***************************************************************** +! * EXTENDED WINDOW MANAGER HINTS +! ***************************************************************** + +C-ENUM: _NET_WM_STATE_REMOVE _NET_WM_STATE_ADD _NET_WM_STATE_TOGGLE ; \ No newline at end of file From 0210823dfcdaa0874097ccdfe41d2510051e0a03 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Mon, 11 Feb 2008 23:01:49 -0800 Subject: [PATCH 44/57] forgot to add alien.c-types to USING: --- extra/ui/x11/x11.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 6a0560cb28..e4794452c7 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2007 Eduardo Cavazos and Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays ui ui.gadgets ui.gestures ui.backend +USING: alien alien.c-types arrays ui ui.gadgets ui.gestures ui.backend ui.clipboards ui.gadgets.worlds assocs kernel math namespaces opengl sequences strings x11.xlib x11.events x11.xim x11.glx x11.clipboard x11.constants x11.windows io.utf8 combinators From 83f1bc5d8c04394d6fa7675e2de424dbd3b6fa90 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 12 Feb 2008 01:27:57 -0600 Subject: [PATCH 45/57] builder: tweaking the report --- extra/builder/builder.factor | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 3e7efcc404..7b959787f4 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -189,11 +189,22 @@ SYMBOL: report ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: ms>minutes ( ms -- minutes ) 1000.0 / 60 / ; +! : ms>minutes ( ms -- minutes ) 1000.0 / 60 / ; -: bootstrap-minutes ( -- ) - "../bootstrap-time" contents eval ms>minutes unparse ; +! : bootstrap-minutes ( -- ) +! "../bootstrap-time" contents eval ms>minutes unparse ; +: min-and-sec ( milliseconds -- str ) + 1000 /i 60 /mod swap + `{ ,[ number>string ] " minutes and " ,[ number>string ] " seconds" } + concat ; + +: eval-file ( file -- obj ) contents eval ; + +: boot-time ( -- string ) "../bootstrap-time" eval-file min-and-sec ; +: load-time ( -- string ) "../load-everything-time" eval-file min-and-sec ; +: test-time ( -- string ) "../test-all-time" eval-file min-and-sec ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : (build) ( -- ) @@ -228,8 +239,11 @@ SYMBOL: report builder-test [ "Builder test error" write nl ] run-or-report - [ "Bootstrap time: " write bootstrap-minutes write " minutes" write nl ] - >>>report + [ + "Bootstrap time: " write boot-time write nl + "Load all time: " write load-time write nl + "Test all time: " write test-time write nl + ] >>>report "../load-everything-vocabs" exists? [ From 1a23b975f2029790c6ecc3c3b959266b3de88bc5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 12 Feb 2008 02:19:18 -0600 Subject: [PATCH 46/57] Cleaning up monitors; add simple-monitor abstraction --- extra/io/monitors/monitors.factor | 35 +++++++++++++++++++- extra/io/unix/linux/linux.factor | 30 +++-------------- extra/io/windows/nt/monitors/monitors.factor | 2 +- 3 files changed, 40 insertions(+), 27 deletions(-) diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index d652f34f1e..1f3b36fadb 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -17,7 +17,7 @@ TUPLE: monitor queue closed? ; set-monitor-queue } monitor construct ; -HOOK: fill-queue io-backend ( monitor -- ) +GENERIC: fill-queue ( monitor -- ) : changed-file ( changed path -- ) namespace [ append ] change-at ; @@ -25,6 +25,39 @@ HOOK: fill-queue io-backend ( monitor -- ) : dequeue-change ( assoc -- path changes ) delete-any prune natural-sort >array ; +M: monitor dispose + dup check-monitor + t over set-monitor-closed? + delegate dispose ; + +! Simple monitor; used on Linux and Mac OS X. On Windows, +! monitors are full-fledged ports. +TUPLE: simple-monitor handle callback ; + +: ( handle -- simple-monitor ) + f (monitor) { + set-simple-monitor-wd + set-delegate + } simple-monitor construct ; + +: construct-simple-monitor ( handle class -- simple-monitor ) + >r r> construct-delegate ; inline + +: notify-callback ( simple-monitor -- ) + dup linux-monitor-callback + f rot set-linux-monitor-callback + [ schedule-thread ] when* ; + +M: simple-monitor fill-queue ( monitor -- ) + dup simple-monitor-callback [ + "Cannot wait for changes on the same file from multiple threads" throw + ] when + [ swap set-simple-monitor-callback stop ] callcc0 + check-monitor ; + +M: simple-monitor dispose ( monitor -- ) + dup delegate dispose notify-callback ; + PRIVATE> HOOK: io-backend ( path recursive? -- monitor ) diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index b3bd2eee4e..25c53478d6 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -11,14 +11,10 @@ TUPLE: linux-io ; INSTANCE: linux-io unix-io -TUPLE: linux-monitor path wd callback ; +TUPLE: linux-monitor ; -: ( path wd -- monitor ) - f (monitor) { - set-linux-monitor-path - set-linux-monitor-wd - set-delegate - } linux-monitor construct ; +: ( wd -- monitor ) + linux-monitor construct-simple-monitor ; TUPLE: inotify watches ; @@ -42,8 +38,7 @@ TUPLE: inotify watches ; ] when ; : add-watch ( path mask -- monitor ) - dupd (add-watch) - dup check-existing + (add-watch) dup check-existing [ dup ] keep watches set-at ; : remove-watch ( monitor -- ) @@ -53,23 +48,8 @@ TUPLE: inotify watches ; M: linux-io ( path recursive? -- monitor ) drop IN_CHANGE_EVENTS add-watch ; -: notify-callback ( monitor -- ) - dup linux-monitor-callback - f rot set-linux-monitor-callback - [ schedule-thread ] when* ; - -M: linux-io fill-queue ( monitor -- ) - dup linux-monitor-callback [ - "Cannot wait for changes on the same file from multiple threads" throw - ] when - [ swap set-linux-monitor-callback stop ] callcc0 - check-monitor ; - M: linux-monitor dispose ( monitor -- ) - dup check-monitor - t over set-monitor-closed? - dup notify-callback - remove-watch ; + dup delegate dispose remove-watch ; : ?flag ( n mask symbol -- n ) pick rot bitand 0 > [ , ] [ drop ] if ; diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index a7a1e2f485..eff3c250dc 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -78,7 +78,7 @@ M: windows-nt-io ( path recursive? -- monitor ) dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero? [ 2drop ] [ swap (changed-files) ] if ; -M: windows-nt-io fill-queue ( monitor -- ) +M: win32-monitor fill-queue ( monitor -- ) dup buffer-ptr over read-changes [ zero? [ drop ] [ (changed-files) ] if ] H{ } make-assoc swap set-monitor-queue ; From e64089fd0a6ec71db86e0d5903a5d6ff7d7127b5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 12 Feb 2008 02:21:47 -0600 Subject: [PATCH 47/57] Mac OS X monitors work in progress --- extra/core-foundation/core-foundation.factor | 39 ++-- .../core-foundation/fsevents/fsevents.factor | 203 ++++++++++++++++++ extra/io/unix/bsd/bsd.factor | 10 +- extra/io/unix/freebsd/freebsd.factor | 8 + extra/io/unix/linux/linux.factor | 2 - extra/io/unix/macosx/macosx.factor | 27 +++ extra/io/unix/netbsd/netbsd.factor | 8 + extra/io/unix/openbsd/openbsd.factor | 8 + extra/io/unix/unix.factor | 9 +- extra/io/windows/nt/nt.factor | 2 - 10 files changed, 288 insertions(+), 28 deletions(-) create mode 100644 extra/core-foundation/fsevents/fsevents.factor create mode 100644 extra/io/unix/freebsd/freebsd.factor create mode 100644 extra/io/unix/macosx/macosx.factor create mode 100644 extra/io/unix/netbsd/netbsd.factor create mode 100644 extra/io/unix/openbsd/openbsd.factor diff --git a/extra/core-foundation/core-foundation.factor b/extra/core-foundation/core-foundation.factor index 4abbeafe57..297e4aec87 100644 --- a/extra/core-foundation/core-foundation.factor +++ b/extra/core-foundation/core-foundation.factor @@ -1,35 +1,45 @@ -! Copyright (C) 2006 Slava Pestov +! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax kernel math sequences ; IN: core-foundation +TYPEDEF: void* CFAllocatorRef +TYPEDEF: void* CFArrayRef +TYPEDEF: void* CFBundleRef +TYPEDEF: void* CFStringRef +TYPEDEF: void* CFURLRef +TYPEDEF: void* CFUUIDRef +TYPEDEF: void* CFRunLoopRef +TYPEDEF: bool Boolean TYPEDEF: int CFIndex +TYPEDEF: double CFTimeInterval +TYPEDEF: double CFAbsoluteTime -FUNCTION: void* CFArrayCreateMutable ( void* allocator, CFIndex capacity, void* callbacks ) ; +FUNCTION: CFArrayRef CFArrayCreateMutable ( CFAllocatorRef allocator, CFIndex capacity, void* callbacks ) ; -FUNCTION: void* CFArrayGetValueAtIndex ( void* array, CFIndex idx ) ; +FUNCTION: void* CFArrayGetValueAtIndex ( CFArrayRef array, CFIndex idx ) ; -FUNCTION: void CFArraySetValueAtIndex ( void* array, CFIndex index, void* value ) ; +FUNCTION: void CFArraySetValueAtIndex ( CFArrayRef array, CFIndex index, void* value ) ; -FUNCTION: CFIndex CFArrayGetCount ( void* array ) ; +FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ; : kCFURLPOSIXPathStyle 0 ; -FUNCTION: void* CFURLCreateWithFileSystemPath ( void* allocator, void* filePath, int pathStyle, bool isDirectory ) ; +FUNCTION: CFURLRef CFURLCreateWithFileSystemPath ( CFAllocatorRef allocator, CFStringRef filePath, int pathStyle, Boolean isDirectory ) ; -FUNCTION: void* CFURLCreateWithString ( void* allocator, void* string, void* base ) ; +FUNCTION: CFURLRef CFURLCreateWithString ( CFAllocatorRef allocator, CFStringRef string, CFURLRef base ) ; -FUNCTION: void* CFURLCopyFileSystemPath ( void* url, int pathStyle ) ; +FUNCTION: CFURLRef CFURLCopyFileSystemPath ( CFURLRef url, int pathStyle ) ; -FUNCTION: void* CFStringCreateWithCharacters ( void* allocator, ushort* cStr, CFIndex numChars ) ; +FUNCTION: CFStringRef CFStringCreateWithCharacters ( CFAllocatorRef allocator, ushort* cStr, CFIndex numChars ) ; -FUNCTION: CFIndex CFStringGetLength ( void* theString ) ; +FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ; FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ; -FUNCTION: void* CFBundleCreate ( void* allocator, void* bundleURL ) ; +FUNCTION: CFBundleRef CFBundleCreate ( CFAllocatorRef allocator, CFURLRef bundleURL ) ; -FUNCTION: bool CFBundleLoadExecutable ( void* bundle ) ; +FUNCTION: Boolean CFBundleLoadExecutable ( CFBundleRef bundle ) ; FUNCTION: void CFRelease ( void* cf ) ; @@ -52,6 +62,9 @@ FUNCTION: void CFRelease ( void* cf ) ; : CF>string-array ( alien -- seq ) CF>array [ CF>string ] map ; +: ( seq -- alien ) + [ ] map dup swap [ CFRelease ] each ; + : ( string dir? -- url ) >r f over kCFURLPOSIXPathStyle r> CFURLCreateWithFileSystemPath swap CFRelease ; @@ -72,3 +85,5 @@ FUNCTION: void CFRelease ( void* cf ) ; ] [ "Cannot load bundled named " swap append throw ] ?if ; + +FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ; diff --git a/extra/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor new file mode 100644 index 0000000000..73232ad522 --- /dev/null +++ b/extra/core-foundation/fsevents/fsevents.factor @@ -0,0 +1,203 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types alien.syntax kernel math sequences +namespaces assocs init continuations ; +IN: core-foundation + +! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! +! FSEventStream API, Leopard only ! +! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + +: kFSEventStreamCreateFlagUseCFTypes 2 ; inline +: kFSEventStreamCreateFlagWatchRoot 4 ; inline + +: kFSEventStreamEventFlagMustScanSubDirs 1 ; inline +: kFSEventStreamEventFlagUserDropped 2 ; inline +: kFSEventStreamEventFlagKernelDropped 4 ; inline +: kFSEventStreamEventFlagEventIdsWrapped 8 ; inline +: kFSEventStreamEventFlagHistoryDone 16 ; inline +: kFSEventStreamEventFlagRootChanged 32 ; inline +: kFSEventStreamEventFlagMount 64 ; inline +: kFSEventStreamEventFlagUnmount 128 ; inline + +TYPEDEF: int FSEventStreamCreateFlags +TYPEDEF: int FSEventStreamEventFlags +TYPEDEF: longlong FSEventStreamEventId +TYPEDEF: void* FSEventStreamRef + +C-STRUCT: FSEventStreamContext + { "CFIndex" "version" } + { "void*" "info" } + { "void*" "retain" } + { "void*" "release" } + { "void*" "copyDescription" } ; + +! callback(FSEventStreamRef streamRef, void *clientCallBackInfo, size_t numEvents, void *eventPaths, const FSEventStreamEventFlags eventFlags[], const FSEventStreamEventId eventIds[]); +TYPEDEF: void* FSEventStreamCallback + +: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF ; inline + +FUNCTION: FSEventStreamRef FSEventStreamCreate ( + CFAllocatorRef allocator, + FSEventStreamCallback callback, + FSEventStreamContext* context, + CFArrayRef pathsToWatch, + FSEventStreamEventId sinceWhen, + CFTimeInterval latency, + FSEventStreamCreateFlags flags ) ; + +FUNCTION: FSEventStreamRef FSEventStreamCreateRelativeToDevice ( + CFAllocatorRef allocator, + FSEventStreamCallback callback, + FSEventStreamContext* context, + dev_t deviceToWatch, + CFArrayRef pathsToWatchRelativeToDevice, + FSEventStreamEventId sinceWhen, + CFTimeInterval latency, + FSEventStreamCreateFlags flags ) ; + +FUNCTION: FSEventStreamEventId FSEventStreamGetLatestEventId ( FSEventStreamRef streamRef ) ; + +FUNCTION: dev_t FSEventStreamGetDeviceBeingWatched ( FSEventStreamRef streamRef ) ; + +FUNCTION: CFArrayRef FSEventStreamCopyPathsBeingWatched ( FSEventStreamRef streamRef ) ; + +FUNCTION: FSEventStreamEventId FSEventsGetCurrentEventId ( ) ; + +FUNCTION: CFUUIDRef FSEventsCopyUUIDForDevice ( dev_t dev ) ; + +FUNCTION: FSEventStreamEventId FSEventsGetLastEventIdForDeviceBeforeTime ( + dev_t dev, + CFAbsoluteTime time ) ; + +FUNCTION: Boolean FSEventsPurgeEventsForDeviceUpToEventId ( + dev_t dev, + FSEventStreamEventId eventId ) ; + +FUNCTION: void FSEventStreamRetain ( FSEventStreamRef streamRef ) ; + +FUNCTION: void FSEventStreamRelease ( FSEventStreamRef streamRef ) ; + +FUNCTION: void FSEventStreamScheduleWithRunLoop ( + FSEventStreamRef streamRef, + CFRunLoopRef runLoop, + CFStringRef runLoopMode ) ; + +FUNCTION: void FSEventStreamUnscheduleFromRunLoop ( + FSEventStreamRef streamRef, + CFRunLoopRef runLoop, + CFStringRef runLoopMode ) ; + +FUNCTION: void FSEventStreamInvalidate ( FSEventStreamRef streamRef ) ; + +FUNCTION: Boolean FSEventStreamStart ( FSEventStreamRef streamRef ) ; + +FUNCTION: FSEventStreamEventId FSEventStreamFlushAsync ( FSEventStreamRef streamRef ) ; + +FUNCTION: void FSEventStreamFlushSync ( FSEventStreamRef streamRef ) ; + +FUNCTION: void FSEventStreamStop ( FSEventStreamRef streamRef ) ; + +FUNCTION: void FSEventStreamShow ( FSEventStreamRef streamRef ) ; + +FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef ) ; + +: make-FSEventStreamContext ( info -- alien ) + "FSEventStreamContext" + [ set-FSEventStreamContext-info ] keep ; + +: ( callback info paths latency flags -- event-stream ) + >r >r >r >r >r + f ! allocator + r> ! callback + r> make-FSEventStreamContext + r> ! paths + FSEventStreamEventIdSinceNow ! sinceWhen + r> ! latency + r> ! flags + FSEventStreamCreate ; + +: kCFRunLoopCommonModes ( -- string ) + "kCFRunLoopCommonModes" f dlsym *void* ; + +: schedule-event-stream ( event-stream -- ) + CFRunLoopGetMain + kCFRunLoopCommonModes + FSEventStreamScheduleWithRunLoop ; + +: unschedule-event-stream ( event-stream -- ) + CFRunLoopGetMain + kCFRunLoopCommonModes + FSEventStreamUnscheduleFromRunLoop ; + +: enable-event-stream ( event-stream -- ) + dup + schedule-event-stream + dup FSEventStreamStart [ + drop + ] [ + dup unschedule-event-stream + FSEventStreamRelease + "Cannot enable FSEventStream" throw + ] if ; + +: disable-event-stream ( event-stream -- ) + dup FSEventStreamStop + unschedule-event-stream ; + +SYMBOL: event-stream-callbacks + +: event-stream-counter \ event-stream-counter counter ; + +[ + H{ } clone event-stream-callbacks set-global + 1 \ event-stream-counter set-global +] "core-foundation" add-init-hook + +event-stream-callbacks global [ H{ } assoc-like ] change-at + +: add-event-source-callback ( quot -- id ) + event-stream-counter + [ event-stream-callbacks get set-at ] keep ; + +: remove-event-source-callback ( id -- ) + event-stream-callbacks get delete-at ; + +: >event-triple ( n eventPaths eventFlags eventIds -- triple ) + [ + >r >r >r dup dup + r> char*-nth , + r> int-nth , + r> longlong-nth , + ] { } make ; + +: master-event-source-callback ( -- alien ) + "void" + { + "FSEventStreamRef" + "void*" ! info + "size_t" ! numEvents + "void*" ! eventPaths + "FSEventStreamEventFlags*" + "FSEventStreamEventId*" + } + "cdecl" [ + [ >event-triple ] 3curry map + swap event-stream-callbacks get at call + drop + ] alien-callback ; + +TUPLE: event-stream info handle ; + +: ( quot paths latency flags -- event-stream ) + >r >r >r + add-event-source-callback dup + >r master-event-source-callback r> + r> r> r> + dup enable-event-stream + event-stream construct-boa ; + +M: event-stream dispose + dup event-stream-info remove-event-source-callback + event-stream-handle dup disable-event-stream + FSEventStreamRelease ; diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index a4315ce5d0..0ab9f4ed2a 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -5,14 +5,14 @@ USING: io.backend io.unix.backend io.unix.kqueue io.unix.select io.launcher io.unix.launcher namespaces kernel assocs threads continuations ; -! On *BSD and Mac OS X, we use select() for the top-level -! multiplexer, and we hang a kqueue off of it but file change -! notification and process exit notification. +! On Mac OS X, we use select() for the top-level +! multiplexer, and we hang a kqueue off of it for process exit +! notification. ! kqueue is buggy with files and ptys so we can't use it as the ! main multiplexer. -TUPLE: bsd-io ; +MIXIN: bsd-io INSTANCE: bsd-io unix-io @@ -25,5 +25,3 @@ M: bsd-io init-io ( -- ) M: bsd-io register-process ( process -- ) process-handle kqueue-mx get-global add-pid-task ; - -T{ bsd-io } set-io-backend diff --git a/extra/io/unix/freebsd/freebsd.factor b/extra/io/unix/freebsd/freebsd.factor new file mode 100644 index 0000000000..2aad0bdb1a --- /dev/null +++ b/extra/io/unix/freebsd/freebsd.factor @@ -0,0 +1,8 @@ +IN: io.unix.freebsd +USING: io.unix.bsd io.backend core-foundation.fsevents ; + +TUPLE: freebsd-io ; + +INSTANCE: freebsd-io bsd-io + +T{ freebsd-io } set-io-backend diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index b3bd2eee4e..dc4c8c8760 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -136,5 +136,3 @@ M: linux-io init-io ( -- ) T{ linux-io } set-io-backend [ start-wait-thread ] "io.unix.linux" add-init-hook - -"vocabs.monitor" require \ No newline at end of file diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor new file mode 100644 index 0000000000..22c013d64b --- /dev/null +++ b/extra/io/unix/macosx/macosx.factor @@ -0,0 +1,27 @@ +IN: io.unix.macosx +USING: io.unix.bsd io.backend io.monitors io.monitors.private +continuations kernel core-foundation.fsevents ; + +TUPLE: macosx-io ; + +INSTANCE: macosx-io bsd-io + +T{ macosx-io } set-io-backend + +TUPLE: macosx-monitor ; + +: enqueue-notifications ( triples monitor -- ) + monitor-queue [ + [ first { +modify-file+ } swap changed-file ] each + ] bind ; + +M: macosx-io + drop + f macosx-monitor construct-simple-monitor + dup [ enqueue-notifications ] curry + rot 1array 0 0 + over set-simple-monitor-handle ; + +M: macosx-monitor dispose + dup simple-monitor-handle dispose delegate dispose ; + diff --git a/extra/io/unix/netbsd/netbsd.factor b/extra/io/unix/netbsd/netbsd.factor new file mode 100644 index 0000000000..3aa8678702 --- /dev/null +++ b/extra/io/unix/netbsd/netbsd.factor @@ -0,0 +1,8 @@ +IN: io.unix.netbsd +USING: io.unix.bsd io.backend ; + +TUPLE: netbsd-io ; + +INSTANCE: netbsd-io bsd-io + +T{ netbsd-io } set-io-backend diff --git a/extra/io/unix/openbsd/openbsd.factor b/extra/io/unix/openbsd/openbsd.factor new file mode 100644 index 0000000000..767861ec75 --- /dev/null +++ b/extra/io/unix/openbsd/openbsd.factor @@ -0,0 +1,8 @@ +IN: io.unix.openbsd +USING: io.unix.bsd io.backend core-foundation.fsevents ; + +TUPLE: openbsd-io ; + +INSTANCE: openbsd-io bsd-io + +T{ openbsd-io } set-io-backend diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index 9013df29aa..14fab00a15 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -2,9 +2,6 @@ USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts io.unix.launcher io.unix.mmap io.backend combinators namespaces system vocabs.loader ; -{ - { [ bsd? ] [ "io.unix.bsd" ] } - { [ macosx? ] [ "io.unix.bsd" ] } - { [ linux? ] [ "io.unix.linux" ] } - { [ solaris? ] [ "io.unix.solaris" ] } -} cond require +"io.unix." os append require + +"vocabs.monitor" require diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index be57a398a2..da7e83baca 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -12,5 +12,3 @@ USE: io.windows.mmap USE: io.backend T{ windows-nt-io } set-io-backend - -"vocabs.monitor" require From e4426eb01aec415ee3958e5eabc8efc2e247b375 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 12 Feb 2008 02:33:06 -0600 Subject: [PATCH 48/57] Mac OS X monitors load --- extra/core-foundation/fsevents/fsevents.factor | 4 ++-- extra/io/monitors/monitors.factor | 8 ++++---- extra/io/unix/macosx/macosx.factor | 3 ++- extra/io/unix/unix.factor | 2 +- 4 files changed, 9 insertions(+), 8 deletions(-) diff --git a/extra/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor index 73232ad522..41d2844811 100644 --- a/extra/core-foundation/fsevents/fsevents.factor +++ b/extra/core-foundation/fsevents/fsevents.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax kernel math sequences -namespaces assocs init continuations ; -IN: core-foundation +namespaces assocs init continuations core-foundation ; +IN: core-foundation.fsevents ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! FSEventStream API, Leopard only ! diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 1f3b36fadb..eff27614ae 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend kernel continuations namespaces sequences -assocs hashtables sorting arrays ; +assocs hashtables sorting arrays threads ; IN: io.monitors ( handle -- simple-monitor ) f (monitor) { - set-simple-monitor-wd + set-simple-monitor-handle set-delegate } simple-monitor construct ; @@ -44,8 +44,8 @@ TUPLE: simple-monitor handle callback ; >r r> construct-delegate ; inline : notify-callback ( simple-monitor -- ) - dup linux-monitor-callback - f rot set-linux-monitor-callback + dup simple-monitor-callback + f rot set-simple-monitor-callback [ schedule-thread ] when* ; M: simple-monitor fill-queue ( monitor -- ) diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor index 22c013d64b..136035991c 100644 --- a/extra/io/unix/macosx/macosx.factor +++ b/extra/io/unix/macosx/macosx.factor @@ -1,6 +1,7 @@ IN: io.unix.macosx USING: io.unix.bsd io.backend io.monitors io.monitors.private -continuations kernel core-foundation.fsevents ; +continuations kernel core-foundation.fsevents sequences +namespaces arrays ; TUPLE: macosx-io ; diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index 14fab00a15..e740561cf9 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,6 +1,6 @@ USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts io.unix.launcher io.unix.mmap io.backend combinators namespaces -system vocabs.loader ; +system vocabs.loader sequences ; "io.unix." os append require From 336ad674d7c5681127970354699ecd1e4630f4d5 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 12 Feb 2008 04:42:47 -0600 Subject: [PATCH 49/57] builder: another refactoring --- extra/builder/builder.factor | 231 +++++++++++++++++++++------------ extra/builder/test/test.factor | 23 +--- 2 files changed, 150 insertions(+), 104 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 7b959787f4..6aa8662095 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,6 +1,6 @@ USING: kernel parser io io.files io.launcher io.sockets hashtables math threads - system continuations namespaces sequences splitting math.parser + arrays system continuations namespaces sequences splitting math.parser prettyprint tools.time calendar bake vars http.client combinators bootstrap.image bootstrap.image.download combinators.cleave ; @@ -11,10 +11,10 @@ IN: builder : runtime ( quot -- time ) benchmark nip ; -: log-runtime ( quot file -- ) - >r runtime r> [ . ] with-stream ; +! : log-runtime ( quot file -- ) +! >r runtime r> [ . ] with-stream ; -: log-object ( object file -- ) [ . ] with-stream ; +! : log-object ( object file -- ) [ . ] with-stream ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -48,16 +48,16 @@ SYMBOL: builder-recipients ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run-or-notify ( desc message -- ) - [ [ try-process ] curry ] - [ [ email-string throw ] curry ] - bi* - recover ; +! : run-or-notify ( desc message -- ) +! [ [ try-process ] curry ] +! [ [ email-string throw ] curry ] +! bi* +! recover ; -: run-or-send-file ( desc message file -- ) - >r >r [ try-process ] curry - r> r> [ email-file throw ] 2curry - recover ; +! : run-or-send-file ( desc message file -- ) +! >r >r [ try-process ] curry +! r> r> [ email-file throw ] 2curry +! recover ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -98,7 +98,9 @@ VAR: stamp : git-id ( -- id ) { "git" "show" } [ readln ] with-stream " " split second ; -: record-git-id ( -- ) git-id "../git-id" log-object ; +! : record-git-id ( -- ) git-id "../git-id" log-object ; + +: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-out ; : make-clean ( -- desc ) { "make" "clean" } ; @@ -110,12 +112,12 @@ VAR: stamp } >hashtable ; -: retrieve-boot-image ( -- ) - [ my-arch download-image ] - [ ] - [ "builder: image download" email-string ] - cleanup - flush ; +! : retrieve-boot-image ( -- ) +! [ my-arch download-image ] +! [ ] +! [ "builder: image download" email-string ] +! cleanup +! flush ; : bootstrap ( -- desc ) `{ @@ -165,27 +167,27 @@ SYMBOL: build-status ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SYMBOL: report +! SYMBOL: report -: >>>report ( quot -- ) report get swap with-stream* ; +! : >>>report ( quot -- ) report get swap with-stream* ; -: file>>>report ( file -- ) [ contents write ] curry >>>report ; +! : file>>>report ( file -- ) [ contents write ] curry >>>report ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: run-or-report ( desc quot -- ) - [ [ try-process ] curry ] - [ [ >>>report throw ] curry ] - bi* - recover ; +! : run-or-report ( desc quot -- ) +! [ [ try-process ] curry ] +! [ [ >>>report throw ] curry ] +! bi* +! recover ; -: run-or-report-file ( desc quot file -- ) - [ [ try-process ] curry ] - [ [ >>>report ] curry ] - [ [ file>>>report throw ] curry ] - tri* - compose - recover ; +! : run-or-report-file ( desc quot file -- ) +! [ [ try-process ] curry ] +! [ [ >>>report ] curry ] +! [ [ file>>>report throw ] curry ] +! tri* +! compose +! recover ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -194,80 +196,137 @@ SYMBOL: report ! : bootstrap-minutes ( -- ) ! "../bootstrap-time" contents eval ms>minutes unparse ; -: min-and-sec ( milliseconds -- str ) - 1000 /i 60 /mod swap - `{ ,[ number>string ] " minutes and " ,[ number>string ] " seconds" } - concat ; +! : min-and-sec ( milliseconds -- str ) +! 1000 /i 60 /mod swap +! `{ ,[ number>string ] " minutes and " ,[ number>string ] " seconds" } +! concat ; + +! : boot-time ( -- string ) "../bootstrap-time" eval-file min-and-sec ; +! : load-time ( -- string ) "../load-everything-time" eval-file min-and-sec ; +! : test-time ( -- string ) "../test-all-time" eval-file min-and-sec ; + +: milli-seconds>time ( n -- string ) + 1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ; : eval-file ( file -- obj ) contents eval ; - -: boot-time ( -- string ) "../bootstrap-time" eval-file min-and-sec ; -: load-time ( -- string ) "../load-everything-time" eval-file min-and-sec ; -: test-time ( -- string ) "../test-all-time" eval-file min-and-sec ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! : (build) ( -- ) + +! enter-build-dir + +! "report" report set + +! [ +! "Build machine: " write host-name write nl +! "Build directory: " write cwd write nl +! ] >>>report + +! git-clone [ "Builder fatal error: git clone failed" write nl ] run-or-report + +! "factor" cd + +! record-git-id + +! make-clean run-process drop + +! make-vm +! [ "Builder fatal error: vm compile error" write nl ] +! "../compile-log" +! run-or-report-file + +! [ my-arch download-image ] +! [ [ "Builder fatal error: image download" write nl ] >>>report throw ] +! recover + +! bootstrap [ "Bootstrap error" write nl ] "../boot-log" run-or-report-file + +! builder-test [ "Builder test error" write nl ] run-or-report + +! [ +! "Bootstrap time: " write boot-time write nl +! "Load all time: " write load-time write nl +! "Test all time: " write test-time write nl +! ] >>>report + +! "../load-everything-vocabs" exists? +! [ +! [ "Did not pass load-everything: " write nl ] >>>report +! "../load-everything-vocabs" file>>>report +! ] +! when + +! "../test-all-vocabs" exists? +! [ +! [ "Did not pass test-all: " write nl ] >>>report +! "../test-all-vocabs" file>>>report +! ] +! when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: cat ( file -- ) contents print ; + +: run-or-bail ( desc quot -- ) + [ [ try-process ] curry ] + [ [ throw ] curry ] + bi* + recover ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : (build) ( -- ) enter-build-dir - "report" report set + "report" [ - [ - "Build machine: " write host-name write nl - "Build directory: " write cwd write nl - ] >>>report + "Build machine: " write host-name print + "Build directory: " write cwd print - git-clone [ "Builder fatal error: git clone failed" write nl ] run-or-report + git-clone [ "git clone failed" print ] run-or-bail - "factor" cd + "factor" cd - record-git-id + record-git-id - make-clean run-process drop + make-clean run-process drop - make-vm - [ "Builder fatal error: vm compile error" write nl ] - "../compile-log" - run-or-report-file + make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail - [ my-arch download-image ] - [ [ "Builder fatal error: image download" write nl ] >>>report throw ] - recover + [ my-arch download-image ] [ "Image download error" print throw ] recover - bootstrap [ "Bootstrap error" write nl ] "../boot-log" run-or-report-file + bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail - builder-test [ "Builder test error" write nl ] run-or-report + [ builder-test try-process ] + [ "Builder test error" print throw ] + recover - [ - "Bootstrap time: " write boot-time write nl - "Load all time: " write load-time write nl - "Test all time: " write test-time write nl - ] >>>report + "Boot time: " write "../boot-time" eval-file milli-seconds>time print + "Load time: " write "../load-time" eval-file milli-seconds>time print + "Test time: " write "../test-time" eval-file milli-seconds>time print - "../load-everything-vocabs" exists? - [ - [ "Did not pass load-everything: " write nl ] >>>report - "../load-everything-vocabs" file>>>report - ] - when + "Did not pass load-everything: " print "../load-everything-vocabs" cat + "Did not pass test-all: " print "../test-all-vocabs" cat - "../test-all-vocabs" exists? - [ - [ "Did not pass test-all: " write nl ] >>>report - "../test-all-vocabs" file>>>report - ] - when ; - -: send-report ( -- ) - report get dispose - "report" "../report" email-file ; + ] with-file-out ; : build ( -- ) - [ (build) ] - [ drop ] - recover - send-report ; + [ (build) ] [ drop ] recover + "report" "../report" email-file ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! : send-report ( -- ) +! report get dispose +! "report" "../report" email-file ; + +! : build ( -- ) +! [ (build) ] +! [ drop ] +! recover +! send-report ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index 0a5750a030..f521af1b7c 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -10,28 +10,15 @@ USING: kernel namespaces sequences assocs builder continuations IN: builder.test -: record-bootstrap-time ( -- ) - "../bootstrap-time" - [ bootstrap-time get . ] - with-stream ; - : do-load ( -- ) - [ try-everything keys ] "../load-everything-time" log-runtime - dup empty? - [ drop ] - [ "../load-everything-vocabs" log-object ] - if ; + try-everything keys "../load-everything-vocabs" [ . ] with-file-out ; : do-tests ( -- ) - [ run-all-tests keys ] "../test-all-time" log-runtime - dup empty? - [ drop ] - [ "../test-all-vocabs" log-object ] - if ; + run-all-tests keys "../test-all-vocabs" [ . ] with-file-out ; : do-all ( -- ) - record-bootstrap-time - do-load - do-tests ; + bootstrap-time get "../boot-time" [ . ] with-file-out + [ do-load ] runtime "../load-time" [ . ] with-file-out + [ do-tests ] runtime "../test-time" [ . ] with-file-out ; MAIN: do-all \ No newline at end of file From 47566fbfac33341e843671b7a5896ccd46ce2c58 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 12 Feb 2008 05:38:09 -0600 Subject: [PATCH 50/57] builder: minor cleanups --- extra/builder/builder.factor | 193 +++-------------------------------- 1 file changed, 14 insertions(+), 179 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 6aa8662095..a5411e6129 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -11,21 +11,6 @@ IN: builder : runtime ( quot -- time ) benchmark nip ; -! : log-runtime ( quot file -- ) -! >r runtime r> [ . ] with-stream ; - -! : log-object ( object file -- ) [ . ] with-stream ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: datestamp ( -- string ) - now `{ ,[ dup timestamp-year ] - ,[ dup timestamp-month ] - ,[ dup timestamp-day ] - ,[ dup timestamp-hour ] - ,[ timestamp-minute ] } - [ pad-00 ] map "-" join ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SYMBOL: builder-recipients @@ -48,23 +33,8 @@ SYMBOL: builder-recipients ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : run-or-notify ( desc message -- ) -! [ [ try-process ] curry ] -! [ [ email-string throw ] curry ] -! bi* -! recover ; - -! : run-or-send-file ( desc message file -- ) -! >r >r [ try-process ] curry -! r> r> [ email-file throw ] 2curry -! recover ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : factor-binary ( -- name ) os { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] } @@ -72,12 +42,6 @@ SYMBOL: builder-recipients [ drop "./factor" ] } case ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -VAR: stamp - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : git-pull ( -- desc ) { "git" @@ -89,17 +53,29 @@ VAR: stamp : git-clone ( -- desc ) { "git" "clone" "../factor" } ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: datestamp ( -- string ) + now `{ ,[ dup timestamp-year ] + ,[ dup timestamp-month ] + ,[ dup timestamp-day ] + ,[ dup timestamp-hour ] + ,[ timestamp-minute ] } + [ pad-00 ] map "-" join ; + +VAR: stamp + : enter-build-dir ( -- ) datestamp >stamp "/builds" cd stamp> make-directory stamp> cd ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : git-id ( -- id ) { "git" "show" } [ readln ] with-stream " " split second ; -! : record-git-id ( -- ) git-id "../git-id" log-object ; - : record-git-id ( -- ) git-id "../git-id" [ . ] with-file-out ; : make-clean ( -- desc ) { "make" "clean" } ; @@ -112,13 +88,6 @@ VAR: stamp } >hashtable ; -! : retrieve-boot-image ( -- ) -! [ my-arch download-image ] -! [ ] -! [ "builder: image download" email-string ] -! cleanup -! flush ; - : bootstrap ( -- desc ) `{ { +arguments+ { @@ -133,78 +102,10 @@ VAR: stamp : builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - SYMBOL: build-status -! : build ( -- ) - -! enter-build-dir - -! git-clone "git clone error" run-or-notify - -! "factor" cd - -! record-git-id - -! make-clean "make clean error" run-or-notify - -! make-vm "vm compile error" "../compile-log" run-or-send-file - -! retrieve-boot-image - -! bootstrap "bootstrap error" "../boot-log" run-or-send-file - -! builder-test "builder.test fatal error" run-or-notify - -! "../load-everything-log" exists? -! [ "load-everything" "../load-everything-log" email-file ] -! when - -! "../failing-tests" exists? -! [ "failing tests" "../failing-tests" email-file ] -! when ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! SYMBOL: report - -! : >>>report ( quot -- ) report get swap with-stream* ; - -! : file>>>report ( file -- ) [ contents write ] curry >>>report ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! : run-or-report ( desc quot -- ) -! [ [ try-process ] curry ] -! [ [ >>>report throw ] curry ] -! bi* -! recover ; - -! : run-or-report-file ( desc quot file -- ) -! [ [ try-process ] curry ] -! [ [ >>>report ] curry ] -! [ [ file>>>report throw ] curry ] -! tri* -! compose -! recover ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! : ms>minutes ( ms -- minutes ) 1000.0 / 60 / ; - -! : bootstrap-minutes ( -- ) -! "../bootstrap-time" contents eval ms>minutes unparse ; - -! : min-and-sec ( milliseconds -- str ) -! 1000 /i 60 /mod swap -! `{ ,[ number>string ] " minutes and " ,[ number>string ] " seconds" } -! concat ; - -! : boot-time ( -- string ) "../bootstrap-time" eval-file min-and-sec ; -! : load-time ( -- string ) "../load-everything-time" eval-file min-and-sec ; -! : test-time ( -- string ) "../test-all-time" eval-file min-and-sec ; - : milli-seconds>time ( n -- string ) 1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ; @@ -212,60 +113,6 @@ SYMBOL: build-status ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : (build) ( -- ) - -! enter-build-dir - -! "report" report set - -! [ -! "Build machine: " write host-name write nl -! "Build directory: " write cwd write nl -! ] >>>report - -! git-clone [ "Builder fatal error: git clone failed" write nl ] run-or-report - -! "factor" cd - -! record-git-id - -! make-clean run-process drop - -! make-vm -! [ "Builder fatal error: vm compile error" write nl ] -! "../compile-log" -! run-or-report-file - -! [ my-arch download-image ] -! [ [ "Builder fatal error: image download" write nl ] >>>report throw ] -! recover - -! bootstrap [ "Bootstrap error" write nl ] "../boot-log" run-or-report-file - -! builder-test [ "Builder test error" write nl ] run-or-report - -! [ -! "Bootstrap time: " write boot-time write nl -! "Load all time: " write load-time write nl -! "Test all time: " write test-time write nl -! ] >>>report - -! "../load-everything-vocabs" exists? -! [ -! [ "Did not pass load-everything: " write nl ] >>>report -! "../load-everything-vocabs" file>>>report -! ] -! when - -! "../test-all-vocabs" exists? -! [ -! [ "Did not pass test-all: " write nl ] >>>report -! "../test-all-vocabs" file>>>report -! ] -! when ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : cat ( file -- ) contents print ; : run-or-bail ( desc quot -- ) @@ -318,18 +165,6 @@ SYMBOL: build-status ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : send-report ( -- ) -! report get dispose -! "report" "../report" email-file ; - -! : build ( -- ) -! [ (build) ] -! [ drop ] -! recover -! send-report ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : minutes>ms ( min -- ms ) 60 * 1000 * ; : updates-available? ( -- ? ) From d283d57c2d2683d0811e96c222fd00ec34d7e649 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 12 Feb 2008 11:58:47 -0600 Subject: [PATCH 51/57] clean up pop-front, add dlist1, add push-all-front and push-all-back --- core/dlists/dlists.factor | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index 12b1cd51ad..38c4ee233e 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Mackenzie Straight, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel math ; +USING: combinators kernel math sequences ; IN: dlists TUPLE: dlist front back length ; @@ -72,6 +72,9 @@ PRIVATE> : push-front ( obj dlist -- ) push-front* drop ; +: push-all-front ( seq dlist -- ) + [ push-front ] curry each ; + : push-back* ( obj dlist -- dlist-node ) [ dlist-back f ] keep [ dlist-back set-next-when ] 2keep @@ -80,11 +83,10 @@ PRIVATE> inc-length ; : push-back ( obj dlist -- ) - [ dlist-back f ] keep - [ dlist-back set-next-when ] 2keep - [ set-dlist-back ] keep - [ set-front-to-back ] keep - inc-length ; + push-back* drop ; + +: push-all-back ( seq dlist -- ) + [ push-back ] curry each ; : peek-front ( dlist -- obj ) dlist-front dlist-node-obj ; @@ -156,3 +158,6 @@ PRIVATE> over dlist-empty? [ 2drop ] [ [ >r pop-back r> call ] 2keep dlist-slurp ] if ; inline + +: 1dlist ( obj -- dlist ) [ push-front ] keep ; + From 023255d6ade9550b1c0b6522bd22a92e269a9053 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 12 Feb 2008 11:59:50 -0600 Subject: [PATCH 52/57] add 4nip to shuffle --- extra/shuffle/shuffle.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/shuffle/shuffle.factor b/extra/shuffle/shuffle.factor index f139a4864e..33587bb7fa 100644 --- a/extra/shuffle/shuffle.factor +++ b/extra/shuffle/shuffle.factor @@ -25,6 +25,8 @@ MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ; : 3nip ( a b c d -- d ) 3 nnip ; inline +: 4nip ( a b c d e -- e ) 4 nnip ; inline + : 4dup ( a b c d -- a b c d a b c d ) 4 ndup ; inline : 4drop ( a b c d -- ) 3drop drop ; inline From f80694183d4c9a6dc9fc6722b6dfcfa76e6ceaf1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 12 Feb 2008 12:00:56 -0600 Subject: [PATCH 53/57] find gvim binary faster on windows --- extra/editors/gvim/windows/windows.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor index 5b51738eea..36af79b697 100644 --- a/extra/editors/gvim/windows/windows.factor +++ b/extra/editors/gvim/windows/windows.factor @@ -4,5 +4,6 @@ IN: editors.gvim.windows M: windows-io gvim-path \ gvim-path get-global [ - program-files walk-dir [ "gvim.exe" tail? ] find nip + program-files "vim" path+ + [ "gvim.exe" tail? ] find-file-breadth ] unless* ; From 1f78e14b6b7013fe4a5d4f147364342b3f567976 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 12 Feb 2008 12:14:57 -0600 Subject: [PATCH 54/57] change append to path+ use find-file-breadth fix load errors --- extra/editors/editpadpro/editpadpro.factor | 6 +++--- extra/editors/editplus/editplus.factor | 2 +- extra/editors/gvim/windows/windows.factor | 2 +- extra/editors/wordpad/wordpad.factor | 5 +++-- 4 files changed, 8 insertions(+), 7 deletions(-) diff --git a/extra/editors/editpadpro/editpadpro.factor b/extra/editors/editpadpro/editpadpro.factor index 885349e27b..5a8168a181 100755 --- a/extra/editors/editpadpro/editpadpro.factor +++ b/extra/editors/editpadpro/editpadpro.factor @@ -1,12 +1,12 @@ USING: definitions kernel parser words sequences math.parser namespaces editors io.launcher windows.shell32 io.files -io.paths strings ; +io.paths strings unicode.case ; IN: editors.editpadpro : editpadpro-path \ editpadpro-path get-global [ - program-files "JGsoft" path+ walk-dir - [ >lower "editpadpro.exe" tail? ] find nip + program-files "JGsoft" path+ + [ >lower "editpadpro.exe" tail? ] find-file-breadth ] unless* ; : editpadpro ( file line -- ) diff --git a/extra/editors/editplus/editplus.factor b/extra/editors/editplus/editplus.factor index feaa177954..ee24c99463 100755 --- a/extra/editors/editplus/editplus.factor +++ b/extra/editors/editplus/editplus.factor @@ -4,7 +4,7 @@ IN: editors.editplus : editplus-path ( -- path ) \ editplus-path get-global [ - program-files "\\EditPlus 2\\editplus.exe" append + program-files "\\EditPlus 2\\editplus.exe" path+ ] unless* ; : editplus ( file line -- ) diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor index 36af79b697..e68bf04732 100644 --- a/extra/editors/gvim/windows/windows.factor +++ b/extra/editors/gvim/windows/windows.factor @@ -1,5 +1,5 @@ USING: editors.gvim.backend io.files io.windows kernel namespaces -sequences windows.shell32 ; +sequences windows.shell32 io.paths ; IN: editors.gvim.windows M: windows-io gvim-path diff --git a/extra/editors/wordpad/wordpad.factor b/extra/editors/wordpad/wordpad.factor index 0a86250a92..5ad08b613b 100755 --- a/extra/editors/wordpad/wordpad.factor +++ b/extra/editors/wordpad/wordpad.factor @@ -1,10 +1,11 @@ USING: editors hardware-info.windows io.launcher kernel -math.parser namespaces sequences windows.shell32 ; +math.parser namespaces sequences windows.shell32 io.files +arrays ; IN: editors.wordpad : wordpad-path ( -- path ) \ wordpad-path get [ - program-files "\\Windows NT\\Accessories\\wordpad.exe" append + program-files "\\Windows NT\\Accessories\\wordpad.exe" path+ ] unless* ; : wordpad ( file line -- ) From 873b7dd214da61365210cfb09a36ec3ced8f0ae3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 12 Feb 2008 12:15:42 -0600 Subject: [PATCH 55/57] remove two unused hooks move walk-dir to extra/io/paths --- core/io/files/files.factor | 31 ------------------------------- 1 file changed, 31 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index aa9f8686ce..9afe9362cf 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -141,37 +141,6 @@ C: pathname M: pathname <=> [ pathname-string ] compare ; -HOOK: library-roots io-backend ( -- seq ) -HOOK: binary-roots io-backend ( -- seq ) - -: find-file ( seq str -- path/f ) - [ - [ path+ exists? ] curry find nip - ] keep over [ path+ ] [ drop ] if ; - -: find-library ( str -- path/f ) - library-roots swap find-file ; - -: find-binary ( str -- path/f ) - binary-roots swap find-file ; - - - -: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ; - : file-lines ( path -- seq ) lines ; : file-contents ( path -- str ) From 19154db59628f1d9fc6dbe54aa9498e48ddd3ff5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 12 Feb 2008 12:16:12 -0600 Subject: [PATCH 56/57] add find-file-breadth, find-file-depth redo walk-dir --- extra/io/paths/paths.factor | 45 ++++++++++++++++++++++++++++--------- 1 file changed, 35 insertions(+), 10 deletions(-) diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index 3740382e58..a393cef7fa 100644 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -1,24 +1,49 @@ -USING: assocs io.files kernel namespaces sequences ; +USING: arrays assocs combinators.lib dlists io.files +kernel namespaces sequences shuffle vectors ; IN: io.paths -: find-file ( seq str -- path/f ) - [ - [ path+ exists? ] curry find nip - ] keep over [ path+ ] [ drop ] if ; +! HOOK: library-roots io-backend ( -- seq ) +! HOOK: binary-roots io-backend ( -- seq ) r path+ r> ] with* assoc-map ; : get-paths ( dir -- paths ) - dup directory keys append-path ; + dup directory append-path ; : (walk-dir) ( path -- ) - dup directory? [ - get-paths dup % [ (walk-dir) ] each + first2 [ + get-paths dup keys % [ (walk-dir) ] each ] [ drop ] if ; PRIVATE> -: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ; +: walk-dir ( path -- seq ) + dup directory? 2array [ (walk-dir) ] { } make ; + +GENERIC# find-file* 1 ( obj quot -- path/f ) + +M: dlist find-file* ( dlist quot -- path/f ) + over dlist-empty? [ 2drop f ] [ + 2dup >r pop-front get-paths dup r> assoc-find + [ drop 3nip ] + [ 2drop [ nip ] assoc-subset keys pick push-all-back find-file* ] if + ] if ; + +M: vector find-file* ( vector quot -- path/f ) + over empty? [ 2drop f ] [ + 2dup >r pop get-paths dup r> assoc-find + [ drop 3nip ] + [ 2drop [ nip ] assoc-subset keys pick push-all find-file* ] if + ] if ; + +: prepare-find-file ( quot -- quot ) + [ drop ] swap compose ; + +: find-file-depth ( path quot -- path/f ) + prepare-find-file >r 1vector r> find-file* ; + +: find-file-breadth ( path quot -- path/f ) + prepare-find-file >r 1dlist r> find-file* ; From 5912cad83f1f91156b0f4a8e8d0e3a3a39e02ad0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 12 Feb 2008 12:19:25 -0600 Subject: [PATCH 57/57] Forgot to invoke callback --- extra/io/unix/macosx/macosx.factor | 7 +++---- extra/vocabs/monitor/monitor.factor | 8 ++++++-- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor index 136035991c..bd48fbc9b5 100644 --- a/extra/io/unix/macosx/macosx.factor +++ b/extra/io/unix/macosx/macosx.factor @@ -12,9 +12,9 @@ T{ macosx-io } set-io-backend TUPLE: macosx-monitor ; : enqueue-notifications ( triples monitor -- ) - monitor-queue [ - [ first { +modify-file+ } swap changed-file ] each - ] bind ; + tuck monitor-queue + [ [ first { +modify-file+ } swap changed-file ] each ] bind + notify-callback ; M: macosx-io drop @@ -25,4 +25,3 @@ M: macosx-io M: macosx-monitor dispose dup simple-monitor-handle dispose delegate dispose ; - diff --git a/extra/vocabs/monitor/monitor.factor b/extra/vocabs/monitor/monitor.factor index 24aa8b1d99..e5b9a8c3a1 100755 --- a/extra/vocabs/monitor/monitor.factor +++ b/extra/vocabs/monitor/monitor.factor @@ -1,4 +1,5 @@ -USING: threads io.files io.monitors init kernel tools.browser ; +USING: threads io.files io.monitors init kernel tools.browser +continuations ; IN: vocabs.monitor ! Use file system change monitoring to flush the tags/authors @@ -7,8 +8,11 @@ IN: vocabs.monitor dup next-change 2drop reset-cache update-thread ; : start-update-thread + #! Silently ignore errors during monitor creation since + #! monitors are not supported on all platforms. [ - "" resource-path t update-thread + [ "" resource-path t ] [ drop f ] recover + [ update-thread ] when* ] in-thread ; [ start-update-thread ] "tools.browser" add-init-hook