! 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
SYMBOL: retina?
-ERROR: not-a-string object ;
-
MEMO: make-attributes ( open-font color -- hashtable )
[
kCTForegroundColorAttributeName ,,
[
[
dup selection? [ string>> ] when
- dup string? [ not-a-string ] unless
+ string check-instance
] 2dip
make-attributes <CFAttributedString> &CFRelease
CTLineCreateWithAttributedString
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" ;
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 ;
! 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 ;
: 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>
! 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 }
: >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
: 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
! 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
! 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* ;
! 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
! 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
! 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
! 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 ;
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 )
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
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 )
! 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
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>
! 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.
: ?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 )
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 ;
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 ;
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 ;
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
[ 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
[
\ 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 ;
[
\ 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
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? ;
{ $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: } "." }
ERROR: too-many-slots class slots got max ;
-ERROR: not-a-tuple object ;
-
: all-slots ( class -- slots )
superclasses-of [ "slots" word-prop ] map concat ;
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 ;
: 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 -- )
! 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
[ [ 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>
! 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
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
] 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 -- )
] 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>> ]
} cleave
] dip lexer-error boa ;
+<PRIVATE
+
: simple-lexer-dump ( error -- )
[ line>> number>string ": " append ]
[ line-text>> ]
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 -- )
- 2dup [ line>> ] same?
- [ drop simple-lexer-dump ]
- [ (parsing-word-lexer-dump) ] if ;
+: 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 ;
+
+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
! 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
"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:" [
[ 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 ;
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 ;
projects / factor.git / commitdiff