steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/core-text/core-text.factor
View File

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

5
basis/debugger/debugger.factor
View File

@ -215,9 +215,6 @@ M: inconsistent-next-method summary
M: check-method-error summary
drop "Invalid parameters for create-method" ;
M: not-a-tuple summary
drop "Not a tuple" ;
M: bad-superclass summary
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: not-a-mixin-class summary drop "Not a mixin class" ;
M: not-found-in-roots summary
path>> "Cannot resolve vocab: " prepend ;

13
basis/delegate/delegate.factor
View File

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

14
basis/interval-maps/interval-maps.factor
View File

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

16
basis/interval-sets/interval-sets.factor
View File

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

11
basis/io/backend/unix/unix.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! 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
io.backend io.backend.unix.multiplexers io.buffers io.files
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
ERROR: not-a-buffered-port port ;
: check-buffered-port ( port -- port )
dup buffered-port? [ not-a-buffered-port ] unless ; inline
M: fd refill
[ check-buffered-port buffer>> ] [ fd>> ] bi*
[ buffered-port check-instance buffer>> ] [ fd>> ] bi*
over [ buffer-end ] [ buffer-capacity ] bi read
{ fixnum } declare dup 0 >= [
swap buffer+ f
@ -108,7 +103,7 @@ M: unix (wait-to-read) ( port -- )
! Writers
M: fd drain
[ check-buffered-port buffer>> ] [ fd>> ] bi*
[ buffered-port check-instance buffer>> ] [ fd>> ] bi*
over [ buffer@ ] [ buffer-length ] bi write
{ fixnum } declare dup 0 >= [
over buffer-consume

13
basis/io/ports/ports.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2010 Slava Pestov, Doug Coleman
! 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
kernel.private libc locals math math.order math.private
namespaces sequences strings system ;
@ -42,11 +42,6 @@ M: input-port stream-read1
check-disposed
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
: read-step ( count port -- count ptr/f )
@ -73,11 +68,11 @@ ERROR: not-a-c-ptr object ;
PRIVATE>
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* ;
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
@ -158,7 +153,7 @@ PRIVATE>
M: output-port stream-write
check-disposed [
binary-object
[ check-c-ptr ] [ integer>fixnum-strict ] bi*
[ c-ptr check-instance ] [ integer>fixnum-strict ] bi*
] [ port-write ] bi* ;
HOOK: tell-handle os ( handle -- n )

2
basis/tuple-arrays/tuple-arrays-tests.factor
View File

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

8
basis/tuple-arrays/tuple-arrays.factor
View File

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

19
basis/ui/gadgets/labels/labels.factor
View File

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

21
core/classes/algebra/algebra.factor
View File

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

5
core/classes/builtin/builtin.factor
View File

@ -9,11 +9,6 @@ SYMBOL: builtins
PREDICATE: builtin-class < class
"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
: type>class ( n -- class ) builtins get-global nth ; foldable

2
core/classes/maybe/maybe-tests.factor
View File

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

4
core/classes/mixin/mixin-tests.factor
View File

@ -125,7 +125,7 @@ SYMBOL: a-symbol
[
\ a-symbol \ silly-mixin add-mixin-instance
] with-compilation-unit
] [ not-a-class? ] must-fail-with
] [ not-an-instance? ] must-fail-with
SYMBOL: not-a-mixin
TUPLE: a-class ;
@ -134,7 +134,7 @@ TUPLE: a-class ;
[
\ a-class \ not-a-mixin add-mixin-instance
] 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
MIXIN: metaclass-change-mixin

7
core/classes/mixin/mixin.factor
View File

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

5
core/classes/tuple/tuple-docs.factor
View File

@ -390,11 +390,6 @@ HELP: define-tuple-slots
{ $description "Defines slot accessor and mutator words for the tuple." }
$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
{ $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: } "." }

20
core/classes/tuple/tuple.factor
View File

@ -17,8 +17,6 @@ PREDICATE: tuple-class < class
ERROR: too-many-slots class slots got max ;
ERROR: not-a-tuple object ;
: all-slots ( class -- slots )
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-up-to-date? ( object -- ? )
dup tuple?
[ [ layout-of ] [ class-of tuple-layout ] bi eq? ] [ drop t ] if ;
: check-tuple ( object -- tuple )
dup tuple? [ not-a-tuple ] unless ; inline
dup tuple? [
[ layout-of ] [ class-of tuple-layout ] bi eq?
] [ drop t ] if ;
: 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 )
[ array-nth ] curry map ;
@ -323,13 +319,9 @@ M: tuple-class (define-tuple-class)
: boa-effect ( class -- 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 -- )
check-tuple-class [ [ boa ] curry ] [ boa-effect ] bi
tuple-class check-instance
[ [ boa ] curry ] [ boa-effect ] bi
define-inline ;
: forget-slot-accessors ( class slots -- )

18
core/io/streams/sequence/sequence.factor
View File

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

65
core/lexer/lexer.factor
View File

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

5
core/syntax/syntax.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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.predicate classes.singleton classes.tuple classes.tuple.parser
classes.union combinators compiler.units definitions effects
@ -128,7 +128,8 @@ IN: bootstrap.syntax
"BUILTIN:" [
scan-word-name
current-vocab lookup-word
(parse-tuple-definition) 2drop check-builtin
(parse-tuple-definition)
2drop builtin-class check-instance drop
] define-core-syntax
"SYMBOL:" [

4
extra/euler/operators/operators.factor
View File

@ -29,10 +29,8 @@ ERROR: edges-in-same-face ;
[ dup opposite-edge>> assert-same-face ]
bi ;
ERROR: not-a-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 ;

7
extra/math/matrices/laplace/laplace.factor
View File

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