classes: use check-instance in a few places, to remove duplication.

master
John Benediktsson 2020-01-15 10:34:47 -08:00
parent cd75a7eb4e
commit 77cd3aaede
22 changed files with 90 additions and 180 deletions

View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.data alien.syntax arrays USING: accessors alien.c-types alien.data alien.syntax arrays
assocs cache colors combinators core-foundation assocs cache classes colors combinators core-foundation
core-foundation.attributed-strings core-foundation.strings core-foundation.attributed-strings core-foundation.strings
core-graphics core-graphics.types core-text.fonts destructors core-graphics core-graphics.types core-text.fonts destructors
fonts init kernel locals make math math.functions math.order fonts init kernel locals make math math.functions math.order
@ -34,8 +34,6 @@ FUNCTION: CGRect CTLineGetImageBounds ( CTLineRef line, CGContextRef context )
SYMBOL: retina? SYMBOL: retina?
ERROR: not-a-string object ;
MEMO: make-attributes ( open-font color -- hashtable ) MEMO: make-attributes ( open-font color -- hashtable )
[ [
kCTForegroundColorAttributeName ,, kCTForegroundColorAttributeName ,,
@ -46,7 +44,7 @@ MEMO: make-attributes ( open-font color -- hashtable )
[ [
[ [
dup selection? [ string>> ] when dup selection? [ string>> ] when
dup string? [ not-a-string ] unless string check-instance
] 2dip ] 2dip
make-attributes <CFAttributedString> &CFRelease make-attributes <CFAttributedString> &CFRelease
CTLineCreateWithAttributedString CTLineCreateWithAttributedString

View File

@ -215,9 +215,6 @@ M: inconsistent-next-method summary
M: check-method-error summary M: check-method-error summary
drop "Invalid parameters for create-method" ; drop "Invalid parameters for create-method" ;
M: not-a-tuple summary
drop "Not a tuple" ;
M: bad-superclass summary M: bad-superclass summary
drop "Tuple classes can only inherit from non-final tuple classes" ; drop "Tuple classes can only inherit from non-final tuple classes" ;
@ -372,8 +369,6 @@ M: bad-escape error.
M: bad-literal-tuple summary drop "Bad literal tuple" ; M: bad-literal-tuple summary drop "Bad literal tuple" ;
M: not-a-mixin-class summary drop "Not a mixin class" ;
M: not-found-in-roots summary M: not-found-in-roots summary
path>> "Cannot resolve vocab: " prepend ; path>> "Cannot resolve vocab: " prepend ;

View File

@ -1,10 +1,10 @@
! Copyright (C) 2007, 2008 Daniel Ehrenberg ! Copyright (C) 2007, 2008 Daniel Ehrenberg
! Portions copyright (C) 2009, 2010 Slava Pestov, Joe Groff ! Portions copyright (C) 2009, 2010 Slava Pestov, Joe Groff
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes.tuple definitions effects generic USING: accessors arrays assocs classes classes.tuple
generic.standard hashtables kernel lexer math parser compiler.units definitions effects fry generic generic.standard
generic.parser sequences sets slots words words.symbol fry hashtables kernel lexer make math parser sequences sets slots
compiler.units make ; words words.symbol ;
IN: delegate IN: delegate
ERROR: broadcast-words-must-have-no-outputs group ; ERROR: broadcast-words-must-have-no-outputs group ;
@ -159,11 +159,8 @@ M: consultation forget*
: show-words ( wordlist' -- wordlist ) : show-words ( wordlist' -- wordlist )
[ dup second zero? [ first ] when ] map ; [ dup second zero? [ first ] when ] map ;
ERROR: not-a-generic word ;
: check-generic ( generic -- ) : check-generic ( generic -- )
dup array? [ first ] when dup array? [ first ] when generic check-instance drop ;
dup generic? [ drop ] [ not-a-generic ] if ;
PRIVATE> PRIVATE>

View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Daniel Ehrenberg. ! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs binary-search grouping kernel USING: accessors arrays assocs binary-search classes grouping
locals make math math.order sequences sequences.private sorting ; kernel locals make math math.order sequences sequences.private
sorting ;
IN: interval-maps IN: interval-maps
! Intervals are triples of { start end value } ! Intervals are triples of { start end value }
@ -28,15 +29,10 @@ TUPLE: interval-map { array array read-only } ;
: >intervals ( specification -- intervals ) : >intervals ( specification -- intervals )
[ suffix ] { } assoc>map concat 3 group ; [ suffix ] { } assoc>map concat 3 group ;
ERROR: not-an-interval-map obj ;
: check-interval-map ( map -- map )
dup interval-map? [ not-an-interval-map ] unless ; inline
PRIVATE> PRIVATE>
: interval-at* ( key map -- value ? ) : interval-at* ( key map -- value ? )
check-interval-map interval-map check-instance
[ drop ] [ find-interval ] 2bi [ drop ] [ find-interval ] 2bi
[ nip ] [ interval-contains? ] 2bi [ nip ] [ interval-contains? ] 2bi
[ third-unsafe t ] [ drop f f ] if ; inline [ third-unsafe t ] [ drop f f ] if ; inline
@ -46,7 +42,7 @@ PRIVATE>
: interval-key? ( key map -- ? ) interval-at* nip ; inline : interval-key? ( key map -- ? ) interval-at* nip ; inline
: interval-values ( map -- values ) : interval-values ( map -- values )
check-interval-map array>> [ third-unsafe ] map ; interval-map check-instance array>> [ third-unsafe ] map ;
: <interval-map> ( specification -- map ) : <interval-map> ( specification -- map )
all-intervals [ first-unsafe second-unsafe ] sort-with all-intervals [ first-unsafe second-unsafe ] sort-with

View File

@ -1,8 +1,9 @@
! Copyright (C) 2009 Daniel Ehrenberg. ! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types arrays assocs binary-search USING: accessors alien.c-types arrays assocs binary-search
combinators fry grouping kernel locals make math math.order classes combinators fry grouping kernel locals make math
sequences sequences.private sorting specialized-arrays ; math.order sequences sequences.private sorting
specialized-arrays ;
SPECIALIZED-ARRAY: uint SPECIALIZED-ARRAY: uint
IN: interval-sets IN: interval-sets
! Sets of positive integers ! Sets of positive integers
@ -10,17 +11,8 @@ IN: interval-sets
! Intervals are a pair of { start end } ! Intervals are a pair of { start end }
TUPLE: interval-set { array uint-array read-only } ; TUPLE: interval-set { array uint-array read-only } ;
<PRIVATE
ERROR: not-an-interval-set obj ;
: check-interval-set ( map -- map )
dup interval-set? [ not-an-interval-set ] unless ; inline
PRIVATE>
: in? ( key set -- ? ) : in? ( key set -- ? )
check-interval-set array>> interval-set check-instance array>>
dupd [ <=> ] with search swap [ dupd [ <=> ] with search swap [
even? [ >= ] [ 1 - <= ] if even? [ >= ] [ 1 - <= ] if
] [ 2drop f ] if* ; ] [ 2drop f ] if* ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.data alien.syntax USING: accessors alien.c-types alien.data alien.syntax classes
classes.struct combinators destructors destructors.private fry classes.struct combinators destructors destructors.private fry
io.backend io.backend.unix.multiplexers io.buffers io.files io.backend io.backend.unix.multiplexers io.buffers io.files
io.ports io.timeouts kernel kernel.private libc locals make math io.ports io.timeouts kernel kernel.private libc locals make math
@ -83,13 +83,8 @@ M: unix wait-for-fd ( handle event -- )
! Some general stuff ! Some general stuff
ERROR: not-a-buffered-port port ;
: check-buffered-port ( port -- port )
dup buffered-port? [ not-a-buffered-port ] unless ; inline
M: fd refill M: fd refill
[ check-buffered-port buffer>> ] [ fd>> ] bi* [ buffered-port check-instance buffer>> ] [ fd>> ] bi*
over [ buffer-end ] [ buffer-capacity ] bi read over [ buffer-end ] [ buffer-capacity ] bi read
{ fixnum } declare dup 0 >= [ { fixnum } declare dup 0 >= [
swap buffer+ f swap buffer+ f
@ -108,7 +103,7 @@ M: unix (wait-to-read) ( port -- )
! Writers ! Writers
M: fd drain M: fd drain
[ check-buffered-port buffer>> ] [ fd>> ] bi* [ buffered-port check-instance buffer>> ] [ fd>> ] bi*
over [ buffer@ ] [ buffer-length ] bi write over [ buffer@ ] [ buffer-length ] bi write
{ fixnum } declare dup 0 >= [ { fixnum } declare dup 0 >= [
over buffer-consume over buffer-consume

View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2010 Slava Pestov, Doug Coleman ! Copyright (C) 2005, 2010 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien combinators destructors hints io USING: accessors alien classes combinators destructors hints io
io.backend io.buffers io.encodings io.files io.timeouts kernel io.backend io.buffers io.encodings io.files io.timeouts kernel
kernel.private libc locals math math.order math.private kernel.private libc locals math math.order math.private
namespaces sequences strings system ; namespaces sequences strings system ;
@ -42,11 +42,6 @@ M: input-port stream-read1
check-disposed check-disposed
dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; inline dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; inline
ERROR: not-a-c-ptr object ;
: check-c-ptr ( c-ptr -- c-ptr )
dup c-ptr? [ not-a-c-ptr ] unless ; inline
<PRIVATE <PRIVATE
: read-step ( count port -- count ptr/f ) : read-step ( count port -- count ptr/f )
@ -73,11 +68,11 @@ ERROR: not-a-c-ptr object ;
PRIVATE> PRIVATE>
M: input-port stream-read-partial-unsafe M: input-port stream-read-partial-unsafe
[ check-c-ptr swap ] dip prepare-read read-step [ c-ptr check-instance swap ] dip prepare-read read-step
[ swap [ memcpy ] keep ] [ 2drop 0 ] if* ; [ swap [ memcpy ] keep ] [ 2drop 0 ] if* ;
M: input-port stream-read-unsafe M: input-port stream-read-unsafe
[ check-c-ptr swap ] dip prepare-read 0 read-loop ; [ c-ptr check-instance swap ] dip prepare-read 0 read-loop ;
<PRIVATE <PRIVATE
@ -158,7 +153,7 @@ PRIVATE>
M: output-port stream-write M: output-port stream-write
check-disposed [ check-disposed [
binary-object binary-object
[ check-c-ptr ] [ integer>fixnum-strict ] bi* [ c-ptr check-instance ] [ integer>fixnum-strict ] bi*
] [ port-write ] bi* ; ] [ port-write ] bi* ;
HOOK: tell-handle os ( handle -- n ) HOOK: tell-handle os ( handle -- n )

View File

@ -33,7 +33,7 @@ TUPLE-ARRAY: broken
! Can't define a tuple array for a non-tuple class ! Can't define a tuple array for a non-tuple class
[ "IN: tuple-arrays.tests USING: tuple-arrays words ; TUPLE-ARRAY: word" eval( -- ) ] [ "IN: tuple-arrays.tests USING: tuple-arrays words ; TUPLE-ARRAY: word" eval( -- ) ]
[ error>> not-a-tuple? ] [ error>> not-an-instance? ]
must-fail-with must-fail-with
! Can't define a tuple array for a non-final class ! Can't define a tuple array for a non-final class

View File

@ -26,11 +26,9 @@ MACRO: write-tuple ( class -- quot )
bi '[ _ dip @ ] ; bi '[ _ dip @ ] ;
: check-final ( class -- ) : check-final ( class -- )
{ tuple-class check-instance
{ [ dup tuple-class? not ] [ not-a-tuple ] } final-class check-instance
{ [ dup final-class? not ] [ not-final ] } drop ;
[ drop ]
} cond ;
PRIVATE> PRIVATE>

View File

@ -1,9 +1,10 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays colors.constants combinators fonts fry USING: accessors arrays classes colors.constants combinators
kernel make math.functions models namespaces sequences splitting fonts fry kernel make math.functions models namespaces sequences
strings ui.baseline-alignment ui.gadgets ui.gadgets.tracks splitting strings ui.baseline-alignment ui.gadgets
ui.pens.solid ui.render ui.text ui.theme.images ; ui.gadgets.tracks ui.pens.solid ui.render ui.text
ui.theme.images ;
IN: ui.gadgets.labels IN: ui.gadgets.labels
! A label gadget draws a string. ! A label gadget draws a string.
@ -23,15 +24,11 @@ PRIVATE>
: ?string-lines ( string -- string/array ) : ?string-lines ( string -- string/array )
CHAR: \n over member-eq? [ string-lines ] when ; CHAR: \n over member-eq? [ string-lines ] when ;
ERROR: not-a-string object ;
M: label string<< ( string label -- ) M: label string<< ( string label -- )
[ [
{ dup string-array? [
{ [ dup string-array? ] [ ] } string check-instance ?string-lines
{ [ dup string? ] [ ?string-lines ] } ] unless
[ not-a-string ]
} cond
] dip [ text<< ] [ relayout ] bi ; inline ] dip [ text<< ] [ relayout ] bi ; inline
: label-theme ( gadget -- gadget ) : label-theme ( gadget -- gadget )

View File

@ -13,21 +13,10 @@ TUPLE: anonymous-union { members read-only } ;
INSTANCE: anonymous-union classoid INSTANCE: anonymous-union classoid
ERROR: not-classoids sequence ;
: check-classoids ( members -- members )
dup [ classoid? ] all?
[ [ classoid? ] reject not-classoids ] unless ;
ERROR: not-a-classoid object ;
: check-classoid ( object -- object )
dup classoid? [ not-a-classoid ] unless ;
: <anonymous-union> ( members -- classoid ) : <anonymous-union> ( members -- classoid )
check-classoids [ classoid check-instance ] map [ null eq? ] reject
[ null eq? ] reject members members dup length 1 =
dup length 1 = [ first ] [ sort-classes f like anonymous-union boa ] if ; [ first ] [ sort-classes f like anonymous-union boa ] if ;
M: anonymous-union rank-class drop 6 ; M: anonymous-union rank-class drop 6 ;
@ -36,7 +25,7 @@ TUPLE: anonymous-intersection { participants read-only } ;
INSTANCE: anonymous-intersection classoid INSTANCE: anonymous-intersection classoid
: <anonymous-intersection> ( participants -- classoid ) : <anonymous-intersection> ( participants -- classoid )
check-classoids [ classoid check-instance ] map
members dup length 1 = members dup length 1 =
[ first ] [ sort-classes f like anonymous-intersection boa ] if ; [ first ] [ sort-classes f like anonymous-intersection boa ] if ;
@ -47,7 +36,7 @@ TUPLE: anonymous-complement { class read-only } ;
INSTANCE: anonymous-complement classoid INSTANCE: anonymous-complement classoid
: <anonymous-complement> ( object -- classoid ) : <anonymous-complement> ( object -- classoid )
check-classoid anonymous-complement boa ; classoid check-instance anonymous-complement boa ;
M: anonymous-complement rank-class drop 3 ; M: anonymous-complement rank-class drop 3 ;

View File

@ -9,11 +9,6 @@ SYMBOL: builtins
PREDICATE: builtin-class < class PREDICATE: builtin-class < class
"metaclass" word-prop builtin-class eq? ; "metaclass" word-prop builtin-class eq? ;
ERROR: not-a-builtin object ;
: check-builtin ( class -- )
dup builtin-class? [ drop ] [ not-a-builtin ] if ;
: class>type ( class -- n ) "type" word-prop ; foldable : class>type ( class -- n ) "type" word-prop ; foldable
: type>class ( n -- class ) builtins get-global nth ; foldable : type>class ( n -- class ) builtins get-global nth ; foldable

View File

@ -63,4 +63,4 @@ M: f lol2 drop "lol22" ;
[ 3 lol2 ] [ no-method? ] must-fail-with [ 3 lol2 ] [ no-method? ] must-fail-with
[ "IN: classes-tests maybe{ 1 2 3 }" eval( -- ) ] [ "IN: classes-tests maybe{ 1 2 3 }" eval( -- ) ]
[ error>> not-classoids? ] must-fail-with [ error>> not-an-instance? ] must-fail-with

View File

@ -125,7 +125,7 @@ SYMBOL: a-symbol
[ [
\ a-symbol \ silly-mixin add-mixin-instance \ a-symbol \ silly-mixin add-mixin-instance
] with-compilation-unit ] with-compilation-unit
] [ not-a-class? ] must-fail-with ] [ not-an-instance? ] must-fail-with
SYMBOL: not-a-mixin SYMBOL: not-a-mixin
TUPLE: a-class ; TUPLE: a-class ;
@ -134,7 +134,7 @@ TUPLE: a-class ;
[ [
\ a-class \ not-a-mixin add-mixin-instance \ a-class \ not-a-mixin add-mixin-instance
] with-compilation-unit ] with-compilation-unit
] [ not-a-mixin-class? ] must-fail-with ] [ not-an-instance? ] must-fail-with
! Changing a mixin member's metaclass should not remove it from the mixin ! Changing a mixin member's metaclass should not remove it from the mixin
MIXIN: metaclass-change-mixin MIXIN: metaclass-change-mixin

View File

@ -61,13 +61,8 @@ M: mixin-class rank-class drop 8 ;
PRIVATE> PRIVATE>
ERROR: not-a-class object ;
ERROR: not-a-mixin-class object ;
: check-types ( class mixin -- class mixin ) : check-types ( class mixin -- class mixin )
[ dup class? [ not-a-class ] unless ] [ class check-instance ] [ mixin-class check-instance ] bi* ;
[ dup mixin-class? [ not-a-mixin-class ] unless ] bi* ;
: add-mixin-instance ( class mixin -- ) : add-mixin-instance ( class mixin -- )
check-types [ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ; check-types [ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ;

View File

@ -390,11 +390,6 @@ HELP: define-tuple-slots
{ $description "Defines slot accessor and mutator words for the tuple." } { $description "Defines slot accessor and mutator words for the tuple." }
$low-level-note ; $low-level-note ;
HELP: check-tuple
{ $values { "class" class } }
{ $description "Throws a " { $link check-tuple } " error if " { $snippet "word" } " is not a tuple class word." }
{ $error-description "Thrown if " { $link POSTPONE: C: } " is called with a word which does not name a tuple class." } ;
HELP: define-tuple-class HELP: define-tuple-class
{ $values { "class" word } { "superclass" class } { "slots" { $sequence string } } } { $values { "class" word } { "superclass" class } { "slots" { $sequence string } } }
{ $description "Defines a tuple class inheriting from " { $snippet "superclass" } " with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." } { $description "Defines a tuple class inheriting from " { $snippet "superclass" } " with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." }

View File

@ -17,8 +17,6 @@ PREDICATE: tuple-class < class
ERROR: too-many-slots class slots got max ; ERROR: too-many-slots class slots got max ;
ERROR: not-a-tuple object ;
: all-slots ( class -- slots ) : all-slots ( class -- slots )
superclasses-of [ "slots" word-prop ] map concat ; superclasses-of [ "slots" word-prop ] map concat ;
@ -59,14 +57,12 @@ M: tuple class-of layout-of 2 slot { word } declare ; inline
layout-of 3 slot { fixnum } declare ; inline layout-of 3 slot { fixnum } declare ; inline
: layout-up-to-date? ( object -- ? ) : layout-up-to-date? ( object -- ? )
dup tuple? dup tuple? [
[ [ layout-of ] [ class-of tuple-layout ] bi eq? ] [ drop t ] if ; [ layout-of ] [ class-of tuple-layout ] bi eq?
] [ drop t ] if ;
: check-tuple ( object -- tuple )
dup tuple? [ not-a-tuple ] unless ; inline
: prepare-tuple-slots ( tuple -- n tuple ) : prepare-tuple-slots ( tuple -- n tuple )
check-tuple [ tuple-size <iota> ] keep ; tuple check-instance [ tuple-size <iota> ] keep ;
: copy-tuple-slots ( n tuple -- array ) : copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ; [ array-nth ] curry map ;
@ -323,13 +319,9 @@ M: tuple-class (define-tuple-class)
: boa-effect ( class -- effect ) : boa-effect ( class -- effect )
[ all-slots [ name>> ] map ] [ name>> 1array ] bi <effect> ; [ all-slots [ name>> ] map ] [ name>> 1array ] bi <effect> ;
ERROR: not-a-tuple-class object ;
: check-tuple-class ( class -- class )
dup tuple-class? [ not-a-tuple-class ] unless ; inline
: define-boa-word ( word class -- ) : define-boa-word ( word class -- )
check-tuple-class [ [ boa ] curry ] [ boa-effect ] bi tuple-class check-instance
[ [ boa ] curry ] [ boa-effect ] bi
define-inline ; define-inline ;
: forget-slot-accessors ( class slots -- ) : forget-slot-accessors ( class slots -- )

View File

@ -1,8 +1,8 @@
! Copyright (C) 2009 Daniel Ehrenberg ! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays combinators destructors growable USING: accessors byte-arrays classes combinators destructors
io io.private io.streams.plain kernel math math.order sequences growable io io.private io.streams.plain kernel math math.order
sequences.private strings ; sequences sequences.private strings ;
IN: io.streams.sequence IN: io.streams.sequence
! Readers ! Readers
@ -29,21 +29,13 @@ SLOT: i
[ [ dup pick + ] change-i underlying>> ] bi [ [ dup pick + ] change-i underlying>> ] bi
] dip [ <sequence-copy> (copy) drop ] 3curry keep ; inline ] dip [ <sequence-copy> (copy) drop ] 3curry keep ; inline
ERROR: not-a-byte-array obj ;
: check-byte-array ( buf stream offset -- buf stream offset )
pick byte-array? [ pick not-a-byte-array ] unless ; inline
ERROR: not-a-string obj ;
: check-string ( buf stream offset -- buf stream offset )
pick string? [ pick not-a-string ] unless ; inline
: (sequence-read-unsafe) ( n buf stream -- count ) : (sequence-read-unsafe) ( n buf stream -- count )
[ integer>fixnum ] [ integer>fixnum ]
[ dup slice? [ [ seq>> ] [ from>> ] bi ] [ 0 ] if ] [ dup slice? [ [ seq>> ] [ from>> ] bi ] [ 0 ] if ]
[ [
tuck stream-element-type +byte+ eq? tuck stream-element-type +byte+ eq?
[ check-byte-array sequence-copy-unsafe ] [ [ byte-array check-instance ] 2dip sequence-copy-unsafe ]
[ check-string sequence-copy-unsafe ] if [ [ string check-instance ] 2dip sequence-copy-unsafe ] if
] tri* ; inline ] tri* ; inline
PRIVATE> PRIVATE>

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff. ! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators continuations io kernel USING: accessors arrays classes combinators continuations io
kernel.private math math.parser namespaces sequences kernel kernel.private math math.parser namespaces sequences
sequences.private source-files.errors strings vectors ; sequences.private source-files.errors strings vectors ;
IN: lexer IN: lexer
@ -15,13 +15,8 @@ TUPLE: lexer
TUPLE: lexer-parsing-word word line line-text column ; TUPLE: lexer-parsing-word word line line-text column ;
ERROR: not-a-lexer object ;
: check-lexer ( lexer -- lexer )
dup lexer? [ not-a-lexer ] unless ; inline
: next-line ( lexer -- ) : next-line ( lexer -- )
check-lexer lexer check-instance
dup [ line>> ] [ text>> ] bi ?nth "" or dup [ line>> ] [ text>> ] bi ?nth "" or
[ >>line-text ] [ length >>line-length ] bi [ >>line-text ] [ length >>line-length ] bi
[ 1 + ] change-line [ 1 + ] change-line
@ -29,13 +24,13 @@ ERROR: not-a-lexer object ;
drop ; drop ;
: push-parsing-word ( word -- ) : push-parsing-word ( word -- )
lexer get check-lexer [ lexer get lexer check-instance [
[ line>> ] [ line-text>> ] [ column>> ] tri [ line>> ] [ line-text>> ] [ column>> ] tri
lexer-parsing-word boa lexer-parsing-word boa
] [ parsing-words>> push ] bi ; ] [ parsing-words>> push ] bi ;
: pop-parsing-word ( -- ) : pop-parsing-word ( -- )
lexer get check-lexer parsing-words>> pop* ; lexer get lexer check-instance parsing-words>> pop* ;
: new-lexer ( text class -- lexer ) : new-lexer ( text class -- lexer )
new new
@ -58,7 +53,7 @@ ERROR: unexpected want got ;
] dip or ; inline ] dip or ; inline
: change-lexer-column ( ..a lexer quot: ( ..a col line -- ..b newcol ) -- ..b ) : change-lexer-column ( ..a lexer quot: ( ..a col line -- ..b newcol ) -- ..b )
[ check-lexer [ column>> ] [ line-text>> ] bi ] prepose [ lexer check-instance [ column>> ] [ line-text>> ] bi ] prepose
keep column<< ; inline keep column<< ; inline
GENERIC: skip-blank ( lexer -- ) GENERIC: skip-blank ( lexer -- )
@ -89,13 +84,13 @@ M: lexer skip-word
] change-lexer-column ; ] change-lexer-column ;
: still-parsing? ( lexer -- ? ) : still-parsing? ( lexer -- ? )
check-lexer [ line>> ] [ text>> length ] bi <= ; lexer check-instance [ line>> ] [ text>> length ] bi <= ;
: still-parsing-line? ( lexer -- ? ) : still-parsing-line? ( lexer -- ? )
check-lexer [ column>> ] [ line-length>> ] bi < ; lexer check-instance [ column>> ] [ line-length>> ] bi < ;
: (parse-raw) ( lexer -- str ) : (parse-raw) ( lexer -- str )
check-lexer { lexer check-instance {
[ column>> ] [ column>> ]
[ skip-word ] [ skip-word ]
[ column>> ] [ column>> ]
@ -159,6 +154,8 @@ M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ;
} cleave } cleave
] dip lexer-error boa ; ] dip lexer-error boa ;
<PRIVATE
: simple-lexer-dump ( error -- ) : simple-lexer-dump ( error -- )
[ line>> number>string ": " append ] [ line>> number>string ": " append ]
[ line-text>> ] [ line-text>> ]
@ -166,24 +163,22 @@ M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ;
pick length + CHAR: \s <string> pick length + CHAR: \s <string>
[ write ] [ print ] [ write "^" print ] tri* ; [ write ] [ print ] [ write "^" print ] tri* ;
: (parsing-word-lexer-dump) ( error parsing-word -- ) : parsing-word-lexer-dump ( error parsing-word -- error )
2dup [ line>> ] same? [ drop ] [
[ [
line>> number>string line>> number>string
over line>> number>string length over line>> number>string length
CHAR: \s pad-head CHAR: \s pad-head
": " append write ": " append write
] [ line-text>> print ] bi ] [ line-text>> print ] bi
simple-lexer-dump ; ] if ;
: parsing-word-lexer-dump ( error parsing-word -- ) PRIVATE>
2dup [ line>> ] same?
[ drop simple-lexer-dump ]
[ (parsing-word-lexer-dump) ] if ;
: lexer-dump ( error -- ) : lexer-dump ( error -- )
dup parsing-words>> dup parsing-words>> ?last [
[ simple-lexer-dump ] parsing-word-lexer-dump
[ last parsing-word-lexer-dump ] if-empty ; ] when* simple-lexer-dump ;
: with-lexer ( lexer quot -- newquot ) : with-lexer ( lexer quot -- newquot )
[ [ <lexer-error> rethrow ] recover ] curry [ [ <lexer-error> rethrow ] recover ] curry

View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2010 Slava Pestov. ! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays byte-vectors USING: accessors arrays byte-arrays byte-vectors
classes.algebra.private classes.builtin classes.error classes classes.algebra.private classes.builtin classes.error
classes.intersection classes.maybe classes.mixin classes.parser classes.intersection classes.maybe classes.mixin classes.parser
classes.predicate classes.singleton classes.tuple classes.tuple.parser classes.predicate classes.singleton classes.tuple classes.tuple.parser
classes.union combinators compiler.units definitions effects classes.union combinators compiler.units definitions effects
@ -128,7 +128,8 @@ IN: bootstrap.syntax
"BUILTIN:" [ "BUILTIN:" [
scan-word-name scan-word-name
current-vocab lookup-word current-vocab lookup-word
(parse-tuple-definition) 2drop check-builtin (parse-tuple-definition)
2drop builtin-class check-instance drop
] define-core-syntax ] define-core-syntax
"SYMBOL:" [ "SYMBOL:" [

View File

@ -29,10 +29,8 @@ ERROR: edges-in-same-face ;
[ dup opposite-edge>> assert-same-face ] [ dup opposite-edge>> assert-same-face ]
bi ; bi ;
ERROR: not-a-base-face face ;
: assert-base-face ( face -- ) : assert-base-face ( face -- )
dup base-face? [ drop ] [ not-a-base-face ] if ; base-face check-instance drop ;
ERROR: has-rings face ; ERROR: has-rings face ;

View File

@ -29,12 +29,7 @@ INSTANCE: missing immutable-sequence
v* [ odd? [ neg ] when ] map-index sum v* [ odd? [ neg ] when ] map-index sum
] if ; ] if ;
ERROR: not-a-square-matrix matrix ;
: check-square-matrix ( matrix -- matrix )
dup square-matrix? [ not-a-square-matrix ] unless ; inline
PRIVATE> PRIVATE>
: determinant ( matrix -- x ) : determinant ( matrix -- x )
check-square-matrix 0 swap laplace-expansion ; square-matrix check-instance 0 swap laplace-expansion ;