ascii encode >base64-lines >string
] unit-test
+[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ]
+[ malformed-base64? ] must-fail-with
+
\ >base64 must-infer
\ base64> must-infer
sequences strings io.crlf ;
IN: base64
+ERROR: malformed-base64 ;
+
<PRIVATE
: read1-ignoring ( ignoring -- ch )
f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39
40 41 42 43 44 45 46 47 48 49 50 51
- } nth ; inline
+ } nth [ malformed-base64 ] unless* ; inline
SYMBOL: column
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
[ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
-ERROR: malformed-base64 ;
-
: decode4 ( seq -- )
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
[ [ CHAR: = = ] count ] bi head-slice*
strings math.parser math.intervals combinators math.bitwise
nmake db db.tuples db.types classes words shuffle arrays
destructors continuations db.tuples.private prettyprint
-db.private ;
+db.private byte-arrays ;
IN: db.queries
GENERIC: where ( specs obj -- )
[ " or " 0% ] [ dupd where ] interleave drop
] in-parens ;
+M: byte-array where ( spec obj -- )
+ over column-name>> 0% " = " 0% bind# ;
+
M: NULL where ( spec obj -- )
drop column-name>> 0% " is NULL" 0% ;
[ test-compound-primary-key ] test-sqlite
[ test-compound-primary-key ] test-postgresql
+
+
+TUPLE: example id data ;
+
+example "EXAMPLE"
+{
+ { "id" "ID" +db-assigned-id+ }
+ { "data" "DATA" BLOB }
+} define-persistent
+
+: test-blob-select ( -- )
+ example ensure-table
+ [ ] [ example new B{ 1 2 3 4 5 } >>data insert-tuple ] unit-test
+ [
+ T{ example { id 1 } { data B{ 1 2 3 4 5 } } }
+ ] [ example new B{ 1 2 3 4 5 } >>data select-tuple ] unit-test ;
+
+[ test-blob-select ] test-sqlite
+[ test-blob-select ] test-postgresql
Slava Pestov
Eduardo Cavazos
Joe Groff
+Alex Chapman
-Slava Pestov
+Alex Chapman
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2005 Alex Chapman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel sequences words ;
-IN: opengl.glu
-
-! These are defined as structs in glu.h, but we only ever use pointers to them
-TYPEDEF: void* GLUnurbs*
-TYPEDEF: void* GLUquadric*
-TYPEDEF: void* GLUtesselator*
-TYPEDEF: void* GLubyte*
-TYPEDEF: void* GLUfuncptr
-
-! StringName
-CONSTANT: GLU_VERSION 100800
-CONSTANT: GLU_EXTENSIONS 100801
-
-! ErrorCode
-CONSTANT: GLU_INVALID_ENUM 100900
-CONSTANT: GLU_INVALID_VALUE 100901
-CONSTANT: GLU_OUT_OF_MEMORY 100902
-CONSTANT: GLU_INCOMPATIBLE_GL_VERSION 100903
-CONSTANT: GLU_INVALID_OPERATION 100904
-
-! NurbsDisplay
-CONSTANT: GLU_OUTLINE_POLYGON 100240
-CONSTANT: GLU_OUTLINE_PATCH 100241
-
-! NurbsCallback
-CONSTANT: GLU_NURBS_ERROR 100103
-CONSTANT: GLU_ERROR 100103
-CONSTANT: GLU_NURBS_BEGIN 100164
-CONSTANT: GLU_NURBS_BEGIN_EXT 100164
-CONSTANT: GLU_NURBS_VERTEX 100165
-CONSTANT: GLU_NURBS_VERTEX_EXT 100165
-CONSTANT: GLU_NURBS_NORMAL 100166
-CONSTANT: GLU_NURBS_NORMAL_EXT 100166
-CONSTANT: GLU_NURBS_COLOR 100167
-CONSTANT: GLU_NURBS_COLOR_EXT 100167
-CONSTANT: GLU_NURBS_TEXTURE_COORD 100168
-CONSTANT: GLU_NURBS_TEX_COORD_EXT 100168
-CONSTANT: GLU_NURBS_END 100169
-CONSTANT: GLU_NURBS_END_EXT 100169
-CONSTANT: GLU_NURBS_BEGIN_DATA 100170
-CONSTANT: GLU_NURBS_BEGIN_DATA_EXT 100170
-CONSTANT: GLU_NURBS_VERTEX_DATA 100171
-CONSTANT: GLU_NURBS_VERTEX_DATA_EXT 100171
-CONSTANT: GLU_NURBS_NORMAL_DATA 100172
-CONSTANT: GLU_NURBS_NORMAL_DATA_EXT 100172
-CONSTANT: GLU_NURBS_COLOR_DATA 100173
-CONSTANT: GLU_NURBS_COLOR_DATA_EXT 100173
-CONSTANT: GLU_NURBS_TEXTURE_COORD_DATA 100174
-CONSTANT: GLU_NURBS_TEX_COORD_DATA_EXT 100174
-CONSTANT: GLU_NURBS_END_DATA 100175
-CONSTANT: GLU_NURBS_END_DATA_EXT 100175
-
-! NurbsError
-CONSTANT: GLU_NURBS_ERROR1 100251
-CONSTANT: GLU_NURBS_ERROR2 100252
-CONSTANT: GLU_NURBS_ERROR3 100253
-CONSTANT: GLU_NURBS_ERROR4 100254
-CONSTANT: GLU_NURBS_ERROR5 100255
-CONSTANT: GLU_NURBS_ERROR6 100256
-CONSTANT: GLU_NURBS_ERROR7 100257
-CONSTANT: GLU_NURBS_ERROR8 100258
-CONSTANT: GLU_NURBS_ERROR9 100259
-CONSTANT: GLU_NURBS_ERROR10 100260
-CONSTANT: GLU_NURBS_ERROR11 100261
-CONSTANT: GLU_NURBS_ERROR12 100262
-CONSTANT: GLU_NURBS_ERROR13 100263
-CONSTANT: GLU_NURBS_ERROR14 100264
-CONSTANT: GLU_NURBS_ERROR15 100265
-CONSTANT: GLU_NURBS_ERROR16 100266
-CONSTANT: GLU_NURBS_ERROR17 100267
-CONSTANT: GLU_NURBS_ERROR18 100268
-CONSTANT: GLU_NURBS_ERROR19 100269
-CONSTANT: GLU_NURBS_ERROR20 100270
-CONSTANT: GLU_NURBS_ERROR21 100271
-CONSTANT: GLU_NURBS_ERROR22 100272
-CONSTANT: GLU_NURBS_ERROR23 100273
-CONSTANT: GLU_NURBS_ERROR24 100274
-CONSTANT: GLU_NURBS_ERROR25 100275
-CONSTANT: GLU_NURBS_ERROR26 100276
-CONSTANT: GLU_NURBS_ERROR27 100277
-CONSTANT: GLU_NURBS_ERROR28 100278
-CONSTANT: GLU_NURBS_ERROR29 100279
-CONSTANT: GLU_NURBS_ERROR30 100280
-CONSTANT: GLU_NURBS_ERROR31 100281
-CONSTANT: GLU_NURBS_ERROR32 100282
-CONSTANT: GLU_NURBS_ERROR33 100283
-CONSTANT: GLU_NURBS_ERROR34 100284
-CONSTANT: GLU_NURBS_ERROR35 100285
-CONSTANT: GLU_NURBS_ERROR36 100286
-CONSTANT: GLU_NURBS_ERROR37 100287
-
-! NurbsProperty
-CONSTANT: GLU_AUTO_LOAD_MATRIX 100200
-CONSTANT: GLU_CULLING 100201
-CONSTANT: GLU_SAMPLING_TOLERANCE 100203
-CONSTANT: GLU_DISPLAY_MODE 100204
-CONSTANT: GLU_PARAMETRIC_TOLERANCE 100202
-CONSTANT: GLU_SAMPLING_METHOD 100205
-CONSTANT: GLU_U_STEP 100206
-CONSTANT: GLU_V_STEP 100207
-CONSTANT: GLU_NURBS_MODE 100160
-CONSTANT: GLU_NURBS_MODE_EXT 100160
-CONSTANT: GLU_NURBS_TESSELLATOR 100161
-CONSTANT: GLU_NURBS_TESSELLATOR_EXT 100161
-CONSTANT: GLU_NURBS_RENDERER 100162
-CONSTANT: GLU_NURBS_RENDERER_EXT 100162
-
-! NurbsSampling
-CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR 100208
-CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR_EXT 100208
-CONSTANT: GLU_OBJECT_PATH_LENGTH 100209
-CONSTANT: GLU_OBJECT_PATH_LENGTH_EXT 100209
-CONSTANT: GLU_PATH_LENGTH 100215
-CONSTANT: GLU_PARAMETRIC_ERROR 100216
-CONSTANT: GLU_DOMAIN_DISTANCE 100217
-
-! NurbsTrim
-CONSTANT: GLU_MAP1_TRIM_2 100210
-CONSTANT: GLU_MAP1_TRIM_3 100211
-
-! QuadricDrawStyle
-CONSTANT: GLU_POINT 100010
-CONSTANT: GLU_LINE 100011
-CONSTANT: GLU_FILL 100012
-CONSTANT: GLU_SILHOUETTE 100013
-
-! QuadricNormal
-CONSTANT: GLU_SMOOTH 100000
-CONSTANT: GLU_FLAT 100001
-CONSTANT: GLU_NONE 100002
-
-! QuadricOrientation
-CONSTANT: GLU_OUTSIDE 100020
-CONSTANT: GLU_INSIDE 100021
-
-! TessCallback
-CONSTANT: GLU_TESS_BEGIN 100100
-CONSTANT: GLU_BEGIN 100100
-CONSTANT: GLU_TESS_VERTEX 100101
-CONSTANT: GLU_VERTEX 100101
-CONSTANT: GLU_TESS_END 100102
-CONSTANT: GLU_END 100102
-CONSTANT: GLU_TESS_ERROR 100103
-CONSTANT: GLU_TESS_EDGE_FLAG 100104
-CONSTANT: GLU_EDGE_FLAG 100104
-CONSTANT: GLU_TESS_COMBINE 100105
-CONSTANT: GLU_TESS_BEGIN_DATA 100106
-CONSTANT: GLU_TESS_VERTEX_DATA 100107
-CONSTANT: GLU_TESS_END_DATA 100108
-CONSTANT: GLU_TESS_ERROR_DATA 100109
-CONSTANT: GLU_TESS_EDGE_FLAG_DATA 100110
-CONSTANT: GLU_TESS_COMBINE_DATA 100111
-
-! TessContour
-CONSTANT: GLU_CW 100120
-CONSTANT: GLU_CCW 100121
-CONSTANT: GLU_INTERIOR 100122
-CONSTANT: GLU_EXTERIOR 100123
-CONSTANT: GLU_UNKNOWN 100124
-
-! TessProperty
-CONSTANT: GLU_TESS_WINDING_RULE 100140
-CONSTANT: GLU_TESS_BOUNDARY_ONLY 100141
-CONSTANT: GLU_TESS_TOLERANCE 100142
-
-! TessError
-CONSTANT: GLU_TESS_ERROR1 100151
-CONSTANT: GLU_TESS_ERROR2 100152
-CONSTANT: GLU_TESS_ERROR3 100153
-CONSTANT: GLU_TESS_ERROR4 100154
-CONSTANT: GLU_TESS_ERROR5 100155
-CONSTANT: GLU_TESS_ERROR6 100156
-CONSTANT: GLU_TESS_ERROR7 100157
-CONSTANT: GLU_TESS_ERROR8 100158
-CONSTANT: GLU_TESS_MISSING_BEGIN_POLYGON 100151
-CONSTANT: GLU_TESS_MISSING_BEGIN_CONTOUR 100152
-CONSTANT: GLU_TESS_MISSING_END_POLYGON 100153
-CONSTANT: GLU_TESS_MISSING_END_CONTOUR 100154
-CONSTANT: GLU_TESS_COORD_TOO_LARGE 100155
-CONSTANT: GLU_TESS_NEED_COMBINE_CALLBACK 100156
-
-! TessWinding
-CONSTANT: GLU_TESS_WINDING_ODD 100130
-CONSTANT: GLU_TESS_WINDING_NONZERO 100131
-CONSTANT: GLU_TESS_WINDING_POSITIVE 100132
-CONSTANT: GLU_TESS_WINDING_NEGATIVE 100133
-CONSTANT: GLU_TESS_WINDING_ABS_GEQ_TWO 100134
-
-LIBRARY: glu
-
-FUNCTION: void gluBeginCurve ( GLUnurbs* nurb ) ;
-FUNCTION: void gluBeginPolygon ( GLUtesselator* tess ) ;
-FUNCTION: void gluBeginSurface ( GLUnurbs* nurb ) ;
-FUNCTION: void gluBeginTrim ( GLUnurbs* nurb ) ;
-
-FUNCTION: void gluCylinder ( GLUquadric* quad, GLdouble base, GLdouble top, GLdouble height, GLint slices, GLint stacks ) ;
-FUNCTION: void gluDeleteNurbsRenderer ( GLUnurbs* nurb ) ;
-FUNCTION: void gluDeleteQuadric ( GLUquadric* quad ) ;
-FUNCTION: void gluDeleteTess ( GLUtesselator* tess ) ;
-FUNCTION: void gluDisk ( GLUquadric* quad, GLdouble inner, GLdouble outer, GLint slices, GLint loops ) ;
-FUNCTION: void gluEndCurve ( GLUnurbs* nurb ) ;
-FUNCTION: void gluEndPolygon ( GLUtesselator* tess ) ;
-FUNCTION: void gluEndSurface ( GLUnurbs* nurb ) ;
-FUNCTION: void gluEndTrim ( GLUnurbs* nurb ) ;
-FUNCTION: char* gluErrorString ( GLenum error ) ;
-FUNCTION: void gluGetNurbsProperty ( GLUnurbs* nurb, GLenum property, GLfloat* data ) ;
-FUNCTION: char* gluGetString ( GLenum name ) ;
-FUNCTION: void gluGetTessProperty ( GLUtesselator* tess, GLenum which, GLdouble* data ) ;
-FUNCTION: void gluLoadSamplingMatrices ( GLUnurbs* nurb, GLfloat* model, GLfloat* perspective, GLint* view ) ;
-FUNCTION: void gluLookAt ( GLdouble eyeX, GLdouble eyeY, GLdouble eyeZ, GLdouble centerX, GLdouble centerY, GLdouble centerZ, GLdouble upX, GLdouble upY, GLdouble upZ ) ;
-FUNCTION: GLUnurbs* gluNewNurbsRenderer ( ) ;
-FUNCTION: GLUquadric* gluNewQuadric ( ) ;
-FUNCTION: GLUtesselator* gluNewTess ( ) ;
-FUNCTION: void gluNextContour ( GLUtesselator* tess, GLenum type ) ;
-FUNCTION: void gluNurbsCallback ( GLUnurbs* nurb, GLenum which, GLUfuncptr CallBackFunc ) ;
-! FUNCTION: void gluNurbsCallbackData ( GLUnurbs* nurb, GLvoid* userData ) ;
-! FUNCTION: void gluNurbsCallbackDataEXT ( GLUnurbs* nurb, GLvoid* userData ) ;
-FUNCTION: void gluNurbsCurve ( GLUnurbs* nurb, GLint knotCount, GLfloat *knots, GLint stride, GLfloat *control, GLint order, GLenum type ) ;
-FUNCTION: void gluNurbsProperty ( GLUnurbs* nurb, GLenum property, GLfloat value ) ;
-FUNCTION: void gluNurbsSurface ( GLUnurbs* nurb, GLint sKnotCount, GLfloat* sKnots, GLint tKnotCount, GLfloat* tKnots, GLint sStride, GLint tStride, GLfloat* control, GLint sOrder, GLint tOrder, GLenum type ) ;
-FUNCTION: void gluOrtho2D ( GLdouble left, GLdouble right, GLdouble bottom, GLdouble top ) ;
-FUNCTION: void gluPartialDisk ( GLUquadric* quad, GLdouble inner, GLdouble outer, GLint slices, GLint loops, GLdouble start, GLdouble sweep ) ;
-FUNCTION: void gluPerspective ( GLdouble fovy, GLdouble aspect, GLdouble zNear, GLdouble zFar ) ;
-FUNCTION: void gluPickMatrix ( GLdouble x, GLdouble y, GLdouble delX, GLdouble delY, GLint* viewport ) ;
-FUNCTION: GLint gluProject ( GLdouble objX, GLdouble objY, GLdouble objZ, GLdouble* model, GLdouble* proj, GLint* view, GLdouble* winX, GLdouble* winY, GLdouble* winZ ) ;
-FUNCTION: void gluPwlCurve ( GLUnurbs* nurb, GLint count, GLfloat* data, GLint stride, GLenum type ) ;
-FUNCTION: void gluQuadricCallback ( GLUquadric* quad, GLenum which, GLUfuncptr CallBackFunc ) ;
-FUNCTION: void gluQuadricDrawStyle ( GLUquadric* quad, GLenum draw ) ;
-FUNCTION: void gluQuadricNormals ( GLUquadric* quad, GLenum normal ) ;
-FUNCTION: void gluQuadricOrientation ( GLUquadric* quad, GLenum orientation ) ;
-FUNCTION: void gluQuadricTexture ( GLUquadric* quad, GLboolean texture ) ;
-FUNCTION: GLint gluScaleImage ( GLenum format, GLsizei wIn, GLsizei hIn, GLenum typeIn, void* dataIn, GLsizei wOut, GLsizei hOut, GLenum typeOut, GLvoid* dataOut ) ;
-FUNCTION: void gluSphere ( GLUquadric* quad, GLdouble radius, GLint slices, GLint stacks ) ;
-FUNCTION: void gluTessBeginContour ( GLUtesselator* tess ) ;
-FUNCTION: void gluTessBeginPolygon ( GLUtesselator* tess, GLvoid* data ) ;
-FUNCTION: void gluTessCallback ( GLUtesselator* tess, GLenum which, GLUfuncptr CallBackFunc ) ;
-FUNCTION: void gluTessEndContour ( GLUtesselator* tess ) ;
-FUNCTION: void gluTessEndPolygon ( GLUtesselator* tess ) ;
-FUNCTION: void gluTessNormal ( GLUtesselator* tess, GLdouble valueX, GLdouble valueY, GLdouble valueZ ) ;
-FUNCTION: void gluTessProperty ( GLUtesselator* tess, GLenum which, GLdouble data ) ;
-FUNCTION: void gluTessVertex ( GLUtesselator* tess, GLdouble* location, GLvoid* data ) ;
-FUNCTION: GLint gluUnProject ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble* model, GLdouble* proj, GLint* view, GLdouble* objX, GLdouble* objY, GLdouble* objZ ) ;
-
-! Not present on Windows
-! FUNCTION: GLint gluBuild1DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
-! FUNCTION: GLint gluBuild1DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLenum format, GLenum type, void* data ) ;
-! FUNCTION: GLint gluBuild2DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
-! FUNCTION: GLint gluBuild2DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLenum format, GLenum type, void* data ) ;
-! FUNCTION: GLint gluBuild3DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
-! FUNCTION: GLint gluBuild3DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, void* data ) ;
-! FUNCTION: GLboolean gluCheckExtension ( GLubyte* extName, GLubyte* extString ) ;
-! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ;
+++ /dev/null
-OpenGL binding - libGLU
! Portions copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types continuations kernel libc math macros
-namespaces math.vectors math.parser opengl.gl opengl.glu combinators
+namespaces math.vectors math.parser opengl.gl combinators
combinators.smart arrays sequences splitting words byte-arrays assocs
colors colors.constants accessors generalizations locals fry
specialized-arrays.float specialized-arrays.uint ;
: gl-clear ( color -- )
gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
+: error>string ( n -- string )
+ H{
+ { HEX: 0 "No error" }
+ { HEX: 0501 "Invalid value" }
+ { HEX: 0500 "Invalid enumerant" }
+ { HEX: 0502 "Invalid operation" }
+ { HEX: 0503 "Stack overflow" }
+ { HEX: 0504 "Stack underflow" }
+ { HEX: 0505 "Out of memory" }
+ } at "Unknown error" or ;
+
+TUPLE: gl-error code string ;
+
: gl-error ( -- )
- glGetError dup zero? [
- "GL error: " over gluErrorString append throw
- ] unless drop ;
+ glGetError dup 0 = [ drop ] [
+ dup error>string \ gl-error boa throw
+ ] if ;
: do-enabled ( what quot -- )
over glEnable dip glDisable ; inline
MACRO: set-draw-buffers ( buffers -- )
words>values '[ _ (set-draw-buffers) ] ;
-: gl-look-at ( eye focus up -- )
- [ first3 ] tri@ gluLookAt ;
-
: gen-dlist ( -- id ) 1 glGenLists ;
: make-dlist ( type quot -- id )
16 * >hex 8 CHAR: 0 pad-head write "h: " write ;
: >hex-digit ( digit -- str )
- >hex 2 CHAR: 0 pad-head " " append ;
+ >hex 2 CHAR: 0 pad-head ;
: >hex-digits ( bytes -- str )
- [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-tail ;
+ [ >hex-digit " " append ] { } map-as concat
+ 48 CHAR: \s pad-tail ;
: >ascii ( bytes -- str )
[ [ printable? ] keep CHAR: . ? ] "" map-as ;
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math.rectangles math.vectors namespaces kernel accessors
-assocs combinators sequences opengl opengl.gl opengl.glu colors
+assocs combinators sequences opengl opengl.gl colors
colors.constants ui.gadgets ui.pens ;
IN: ui.render
dim>>
[ { 0 1 } v* viewport-translation set ]
[ [ { 0 0 } ] dip gl-viewport ]
- [ [ 0 ] dip first2 0 gluOrtho2D ] tri
+ [ [ 0 ] dip first2 0 1 -1 glOrtho ] tri
]
[ clip set ] bi
do-clip ;
-USING: kernel namespaces math.vectors opengl 4DNav.turtle ;
+USING: kernel namespaces math.vectors opengl opengl.glu 4DNav.turtle ;
IN: 4DNav.camera
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: html.parser.state io io.encodings.utf8 io.files
+USING: sequence-parser io io.encodings.utf8 io.files
io.streams.string kernel combinators accessors io.pathnames
fry sequences arrays locals namespaces io.directories
assocs math splitting make unicode.categories
DEFER: preprocess-file
-ERROR: unknown-c-preprocessor state-parser name ;
+ERROR: unknown-c-preprocessor sequence-parser name ;
ERROR: bad-include-line line ;
drop
] if ;
-: handle-include ( preprocessor-state state-parser -- )
- skip-whitespace advance dup previous {
+: skip-whitespace/comments ( sequence-parser -- sequence-parser )
+ skip-whitespace
+ {
+ { [ dup take-c-comment ] [ skip-whitespace/comments ] }
+ { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
+ [ ]
+ } cond ;
+
+: handle-include ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments advance dup previous {
{ CHAR: < [ CHAR: > take-until-object read-standard-include ] }
{ CHAR: " [ CHAR: " take-until-object read-local-include ] }
[ bad-include-line ]
: readlns ( -- string ) [ (readlns) ] { } make concat ;
-: take-define-identifier ( state-parser -- string )
- skip-whitespace
+: take-define-identifier ( sequence-parser -- string )
+ skip-whitespace/comments
[ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
-: handle-define ( preprocessor-state state-parser -- )
+: handle-define ( preprocessor-state sequence-parser -- )
[ take-define-identifier ]
- [ skip-whitespace take-rest ] bi
+ [ skip-whitespace/comments take-rest ] bi
"\\" ?tail [ readlns append ] when
spin symbol-table>> set-at ;
-: handle-undef ( preprocessor-state state-parser -- )
+: handle-undef ( preprocessor-state sequence-parser -- )
take-token swap symbol-table>> delete-at ;
-: handle-ifdef ( preprocessor-state state-parser -- )
+: handle-ifdef ( preprocessor-state sequence-parser -- )
[ [ 1 + ] change-ifdef-nesting ] dip
take-token over symbol-table>> key?
[ drop ] [ t >>processing-disabled? drop ] if ;
-: handle-ifndef ( preprocessor-state state-parser -- )
+: handle-ifndef ( preprocessor-state sequence-parser -- )
[ [ 1 + ] change-ifdef-nesting ] dip
take-token over symbol-table>> key?
[ t >>processing-disabled? drop ]
[ drop ] if ;
-: handle-endif ( preprocessor-state state-parser -- )
+: handle-endif ( preprocessor-state sequence-parser -- )
drop [ 1 - ] change-ifdef-nesting drop ;
-: handle-if ( preprocessor-state state-parser -- )
+: handle-if ( preprocessor-state sequence-parser -- )
[ [ 1 + ] change-ifdef-nesting ] dip
- skip-whitespace take-rest swap ifs>> push ;
+ skip-whitespace/comments take-rest swap ifs>> push ;
-: handle-elif ( preprocessor-state state-parser -- )
- skip-whitespace take-rest swap elifs>> push ;
+: handle-elif ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap elifs>> push ;
-: handle-else ( preprocessor-state state-parser -- )
- skip-whitespace take-rest swap elses>> push ;
+: handle-else ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap elses>> push ;
-: handle-pragma ( preprocessor-state state-parser -- )
- skip-whitespace take-rest swap pragmas>> push ;
+: handle-pragma ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap pragmas>> push ;
-: handle-include-next ( preprocessor-state state-parser -- )
- skip-whitespace take-rest swap include-nexts>> push ;
+: handle-include-next ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap include-nexts>> push ;
-: handle-error ( preprocessor-state state-parser -- )
- skip-whitespace take-rest swap errors>> push ;
+: handle-error ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap errors>> push ;
! nip take-rest throw ;
-: handle-warning ( preprocessor-state state-parser -- )
- skip-whitespace
+: handle-warning ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments
take-rest swap warnings>> push ;
-: parse-directive ( preprocessor-state state-parser string -- )
+: parse-directive ( preprocessor-state sequence-parser string -- )
{
{ "warning" [ handle-warning ] }
{ "error" [ handle-error ] }
[ unknown-c-preprocessor ]
} case ;
-: parse-directive-line ( preprocessor-state state-parser -- )
+: parse-directive-line ( preprocessor-state sequence-parser -- )
advance dup take-token
pick processing-disabled?>> [
"endif" = [
parse-directive
] if ;
-: preprocess-line ( preprocessor-state state-parser -- )
- skip-whitespace dup current CHAR: # =
+: preprocess-line ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments dup current CHAR: # =
[ parse-directive-line ]
[ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
: preprocess-lines ( preprocessor-state -- )
readln
- [ <state-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
+ [ <sequence-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
[ drop ] if* ;
ERROR: include-nested-too-deeply ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables html.parser.state
+USING: accessors arrays hashtables sequence-parser
html.parser.utils kernel namespaces sequences
unicode.case unicode.categories combinators.short-circuit
quoting fry ;
swap >>name
swap >>text ; inline
-: (read-quote) ( state-parser ch -- string )
+: (read-quote) ( sequence-parser ch -- string )
'[ [ current _ = ] take-until ] [ advance drop ] bi ;
-: read-single-quote ( state-parser -- string )
+: read-single-quote ( sequence-parser -- string )
CHAR: ' (read-quote) ;
-: read-double-quote ( state-parser -- string )
+: read-double-quote ( sequence-parser -- string )
CHAR: " (read-quote) ;
-: read-quote ( state-parser -- string )
+: read-quote ( sequence-parser -- string )
dup get+increment CHAR: ' =
[ read-single-quote ] [ read-double-quote ] if ;
-: read-key ( state-parser -- string )
+: read-key ( sequence-parser -- string )
skip-whitespace
[ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
-: read-token ( state-parser -- string )
+: read-token ( sequence-parser -- string )
[ current blank? ] take-until ;
-: read-value ( state-parser -- string )
+: read-value ( sequence-parser -- string )
skip-whitespace
dup current quote? [ read-quote ] [ read-token ] if
[ blank? ] trim ;
-: read-comment ( state-parser -- )
+: read-comment ( sequence-parser -- )
"-->" take-until-sequence comment new-tag push-tag ;
-: read-dtd ( state-parser -- )
+: read-dtd ( sequence-parser -- )
">" take-until-sequence dtd new-tag push-tag ;
-: read-bang ( state-parser -- )
+: read-bang ( sequence-parser -- )
advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
[ advance advance read-comment ] [ read-dtd ] if ;
-: read-tag ( state-parser -- string )
+: read-tag ( sequence-parser -- string )
[ [ current "><" member? ] take-until ]
[ dup current CHAR: < = [ advance ] unless drop ] bi ;
-: read-until-< ( state-parser -- string )
+: read-until-< ( sequence-parser -- string )
[ current CHAR: < = ] take-until ;
-: parse-text ( state-parser -- )
+: parse-text ( sequence-parser -- )
read-until-< [ text new-tag push-tag ] unless-empty ;
-: parse-key/value ( state-parser -- key value )
+: parse-key/value ( sequence-parser -- key value )
[ read-key >lower ]
[ skip-whitespace "=" take-sequence ]
[ swap [ read-value ] [ drop dup ] if ] tri ;
-: (parse-attributes) ( state-parser -- )
+: (parse-attributes) ( sequence-parser -- )
skip-whitespace
- dup state-parse-end? [
+ dup sequence-parse-end? [
drop
] [
[ parse-key/value swap set ] [ (parse-attributes) ] bi
] if ;
-: parse-attributes ( state-parser -- hashtable )
+: parse-attributes ( sequence-parser -- hashtable )
[ (parse-attributes) ] H{ } make-assoc ;
: (parse-tag) ( string -- string' hashtable )
[
[ read-token >lower ] [ parse-attributes ] bi
- ] state-parse ;
+ ] parse-sequence ;
-: read-< ( state-parser -- string/f )
+: read-< ( sequence-parser -- string/f )
advance dup current [
CHAR: ! = [ read-bang f ] [ read-tag ] if
] [
drop f
] if* ;
-: parse-tag ( state-parser -- )
+: parse-tag ( sequence-parser -- )
read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
-: (parse-html) ( state-parser -- )
+: (parse-html) ( sequence-parser -- )
dup peek-next [
[ parse-text ] [ parse-tag ] [ (parse-html) ] tri
] [ drop ] if ;
: tag-parse ( quot -- vector )
- V{ } clone tagstack [ state-parse ] with-variable ; inline
+ V{ } clone tagstack [ parse-sequence ] with-variable ; inline
PRIVATE>
+++ /dev/null
-USING: tools.test html.parser.state ascii kernel accessors ;
-IN: html.parser.state.tests
-
-[ "hello" ]
-[ "hello" [ take-rest ] state-parse ] unit-test
-
-[ "hi" " how are you?" ]
-[
- "hi how are you?"
- [ [ [ current blank? ] take-until ] [ take-rest ] bi ] state-parse
-] unit-test
-
-[ "foo" ";bar" ]
-[
- "foo;bar" [
- [ CHAR: ; take-until-object ] [ take-rest ] bi
- ] state-parse
-] unit-test
-
-[ "foo " " bar" ]
-[
- "foo and bar" [
- [ "and" take-until-sequence ] [ take-rest ] bi
- ] state-parse
-] unit-test
-
-[ 6 ]
-[
- " foo " [ skip-whitespace n>> ] state-parse
-] unit-test
-
-[ { 1 2 } ]
-[ { 1 2 3 } <state-parser> [ current 3 = ] take-until ] unit-test
-
-[ { 1 2 } ]
-[ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test
-
-[ "ab" ]
-[ "abcd" <state-parser> "ab" take-sequence ] unit-test
-
-[ f ]
-[ "abcd" <state-parser> "lol" take-sequence ] unit-test
-
-[ "ab" ]
-[
- "abcd" <state-parser>
- [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
-] unit-test
-
-[ "" ]
-[ "abcd" <state-parser> "" take-sequence ] unit-test
-
-[ "cd" ]
-[ "abcd" <state-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
-
-[ f ]
-[
- "\"abc\" asdf" <state-parser>
- [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
-] unit-test
-
-[ "abc\\\"def" ]
-[
- "\"abc\\\"def\" asdf" <state-parser>
- CHAR: \ CHAR: " take-quoted-string
-] unit-test
-
-[ "asdf" ]
-[
- "\"abc\" asdf" <state-parser>
- [ CHAR: \ CHAR: " take-quoted-string drop ]
- [ skip-whitespace "asdf" take-sequence ] bi
-] unit-test
-
-[ f ]
-[
- "\"abc asdf" <state-parser>
- CHAR: \ CHAR: " take-quoted-string
-] unit-test
-
-[ "\"abc" ]
-[
- "\"abc asdf" <state-parser>
- [ CHAR: \ CHAR: " take-quoted-string drop ]
- [ "\"abc" take-sequence ] bi
-] unit-test
-
-[ "c" ]
-[ "c" <state-parser> take-token ] unit-test
-
-[ f ]
-[ "" <state-parser> take-token ] unit-test
-
-[ "abcd e \\\"f g" ]
-[ "\"abcd e \\\"f g\"" <state-parser> CHAR: \ CHAR: " take-token* ] unit-test
-
-[ "" ]
-[ "" <state-parser> take-rest ] unit-test
-
-[ "" ]
-[ "abc" <state-parser> dup "abc" take-sequence drop take-rest ] unit-test
-
-[ f ]
-[ "abc" <state-parser> "abcdefg" take-sequence ] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces math kernel sequences accessors fry circular
-unicode.case unicode.categories locals combinators.short-circuit
-make combinators io splitting ;
-
-IN: html.parser.state
-
-TUPLE: state-parser sequence n ;
-
-: <state-parser> ( sequence -- state-parser )
- state-parser new
- swap >>sequence
- 0 >>n ;
-
-: offset ( state-parser offset -- char/f )
- swap
- [ n>> + ] [ sequence>> ?nth ] bi ; inline
-
-: current ( state-parser -- char/f ) 0 offset ; inline
-
-: previous ( state-parser -- char/f ) -1 offset ; inline
-
-: peek-next ( state-parser -- char/f ) 1 offset ; inline
-
-: advance ( state-parser -- state-parser )
- [ 1 + ] change-n ; inline
-
-: advance* ( state-parser -- )
- advance drop ; inline
-
-: get+increment ( state-parser -- char/f )
- [ current ] [ advance drop ] bi ; inline
-
-:: skip-until ( state-parser quot: ( obj -- ? ) -- )
- state-parser current [
- state-parser quot call [ state-parser advance quot skip-until ] unless
- ] when ; inline recursive
-
-: state-parse-end? ( state-parser -- ? ) current not ;
-
-: take-until ( state-parser quot: ( obj -- ? ) -- sequence/f )
- over state-parse-end? [
- 2drop f
- ] [
- [ drop n>> ]
- [ skip-until ]
- [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
- ] if ; inline
-
-: take-while ( state-parser quot: ( obj -- ? ) -- sequence/f )
- [ not ] compose take-until ; inline
-
-: <safe-slice> ( from to seq -- slice/f )
- 3dup {
- [ 2drop 0 < ]
- [ [ drop ] 2dip length > ]
- [ drop > ]
- } 3|| [ 3drop f ] [ slice boa ] if ; inline
-
-:: take-sequence ( state-parser sequence -- obj/f )
- state-parser [ n>> dup sequence length + ] [ sequence>> ] bi
- <safe-slice> sequence sequence= [
- sequence
- state-parser [ sequence length + ] change-n drop
- ] [
- f
- ] if ;
-
-:: take-until-sequence ( state-parser sequence -- sequence' )
- sequence length <growing-circular> :> growing
- state-parser
- [
- current growing push-growing-circular
- sequence growing sequence=
- ] take-until :> found
- found dup length
- growing length 1- - head
- state-parser advance drop ;
-
-: skip-whitespace ( state-parser -- state-parser )
- [ [ current blank? not ] take-until drop ] keep ;
-
-: take-rest-slice ( state-parser -- sequence/f )
- [ sequence>> ] [ n>> ] bi
- 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
-
-: take-rest ( state-parser -- sequence )
- [ take-rest-slice ] [ sequence>> like ] bi ;
-
-: take-until-object ( state-parser obj -- sequence )
- '[ current _ = ] take-until ;
-
-: state-parse ( sequence quot -- )
- [ <state-parser> ] dip call ; inline
-
-:: take-quoted-string ( state-parser escape-char quote-char -- string )
- state-parser n>> :> start-n
- state-parser advance
- [
- {
- [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
- [ current quote-char = not ]
- } 1||
- ] take-while :> string
- state-parser current quote-char = [
- state-parser advance* string
- ] [
- start-n state-parser (>>n) f
- ] if ;
-
-: (take-token) ( state-parser -- string )
- skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
-
-:: take-token* ( state-parser escape-char quote-char -- string/f )
- state-parser skip-whitespace
- dup current {
- { quote-char [ escape-char quote-char take-quoted-string ] }
- { f [ drop f ] }
- [ drop (take-token) ]
- } case ;
-
-: take-token ( state-parser -- string/f )
- CHAR: \ CHAR: " take-token* ;
-
-: write-full ( state-parser -- ) sequence>> write ;
-: write-rest ( state-parser -- ) take-rest write ;
! See http://factorcode.org/license.txt for BSD license.
USING: assocs circular combinators continuations hashtables
hashtables.private io kernel math namespaces prettyprint
-quotations sequences splitting html.parser.state strings
-combinators.short-circuit quoting ;
+quotations sequences splitting strings quoting
+combinators.short-circuit ;
IN: html.parser.utils
: trim1 ( seq ch -- newseq )
HELP: mp3>id3
{ $values
{ "path" "a path string" }
- { "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } }
+ { "id3/f" "a tuple storing ID3v2 metadata or f" } }
{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Words to access the ID3v1 information are here:"
{ $list
{ $link title }
HELP: album
{ $values
- { "id3" id3v2-info }
- { "album/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the album, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: artist
{ $values
- { "id3" id3v2-info }
- { "artist/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the artist, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: comment
{ $values
- { "id3" id3v2-info }
- { "comment/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the comment, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: genre
{ $values
- { "id3" id3v2-info }
- { "genre/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the genre, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: title
{ $values
- { "id3" id3v2-info }
- { "title/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the title, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: year
{ $values
- { "id3" id3v2-info }
- { "year/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the year, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: find-id3-frame
{ $values
- { "id3" id3v2-info } { "name" string }
+ { "id3" id3 } { "name" string }
{ "obj/f" "object or f" }
}
{ $description "Returns the " { $slot "data" } " slot of the ID3 frame with the given name, or " { $link f } "." } ;
! Copyright (C) 2009 Tim Wawrzynczak
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test id3 combinators ;
+USING: tools.test id3 combinators grouping id3.private
+sequences math ;
IN: id3.tests
: id3-params ( id3 -- title artist album year comment genre )
"Big Band"
] [ "vocab:id3/tests/blah3.mp3" mp3>id3 id3-params ] unit-test
+
+[ t ]
+[ 10000 [ synchsafe>seq seq>synchsafe ] map [ < ] monotonic? ] unit-test
io.encodings.string io.encodings.utf16 assocs math.parser
combinators.short-circuit fry namespaces combinators.smart
splitting io.encodings.ascii arrays io.files.info unicode.case
-io.directories.search ;
+io.directories.search literals math.functions ;
IN: id3
<PRIVATE
"Primus" "Porn Groove" "Satire" "Slow Jam" "Club" "Tango"
"Samba" "Folklore" "Ballad" "Power Ballad" "Rhythmic Soul"
"Freestyle" "Duet" "Punk Rock" "Drum Solo" "A capella"
- "Euro-House" "Dance Hall"
+ "Euro-House" "Dance Hall" "Goa" "Drum & Bass" "Club-House"
+ "Hardcore" "Terror" "Indie" "BritPop" "Negerpunk"
+ "Polsk Punk" "Beat" "Christian Gangsta Rap" "Heavy Metal"
+ "Black Metal" "Crossover" "Contemporary Christian"
+ "Christian Rock"
}
TUPLE: header version flags size ;
-TUPLE: frame frame-id flags size data ;
+TUPLE: frame tag flags size data ;
-TUPLE: id3v2-info header frames ;
+TUPLE: id3 header frames
+title artist album year comment genre
+speed genre-name start-time end-time ;
-TUPLE: id3v1-info title artist album year comment genre ;
-
-: <id3v1-info> ( -- object ) id3v1-info new ; inline
-
-: <id3v2-info> ( header frames -- object )
- [ [ frame-id>> ] keep ] H{ } map>assoc id3v2-info boa ;
+: <id3> ( -- id3 )
+ id3 new
+ H{ } clone >>frames ; inline
: <header> ( -- object ) header new ; inline
: <frame> ( -- object ) frame new ; inline
-: id3v2? ( mmap -- ? ) "ID3" head? ; inline
+: id3v2? ( seq -- ? ) "ID3" head? ; inline
-: id3v1? ( mmap -- ? )
- { [ length 128 >= ] [ 128 tail-slice* "TAG" head? ] } 1&& ; inline
+CONSTANT: id3v1-length 128
+CONSTANT: id3v1-offset 128
+CONSTANT: id3v1+-length 227
+CONSTANT: id3v1+-offset $[ 128 227 + ]
-: id3v1-frame ( string key -- frame )
- <frame>
- swap >>frame-id
- swap >>data ; inline
+: id3v1? ( seq -- ? )
+ {
+ [ length id3v1-offset >= ]
+ [ id3v1-length tail-slice* "TAG" head? ]
+ } 1&& ; inline
-: id3v1>id3v2 ( id3v1 -- id3v2 )
+: id3v1+? ( seq -- ? )
+ {
+ [ length id3v1+-offset >= ]
+ [ id3v1+-length tail-slice* "TAG+" head? ]
+ } 1&& ; inline
+
+: pair>frame ( string key -- frame/f )
+ over [
+ <frame>
+ swap >>tag
+ swap >>data
+ ] [
+ 2drop f
+ ] if ; inline
+
+: id3v1>frames ( id3v1 -- seq )
[
{
- [ title>> "TIT2" id3v1-frame ]
- [ artist>> "TPE1" id3v1-frame ]
- [ album>> "TALB" id3v1-frame ]
- [ year>> "TYER" id3v1-frame ]
- [ comment>> "COMM" id3v1-frame ]
- [ genre>> "TCON" id3v1-frame ]
+ [ title>> "TIT2" pair>frame ]
+ [ artist>> "TPE1" pair>frame ]
+ [ album>> "TALB" pair>frame ]
+ [ year>> "TYER" pair>frame ]
+ [ comment>> "COMM" pair>frame ]
+ [ genre>> "TCON" pair>frame ]
} cleave
- ] output>array f swap <id3v2-info> ; inline
+ ] output>array sift ;
-: >28bitword ( seq -- int )
+: seq>synchsafe ( seq -- n )
0 [ [ 7 shift ] dip bitor ] reduce ; inline
+: synchsafe>seq ( n -- seq )
+ dup 1+ log2 1+ 7 / ceiling
+ [ [ -7 shift ] keep HEX: 7f bitand ] replicate nip reverse ; inline
+
: filter-text-data ( data -- filtered )
[ printable? ] filter ; inline
-: valid-frame-id? ( id -- ? )
+: valid-tag? ( id -- ? )
[ { [ digit? ] [ LETTER? ] } 1|| ] all? ; inline
-: read-frame-data ( frame mmap -- frame data )
+: read-frame-data ( frame seq -- frame data )
[ 10 over size>> 10 + ] dip <slice> filter-text-data ; inline
: decode-text ( string -- string' )
{ { HEX: ff HEX: fe } { HEX: fe HEX: ff } } member?
utf16 ascii ? decode ; inline
-: (read-frame) ( mmap -- frame )
+: (read-frame) ( seq -- frame )
[ <frame> ] dip
{
- [ 4 head-slice decode-text >>frame-id ]
- [ [ 4 8 ] dip subseq >28bitword >>size ]
+ [ 4 head-slice decode-text >>tag ]
+ [ [ 4 8 ] dip subseq seq>synchsafe >>size ]
[ [ 8 10 ] dip subseq >byte-array >>flags ]
[ read-frame-data decode-text >>data ]
} cleave ; inline
-: read-frame ( mmap -- frame/f )
- dup 4 head-slice valid-frame-id?
+: read-frame ( seq -- frame/f )
+ dup 4 head-slice valid-tag?
[ (read-frame) ] [ drop f ] if ; inline
-: remove-frame ( mmap frame -- mmap )
+: remove-frame ( seq frame -- seq )
size>> 10 + tail-slice ; inline
-: read-frames ( mmap -- frames )
- [ dup read-frame dup ]
- [ [ remove-frame ] keep ]
- produce 2nip ; inline
+: frames>assoc ( seq -- assoc )
+ [ [ tag>> ] keep ] H{ } map>assoc ; inline
+
+: read-frames ( seq -- assoc )
+ [ dup read-frame dup ] [ [ remove-frame ] keep ] produce 2nip ; inline
-: read-v2-header ( seq -- id3header )
+: read-v2-header ( seq -- header )
[ <header> ] dip
{
[ [ 3 5 ] dip <slice> >array >>version ]
[ [ 5 ] dip nth >>flags ]
- [ [ 6 10 ] dip <slice> >28bitword >>size ]
+ [ [ 6 10 ] dip <slice> seq>synchsafe >>size ]
} cleave ; inline
-: read-v2-tag-data ( seq -- id3v2-info )
+: merge-frames ( id3 assoc -- id3 )
+ [ dup frames>> ] dip update ; inline
+
+: merge-id3v1 ( id3 -- id3 )
+ dup id3v1>frames frames>assoc merge-frames ; inline
+
+: read-v2-tags ( id3 seq -- id3 )
10 cut-slice
- [ read-v2-header ]
- [ read-frames ] bi* <id3v2-info> ; inline
+ [ read-v2-header >>header ]
+ [ read-frames frames>assoc merge-frames ] bi* ; inline
-: skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline
-
-: (read-v1-tag-data) ( seq -- mp3-file )
- [ <id3v1-info> ] dip
+: extract-v1-tags ( id3 seq -- id3 )
{
[ 30 head-slice decode-text filter-text-data >>title ]
[ [ 30 60 ] dip subseq decode-text filter-text-data >>artist ]
[ [ 124 ] dip nth number>string >>genre ]
} cleave ; inline
-: read-v1-tag-data ( seq -- mp3-file )
- skip-to-v1-data (read-v1-tag-data) ; inline
+: read-v1-tags ( id3 seq -- id3 )
+ id3v1-offset tail-slice* 3 tail-slice
+ extract-v1-tags ; inline
+
+: extract-v1+-tags ( id3 seq -- id3 )
+ {
+ [ 60 head-slice decode-text filter-text-data [ append ] change-title ]
+ [
+ [ 60 120 ] dip subseq decode-text filter-text-data
+ [ append ] change-artist
+ ]
+ [
+ [ 120 180 ] dip subseq decode-text filter-text-data
+ [ append ] change-album
+ ]
+ [ [ 180 ] dip nth >>speed ]
+ [ [ 181 211 ] dip subseq decode-text >>genre-name ]
+ [ [ 211 217 ] dip subseq decode-text >>start-time ]
+ [ [ 217 223 ] dip subseq decode-text >>end-time ]
+ } cleave ; inline
+
+: read-v1+-tags ( id3 seq -- id3 )
+ id3v1+-offset tail-slice* 4 tail-slice
+ extract-v1+-tags ; inline
: parse-genre ( string -- n/f )
dup "(" ?head-slice drop ")" ?tail-slice drop
drop
] if ; inline
-: (mp3>id3) ( path -- id3v2-info/f )
+: (mp3>id3) ( path -- id3v2/f )
[
+ [ <id3> ] dip
{
- { [ dup id3v2? ] [ read-v2-tag-data ] }
- { [ dup id3v1? ] [ read-v1-tag-data id3v1>id3v2 ] }
- [ drop f ]
- } cond
+ [ dup id3v1? [ read-v1-tags merge-id3v1 ] [ drop ] if ]
+ [ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
+ [ dup id3v2? [ read-v2-tags ] [ drop ] if ]
+ } cleave
] with-mapped-uchar-file ;
PRIVATE>
-: mp3>id3 ( path -- id3v2-info/f )
+: mp3>id3 ( path -- id3/f )
dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline
: find-id3-frame ( id3 name -- obj/f )
swap frames>> at* [ data>> ] when ; inline
-: title ( id3 -- title/f ) "TIT2" find-id3-frame ; inline
+: title ( id3 -- string/f ) "TIT2" find-id3-frame ; inline
-: artist ( id3 -- artist/f ) "TPE1" find-id3-frame ; inline
+: artist ( id3 -- string/f ) "TPE1" find-id3-frame ; inline
-: album ( id3 -- album/f ) "TALB" find-id3-frame ; inline
+: album ( id3 -- string/f ) "TALB" find-id3-frame ; inline
-: year ( id3 -- year/f ) "TYER" find-id3-frame ; inline
+: year ( id3 -- string/f ) "TYER" find-id3-frame ; inline
-: comment ( id3 -- comment/f ) "COMM" find-id3-frame ; inline
+: comment ( id3 -- string/f ) "COMM" find-id3-frame ; inline
-: genre ( id3 -- genre/f )
+: genre ( id3 -- string/f )
"TCON" find-id3-frame parse-genre ; inline
: find-mp3s ( path -- seq )
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2005 Alex Chapman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.libraries alien.syntax kernel sequences words system
+combinators ;
+IN: opengl.glu
+
+os {
+ { [ dup macosx? ] [ drop ] }
+ { [ dup windows? ] [ drop ] }
+ { [ dup unix? ] [ drop "glu" "libGLU.so.1" "cdecl" add-library ] }
+} cond
+
+LIBRARY: glu
+
+! These are defined as structs in glu.h, but we only ever use pointers to them
+TYPEDEF: void* GLUnurbs*
+TYPEDEF: void* GLUquadric*
+TYPEDEF: void* GLUtesselator*
+TYPEDEF: void* GLubyte*
+TYPEDEF: void* GLUfuncptr
+
+! StringName
+CONSTANT: GLU_VERSION 100800
+CONSTANT: GLU_EXTENSIONS 100801
+
+! ErrorCode
+CONSTANT: GLU_INVALID_ENUM 100900
+CONSTANT: GLU_INVALID_VALUE 100901
+CONSTANT: GLU_OUT_OF_MEMORY 100902
+CONSTANT: GLU_INCOMPATIBLE_GL_VERSION 100903
+CONSTANT: GLU_INVALID_OPERATION 100904
+
+! NurbsDisplay
+CONSTANT: GLU_OUTLINE_POLYGON 100240
+CONSTANT: GLU_OUTLINE_PATCH 100241
+
+! NurbsCallback
+CONSTANT: GLU_NURBS_ERROR 100103
+CONSTANT: GLU_ERROR 100103
+CONSTANT: GLU_NURBS_BEGIN 100164
+CONSTANT: GLU_NURBS_BEGIN_EXT 100164
+CONSTANT: GLU_NURBS_VERTEX 100165
+CONSTANT: GLU_NURBS_VERTEX_EXT 100165
+CONSTANT: GLU_NURBS_NORMAL 100166
+CONSTANT: GLU_NURBS_NORMAL_EXT 100166
+CONSTANT: GLU_NURBS_COLOR 100167
+CONSTANT: GLU_NURBS_COLOR_EXT 100167
+CONSTANT: GLU_NURBS_TEXTURE_COORD 100168
+CONSTANT: GLU_NURBS_TEX_COORD_EXT 100168
+CONSTANT: GLU_NURBS_END 100169
+CONSTANT: GLU_NURBS_END_EXT 100169
+CONSTANT: GLU_NURBS_BEGIN_DATA 100170
+CONSTANT: GLU_NURBS_BEGIN_DATA_EXT 100170
+CONSTANT: GLU_NURBS_VERTEX_DATA 100171
+CONSTANT: GLU_NURBS_VERTEX_DATA_EXT 100171
+CONSTANT: GLU_NURBS_NORMAL_DATA 100172
+CONSTANT: GLU_NURBS_NORMAL_DATA_EXT 100172
+CONSTANT: GLU_NURBS_COLOR_DATA 100173
+CONSTANT: GLU_NURBS_COLOR_DATA_EXT 100173
+CONSTANT: GLU_NURBS_TEXTURE_COORD_DATA 100174
+CONSTANT: GLU_NURBS_TEX_COORD_DATA_EXT 100174
+CONSTANT: GLU_NURBS_END_DATA 100175
+CONSTANT: GLU_NURBS_END_DATA_EXT 100175
+
+! NurbsError
+CONSTANT: GLU_NURBS_ERROR1 100251
+CONSTANT: GLU_NURBS_ERROR2 100252
+CONSTANT: GLU_NURBS_ERROR3 100253
+CONSTANT: GLU_NURBS_ERROR4 100254
+CONSTANT: GLU_NURBS_ERROR5 100255
+CONSTANT: GLU_NURBS_ERROR6 100256
+CONSTANT: GLU_NURBS_ERROR7 100257
+CONSTANT: GLU_NURBS_ERROR8 100258
+CONSTANT: GLU_NURBS_ERROR9 100259
+CONSTANT: GLU_NURBS_ERROR10 100260
+CONSTANT: GLU_NURBS_ERROR11 100261
+CONSTANT: GLU_NURBS_ERROR12 100262
+CONSTANT: GLU_NURBS_ERROR13 100263
+CONSTANT: GLU_NURBS_ERROR14 100264
+CONSTANT: GLU_NURBS_ERROR15 100265
+CONSTANT: GLU_NURBS_ERROR16 100266
+CONSTANT: GLU_NURBS_ERROR17 100267
+CONSTANT: GLU_NURBS_ERROR18 100268
+CONSTANT: GLU_NURBS_ERROR19 100269
+CONSTANT: GLU_NURBS_ERROR20 100270
+CONSTANT: GLU_NURBS_ERROR21 100271
+CONSTANT: GLU_NURBS_ERROR22 100272
+CONSTANT: GLU_NURBS_ERROR23 100273
+CONSTANT: GLU_NURBS_ERROR24 100274
+CONSTANT: GLU_NURBS_ERROR25 100275
+CONSTANT: GLU_NURBS_ERROR26 100276
+CONSTANT: GLU_NURBS_ERROR27 100277
+CONSTANT: GLU_NURBS_ERROR28 100278
+CONSTANT: GLU_NURBS_ERROR29 100279
+CONSTANT: GLU_NURBS_ERROR30 100280
+CONSTANT: GLU_NURBS_ERROR31 100281
+CONSTANT: GLU_NURBS_ERROR32 100282
+CONSTANT: GLU_NURBS_ERROR33 100283
+CONSTANT: GLU_NURBS_ERROR34 100284
+CONSTANT: GLU_NURBS_ERROR35 100285
+CONSTANT: GLU_NURBS_ERROR36 100286
+CONSTANT: GLU_NURBS_ERROR37 100287
+
+! NurbsProperty
+CONSTANT: GLU_AUTO_LOAD_MATRIX 100200
+CONSTANT: GLU_CULLING 100201
+CONSTANT: GLU_SAMPLING_TOLERANCE 100203
+CONSTANT: GLU_DISPLAY_MODE 100204
+CONSTANT: GLU_PARAMETRIC_TOLERANCE 100202
+CONSTANT: GLU_SAMPLING_METHOD 100205
+CONSTANT: GLU_U_STEP 100206
+CONSTANT: GLU_V_STEP 100207
+CONSTANT: GLU_NURBS_MODE 100160
+CONSTANT: GLU_NURBS_MODE_EXT 100160
+CONSTANT: GLU_NURBS_TESSELLATOR 100161
+CONSTANT: GLU_NURBS_TESSELLATOR_EXT 100161
+CONSTANT: GLU_NURBS_RENDERER 100162
+CONSTANT: GLU_NURBS_RENDERER_EXT 100162
+
+! NurbsSampling
+CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR 100208
+CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR_EXT 100208
+CONSTANT: GLU_OBJECT_PATH_LENGTH 100209
+CONSTANT: GLU_OBJECT_PATH_LENGTH_EXT 100209
+CONSTANT: GLU_PATH_LENGTH 100215
+CONSTANT: GLU_PARAMETRIC_ERROR 100216
+CONSTANT: GLU_DOMAIN_DISTANCE 100217
+
+! NurbsTrim
+CONSTANT: GLU_MAP1_TRIM_2 100210
+CONSTANT: GLU_MAP1_TRIM_3 100211
+
+! QuadricDrawStyle
+CONSTANT: GLU_POINT 100010
+CONSTANT: GLU_LINE 100011
+CONSTANT: GLU_FILL 100012
+CONSTANT: GLU_SILHOUETTE 100013
+
+! QuadricNormal
+CONSTANT: GLU_SMOOTH 100000
+CONSTANT: GLU_FLAT 100001
+CONSTANT: GLU_NONE 100002
+
+! QuadricOrientation
+CONSTANT: GLU_OUTSIDE 100020
+CONSTANT: GLU_INSIDE 100021
+
+! TessCallback
+CONSTANT: GLU_TESS_BEGIN 100100
+CONSTANT: GLU_BEGIN 100100
+CONSTANT: GLU_TESS_VERTEX 100101
+CONSTANT: GLU_VERTEX 100101
+CONSTANT: GLU_TESS_END 100102
+CONSTANT: GLU_END 100102
+CONSTANT: GLU_TESS_ERROR 100103
+CONSTANT: GLU_TESS_EDGE_FLAG 100104
+CONSTANT: GLU_EDGE_FLAG 100104
+CONSTANT: GLU_TESS_COMBINE 100105
+CONSTANT: GLU_TESS_BEGIN_DATA 100106
+CONSTANT: GLU_TESS_VERTEX_DATA 100107
+CONSTANT: GLU_TESS_END_DATA 100108
+CONSTANT: GLU_TESS_ERROR_DATA 100109
+CONSTANT: GLU_TESS_EDGE_FLAG_DATA 100110
+CONSTANT: GLU_TESS_COMBINE_DATA 100111
+
+! TessContour
+CONSTANT: GLU_CW 100120
+CONSTANT: GLU_CCW 100121
+CONSTANT: GLU_INTERIOR 100122
+CONSTANT: GLU_EXTERIOR 100123
+CONSTANT: GLU_UNKNOWN 100124
+
+! TessProperty
+CONSTANT: GLU_TESS_WINDING_RULE 100140
+CONSTANT: GLU_TESS_BOUNDARY_ONLY 100141
+CONSTANT: GLU_TESS_TOLERANCE 100142
+
+! TessError
+CONSTANT: GLU_TESS_ERROR1 100151
+CONSTANT: GLU_TESS_ERROR2 100152
+CONSTANT: GLU_TESS_ERROR3 100153
+CONSTANT: GLU_TESS_ERROR4 100154
+CONSTANT: GLU_TESS_ERROR5 100155
+CONSTANT: GLU_TESS_ERROR6 100156
+CONSTANT: GLU_TESS_ERROR7 100157
+CONSTANT: GLU_TESS_ERROR8 100158
+CONSTANT: GLU_TESS_MISSING_BEGIN_POLYGON 100151
+CONSTANT: GLU_TESS_MISSING_BEGIN_CONTOUR 100152
+CONSTANT: GLU_TESS_MISSING_END_POLYGON 100153
+CONSTANT: GLU_TESS_MISSING_END_CONTOUR 100154
+CONSTANT: GLU_TESS_COORD_TOO_LARGE 100155
+CONSTANT: GLU_TESS_NEED_COMBINE_CALLBACK 100156
+
+! TessWinding
+CONSTANT: GLU_TESS_WINDING_ODD 100130
+CONSTANT: GLU_TESS_WINDING_NONZERO 100131
+CONSTANT: GLU_TESS_WINDING_POSITIVE 100132
+CONSTANT: GLU_TESS_WINDING_NEGATIVE 100133
+CONSTANT: GLU_TESS_WINDING_ABS_GEQ_TWO 100134
+
+LIBRARY: glu
+
+FUNCTION: void gluBeginCurve ( GLUnurbs* nurb ) ;
+FUNCTION: void gluBeginPolygon ( GLUtesselator* tess ) ;
+FUNCTION: void gluBeginSurface ( GLUnurbs* nurb ) ;
+FUNCTION: void gluBeginTrim ( GLUnurbs* nurb ) ;
+
+FUNCTION: void gluCylinder ( GLUquadric* quad, GLdouble base, GLdouble top, GLdouble height, GLint slices, GLint stacks ) ;
+FUNCTION: void gluDeleteNurbsRenderer ( GLUnurbs* nurb ) ;
+FUNCTION: void gluDeleteQuadric ( GLUquadric* quad ) ;
+FUNCTION: void gluDeleteTess ( GLUtesselator* tess ) ;
+FUNCTION: void gluDisk ( GLUquadric* quad, GLdouble inner, GLdouble outer, GLint slices, GLint loops ) ;
+FUNCTION: void gluEndCurve ( GLUnurbs* nurb ) ;
+FUNCTION: void gluEndPolygon ( GLUtesselator* tess ) ;
+FUNCTION: void gluEndSurface ( GLUnurbs* nurb ) ;
+FUNCTION: void gluEndTrim ( GLUnurbs* nurb ) ;
+FUNCTION: char* gluErrorString ( GLenum error ) ;
+FUNCTION: void gluGetNurbsProperty ( GLUnurbs* nurb, GLenum property, GLfloat* data ) ;
+FUNCTION: char* gluGetString ( GLenum name ) ;
+FUNCTION: void gluGetTessProperty ( GLUtesselator* tess, GLenum which, GLdouble* data ) ;
+FUNCTION: void gluLoadSamplingMatrices ( GLUnurbs* nurb, GLfloat* model, GLfloat* perspective, GLint* view ) ;
+FUNCTION: void gluLookAt ( GLdouble eyeX, GLdouble eyeY, GLdouble eyeZ, GLdouble centerX, GLdouble centerY, GLdouble centerZ, GLdouble upX, GLdouble upY, GLdouble upZ ) ;
+FUNCTION: GLUnurbs* gluNewNurbsRenderer ( ) ;
+FUNCTION: GLUquadric* gluNewQuadric ( ) ;
+FUNCTION: GLUtesselator* gluNewTess ( ) ;
+FUNCTION: void gluNextContour ( GLUtesselator* tess, GLenum type ) ;
+FUNCTION: void gluNurbsCallback ( GLUnurbs* nurb, GLenum which, GLUfuncptr CallBackFunc ) ;
+! FUNCTION: void gluNurbsCallbackData ( GLUnurbs* nurb, GLvoid* userData ) ;
+! FUNCTION: void gluNurbsCallbackDataEXT ( GLUnurbs* nurb, GLvoid* userData ) ;
+FUNCTION: void gluNurbsCurve ( GLUnurbs* nurb, GLint knotCount, GLfloat *knots, GLint stride, GLfloat *control, GLint order, GLenum type ) ;
+FUNCTION: void gluNurbsProperty ( GLUnurbs* nurb, GLenum property, GLfloat value ) ;
+FUNCTION: void gluNurbsSurface ( GLUnurbs* nurb, GLint sKnotCount, GLfloat* sKnots, GLint tKnotCount, GLfloat* tKnots, GLint sStride, GLint tStride, GLfloat* control, GLint sOrder, GLint tOrder, GLenum type ) ;
+FUNCTION: void gluOrtho2D ( GLdouble left, GLdouble right, GLdouble bottom, GLdouble top ) ;
+FUNCTION: void gluPartialDisk ( GLUquadric* quad, GLdouble inner, GLdouble outer, GLint slices, GLint loops, GLdouble start, GLdouble sweep ) ;
+FUNCTION: void gluPerspective ( GLdouble fovy, GLdouble aspect, GLdouble zNear, GLdouble zFar ) ;
+FUNCTION: void gluPickMatrix ( GLdouble x, GLdouble y, GLdouble delX, GLdouble delY, GLint* viewport ) ;
+FUNCTION: GLint gluProject ( GLdouble objX, GLdouble objY, GLdouble objZ, GLdouble* model, GLdouble* proj, GLint* view, GLdouble* winX, GLdouble* winY, GLdouble* winZ ) ;
+FUNCTION: void gluPwlCurve ( GLUnurbs* nurb, GLint count, GLfloat* data, GLint stride, GLenum type ) ;
+FUNCTION: void gluQuadricCallback ( GLUquadric* quad, GLenum which, GLUfuncptr CallBackFunc ) ;
+FUNCTION: void gluQuadricDrawStyle ( GLUquadric* quad, GLenum draw ) ;
+FUNCTION: void gluQuadricNormals ( GLUquadric* quad, GLenum normal ) ;
+FUNCTION: void gluQuadricOrientation ( GLUquadric* quad, GLenum orientation ) ;
+FUNCTION: void gluQuadricTexture ( GLUquadric* quad, GLboolean texture ) ;
+FUNCTION: GLint gluScaleImage ( GLenum format, GLsizei wIn, GLsizei hIn, GLenum typeIn, void* dataIn, GLsizei wOut, GLsizei hOut, GLenum typeOut, GLvoid* dataOut ) ;
+FUNCTION: void gluSphere ( GLUquadric* quad, GLdouble radius, GLint slices, GLint stacks ) ;
+FUNCTION: void gluTessBeginContour ( GLUtesselator* tess ) ;
+FUNCTION: void gluTessBeginPolygon ( GLUtesselator* tess, GLvoid* data ) ;
+FUNCTION: void gluTessCallback ( GLUtesselator* tess, GLenum which, GLUfuncptr CallBackFunc ) ;
+FUNCTION: void gluTessEndContour ( GLUtesselator* tess ) ;
+FUNCTION: void gluTessEndPolygon ( GLUtesselator* tess ) ;
+FUNCTION: void gluTessNormal ( GLUtesselator* tess, GLdouble valueX, GLdouble valueY, GLdouble valueZ ) ;
+FUNCTION: void gluTessProperty ( GLUtesselator* tess, GLenum which, GLdouble data ) ;
+FUNCTION: void gluTessVertex ( GLUtesselator* tess, GLdouble* location, GLvoid* data ) ;
+FUNCTION: GLint gluUnProject ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble* model, GLdouble* proj, GLint* view, GLdouble* objX, GLdouble* objY, GLdouble* objZ ) ;
+
+! Not present on Windows
+! FUNCTION: GLint gluBuild1DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
+! FUNCTION: GLint gluBuild1DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLenum format, GLenum type, void* data ) ;
+! FUNCTION: GLint gluBuild2DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
+! FUNCTION: GLint gluBuild2DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLenum format, GLenum type, void* data ) ;
+! FUNCTION: GLint gluBuild3DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
+! FUNCTION: GLint gluBuild3DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, void* data ) ;
+! FUNCTION: GLboolean gluCheckExtension ( GLubyte* extName, GLubyte* extString ) ;
+! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ;
+
+: gl-look-at ( eye focus up -- )
+ [ first3 ] tri@ gluLookAt ;
\ No newline at end of file
--- /dev/null
+OpenGL binding - libGLU
--- /dev/null
+USING: tools.test sequence-parser ascii kernel accessors ;
+IN: sequence-parser.tests
+
+[ "hello" ]
+[ "hello" [ take-rest ] parse-sequence ] unit-test
+
+[ "hi" " how are you?" ]
+[
+ "hi how are you?"
+ [ [ [ current blank? ] take-until ] [ take-rest ] bi ] parse-sequence
+] unit-test
+
+[ "foo" ";bar" ]
+[
+ "foo;bar" [
+ [ CHAR: ; take-until-object ] [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ "foo " "and bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence ] [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ "foo " " bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence ]
+ [ "and" take-sequence drop ]
+ [ take-rest ] tri
+ ] parse-sequence
+] unit-test
+
+[ "foo " " bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence* ]
+ [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 4 } <sequence-parser> { 3 4 } take-until-sequence ] unit-test
+
+[ f "aaaa" ]
+[
+ "aaaa" <sequence-parser>
+ [ "b" take-until-sequence ] [ take-rest ] bi
+] unit-test
+
+[ 6 ]
+[
+ " foo " [ skip-whitespace n>> ] parse-sequence
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 } <sequence-parser> [ current 3 = ] take-until ] unit-test
+
+[ "ab" ]
+[ "abcd" <sequence-parser> "ab" take-sequence ] unit-test
+
+[ f ]
+[ "abcd" <sequence-parser> "lol" take-sequence ] unit-test
+
+[ "ab" ]
+[
+ "abcd" <sequence-parser>
+ [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
+] unit-test
+
+[ "" ]
+[ "abcd" <sequence-parser> "" take-sequence ] unit-test
+
+[ "cd" ]
+[ "abcd" <sequence-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
+
+[ f ]
+[
+ "\"abc\" asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
+] unit-test
+
+[ "abc\\\"def" ]
+[
+ "\"abc\\\"def\" asdf" <sequence-parser>
+ CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "asdf" ]
+[
+ "\"abc\" asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ]
+ [ skip-whitespace "asdf" take-sequence ] bi
+] unit-test
+
+[ f ]
+[
+ "\"abc asdf" <sequence-parser>
+ CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "\"abc" ]
+[
+ "\"abc asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ]
+ [ "\"abc" take-sequence ] bi
+] unit-test
+
+[ "c" ]
+[ "c" <sequence-parser> take-token ] unit-test
+
+[ f ]
+[ "" <sequence-parser> take-token ] unit-test
+
+[ "abcd e \\\"f g" ]
+[ "\"abcd e \\\"f g\"" <sequence-parser> CHAR: \ CHAR: " take-token* ] unit-test
+
+[ "" ]
+[ "" <sequence-parser> take-rest ] unit-test
+
+[ "" ]
+[ "abc" <sequence-parser> dup "abc" take-sequence drop take-rest ] unit-test
+
+[ f ]
+[ "abc" <sequence-parser> "abcdefg" take-sequence ] unit-test
+
+[ "1234" ]
+[ "1234f" <sequence-parser> take-integer ] unit-test
+
+[ "yes" ]
+[
+ "yes1234f" <sequence-parser>
+ [ take-integer drop ] [ "yes" take-sequence ] bi
+] unit-test
+
+[ f ] [ "" <sequence-parser> 4 take-n ] unit-test
+[ "abcd" ] [ "abcd" <sequence-parser> 4 take-n ] unit-test
+[ "abcd" "efg" ] [ "abcdefg" <sequence-parser> [ 4 take-n ] [ take-rest ] bi ] unit-test
+
+[ "asdfasdf" ] [
+ "/*asdfasdf*/" <sequence-parser> take-c-comment
+] unit-test
+
+[ "k" ] [
+ "/*asdfasdf*/k" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "omg" ] [
+ "//asdfasdf\nomg" <sequence-parser>
+ [ take-c++-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "omg" ] [
+ "omg" <sequence-parser>
+ [ take-c++-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "/*asdfasdf" ] [
+ "/*asdfasdf" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "asdf" "eoieoei" ] [
+ "//asdf\neoieoei" <sequence-parser>
+ [ take-c++-comment ] [ take-rest ] bi
+] unit-test
+
+[ f "33asdf" ]
+[ "33asdf" <sequence-parser> [ take-c-identifier ] [ take-rest ] bi ] unit-test
+
+[ "asdf" ]
+[ "asdf" <sequence-parser> take-c-identifier ] unit-test
+
+[ "_asdf" ]
+[ "_asdf" <sequence-parser> take-c-identifier ] unit-test
+
+[ "_asdf400" ]
+[ "_asdf400" <sequence-parser> take-c-identifier ] unit-test
+
+[ "123" ]
+[ "123jjj" <sequence-parser> take-c-integer ] unit-test
+
+[ "123uLL" ]
+[ "123uLL" <sequence-parser> take-c-integer ] unit-test
+
+[ "123ull" ]
+[ "123ull" <sequence-parser> take-c-integer ] unit-test
+
+[ "123u" ]
+[ "123u" <sequence-parser> take-c-integer ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces math kernel sequences accessors fry circular
+unicode.case unicode.categories locals combinators.short-circuit
+make combinators io splitting math.parser math.ranges
+generalizations sorting.functor math.order sorting.slots ;
+IN: sequence-parser
+
+TUPLE: sequence-parser sequence n ;
+
+: <sequence-parser> ( sequence -- sequence-parser )
+ sequence-parser new
+ swap >>sequence
+ 0 >>n ;
+
+:: with-sequence-parser ( sequence-parser quot -- seq/f )
+ sequence-parser n>> :> n
+ sequence-parser quot call [
+ n sequence-parser (>>n) f
+ ] unless* ; inline
+
+: offset ( sequence-parser offset -- char/f )
+ swap
+ [ n>> + ] [ sequence>> ?nth ] bi ; inline
+
+: current ( sequence-parser -- char/f ) 0 offset ; inline
+
+: previous ( sequence-parser -- char/f ) -1 offset ; inline
+
+: peek-next ( sequence-parser -- char/f ) 1 offset ; inline
+
+: advance ( sequence-parser -- sequence-parser )
+ [ 1 + ] change-n ; inline
+
+: advance* ( sequence-parser -- )
+ advance drop ; inline
+
+: get+increment ( sequence-parser -- char/f )
+ [ current ] [ advance drop ] bi ; inline
+
+:: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
+ sequence-parser current [
+ sequence-parser quot call
+ [ sequence-parser advance quot skip-until ] unless
+ ] when ; inline recursive
+
+: sequence-parse-end? ( sequence-parser -- ? ) current not ;
+
+: take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+ over sequence-parse-end? [
+ 2drop f
+ ] [
+ [ drop n>> ]
+ [ skip-until ]
+ [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
+ ] if ; inline
+
+: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+ [ not ] compose take-until ; inline
+
+: <safe-slice> ( from to seq -- slice/f )
+ 3dup {
+ [ 2drop 0 < ]
+ [ [ drop ] 2dip length > ]
+ [ drop > ]
+ } 3|| [ 3drop f ] [ slice boa ] if ; inline
+
+:: take-sequence ( sequence-parser sequence -- obj/f )
+ sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi
+ <safe-slice> sequence sequence= [
+ sequence
+ sequence-parser [ sequence length + ] change-n drop
+ ] [
+ f
+ ] if ;
+
+: take-sequence* ( sequence-parser sequence -- )
+ take-sequence drop ;
+
+:: take-until-sequence ( sequence-parser sequence -- sequence'/f )
+ sequence-parser n>> :> saved
+ sequence length <growing-circular> :> growing
+ sequence-parser
+ [
+ current growing push-growing-circular
+ sequence growing sequence=
+ ] take-until :> found
+ growing sequence sequence= [
+ found dup length
+ growing length 1- - head
+ sequence-parser [ growing length - 1 + ] change-n drop
+ ! sequence-parser advance drop
+ ] [
+ saved sequence-parser (>>n)
+ f
+ ] if ;
+
+:: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
+ sequence-parser sequence take-until-sequence :> out
+ out [
+ sequence-parser [ sequence length + ] change-n drop
+ ] when out ;
+
+: skip-whitespace ( sequence-parser -- sequence-parser )
+ [ [ current blank? not ] take-until drop ] keep ;
+
+: take-rest-slice ( sequence-parser -- sequence/f )
+ [ sequence>> ] [ n>> ] bi
+ 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
+
+: take-rest ( sequence-parser -- sequence )
+ [ take-rest-slice ] [ sequence>> like ] bi ;
+
+: take-until-object ( sequence-parser obj -- sequence )
+ '[ current _ = ] take-until ;
+
+: parse-sequence ( sequence quot -- )
+ [ <sequence-parser> ] dip call ; inline
+
+:: take-quoted-string ( sequence-parser escape-char quote-char -- string )
+ sequence-parser n>> :> start-n
+ sequence-parser advance
+ [
+ {
+ [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
+ [ current quote-char = not ]
+ } 1||
+ ] take-while :> string
+ sequence-parser current quote-char = [
+ sequence-parser advance* string
+ ] [
+ start-n sequence-parser (>>n) f
+ ] if ;
+
+: (take-token) ( sequence-parser -- string )
+ skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
+
+:: take-token* ( sequence-parser escape-char quote-char -- string/f )
+ sequence-parser skip-whitespace
+ dup current {
+ { quote-char [ escape-char quote-char take-quoted-string ] }
+ { f [ drop f ] }
+ [ drop (take-token) ]
+ } case ;
+
+: take-token ( sequence-parser -- string/f )
+ CHAR: \ CHAR: " take-token* ;
+
+: take-integer ( sequence-parser -- n/f )
+ [ current digit? ] take-while ;
+
+:: take-n ( sequence-parser n -- seq/f )
+ n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
+ f
+ ] [
+ sequence-parser n>> dup n + sequence-parser sequence>> subseq
+ sequence-parser [ n + ] change-n drop
+ ] if ;
+
+: take-c-comment ( sequence-parser -- seq/f )
+ [
+ dup "/*" take-sequence [
+ "*/" take-until-sequence*
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+: take-c++-comment ( sequence-parser -- seq/f )
+ [
+ dup "//" take-sequence [
+ [
+ [
+ { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
+ ] take-until
+ ] [
+ advance drop
+ ] bi
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+: c-identifier-begin? ( ch -- ? )
+ CHAR: a CHAR: z [a,b]
+ CHAR: A CHAR: Z [a,b]
+ { CHAR: _ } 3append member? ;
+
+: c-identifier-ch? ( ch -- ? )
+ CHAR: a CHAR: z [a,b]
+ CHAR: A CHAR: Z [a,b]
+ CHAR: 0 CHAR: 9 [a,b]
+ { CHAR: _ } 4 nappend member? ;
+
+: take-c-identifier ( state-parser -- string/f )
+ [
+ dup current c-identifier-begin? [
+ [ current c-identifier-ch? ] take-while
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+<< "length" [ length ] define-sorting >>
+
+: sort-tokens ( seq -- seq' )
+ { length>=< <=> } sort-by ;
+
+: take-first-matching ( state-parser seq -- seq )
+ swap
+ '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
+
+
+: take-longest ( state-parser seq -- seq )
+ sort-tokens take-first-matching ;
+
+: take-c-integer ( state-parser -- string/f )
+ [
+ dup take-integer [
+ swap
+ { "ull" "uLL" "Ull" "ULL" "ll" "LL" "l" "L" "u" "U" }
+ take-longest [ append ] when*
+ ] [
+ drop f
+ ] if*
+ ] with-sequence-parser ;
+
+: write-full ( sequence-parser -- ) sequence>> write ;
+: write-rest ( sequence-parser -- ) take-rest write ;
: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
+
+: slurp-deque-when ( deque quot1 quot2: ( value -- ) -- )
+ pick deque-empty? [ 3drop ] [
+ [ [ pop-front dup ] 2dip slip [ t ] compose [ drop f ] if ]
+ [ roll [ slurp-deque-when ] [ 3drop ] if ] 3bi
+ ] if ; inline recursive
ifdef NO_UI
X11_UI_LIBS =
else
- X11_UI_LIBS = -lpango-1.0 -lpangocairo-1.0 -lcairo -lglib-2.0 -lgobject-2.0 -lGL -lGLU -lX11
+ X11_UI_LIBS = -lpango-1.0 -lpangocairo-1.0 -lcairo -lglib-2.0 -lgobject-2.0 -lGL -lX11
endif
# CFLAGS += -fPIC
}
F_HEADER h;
- fread(&h,sizeof(F_HEADER),1,file);
+ if(fread(&h,sizeof(F_HEADER),1,file) != 1)
+ fatal_error("Cannot read image header",0);
if(h.magic != IMAGE_MAGIC)
fatal_error("Bad image: magic number check failed",h.magic);
h.userenv[i] = userenv[i];
}
- fwrite(&h,sizeof(F_HEADER),1,file);
+ bool ok = true;
- if(fwrite((void*)tenured->start,h.data_size,1,file) != 1)
- {
- print_string("Save data heap failed: "); print_string(strerror(errno)); nl();
- return false;
- }
-
- if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1)
- {
- print_string("Save code heap failed: "); print_string(strerror(errno)); nl();
- return false;
- }
+ if(fwrite(&h,sizeof(F_HEADER),1,file) != 1) ok = false;
+ if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) ok = false;
+ if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1) ok = false;
+ if(fclose(file)) ok = false;
- if(fclose(file))
+ if(!ok)
{
- print_string("Failed to close image file: "); print_string(strerror(errno)); nl();
- return false;
+ print_string("save-image failed: "); print_string(strerror(errno)); nl();
}
- return true;
+ return ok;
}
void primitive_save_image(void)
projects / factor.git / commitdiff