: LIBRARY: scan "c-library" set ; parsing
: parse-arglist ( lst -- types stack effect )
- unpair [
+ 2 swap group flip 2unseq [
" " % [ "," ?tail drop % " " % ] each "-- " %
] make-string ;
"Bootstrap stage 1..." print
-: pull-in ( list -- ) [ dup print parse-resource % ] each ;
-
"/library/bootstrap/primitives.factor" run-resource
! The make-list form creates a boot quotation
{
"/version.factor"
+ "/library/generic/early-generic.factor"
+
"/library/kernel.factor"
"/library/collections/sequences.factor"
"/library/syntax/parse-errors.factor"
"/library/syntax/parser.factor"
"/library/syntax/parse-stream.factor"
+
+ "/library/generic/generic.factor"
+ "/library/generic/standard-combination.factor"
+ "/library/generic/slots.factor"
+ "/library/generic/object.factor"
+ "/library/generic/null.factor"
+ "/library/generic/math-combination.factor"
+ "/library/generic/predicate.factor"
+ "/library/generic/union.factor"
+ "/library/generic/complement.factor"
+ "/library/generic/tuple.factor"
+
"/library/syntax/generic.factor"
- "/library/syntax/math.factor"
"/library/syntax/parse-syntax.factor"
"/library/alien/aliens.factor"
"/library/cli.factor"
"/library/tools/memory.factor"
- } pull-in
-] make-list
-
-"object" [ "generic" ] search
-"null" [ "generic" ] search
-"typemap" [ "generic" ] search
-"builtins" [ "generic" ] search
-
-vocabularies get [ "generic" off ] bind
-
-reveal
-reveal
-reveal
-reveal
-
-[
+
+ "/library/bootstrap/init.factor"
+ } [ dup print parse-resource % ] each
+
[
boot
[ hashtable? ] instances
[ dup hash-size 1 max swap set-bucket-count ] each
+
+ "/library/bootstrap/boot-stage2.factor" run-resource
] %
-
- {
- "/library/generic/generic.factor"
- "/library/generic/standard-combination.factor"
- "/library/generic/slots.factor"
- "/library/generic/object.factor"
- "/library/generic/null.factor"
- "/library/generic/math-combination.factor"
- "/library/generic/predicate.factor"
- "/library/generic/union.factor"
- "/library/generic/complement.factor"
- "/library/generic/tuple.factor"
-
- "/library/bootstrap/init.factor"
- } pull-in
] make-list
-swap
-
-[
- "/library/bootstrap/boot-stage2.factor" run-resource
-]
-
-append3
-
vocabularies get [
"!syntax" get "syntax" set
- "syntax" get [
- cdr dup word? [
- "syntax" "vocabulary" set-word-prop
- ] [
- drop
- ] ifte
- ] hash-each
+ "syntax" get hash-values [ word? ] subset
+ [ "syntax" "vocabulary" set-word-prop ] each
] bind
"!syntax" vocabularies get remove-hash
-
-FORGET: pull-in
"Creating primitives and basic runtime structures..." print
-! This symbol needs the same hashcode in the target as in the
+! These symbols need the same hashcode in the target as in the
! host.
-vocabularies
+{ vocabularies object null typemap builtins }
! Bring up a bare cross-compiling vocabulary.
-"syntax" vocab clone
-"generic" vocab clone
+"syntax" vocab
<namespace> vocabularies set
f crossref set
-vocabularies get [
- "generic" set
- "syntax" set
- reveal
-] bind
+vocabularies get [ "syntax" set [ reveal ] each ] bind
: make-primitive ( { vocab word } n -- )
>r 2unseq create r> f define ;
: swons ( cdr car -- [[ car cdr ]] ) swap cons ; inline
: unit ( a -- [ a ] ) f cons ; inline
: 2list ( a b -- [ a b ] ) unit cons ; inline
-: 2unlist ( [ a b ] -- a b ) uncons car ; inline
: 2car ( cons cons -- car car ) swap car swap car ; inline
: 2cdr ( cons cons -- car car ) swap cdr swap cdr ; inline
-: unpair ( list -- list1 list2 )
- [ uncons uncons unpair rot swons >r cons r> ] [ f f ] ifte* ;
- flushable
-
: <queue> ( -- queue )
#! Make a new functional queue.
[[ [ ] [ ] ]] ; foldable
: midpoint ( seq -- elt ) dup length 2 /i swap nth ; inline
-TUPLE: sorter start end mid ;
+TUPLE: sorter seq start end mid ;
C: sorter ( seq start end -- sorter )
[ >r 1 + rot <slice> r> set-sorter-seq ] keep
swap [ thaw ] keep >r dup >r swap call r> r> like ; inline
G: each ( seq quot -- | quot: elt -- )
- [ over ] [ standard-combination ] ; inline
+ [ over ] standard-combination ; inline
: each-with ( obj seq quot -- | quot: obj elt -- )
swap [ with ] each 2drop ; inline
swapd each ; inline
G: find ( seq quot -- i elt | quot: elt -- ? )
- [ over ] [ standard-combination ] ; inline
+ [ over ] standard-combination ; inline
: find-with ( obj seq quot -- i elt | quot: elt -- ? )
swap [ with rot ] find 2swap 2drop ; inline
: group ( n seq -- list )
#! Split a sequence into element chunks.
- [ 0 -rot (group) ] make-list ; flushable
+ [ 0 -rot (group) ] make-vector ; flushable
: start-step ( subseq seq n -- subseq slice )
pick length dupd + rot <slice> ;
USING: generic kernel lists strings ;
G: tree-each ( obj quot -- | quot: elt -- )
- [ over ] [ standard-combination ] ; inline
+ [ over ] standard-combination ; inline
: tree-each-with ( obj vector quot -- )
swap [ with ] tree-each 2drop ; inline
: STH d-form 44 insn ; : STHU d-form 45 insn ;
: STW d-form 36 insn ; : STWU d-form 37 insn ;
-G: (B) ( dest aa lk -- ) [ pick ] [ standard-combination ] ;
+G: (B) ( dest aa lk -- ) [ pick ] standard-combination ;
M: integer (B) i-form 18 insn ;
M: word (B) 0 -rot (B) relative-24 ;
: empty-vop f f f ;
: label-vop ( label) >r f f r> ;
: label/src-vop ( label src) 1vector swap f swap ;
-: src-vop ( src) unit f f ;
-: dest-vop ( dest) unit dup f ;
+: src-vop ( src) 1vector f f ;
+: dest-vop ( dest) 1vector dup f ;
: src/dest-vop ( src dest) >r 1vector r> 1vector f ;
: 2-in-vop ( in1 in2) 2vector f f ;
: 3-in-vop ( in1 in2 in3) 3vector f f ;
C: %fast-set-slot make-vop ;
: %fast-set-slot ( value obj n )
#! %fast-set-slot writes to vreg obj.
- >r >r <vreg> r> <vreg> r> over >r 3vector r> unit f
+ >r >r <vreg> r> <vreg> r> over >r 3vector r> 1vector f
<%fast-set-slot> ;
M: %fast-set-slot basic-block? drop t ;
TUPLE: %write-barrier ;
C: %write-barrier make-vop ;
-: %write-barrier ( ptr ) <vreg> unit dup f <%write-barrier> ;
+: %write-barrier ( ptr ) <vreg> dest-vop <%write-barrier> ;
! fixnum intrinsics
TUPLE: %fixnum+ ;
( Displaced indirect register operands -- eg, [ EAX 4 ] )
PREDICATE: cons displaced
dup length 2 =
- [ 2unlist integer? swap register? and ] [ drop f ] ifte ;
+ [ 2unseq integer? swap register? and ] [ drop f ] ifte ;
M: displaced modifier second byte? BIN: 01 BIN: 10 ? ;
M: displaced register car register ;
[ drop ] [ <namespace> "methods" set-word-prop ] ifte ;
! Defining generic words
+
+: bootstrap-combination ( quot -- quot )
+ #! Bootstrap hack.
+ global [
+ [
+ dup word? [
+ dup word-name swap word-vocabulary vocab hash
+ ] when
+ ] map
+ ] bind ;
+
: define-generic* ( word combination -- )
+ bootstrap-combination
dupd "combination" set-word-prop
dup init-methods make-generic ;
! slot 2 - the class, a word
! slot 3 - the delegate tuple, or f
-: delegate ( object -- delegate )
- dup tuple? [ 3 slot ] [ drop f ] ifte ; inline
-
-: set-delegate ( delegate tuple -- )
- dup tuple? [ 3 set-slot ] [ 2drop ] ifte ; inline
-
: class ( object -- class )
dup tuple? [ 2 slot ] [ type type>class ] ifte ; inline
: union-predicate ( members -- list )
[
- "predicate" word-prop
- [ dup ] swap add [ drop t ] cons
+ "predicate" word-prop \ dup swons [ drop t ] cons
] map [ drop f ] swap alist>quot ;
: set-members ( class members -- )
#! produces a number of values.
swap #call [
over [
- 2unlist swap consume-d produce-d
+ 2unseq swap consume-d produce-d
] hairy-node
] keep node, ;
USING: errors generic kernel math-internals ;
! Math operations
-G: number= ( x y -- ? ) [ ] [ math-combination ] ; foldable
+G: number= ( x y -- ? ) math-combination ; foldable
M: object number= 2drop f ;
-G: < ( x y -- ? ) [ ] [ math-combination ] ; foldable
-G: <= ( x y -- ? ) [ ] [ math-combination ] ; foldable
-G: > ( x y -- ? ) [ ] [ math-combination ] ; foldable
-G: >= ( x y -- ? ) [ ] [ math-combination ] ; foldable
-
-G: + ( x y -- x+y ) [ ] [ math-combination ] ; foldable
-G: - ( x y -- x-y ) [ ] [ math-combination ] ; foldable
-G: * ( x y -- x*y ) [ ] [ math-combination ] ; foldable
-G: / ( x y -- x/y ) [ ] [ math-combination ] ; foldable
-G: /i ( x y -- x/y ) [ ] [ math-combination ] ; foldable
-G: /f ( x y -- x/y ) [ ] [ math-combination ] ; foldable
-G: mod ( x y -- x%y ) [ ] [ math-combination ] ; foldable
-
-G: /mod ( x y -- x/y x%y ) [ ] [ math-combination ] ; foldable
-
-G: bitand ( x y -- z ) [ ] [ math-combination ] ; foldable
-G: bitor ( x y -- z ) [ ] [ math-combination ] ; foldable
-G: bitxor ( x y -- z ) [ ] [ math-combination ] ; foldable
-G: shift ( x n -- y ) [ ] [ math-combination ] ; foldable
+G: < ( x y -- ? ) math-combination ; foldable
+G: <= ( x y -- ? ) math-combination ; foldable
+G: > ( x y -- ? ) math-combination ; foldable
+G: >= ( x y -- ? ) math-combination ; foldable
+
+G: + ( x y -- x+y ) math-combination ; foldable
+G: - ( x y -- x-y ) math-combination ; foldable
+G: * ( x y -- x*y ) math-combination ; foldable
+G: / ( x y -- x/y ) math-combination ; foldable
+G: /i ( x y -- x/y ) math-combination ; foldable
+G: /f ( x y -- x/y ) math-combination ; foldable
+G: mod ( x y -- x%y ) math-combination ; foldable
+
+G: /mod ( x y -- x/y x%y ) math-combination ; foldable
+
+G: bitand ( x y -- z ) math-combination ; foldable
+G: bitor ( x y -- z ) math-combination ; foldable
+G: bitxor ( x y -- z ) math-combination ; foldable
+G: shift ( x n -- y ) math-combination ; foldable
GENERIC: bitnot ( n -- n ) foldable
#! stack.
scan-word [ tuple-constructor ] keep
[ define-constructor ] [ ] ; parsing
+
+! Tuples.
+: << f ; parsing
+: >> reverse literal-tuple swons ; parsing
+++ /dev/null
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-
-IN: !syntax
-USING: kernel lists math parser sequences syntax vectors ;
-
-! Complex numbers
-: #{ f ; parsing
-: }# dup second swap first rect> swons ; parsing
-
-! Reading integers in other bases
-: (BASE) ( base -- )
- #! Reads an integer in a specific base.
- scan swap base> swons ;
-
-: HEX: 16 (BASE) ; parsing
-: DEC: 10 (BASE) ; parsing
-: OCT: 8 (BASE) ; parsing
-: BIN: 2 (BASE) ; parsing
! Conses (whose cdr might not be a list)
: [[ f ; parsing
-: ]] 2unlist swons swons ; parsing
+: ]] 2unseq swons swons ; parsing
! Vectors
: { f ; parsing
: {{ f ; parsing
: }} alist>hash swons ; parsing
-! Tuples.
-: << f ; parsing
-: >> reverse literal-tuple swons ; parsing
-
! Do not execute parsing word
: POSTPONE: ( -- ) scan-word swons ; parsing
: #!
#! Documentation comment.
until-eol parsed-documentation ; parsing
+
+! Complex numbers
+: #{ f ; parsing
+: }# dup second swap first rect> swons ; parsing
+
+! Reading integers in other bases
+: (BASE) ( base -- )
+ #! Reads an integer in a specific base.
+ scan swap base> swons ;
+
+: HEX: 16 (BASE) ; parsing
+: DEC: 10 (BASE) ; parsing
+: OCT: 8 (BASE) ; parsing
+: BIN: 2 (BASE) ; parsing
M: cons pprint* ( list -- )
[
- dup list? [ \ [ \ ] ] [ uncons 2list \ [[ \ ]] ] ifte
+ dup list? [ \ [ \ ] ] [ uncons 2vector \ [[ \ ]] ] ifte
pprint-sequence
] check-recursion ;
[ "M: vocabularies unhappy ;" eval ] unit-test-fails
[ ] [ "GENERIC: unhappy" eval ] unit-test
-G: complex-combination [ over ] [ standard-combination ] ;
+G: complex-combination [ over ] standard-combination ;
M: string complex-combination drop ;
M: object complex-combination nip ;
2dup = [ 2drop ] [ <assert> throw ] ifte ;
: print-test ( input output -- )
- "--> " write 2list . flush ;
+ "--> " write 2vector . flush ;
: time ( code -- )
#! Evaluates the given code and prints the time taken to
tuck [ execute ] map-with
2vector ;
-M: list sheet unit ;
+M: list sheet 1vector ;
-M: vector sheet unit ;
+M: vector sheet 1vector ;
-M: array sheet unit ;
+M: array sheet 1vector ;
-M: hashtable sheet dup hash-keys swap hash-values 2list ;
+M: hashtable sheet dup hash-keys swap hash-values 2vector ;
: format-column ( list -- list )
[ unparse-short ] map
] make-list ;
G: each-slot ( obj quot -- )
- [ over ] [ standard-combination ] ; inline
+ [ over ] standard-combination ; inline
M: array each-slot ( array quot -- ) each ;