#! Last element of a list.
last* car ;
-: tail ( list -- tail )
- #! Return the cdr of the last cons cell, or f.
- dup [ last* cdr ] when ;
-
UNION: general-list f cons ;
PREDICATE: general-list list ( list -- ? )
#! Proper list test. A proper list is either f, or a cons
#! cell whose cdr is a proper list.
- tail not ;
+ dup [ last* cdr ] when not ;
: all? ( list pred -- ? )
#! Push if the predicate returns true for each element of
! Builtin metaclass for builtin types: fixnum, word, cons, etc.
SYMBOL: builtin
-! Vector in global namespace mapping type numbers to
-! builtin classes.
-SYMBOL: types
-
builtin [
"builtin-type" word-property unit
] "builtin-supertypes" set-word-property
builtin 50 "priority" set-word-property
-: add-builtin-table types get set-vector-nth ;
-
: builtin-predicate ( type# symbol -- )
over f type = [
nip [ not ] "predicate" set-word-property
] [
dup predicate-word
- [ rot [ swap type eq? ] cons define-compound ] keep
+ [ rot [ swap type eq? ] cons define-compound ] keep
unit "predicate" set-word-property
] ifte ;
: builtin-class ( type# symbol -- )
- 2dup swap add-builtin-table
- dup undefined? [ dup define-symbol ] when
+ dup intern-symbol
2dup builtin-predicate
- dup builtin "metaclass" set-word-property
- swap "builtin-type" set-word-property ;
+ [ swap "builtin-type" set-word-property ] keep
+ builtin define-class ;
: BUILTIN:
#! Followed by type name and type number. Define a built-in
CREATE scan-word swap builtin-class ; parsing
: builtin-type ( n -- symbol )
- types get vector-nth ;
+ unit classes get hash ;
: type-name ( n -- string )
builtin-type word-name ;
#! Analogous to the type primitive. Pushes the builtin
#! class of an object.
type builtin-type ;
-
-global [ num-types <vector> types set ] bind
: class-ord ( class -- n ) metaclass "priority" word-property ;
: class< ( cls1 cls2 -- ? )
- swap car class-ord swap car class-ord < ;
+ swap class-ord swap class-ord < ;
: sort-methods ( methods -- alist )
- hash>alist [ class< ] sort ;
+ hash>alist [ 2car class< ] sort ;
: add-method ( vtable definition class -- )
#! Add the method entry to the vtable. Unlike define-method,
#! M: foo bar begins a definition of the bar generic word
#! specialized to the foo type.
scan-word dup define-method scan-word swap [ ] ; parsing
+
+! Maps lists of builtin type numbers to class objects.
+SYMBOL: classes
+
+SYMBOL: object
+
+: type-union ( list list -- list )
+ append prune [ > ] sort ;
+
+: class\/ ( class class -- class )
+ #! Return a class that both classes are subclasses of.
+ swap builtin-supertypes
+ swap builtin-supertypes
+ type-union classes get hash [ object ] unless* ;
+
+: class/\ ( class class -- class )
+ #! Return a class that is a subclass of both, or raise an
+ #! error if this is impossible.
+ over builtin-supertypes
+ over builtin-supertypes
+ intersection dup [
+ nip nip classes get hash [ object ] unless*
+ ] [
+ drop [
+ word-name , " and " , word-name ,
+ " do not intersect" ,
+ ] make-string throw
+ ] ifte ;
+
+: define-class ( class metaclass -- )
+ dupd "metaclass" set-word-property
+ dup builtin-supertypes [ > ] sort
+ classes get set-hash ;
+
+global [ <namespace> classes set ] bind
! Catch-all metaclass for providing a default method.
SYMBOL: object
-object object "metaclass" set-word-property
-
object [
drop num-types count
] "builtin-supertypes" set-word-property
object [ drop t ] "predicate" set-word-property
object 100 "priority" set-word-property
+
+object object define-class
: PREDICATE: ( -- class predicate definition )
#! Followed by a superclass name, then a class name.
scan-word
- CREATE
+ CREATE dup intern-symbol
dup rot "superclass" set-word-property
dup predicate "metaclass" set-word-property
dup predicate-word
: UNION: ( -- class predicate definition )
#! Followed by a class name, then a list of union members.
CREATE
- dup union "metaclass" set-word-property
+ dup intern-symbol
+ dup union define-class
dup predicate-word
[ dupd unit "predicate" set-word-property ] keep
[ define-union ] [ ] ; parsing
#! shorter, pad it with unknown results at the bottom.
dup longest-vector swap [ dupd add-inputs nip ] map nip ;
-: unify-classes ( class class -- class )
- #! Return a class that both classes are subclasses of.
- 2dup = [ drop ] [ 2drop object ] ifte ;
-
: unify-results ( obj obj -- obj )
#! Replace values with unknown result if they differ,
#! otherwise retain them.
2dup = [
drop
] [
- value-class swap value-class unify-classes <computed>
+ value-class swap value-class class\/ <computed>
] ifte ;
: unify-stacks ( list -- stack )
: head ( list n -- list )
#! Return the first n elements of the list.
dup 0 > [ >r uncons r> pred head cons ] [ 2drop f ] ifte ;
+
+: tail ( list n -- tail )
+ #! Return the rest of the list, from the nth index onward.
+ [ cdr ] times ;
+
+: intersection ( list list -- list )
+ #! Make a list of elements that occur in both lists.
+ [ over contains? ] subset nip ;
[ t ] [ 0 <alien> 0 <alien> = ] unit-test
[ f ] [ 0 <alien> local-alien? ] unit-test
+[ f ] [ 0 <alien> 1024 <local-alien> = ] unit-test
+[ f ] [ 0 <alien> 1024 <alien> = ] unit-test
+[ f ] [ "hello" 1024 <alien> = ] unit-test
[ t ] [ 1024 <local-alien> local-alien? ] unit-test
USE: math
USE: words
USE: lists
+USE: vectors
TRAITS: test-traits
C: test-traits ;
M: very-funny gooey sq ;
[ 1/4 ] [ 1/2 gooey ] unit-test
+
+[ object ] [ object object class/\ ] unit-test
+[ fixnum ] [ fixnum object class/\ ] unit-test
+[ fixnum ] [ object fixnum class/\ ] unit-test
+[ fixnum ] [ fixnum fixnum class/\ ] unit-test
+[ fixnum ] [ fixnum integer class/\ ] unit-test
+[ fixnum ] [ integer fixnum class/\ ] unit-test
+[ vector fixnum class/\ ] unit-test-fails
+[ integer ] [ fixnum bignum class\/ ] unit-test
+[ integer ] [ fixnum integer class\/ ] unit-test
+[ rational ] [ ratio integer class\/ ] unit-test
: define-compound ( word def -- ) 1 swap define ;
: define-symbol ( word -- ) 2 over define ;
+: intern-symbol ( word -- )
+ dup undefined? [ define-symbol ] [ drop ] ifte ;
+
: word-name ( word -- str ) "name" word-property ;
: word-vocabulary ( word -- str ) "vocabulary" word-property ;
: stack-effect ( word -- str ) "stack-effect" word-property ;