diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index b78bb020d0..ec5db31940 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -60,6 +60,7 @@ SYNTAX: IMPORT: scan [ ] import-objc-class ; "NSOpenGLPixelFormat" "NSOpenGLView" "NSOpenPanel" + "NSPanel" "NSPasteboard" "NSPropertyListSerialization" "NSResponder" diff --git a/basis/cocoa/windows/windows.factor b/basis/cocoa/windows/windows.factor index 4e0f768b96..ed2c2d51bd 100644 --- a/basis/cocoa/windows/windows.factor +++ b/basis/cocoa/windows/windows.factor @@ -4,36 +4,37 @@ USING: arrays kernel math cocoa cocoa.messages cocoa.classes sequences math.bitwise ; IN: cocoa.windows +! Window styles CONSTANT: NSBorderlessWindowMask 0 CONSTANT: NSTitledWindowMask 1 CONSTANT: NSClosableWindowMask 2 CONSTANT: NSMiniaturizableWindowMask 4 CONSTANT: NSResizableWindowMask 8 +! Additional panel-only styles +CONSTANT: NSUtilityWindowMask 16 +CONSTANT: NSDocModalWindowMask 64 +CONSTANT: NSNonactivatingPanelMask 128 +CONSTANT: NSHUDWindowMask HEX: 1000 + CONSTANT: NSBackingStoreRetained 0 CONSTANT: NSBackingStoreNonretained 1 CONSTANT: NSBackingStoreBuffered 2 -: standard-window-type ( -- n ) - { - NSTitledWindowMask - NSClosableWindowMask - NSMiniaturizableWindowMask - NSResizableWindowMask - } flags ; inline - -: ( rect -- window ) - NSWindow -> alloc swap - standard-window-type NSBackingStoreBuffered 1 +: ( rect style class -- window ) + [ -> alloc ] curry 2dip NSBackingStoreBuffered 1 -> initWithContentRect:styleMask:backing:defer: ; -: ( view rect -- window ) - [ swap -> setContentView: ] keep +: class-for-style ( style -- NSWindow/NSPanel ) + HEX: 1ff0 bitand zero? NSWindow NSPanel ? ; + +: ( view rect style -- window ) + dup class-for-style [ swap -> setContentView: ] keep dup dup -> contentView -> setInitialFirstResponder: dup 1 -> setAcceptsMouseMovedEvents: dup 0 -> setReleasedWhenClosed: ; : window-content-rect ( window -- rect ) - [ NSWindow ] dip + dup -> class swap [ -> frame ] [ -> styleMask ] bi -> contentRectForFrameRect:styleMask: ; diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index 2688f7f8f1..4fb01608f0 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -328,10 +328,3 @@ C: ro-box TUPLE: empty-tuple ; [ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test - -! Make sure that initial-quot: doesn't inhibit unboxing -TUPLE: initial-quot-tuple { x read-only initial-quot: [ 0 ] } ; - -[ 1 ] [ - [ initial-quot-tuple new x>> ] count-unboxed-allocations -] unit-test \ No newline at end of file diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index e5eb50e82f..b7dab0d6af 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -58,8 +58,6 @@ M: object (fake-quotations>) , ; [ parse-definition* ] dip parsed ; -: DEFINE* ( accum -- accum ) \ define-declared* parsed ; - SYNTAX: `TUPLE: scan-param parsed scan { diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index becfb6826d..ae546080a1 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -51,9 +51,6 @@ M: heap heap-size ( heap -- n ) : data-nth ( n heap -- entry ) data>> nth-unsafe ; inline -: up-value ( n heap -- entry ) - [ up ] dip data-nth ; inline - : left-value ( n heap -- entry ) [ left ] dip data-nth ; inline @@ -75,9 +72,6 @@ M: heap heap-size ( heap -- n ) : data-pop* ( heap -- ) data>> pop* ; inline -: data-peek ( heap -- entry ) - data>> last ; inline - : data-first ( heap -- entry ) data>> first ; inline @@ -130,9 +124,6 @@ DEFER: up-heap 2dup right-bounds-check? [ drop left ] [ (child) ] if ; -: swap-down ( m heap -- ) - [ child ] 2keep data-exchange ; - DEFER: down-heap : (down-heap) ( m heap -- ) diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 4ead01159a..c1dd591013 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -55,8 +55,6 @@ PRIVATE> ] check-something ] [ drop ] if ; -: check-words ( words -- ) [ check-word ] each ; - : check-article ( article -- ) [ with-interactive-vocabs ] vocabs-quot set >link dup '[ diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index de75165c7a..345b739b61 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -11,17 +11,18 @@ combinators.short-circuit ; IN: io.servers.connection TUPLE: threaded-server -{ name initial: "server" } -{ log-level initial: DEBUG } -secure insecure -{ secure-config initial-quot: [ ] } -{ sockets initial-quot: [ V{ } clone ] } +name +log-level +secure +insecure +secure-config +sockets max-connections semaphore -{ timeout initial-quot: [ 1 minutes ] } +timeout encoding -{ handler initial: [ "No handler quotation" throw ] } -{ ready initial-quot: [ ] } ; +handler +ready ; : local-server ( port -- addrspec ) "localhost" swap ; @@ -29,6 +30,13 @@ encoding : new-threaded-server ( encoding class -- threaded-server ) new + "server" >>name + DEBUG >>log-level + >>secure-config + V{ } clone >>sockets + 1 minutes >>timeout + [ "No handler quotation" throw ] >>handler + >>ready swap >>encoding ; : ( encoding -- threaded-server ) diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 72ca8b8cdb..7d79516a2c 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -25,6 +25,7 @@ IN: opengl { HEX: 0503 "Stack overflow" } { HEX: 0504 "Stack underflow" } { HEX: 0505 "Out of memory" } + { HEX: 0506 "Invalid framebuffer operation" } } at "Unknown error" or ; TUPLE: gl-error code string ; @@ -190,4 +191,4 @@ MACRO: set-draw-buffers ( buffers -- ) GL_PROJECTION glMatrixMode glLoadIdentity GL_MODELVIEW glMatrixMode - glLoadIdentity ; \ No newline at end of file + glLoadIdentity ; diff --git a/basis/opengl/shaders/shaders.factor b/basis/opengl/shaders/shaders.factor index 15fab1aae0..a946fd16f4 100755 --- a/basis/opengl/shaders/shaders.factor +++ b/basis/opengl/shaders/shaders.factor @@ -61,10 +61,21 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; ! Programs +: ( shaders frag-data-locations -- program ) + glCreateProgram + [ + [ swap [ glAttachShader ] with each ] + [ swap [ first2 swap glBindFragDataLocationEXT ] with each ] bi-curry bi* + ] + [ glLinkProgram ] + [ ] tri + gl-error ; + : ( shaders -- program ) - glCreateProgram swap - [ dupd glAttachShader ] each - [ glLinkProgram ] keep + glCreateProgram + [ swap [ glAttachShader ] with each ] + [ glLinkProgram ] + [ ] tri gl-error ; : (gl-program?) ( object -- ? ) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index d43e1736d1..2eabbd478b 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -135,9 +135,6 @@ TUPLE: multi-texture grid display-list loc disposed ; [ dup image-locs ] dip '[ [ _ v+ |dispose ] 2map ] 2map ; -: draw-textured-grid ( grid -- ) - [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ; - : grid-has-alpha? ( grid -- ? ) first first image>> has-alpha? ; diff --git a/basis/persistent/vectors/vectors-docs.factor b/basis/persistent/vectors/vectors-docs.factor index 4816877a35..aa817edf52 100644 --- a/basis/persistent/vectors/vectors-docs.factor +++ b/basis/persistent/vectors/vectors-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax kernel math sequences ; IN: persistent.vectors HELP: PV{ -{ $syntax "elements... }" } +{ $syntax "PV{ elements... }" } { $description "Parses a literal " { $link persistent-vector } "." } ; HELP: >persistent-vector diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index aa84ee43c5..7e78fcc8b8 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -109,10 +109,23 @@ M: cocoa-ui-backend (set-fullscreen) ( world ? -- ) M: cocoa-ui-backend (fullscreen?) ( world -- ? ) handle>> view>> -> isInFullScreenMode zero? not ; +CONSTANT: window-control>styleMask + H{ + { close-button $ NSClosableWindowMask } + { minimize-button $ NSMiniaturizableWindowMask } + { maximize-button 0 } + { resize-handles $ NSResizableWindowMask } + { small-title-bar $[ NSTitledWindowMask NSUtilityWindowMask bitor ] } + { normal-title-bar $ NSTitledWindowMask } + } + +: world>styleMask ( world -- n ) + window-controls>> [ window-control>styleMask at ] map 0 [ bitor ] reduce ; + M:: cocoa-ui-backend (open-window) ( world -- ) world [ [ dim>> ] dip ] with-world-pixel-format :> view - view world world>NSRect :> window + view world [ world>NSRect ] [ world>styleMask ] bi :> window view -> release world view register-window window world window-loc>> auto-position @@ -145,7 +158,7 @@ M: cocoa-ui-backend (ungrab-input) ( handle -- ) M: cocoa-ui-backend close-window ( gadget -- ) find-world [ handle>> [ - window>> f -> performClose: + window>> -> close ] when* ] when* ; diff --git a/basis/ui/baseline-alignment/baseline-alignment.factor b/basis/ui/baseline-alignment/baseline-alignment.factor index f7f7a757f5..6e2b58479b 100644 --- a/basis/ui/baseline-alignment/baseline-alignment.factor +++ b/basis/ui/baseline-alignment/baseline-alignment.factor @@ -36,9 +36,6 @@ TUPLE: gadget-metrics height ascent descent cap-height ; : max-descent ( seq -- n ) [ descent>> ] map ?supremum ; -: max-text-height ( seq -- y ) - [ ascent>> ] filter [ height>> ] map ?supremum ; - : max-graphics-height ( seq -- y ) [ ascent>> not ] filter [ height>> ] map ?supremum 0 or ; diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index 6a289ec1d6..0295012584 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -112,8 +112,7 @@ M: gadget gadget-text-separator orientation>> vertical = "\n" "" ? ; : gadget-seq-text ( seq gadget -- ) - gadget-text-separator swap - [ dup % ] [ gadget-text* ] interleave drop ; + gadget-text-separator '[ _ % ] [ gadget-text* ] interleave ; M: gadget gadget-text* [ children>> ] keep gadget-seq-text ; diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index eb741f13b6..2c5ed596ac 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -96,10 +96,6 @@ M: pane selected-children add-incremental ] [ next-line ] bi ; -: ?pane-nl ( pane -- ) - [ dup current>> children>> empty? [ pane-nl ] [ drop ] if ] - [ pane-nl ] bi ; - : smash-pane ( pane -- gadget ) [ pane-nl ] [ output>> smash-line ] bi ; : pane-write ( seq pane -- ) diff --git a/basis/ui/gadgets/sliders/sliders-docs.factor b/basis/ui/gadgets/sliders/sliders-docs.factor index 38f4b5ac15..570291a18f 100644 --- a/basis/ui/gadgets/sliders/sliders-docs.factor +++ b/basis/ui/gadgets/sliders/sliders-docs.factor @@ -5,10 +5,6 @@ IN: ui.gadgets.sliders HELP: elevator { $class-description "An elevator is the part of a " { $link slider } " between the up/down arrow buttons, where a " { $link thumb } " may be moved up and down." } ; -HELP: find-elevator -{ $values { "gadget" gadget } { "elevator/f" { $maybe elevator } } } -{ $description "Finds the first parent of " { $snippet "gadget" } " which is an " { $link elevator } ". Outputs " { $link f } " if the gadget is not contained in an " { $link elevator } "." } ; - HELP: slider { $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "." $nl diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 80829d7b66..d293fd7f8b 100644 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -23,8 +23,6 @@ TUPLE: slider < track elevator thumb saved line ; TUPLE: elevator < gadget direction ; -: find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ; - : find-slider ( gadget -- slider/f ) [ slider? ] find-parent ; CONSTANT: elevator-padding 4 diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index dfce3d3eee..82f3637b83 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -7,16 +7,34 @@ ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks ui.pixel-formats destructors literals strings ; IN: ui.gadgets.worlds +SYMBOLS: + close-button + minimize-button + maximize-button + resize-handles + small-title-bar + normal-title-bar ; + CONSTANT: default-world-pixel-format-attributes { windowed double-buffered T{ depth-bits { value 16 } } } +CONSTANT: default-world-window-controls + { + normal-title-bar + close-button + minimize-button + maximize-button + resize-handles + } + TUPLE: world < track active? focused? grab-input? layers title status status-owner text-handle handle images window-loc - pixel-format-attributes ; + pixel-format-attributes + window-controls ; TUPLE: world-attributes { world-class initial: world } @@ -24,7 +42,8 @@ TUPLE: world-attributes { title string initial: "Factor Window" } status gadgets - { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ; + { pixel-format-attributes initial: $ default-world-pixel-format-attributes } + { window-controls initial: $ default-world-window-controls } ; : ( -- world-attributes ) world-attributes new ; inline @@ -86,6 +105,7 @@ M: world request-focus-on ( child gadget -- ) [ title>> >>title ] [ status>> >>status ] [ pixel-format-attributes>> >>pixel-format-attributes ] + [ window-controls>> >>window-controls ] [ grab-input?>> >>grab-input? ] [ gadgets>> [ 1 track-add ] each ] } cleave ; diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index 1b1d9434f8..6d6b5cc0cf 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/basis/unicode/breaks/breaks.factor @@ -72,9 +72,6 @@ SYMBOL: table : connect ( class1 class2 -- ) 1 set-table ; : disconnect ( class1 class2 -- ) 0 set-table ; -: break-around ( classes1 classes2 -- ) - [ disconnect ] [ swap disconnect ] 2bi ; - : make-grapheme-table ( -- ) { CR } { LF } connect { Control CR LF } graphemes disconnect @@ -91,9 +88,6 @@ VALUE: grapheme-table : grapheme-break? ( class1 class2 -- ? ) grapheme-table nth nth not ; -: chars ( i str n -- str[i] str[i+n] ) - swap [ dupd + ] dip [ ?nth ] curry bi@ ; - PRIVATE> : first-grapheme ( str -- i ) diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 24538229c6..f5182a0210 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -80,7 +80,6 @@ IN: bootstrap.syntax ">>" "call-next-method" "initial:" - "initial-quot:" "read-only" "call(" "execute(" diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 350b594274..72457ff974 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -141,12 +141,4 @@ TUPLE: parsing-corner-case x ; "USE: classes.tuple.parser.tests T{ parsing-corner-case {" " x 3 }" } "\n" join eval( -- tuple ) -] [ error>> unexpected-eof? ] must-fail-with - - -[ ] [ - <" USE: sequences - IN: classes.tuple.tests - TUPLE: book { name initial-quot: [ "Lord of the " "Rings" append ] } ;"> - eval( -- ) -] unit-test +] [ error>> unexpected-eof? ] must-fail-with \ No newline at end of file diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 4b23578a29..191ec75544 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -729,50 +729,3 @@ DEFER: redefine-tuple-twice [ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test [ t ] [ \ redefine-tuple-twice symbol? ] unit-test - -TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } ; -SLOT: winner? - -[ t ] [ lucky-number new n>> integer? ] unit-test - -: compiled-lucky-number ( -- tuple ) lucky-number new ; - -[ t ] [ compiled-lucky-number n>> integer? ] unit-test - -! Reshaping initial-quot: -lucky-number new dup n>> 2array "luckiest-number" set - -[ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test - -[ ] [ "USING: accessors random ; IN: classes.tuple.tests TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } { winner? initial-quot: [ t ] } ;" eval( -- ) ] unit-test - -[ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test -[ t ] [ "luckiest-number" get first winner?>> ] unit-test - -! invalid-quot: together with type declaration -TUPLE: decl-initial-quot { x integer initial-quot: [ 1 ] } ; - -[ t ] [ decl-initial-quot new x>> integer? ] unit-test - -: compiled-decl-initial-quot ( -- tuple ) decl-initial-quot new ; - -[ t ] [ compiled-decl-initial-quot x>> integer? ] unit-test - -! invalid-quot: with read-only -TUPLE: read-only-initial-quot { x integer read-only initial-quot: [ 1 ] } ; - -[ t ] [ read-only-initial-quot new x>> integer? ] unit-test - -: compiled-read-only-initial-quot ( -- tuple ) read-only-initial-quot new ; - -[ t ] [ compiled-read-only-initial-quot x>> integer? ] unit-test - -! Specifying both initial: and initial-quot: should fail -2 [ - [ - "IN: classes.tuple.test TUPLE: redundant-decl { x initial: 0 initial-quot: [ 0 ] } ;" - eval( -- ) - ] - [ error>> duplicate-initial-values? ] - must-fail-with -] times diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 4ca57a59ed..7633f9b4c8 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -50,9 +50,6 @@ M: tuple class layout-of 2 slot { word } declare ; PRIVATE> -: initial-quots? ( class -- ? ) - all-slots [ initial-quot>> ] any? ; - : initial-values ( class -- slots ) all-slots [ initial>> ] map ; @@ -149,21 +146,12 @@ ERROR: bad-superclass class ; : define-boa-check ( class -- ) dup boa-check-quot "boa-check" set-word-prop ; -: tuple-initial-quots-quot ( class -- quot ) - all-slots [ initial-quot>> ] filter - [ - [ - [ initial-quot>> % \ over , ] [ offset>> , ] bi \ set-slot , - ] each - ] [ ] make f like ; - : tuple-prototype ( class -- prototype ) - [ initial-values ] [ over [ ] any? ] [ initial-quots? or ] tri + [ initial-values ] keep over [ ] any? [ slots>tuple ] [ 2drop f ] if ; : define-tuple-prototype ( class -- ) - dup [ tuple-prototype ] [ tuple-initial-quots-quot ] bi 2array - dup [ ] any? [ drop f ] unless "prototype" set-word-prop ; + dup tuple-prototype "prototype" set-word-prop ; : prepare-slots ( slots superclass -- slots' ) [ make-slots ] [ class-size 2 + ] bi* finalize-slots ; @@ -185,16 +173,10 @@ ERROR: bad-superclass class ; : define-tuple-layout ( class -- ) dup make-tuple-layout "layout" set-word-prop ; -: calculate-initial-value ( slot-spec -- value ) - dup initial>> [ ] [ - dup initial-quot>> - [ call( -- obj ) ] [ drop f ] ?if - ] ?if ; - : compute-slot-permutation ( new-slots old-slots -- triples ) [ [ [ name>> ] map ] bi@ [ index ] curry map ] [ drop [ class>> ] map ] - [ drop [ calculate-initial-value ] map ] + [ drop [ initial>> ] map ] 2tri 3array flip ; : update-slot ( old-values n class initial -- value ) @@ -358,11 +340,7 @@ M: tuple tuple-hashcode M: tuple hashcode* tuple-hashcode ; M: tuple-class new - dup "prototype" word-prop [ - first2 [ (clone) ] dip [ call( obj -- obj ) ] when* - ] [ - tuple-layout - ] ?if ; + dup "prototype" word-prop [ (clone) ] [ tuple-layout ] ?if ; M: tuple-class boa [ "boa-check" word-prop [ call ] when* ] diff --git a/core/generic/math/math-docs.factor b/core/generic/math/math-docs.factor index 7d7d6e725b..5953c5ad9b 100644 --- a/core/generic/math/math-docs.factor +++ b/core/generic/math/math-docs.factor @@ -40,6 +40,4 @@ $nl HELP: math-generic { $class-description "The class of generic words using " { $link math-combination } "." } ; -HELP: last/first -{ $values { "seq" sequence } { "pair" "a two-element array" } } -{ $description "Creates an array holding the first and last element of the sequence." } ; + diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index e88c0c02e4..e0e8b91a2c 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -15,8 +15,6 @@ PREDICATE: math-class < class HELP: skip { $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } } -{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ; +{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise). Tabulations used as separators instead of spaces will be flagged as an error." } ; HELP: change-lexer-column { $values { "lexer" lexer } { "quot" { $quotation "( col line -- newcol )" } } } diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index 60157033d7..99e6f05c6c 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -22,9 +22,17 @@ TUPLE: lexer text line line-text line-length column ; : ( text -- lexer ) lexer new-lexer ; +ERROR: unexpected want got ; + +PREDICATE: unexpected-tab < unexpected + got>> CHAR: \t = ; + +: forbid-tab ( c -- c ) + [ CHAR: \t eq? [ "[space]" "[tab]" unexpected ] when ] keep ; + : skip ( i seq ? -- n ) over length - [ [ swap CHAR: \s eq? xor ] curry find-from drop ] dip or ; + [ [ swap forbid-tab CHAR: \s eq? xor ] curry find-from drop ] dip or ; : change-lexer-column ( lexer quot -- ) [ [ column>> ] [ line-text>> ] bi ] prepose keep @@ -65,8 +73,6 @@ M: lexer skip-word ( lexer -- ) : scan ( -- str/f ) lexer get parse-token ; -ERROR: unexpected want got ; - PREDICATE: unexpected-eof < unexpected got>> not ; diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 85f9d56596..5e0d5597ca 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -286,3 +286,8 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ; [ f f ] [ { 1 2 3 4 5 6 7 8 } [ H{ { 11 "hi" } } at ] map-find ] unit-test + +USE: make + +[ { "a" 1 "b" 1 "c" } ] +[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test \ No newline at end of file diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index c58304de44..6eea872343 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -510,7 +510,7 @@ PRIVATE> : interleave ( seq between quot -- ) pick empty? [ 3drop ] [ [ [ drop first-unsafe ] dip call ] - [ [ rest-slice ] 2dip [ [ call ] bi@ ] 2curry each ] + [ [ rest-slice ] 2dip [ bi* ] 2curry each ] 3bi ] if ; inline diff --git a/core/slots/slots.factor b/core/slots/slots.factor index c8be08e79b..304ded0adb 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -6,7 +6,7 @@ classes classes.algebra slots.private combinators accessors words sequences.private assocs alien quotations hashtables ; IN: slots -TUPLE: slot-spec name offset class initial initial-quot read-only ; +TUPLE: slot-spec name offset class initial read-only ; PREDICATE: reader < word "reader" word-prop ; @@ -190,7 +190,6 @@ ERROR: bad-slot-attribute key ; dup empty? [ unclip { { initial: [ [ first >>initial ] [ rest ] bi ] } - { initial-quot: [ [ first >>initial-quot ] [ rest ] bi ] } { read-only [ [ t >>read-only ] dip ] } [ bad-slot-attribute ] } case @@ -198,14 +197,7 @@ ERROR: bad-slot-attribute key ; ERROR: bad-initial-value name ; -ERROR: duplicate-initial-values slot ; - -: check-duplicate-initial-values ( slot-spec -- slot-spec ) - dup [ initial>> ] [ initial-quot>> ] bi and - [ duplicate-initial-values ] when ; - : check-initial-value ( slot-spec -- slot-spec ) - check-duplicate-initial-values dup initial>> [ [ ] [ dup [ initial>> ] [ class>> ] bi instance? diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 8093b6345b..7b9a0d36ef 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -246,8 +246,6 @@ IN: bootstrap.syntax "initial:" "syntax" lookup define-symbol - "initial-quot:" "syntax" lookup define-symbol - "read-only" "syntax" lookup define-symbol "call(" [ \ call-effect parse-call( ] define-core-syntax