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

huge cleanup

cvs
Slava Pestov 2004-12-24 07:52:02 +00:00
parent 6e24186be8
commit 66ff0243b5
62 changed files with 410 additions and 835 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
TODO.FACTOR.txt
View File

@ -13,6 +13,8 @@
+ compiler:
- slot compilation
- optimize away dispatch
- getenv/setenv: if literal arg, compile as a load/store
- assembler opcodes dispatch on operand types
- save code in image
@ -21,6 +23,7 @@
- make see work with generics
- doc comments of generics
- redo traits with generic method map
+ ffi:
@ -47,10 +50,8 @@
- remove sbufs
- cat, reverse-cat primitives
- first-class hashtables
- rewrite accessors and mutators in Factor, with slot/set-slot primitive
- add a socket timeout
- do transfer-word in fixup
- move dispatch getenv setenv to kernel-internals
+ misc:
@ -62,8 +63,7 @@
- jedit ==> jedit-word, jedit takes a file name
- nicer way to combine two paths
- ditch object paths
- browser responder for word links in HTTPd; inspect responder for
objects
- browser responder for word links in HTTPd
- worddef props
- prettyprint: when unparse called due to recursion, write a link

2
library/bootstrap/boot-stage2.factor
View File

@ -99,7 +99,6 @@ USE: namespaces
"/library/io/files.factor"
"/library/eval-catch.factor"
"/library/tools/listener.factor"
"/library/tools/inspector.factor"
"/library/tools/word-tools.factor"
"/library/test/test.factor"
"/library/io/ansi.factor"
@ -146,7 +145,6 @@ USE: namespaces
"/library/httpd/responder.factor"
"/library/httpd/httpd.factor"
"/library/httpd/file-responder.factor"
"/library/httpd/inspect-responder.factor"
"/library/httpd/test-responder.factor"
"/library/httpd/quit-responder.factor"
"/library/httpd/resource-responder.factor"

1
library/bootstrap/init-stage2.factor
View File

@ -42,6 +42,7 @@ USE: stdio
USE: presentation
USE: words
USE: unparser
USE: kernel-internals
: cli-args ( -- args ) 10 getenv ;

43
library/bootstrap/primitives.factor
View File

@ -55,14 +55,9 @@ vocabularies get [
[ "kernel" | "call" ]
[ "kernel" | "ifte" ]
[ "lists" | "cons" ]
[ "lists" | "car" ]
[ "lists" | "cdr" ]
[ "vectors" | "<vector>" ]
[ "vectors" | "vector-length" ]
[ "vectors" | "set-vector-length" ]
[ "vectors" | "vector-nth" ]
[ "vectors" | "set-vector-nth" ]
[ "strings" | "str-length" ]
[ "strings" | "str-nth" ]
[ "strings" | "str-compare" ]
[ "strings" | "str=" ]
@ -85,15 +80,10 @@ vocabularies get [
[ "math" | ">fixnum" ]
[ "math" | ">bignum" ]
[ "math" | ">float" ]
[ "math" | "numerator" ]
[ "math" | "denominator" ]
[ "math" | "fraction>" ]
[ "math-internals" | "(fraction>)" ]
[ "parser" | "str>float" ]
[ "unparser" | "(unparse-float)" ]
[ "math" | "float>bits" ]
[ "math" | "real" ]
[ "math" | "imaginary" ]
[ "math" | "rect>" ]
[ "math-internals" | "(rect>)" ]
[ "math-internals" | "fixnum=" ]
[ "math-internals" | "fixnum+" ]
[ "math-internals" | "fixnum-" ]
@ -150,21 +140,9 @@ vocabularies get [
[ "math-internals" | "fsinh" ]
[ "math-internals" | "fsqrt" ]
[ "words" | "<word>" ]
[ "words" | "word-hashcode" ]
[ "words" | "word-xt" ]
[ "words" | "set-word-xt" ]
[ "words" | "word-primitive" ]
[ "words" | "set-word-primitive" ]
[ "words" | "word-parameter" ]
[ "words" | "set-word-parameter" ]
[ "words" | "word-plist" ]
[ "words" | "set-word-plist" ]
[ "words" | "update-xt" ]
[ "profiler" | "call-profiling" ]
[ "profiler" | "call-count" ]
[ "profiler" | "set-call-count" ]
[ "profiler" | "allot-profiling" ]
[ "profiler" | "allot-count" ]
[ "profiler" | "set-allot-count" ]
[ "words" | "compiled?" ]
[ "kernel" | "drop" ]
[ "kernel" | "dup" ]
@ -174,8 +152,8 @@ vocabularies get [
[ "kernel" | ">r" ]
[ "kernel" | "r>" ]
[ "kernel" | "eq?" ]
[ "kernel" | "getenv" ]
[ "kernel" | "setenv" ]
[ "kernel-internals" | "getenv" ]
[ "kernel-internals" | "setenv" ]
[ "io-internals" | "open-file" ]
[ "files" | "stat" ]
[ "files" | "(directory)" ]
@ -214,8 +192,6 @@ vocabularies get [
[ "files" | "cd" ]
[ "compiler" | "compiled-offset" ]
[ "compiler" | "set-compiled-offset" ]
[ "compiler" | "set-compiled-cell" ]
[ "compiler" | "set-compiled-byte" ]
[ "compiler" | "literal-top" ]
[ "compiler" | "set-literal-top" ]
[ "kernel" | "address" ]
@ -239,6 +215,15 @@ vocabularies get [
[ "kernel-internals" | "memory>string" ]
[ "alien" | "local-alien?" ]
[ "alien" | "alien-address" ]
[ "lists" | ">cons" ]
[ "vectors" | ">vector" ]
[ "strings" | ">string" ]
[ "words" | ">word" ]
[ "kernel-internals" | "slot" ]
[ "kernel-internals" | "set-slot" ]
[ "kernel-internals" | "integer-slot" ]
[ "kernel-internals" | "set-integer-slot" ]
[ "kernel-internals" | "grow-array" ]
] [
unswons create swap succ [ f define ] keep
] each drop

14
library/cli.factor
View File

@ -54,8 +54,12 @@ USE: words
?run-file
] when ;
: cli-var-param ( name value -- )
swap ":" split set-object-path ;
: set-path ( value list -- )
unswons over [ nest [ set-path ] bind ] [ nip set ] ifte ;
: cli-var-param ( name value -- ) swap ":" split set-path ;
: cli-bool-param ( name -- ) "no-" ?str-head not put ;
: cli-param ( param -- )
#! Handle a command-line argument starting with '-' by
@ -64,11 +68,7 @@ USE: words
#!
#! Arguments containing = are handled differently; they
#! set the object path.
"=" split1 [
cli-var-param
] [
"no-" ?str-head not put
] ifte* ;
"=" split1 [ cli-var-param ] [ cli-bool-param ] ifte* ;
: cli-arg ( argument -- argument )
#! Handle a command-line argument. If the argument was

31
library/combinators.factor
View File

@ -26,7 +26,6 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: kernel
USE: lists
: slip ( quot x -- x )
>r call r> ; inline
@ -51,36 +50,6 @@ USE: lists
#! Apply code to input.
swap dup >r call r> swap ; inline
IN: lists DEFER: uncons IN: kernel
: cond ( x list -- )
#! The list is of this form:
#!
#! [ [ condition 1 ] [ code 1 ]
#! [ condition 2 ] [ code 2 ]
#! ... ]
#!
#! Each condition is evaluated in turn. If it returns true,
#! the code is evaluated. If it returns false, the next
#! condition is checked.
#!
#! Before evaluating each condition, the top of the stack is
#! duplicated. After the last condition is evaluated, the
#! top of the stack is popped.
#!
#! So each condition and code block must have stack effect:
#! ( X -- )
#!
#! This combinator will not compile.
dup [
uncons >r over >r call r> r> rot [
car call
] [
cdr cond
] ifte
] [
2drop
] ifte ;
: ifte* ( cond true false -- )
#! If the condition is not f, execute the 'true' quotation,
#! with the condition on the stack. Otherwise, pop the

17
library/compiler/assembler.factor
View File

@ -26,17 +26,24 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: compiler
USE: alien
USE: math
USE: kernel
: cell 4 ;
: literal-table 1024 cell * ;
: cell 4 ; inline
: literal-table 1024 cell * ; inline
: init-assembler ( -- )
compiled-offset literal-table + set-compiled-offset ;
: set-compiled-byte ( n addr -- )
<alien> 0 set-alien-1 ; inline
: set-compiled-cell ( n addr -- )
<alien> 0 set-alien-cell ; inline
: compile-aligned ( n -- )
compiled-offset swap align set-compiled-offset ;
compiled-offset swap align set-compiled-offset ; inline
: intern-literal ( obj -- lit# )
address
@ -45,8 +52,8 @@ USE: kernel
: compile-byte ( n -- )
compiled-offset set-compiled-byte
compiled-offset 1 + set-compiled-offset ;
compiled-offset 1 + set-compiled-offset ; inline
: compile-cell ( n -- )
compiled-offset set-compiled-cell
compiled-offset cell + set-compiled-offset ;
compiled-offset cell + set-compiled-offset ; inline

4
library/cons.factor
View File

@ -28,6 +28,7 @@
IN: lists
USE: generic
USE: kernel
USE: kernel-internals
! This file contains vital list-related words that everything
! else depends on, and is loaded early in bootstrap.
@ -35,6 +36,9 @@ USE: kernel
BUILTIN: cons 2
: car ( [ car | cdr ] -- car ) >cons 0 slot ; inline
: cdr ( [ car | cdr ] -- cdr ) >cons 1 slot ; inline
: swons ( cdr car -- [ car | cdr ] )
#! Push a new cons cell. If the cdr is f or a proper list,
#! has the effect of prepending the car to the cdr.

1
library/errors.factor
View File

@ -30,6 +30,7 @@ DEFER: callcc1
IN: errors
USE: kernel
USE: kernel-internals
USE: lists
USE: math
USE: namespaces

1
library/generic/generic.factor
View File

@ -29,6 +29,7 @@ IN: generic
USE: errors
USE: hashtables
USE: kernel
USE: kernel-internals
USE: lists
USE: namespaces
USE: parser

6
library/httpd/default-responders.factor
View File

@ -51,12 +51,6 @@ global [ <namespace> "httpd-responders" set ] bind
[ test-responder ] "get" set
] extend add-responder
<responder> [
"inspect" "responder" set
[ inspect-responder ] "get" set
"global" "default-argument" set
] extend add-responder
<responder> [
"quit" "responder" set
[ quit-responder ] "get" set

17
library/httpd/html.factor
View File

@ -110,17 +110,6 @@ USE: generic
call
] ifte* ;
: object-link-href ( path -- href )
#! Perhaps this should not be hard-coded.
"/responder/inspect/" swap cat2 ;
: object-link-tag ( style quot -- )
over "object-link" swap assoc [
<a href= object-link-href url-encode a> call </a>
] [
call
] ifte* ;
: icon-tag ( string style quot -- )
over "icon" swap assoc dup [
<img src= "/responder/resource/" swap cat2 img/>
@ -137,10 +126,8 @@ M: html-stream fwrite-attr ( str style stream -- )
[
[
[
[
[ drop chars>entities write ] span-tag
] file-link-tag
] object-link-tag
[ drop chars>entities write ] span-tag
] file-link-tag
] icon-tag
] bind ;

40
library/httpd/inspect-responder.factor
View File

@ -1,40 +0,0 @@
! :folding=indent:collapseFolds=0:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: inspect-responder
USE: html
USE: inspector
USE: namespaces
USE: kernel
USE: httpd
USE: httpd-responder
: inspect-responder ( argument -- )
serving-html dup [
describe-path
] simple-html-document ;

1
library/inference/branches.factor
View File

@ -194,5 +194,6 @@ USE: hashtables
pop-d drop ( n )
infer-branches ;
USE: kernel-internals
\ dispatch [ infer-dispatch ] "infer" set-word-property
\ dispatch [ 2 | 0 ] "infer-effect" set-word-property

22
library/inference/words.factor
View File

@ -136,7 +136,9 @@ USE: parser
] when*
] catch ;
: apply-compound ( word -- )
GENERIC: (apply-word)
M: compound (apply-word) ( word -- )
#! Infer a compound word's stack effect.
dup "inline" word-property [
inline-compound drop
@ -144,6 +146,9 @@ USE: parser
infer-compound
] ifte ;
M: symbol (apply-word) ( word -- )
apply-literal ;
: current-word ( -- word )
#! Push word we're currently inferring effect of.
recursive-state get car car ;
@ -175,9 +180,6 @@ USE: parser
2drop no-base-case
] ifte ;
: no-effect? ( word -- ? )
"no-effect" word-property ;
: apply-word ( word -- )
#! Apply the word's stack effect to the inferencer state.
dup recursive-state get assoc dup [
@ -186,13 +188,11 @@ USE: parser
drop dup "infer-effect" word-property dup [
apply-effect
] [
drop
[
[ no-effect? ] [ no-effect ]
[ compound? ] [ apply-compound ]
[ symbol? ] [ apply-literal ]
[ drop t ] [ no-effect ]
] cond
drop dup "no-effect" word-property [
no-effect
] [
(apply-word)
] ifte
] ifte
] ifte ;

1
library/io/io-internals.factor
View File

@ -28,6 +28,7 @@
IN: io-internals
USE: generic
USE: kernel
USE: kernel-internals
USE: namespaces
USE: strings
USE: threads

11
library/kernel.factor
View File

@ -25,10 +25,16 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: kernel
IN: kernel-internals
USE: generic
USE: kernel
USE: vectors
: dispatch ( n vtable -- )
vector-nth call ;
IN: kernel
GENERIC: hashcode ( obj -- n )
M: object hashcode drop 0 ;
@ -43,9 +49,6 @@ M: object = eq? ;
#! Returns one of "unix" or "win32".
11 getenv ;
: dispatch ( n vtable -- )
vector-nth call ;
: set-boot ( quot -- )
#! Set the boot quotation.
8 setenv ;

19
library/math/complex.factor
View File

@ -25,12 +25,31 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: errors
DEFER: throw
IN: math
USE: generic
USE: kernel
USE: kernel-internals
USE: math
USE: math-internals
GENERIC: real ( #{ re im } -- re )
M: real real ;
M: complex real 0 slot ;
GENERIC: imaginary ( #{ re im } -- im )
M: real imaginary drop 0 ;
M: complex imaginary 1 slot ;
: rect> ( xr xi -- x )
over real? over real? and [
dup 0 = [ drop ] [ (rect>) ] ifte
] [
"Complex number must have real components" throw drop
] ifte ; inline
: >rect ( x -- xr xi ) dup real swap imaginary ; inline
: conjugate ( z -- z* )

14
library/math/integer.factor
View File

@ -25,6 +25,9 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: errors
DEFER: throw
IN: math-internals
USE: generic
USE: kernel
@ -34,6 +37,17 @@ USE: math
dup 0 < [ swap neg swap neg ] when
2dup gcd tuck /i >r /i r> ; inline
: fraction> ( a b -- a/b )
dup 0 = [
"Division by zero" throw drop
] [
dup 1 = [
drop
] [
(fraction>)
] ifte
] ifte ; inline
: integer/ ( x y -- x/y )
reduce fraction> ; inline

14
library/math/ratio.factor
View File

@ -25,10 +25,22 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: math-internals
IN: math
USE: generic
USE: kernel
USE: kernel-internals
USE: math
USE: math-internals
GENERIC: numerator ( a/b -- a )
M: integer numerator ;
M: ratio numerator 0 slot ;
GENERIC: denominator ( a/b -- b )
M: integer denominator drop 1 ;
M: ratio denominator 1 slot ;
IN: math-internals
: 2>fraction ( a/b c/d -- a c b d )
[ swap numerator swap numerator ] 2keep

42
library/namespaces.factor
View File

@ -28,9 +28,8 @@
IN: namespaces
USE: hashtables
USE: kernel
USE: kernel-internals
USE: lists
USE: strings
USE: vectors
! Other languages have classes, objects, variables, etc.
! Factor has similar concepts.
@ -72,11 +71,9 @@ USE: vectors
: init-namespaces ( -- )
global >n ;
: namespace-buckets 23 ;
: <namespace> ( -- n )
#! Create a new namespace.
namespace-buckets <hashtable> ;
23 <hashtable> ;
: (get) ( var ns -- value )
#! Internal word for searching the namestack.
@ -98,6 +95,15 @@ USE: vectors
: set ( value variable -- ) namespace set-hash ;
: put ( variable value -- ) swap set ;
: nest ( variable -- hash )
#! If the variable is set in the current namespace, return
#! its value, otherwise set its value to a new namespace.
dup namespace hash dup [
nip
] [
drop >r <namespace> dup r> set
] ifte ;
: change ( var quot -- )
#! Execute the quotation with the variable value on the
#! stack. The set the variable to the return value of the
@ -121,31 +127,5 @@ USE: vectors
#! ] extend ;
over >r bind r> ; inline
: traverse-path ( name object -- object )
dup hashtable? [ hash ] [ 2drop f ] ifte ;
: (object-path) ( object list -- object )
[ uncons >r swap traverse-path r> (object-path) ] when* ;
: object-path ( list -- object )
#! An object path is a list of strings. Each string is a
#! variable name in the object namespace at that level.
#! Returns f if any of the objects are not set.
namespace swap (object-path) ;
: (set-object-path) ( name -- namespace )
dup namespace hash dup [
nip
] [
drop <namespace> tuck put
] ifte ;
: set-object-path ( value list -- )
unswons over [
(set-object-path) [ set-object-path ] bind
] [
nip set
] ifte ;
: on ( var -- ) t put ;
: off ( var -- ) f put ;

114
library/primitives.factor
View File

@ -27,6 +27,7 @@
IN: alien
DEFER: alien
DEFER: dll
USE: alien
USE: compiler
@ -52,14 +53,9 @@ USE: words
[ call " quot -- " [ [ general-list ] [ ] ] ]
[ ifte " cond true false -- " [ [ object general-list general-list ] [ ] ] ]
[ cons " car cdr -- [ car | cdr ] " [ [ object object ] [ cons ] ] ]
[ car " [ car | cdr ] -- car " [ [ cons ] [ object ] ] ]
[ cdr " [ car | cdr ] -- cdr " [ [ cons ] [ object ] ] ]
[ <vector> " capacity -- vector" [ [ integer ] [ vector ] ] ]
[ vector-length " vector -- n " [ [ vector ] [ integer ] ] ]
[ set-vector-length " n vector -- " [ [ integer vector ] [ ] ] ]
[ vector-nth " n vector -- obj " [ [ integer vector ] [ object ] ] ]
[ set-vector-nth " obj n vector -- " [ [ object integer vector ] [ ] ] ]
[ str-length " str -- n " [ [ string ] [ integer ] ] ]
[ str-nth " n str -- ch " [ [ integer string ] [ integer ] ] ]
[ str-compare " str str -- -1/0/1 " [ [ string string ] [ integer ] ] ]
[ str= " str str -- ? " [ [ string string ] [ boolean ] ] ]
@ -82,15 +78,10 @@ USE: words
[ >fixnum " n -- fixnum " [ [ number ] [ fixnum ] ] ]
[ >bignum " n -- bignum " [ [ number ] [ bignum ] ] ]
[ >float " n -- float " [ [ number ] [ float ] ] ]
[ numerator " a/b -- a " [ [ rational ] [ integer ] ] ]
[ denominator " a/b -- b " [ [ rational ] [ integer ] ] ]
[ fraction> " a b -- a/b " [ [ integer integer ] [ rational ] ] ]
[ (fraction>) " a b -- a/b " [ [ integer integer ] [ rational ] ] ]
[ str>float " str -- float " [ [ string ] [ float ] ] ]
[ (unparse-float) " float -- str " [ [ float ] [ string ] ] ]
[ float>bits " float -- n " [ [ float ] [ integer ] ] ]
[ real " #{ re im } -- re " [ [ number ] [ real ] ] ]
[ imaginary " #{ re im } -- im " [ [ number ] [ real ] ] ]
[ rect> " re im -- #{ re im } " [ [ real real ] [ number ] ] ]
[ (rect>) " re im -- #{ re im } " [ [ real real ] [ number ] ] ]
[ fixnum= " x y -- ? " [ [ fixnum fixnum ] [ boolean ] ] ]
[ fixnum+ " x y -- x+y " [ [ fixnum fixnum ] [ integer ] ] ]
[ fixnum- " x y -- x-y " [ [ fixnum fixnum ] [ integer ] ] ]
@ -146,16 +137,8 @@ USE: words
[ fsin " x -- y " [ [ real ] [ float ] ] ]
[ fsinh " x -- y " [ [ real ] [ float ] ] ]
[ fsqrt " x -- y " [ [ real ] [ float ] ] ]
[ <word> " prim param plist -- word " [ [ integer object general-list ] [ word ] ] ]
[ word-hashcode " word -- n " [ [ word ] [ integer ] ] ]
[ word-xt " word -- xt " [ [ word ] [ integer ] ] ]
[ set-word-xt " xt word -- " [ [ integer word ] [ ] ] ]
[ word-primitive " word -- n " [ [ word ] [ integer ] ] ]
[ set-word-primitive " n word -- " [ [ integer word ] [ ] ] ]
[ word-parameter " word -- obj " [ [ word ] [ object ] ] ]
[ set-word-parameter " obj word -- " [ [ object word ] [ ] ] ]
[ word-plist " word -- alist" [ [ word ] [ general-list ] ] ]
[ set-word-plist " alist word -- " [ [ general-list word ] [ ] ] ]
[ <word> " -- word " [ [ ] [ word ] ] ]
[ update-xt " word -- " [ [ word ] [ ] ] ]
[ drop " x -- " [ [ object ] [ ] ] ]
[ dup " x -- x x " [ [ object ] [ object object ] ] ]
[ swap " x y -- y x " [ [ object object ] [ object object ] ] ]
@ -166,19 +149,19 @@ USE: words
[ eq? " x y -- ? " [ [ object object ] [ boolean ] ] ]
[ getenv " n -- obj " [ [ fixnum ] [ object ] ] ]
[ setenv " obj n -- " [ [ object fixnum ] [ ] ] ]
[ open-file " path r w -- port " [ 3 | 1 ] ]
[ stat " path -- [ dir? perm size mtime ] " [ 1 | 1 ] ]
[ (directory) " path -- list " [ 1 | 1 ] ]
[ garbage-collection " -- " [ 0 | 0 ] ]
[ save-image " path -- " [ 1 | 0 ] ]
[ open-file " path r w -- port " [ [ string object object ] [ port ] ] ]
[ stat " path -- [ dir? perm size mtime ] " [ [ string ] [ cons ] ] ]
[ (directory) " path -- list " [ [ string ] [ general-list ] ] ]
[ garbage-collection " -- " [ [ ] [ ] ] ]
[ save-image " path -- " [ [ string ] [ ] ] ]
[ datastack " -- ds " f ]
[ callstack " -- cs " f ]
[ set-datastack " ds -- " f ]
[ set-callstack " cs -- " f ]
[ exit* " n -- " [ 1 | 0 ] ]
[ client-socket " host port -- in out " [ 2 | 2 ] ]
[ server-socket " port -- server " [ 1 | 1 ] ]
[ close-port " port -- " [ 1 | 0 ] ]
[ exit* " n -- " [ [ integer ] [ ] ] ]
[ client-socket " host port -- in out " [ [ string integer ] [ port port ] ] ]
[ server-socket " port -- server " [ [ integer ] [ port ] ] ]
[ close-port " port -- " [ [ port ] ] ]
[ add-accept-io-task " server callback -- " [ 2 | 0 ] ]
[ accept-fd " server -- host port in out " [ 1 | 4 ] ]
[ can-read-line? " port -- ? " [ 1 | 1 ] ]
@ -195,45 +178,48 @@ USE: words
[ next-io-task " -- callback " [ 0 | 1 ] ]
[ room " -- free total free total " [ 0 | 4 ] ]
[ os-env " str -- str " [ 1 | 1 ] ]
[ millis " -- n " [ 0 | 1 ] ]
[ init-random " -- " [ 0 | 0 ] ]
[ (random-int) " -- n " [ 0 | 1 ] ]
[ type " obj -- n " [ 1 | 1 ] ]
[ call-profiling " depth -- " [ 1 | 0 ] ]
[ call-count " word -- n " [ 1 | 1 ] ]
[ set-call-count " n word -- " [ 2 | 0 ] ]
[ allot-profiling " depth -- " [ 1 | 0 ] ]
[ allot-count " word -- n " [ 1 | 1 ] ]
[ set-allot-count " n word -- n " [ 2 | 1 ] ]
[ cwd " -- dir " [ 0 | 1 ] ]
[ cd " dir -- " [ 1 | 0 ] ]
[ compiled-offset " -- ptr " [ 0 | 1 ] ]
[ set-compiled-offset " ptr -- " [ 1 | 0 ] ]
[ set-compiled-cell " n ptr -- " [ 2 | 0 ] ]
[ set-compiled-byte " n ptr -- " [ 2 | 0 ] ]
[ literal-top " -- ptr " [ 0 | 1 ] ]
[ set-literal-top " ptr -- " [ 1 | 0 ] ]
[ address " obj -- ptr " [ 1 | 1 ] ]
[ dlopen " path -- dll " [ 1 | 1 ] ]
[ dlsym " name dll -- ptr " [ 2 | 1 ] ]
[ dlsym-self " name -- ptr " [ 1 | 1 ] ]
[ dlclose " dll -- " [ 1 | 0 ] ]
[ <alien> " ptr -- alien " [ 1 | 1 ] ]
[ <local-alien> " len -- alien " [ 1 | 1 ] ]
[ alien-cell " alien off -- n " [ 2 | 1 ] ]
[ set-alien-cell " n alien off -- " [ 3 | 0 ] ]
[ alien-4 " alien off -- n " [ 2 | 1 ] ]
[ set-alien-4 " n alien off -- " [ 3 | 0 ] ]
[ alien-2 " alien off -- n " [ 2 | 1 ] ]
[ set-alien-2 " n alien off -- " [ 3 | 0 ] ]
[ alien-1 " alien off -- n " [ 2 | 1 ] ]
[ set-alien-1 " n alien off -- " [ 3 | 0 ] ]
[ millis " -- n " [ [ ] [ integer ] ] ]
[ init-random " -- " [ [ ] [ ] ] ]
[ (random-int) " -- n " [ [ ] [ integer ] ] ]
[ type " obj -- n " [ [ object ] [ fixnum ] ] ]
[ call-profiling " depth -- " [ [ integer ] [ ] ] ]
[ allot-profiling " depth -- " [ [ integer ] [ ] ] ]
[ cwd " -- dir " [ [ ] [ string ] ] ]
[ cd " dir -- " [ [ string ] [ ] ] ]
[ compiled-offset " -- ptr " [ [ ] [ integer ] ] ]
[ set-compiled-offset " ptr -- " [ [ integer ] [ ] ] ]
[ literal-top " -- ptr " [ [ ] [ integer ] ] ]
[ set-literal-top " ptr -- " [ [ integer ] [ ] ] ]
[ address " obj -- ptr " [ [ object ] [ integer ] ] ]
[ dlopen " path -- dll " [ [ string ] [ dll ] ] ]
[ dlsym " name dll -- ptr " [ [ string dll ] [ integer ] ] ]
[ dlsym-self " name -- ptr " [ [ string ] [ integer ] ] ]
[ dlclose " dll -- " [ [ dll ] [ ] ] ]
[ <alien> " ptr -- alien " [ [ integer ] [ alien ] ] ]
[ <local-alien> " len -- alien " [ [ integer ] [ alien ] ] ]
[ alien-cell " alien off -- n " [ [ alien integer ] [ integer ] ] ]
[ set-alien-cell " n alien off -- " [ [ integer alien integer ] [ ] ] ]
[ alien-4 " alien off -- n " [ [ alien integer ] [ integer ] ] ]
[ set-alien-4 " n alien off -- " [ [ integer alien integer ] [ ] ] ]
[ alien-2 " alien off -- n " [ [ alien integer ] [ fixnum ] ] ]
[ set-alien-2 " n alien off -- " [ [ integer alien integer ] [ ] ] ]
[ alien-1 " alien off -- n " [ [ alien integer ] [ fixnum ] ] ]
[ set-alien-1 " n alien off -- " [ [ integer alien integer ] [ ] ] ]
[ heap-stats " -- instances bytes " [ [ ] [ general-list ] ] ]
[ throw " error -- " [ [ object ] [ ] ] ]
[ string>memory " str address -- " [ [ string integer ] [ ] ] ]
[ memory>string " address length -- str " [ [ integer integer ] [ string ] ] ]
[ local-alien? " alien -- ? " [ [ alien ] [ object ] ] ]
[ alien-address " alien -- address " [ [ alien ] [ integer ] ] ]
[ >cons " cons -- cons " [ [ cons ] [ cons ] ] ]
[ >vector " vector -- vector " [ [ vector ] [ vector ] ] ]
[ >string " string -- string " [ [ string ] [ string ] ] ]
[ >word " word -- word " [ [ word ] [ word ] ] ]
[ slot " obj n -- obj " [ [ object fixnum ] [ object ] ] ]
[ set-slot " obj obj n -- " [ [ object object fixnum ] [ ] ] ]
[ integer-slot " obj n -- n " [ [ object fixnum ] [ integer ] ] ]
[ set-integer-slot " n obj n -- " [ [ integer object fixnum ] [ ] ] ]
[ grow-array " n array -- array " [ [ integer array ] [ integer ] ] ]
] [
uncons dupd uncons car ( word word stack-effect infer-effect )
>r "stack-effect" set-word-property r>

5
library/stack.factor
View File

@ -26,7 +26,6 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: kernel
USE: vectors
: 2drop ( x x -- ) drop drop ; inline
: 3drop ( x x x -- ) drop drop drop ; inline
@ -44,7 +43,3 @@ USE: vectors
#! this from a word definition will clobber any values left
#! on the data stack by the caller.
{ } set-datastack ;
: depth ( -- n )
#! Push the number of elements on the datastack.
datastack vector-length ;

3
library/strings.factor
View File

@ -28,6 +28,7 @@
IN: strings
USE: generic
USE: kernel
USE: kernel-internals
USE: lists
USE: math
@ -36,6 +37,8 @@ BUILTIN: string 12
M: string hashcode str-hashcode ;
M: string = str= ;
: str-length ( str -- len ) >string 1 integer-slot ; inline
BUILTIN: sbuf 13
M: sbuf hashcode sbuf-hashcode ;
M: sbuf = sbuf= ;

3
library/test/dataflow.factor
View File

@ -10,6 +10,7 @@ USE: namespaces
USE: prettyprint
USE: words
USE: kernel
USE: kernel-internals
USE: generic
: dataflow-contains-op? ( object list -- ? )
@ -36,7 +37,7 @@ USE: generic
car car ; inline
[ t ] [
\ car [ inline-test ] dataflow dataflow-contains-param? >boolean
\ slot [ inline-test ] dataflow dataflow-contains-param? >boolean
] unit-test
[ t ] [

26
library/test/init.factor
View File

@ -2,6 +2,9 @@ IN: scratchpad
USE: command-line
USE: namespaces
USE: test
USE: kernel
USE: hashtables
USE: lists
[
[ f ] [ "-no-user-init" cli-arg ] unit-test
@ -12,3 +15,26 @@ USE: test
[ "sdl.factor" ] [ "sdl.factor" cli-arg ] unit-test
] with-scope
: traverse-path ( name object -- object )
dup hashtable? [ hash ] [ 2drop f ] ifte ;
: (object-path) ( object list -- object )
[ uncons >r swap traverse-path r> (object-path) ] when* ;
: object-path ( list -- object )
#! An object path is a list of strings. Each string is a
#! variable name in the object namespace at that level.
#! Returns f if any of the objects are not set.
namespace swap (object-path) ;
[
5 [ "test" "object" "path" ] set-path
[ 5 ] [ [ "test" "object" "path" ] object-path ] unit-test
7 [ "test" "object" "pathe" ] set-path
[ 7 ] [ [ "test" "object" "pathe" ] object-path ] unit-test
9 [ "teste" "object" "pathe" ] set-path
[ 9 ] [ [ "teste" "object" "pathe" ] object-path ] unit-test
] with-scope

3
library/test/lists/cons.factor
View File

@ -2,6 +2,9 @@ IN: scratchpad
USE: lists
USE: test
[ 5 car ] unit-test-fails
[ "Hello world" cdr ] unit-test-fails
[ f ] [ f cons? ] unit-test
[ f ] [ t cons? ] unit-test
[ t ] [ [ t | f ] cons? ] unit-test

4
library/test/math/float.factor
View File

@ -29,7 +29,3 @@ USE: test
[ t ] [ pi 3 > ] unit-test
[ f ] [ e 2 <= ] unit-test
[ 4607182418800017408 ] [ 1.0 float>bits ] unit-test
[ 4614256656552045848 ] [ pi float>bits ] unit-test
[ 4613303445314885481 ] [ e float>bits ] unit-test

37
library/test/namespaces.factor
View File

@ -11,40 +11,15 @@ USE: words
[ t ] [ test-namespace ] unit-test
! Object paths should not resolve further up in the namestack.
<namespace> "test-namespace" set
[ f ]
[ [ "test-namespace" "test-namespace" ] object-path ]
unit-test
[ f ]
[ [ "alalal" "boobobo" "bah" ] object-path ]
unit-test
[ t ]
[ namespace [ ] object-path = ]
unit-test
[ t ]
[
\ test-word
global [ [ vocabularies "test" "test-word" ] object-path ] bind
=
] unit-test
"nested" off
"nested" nest [ 5 "x" set ] bind
[ 5 ] [ "nested" nest [ "x" get ] bind ] unit-test
] with-scope
10 "some-global" set
[ f ]
[ <namespace> [ f "some-global" set "some-global" get ] bind ]
unit-test
[
5 [ "test" "object" "path" ] set-object-path
[ 5 ] [ [ "test" "object" "path" ] object-path ] unit-test
7 [ "test" "object" "pathe" ] set-object-path
[ 7 ] [ [ "test" "object" "pathe" ] object-path ] unit-test
9 [ "teste" "object" "pathe" ] set-object-path
[ 9 ] [ [ "teste" "object" "pathe" ] object-path ] unit-test
] with-scope

11
library/test/vectors.factor
View File

@ -6,9 +6,20 @@ USE: test
USE: vectors
USE: strings
[ [ t f t ] vector-length ] unit-test-fails
[ 3 ] [ { t f t } vector-length ] unit-test
[ 3 { } vector-nth ] unit-test-fails
[ 3 #{ 1 2 } vector-nth ] unit-test-fails
[ "hey" [ 1 2 ] set-vector-length ] unit-test-fails
[ "hey" { 1 2 } set-vector-length ] unit-test-fails
[ 3 ] [ 3 0 <vector> [ set-vector-length ] keep vector-length ] unit-test
[ "yo" ] [
"yo" 4 1 <vector> [ set-vector-nth ] keep 4 swap vector-nth
] unit-test
[ 5 list>vector ] unit-test-fails
[ { } ] [ [ ] list>vector ] unit-test
[ { 1 2 } ] [ [ 1 2 ] list>vector ] unit-test

1
library/threads.factor
View File

@ -28,6 +28,7 @@
IN: threads
USE: io-internals
USE: kernel
USE: kernel-internals
USE: lists
! Core of the multitasker. Used by io-internals.factor and

6
library/tools/debugger.factor
View File

@ -27,6 +27,7 @@
IN: errors
USE: kernel
USE: kernel-internals
USE: lists
USE: namespaces
USE: prettyprint
@ -63,10 +64,7 @@ USE: generic
#! reporting.
dup [
[ 100 | "fixnum/bignum" ]
[ 101 | "fixnum/bignum/ratio" ]
[ 102 | "fixnum/bignum/ratio/float" ]
[ 103 | "fixnum/bignum/ratio/float/complex" ]
[ 104 | "fixnum/string" ]
[ 104 | "fixnum/bignum/string" ]
] assoc dup [
nip
] [

113
library/tools/inspector.factor
View File

@ -1,113 +0,0 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2003, 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: inspector
USE: kernel
USE: hashtables
USE: lists
USE: namespaces
USE: stdio
USE: strings
USE: presentation
USE: words
USE: prettyprint
USE: unparser
USE: vectors
USE: math
: relative>absolute-object-path ( string -- string )
"object-path" get [ "'" rot cat3 ] when* ;
: vars. ( -- )
#! Print a list of defined variables.
namespace hash-keys [.] ;
: object-actions ( -- alist )
[
[ "Describe" | "describe-path" ]
[ "Push" | "lookup" ]
] ;
: link-style ( path -- style )
relative>absolute-object-path
dup "object-link" swons swap
object-actions <actions> "actions" swons
t "underline" swons
3list
default-style append ;
: pad-string ( len str -- str )
str-length - " " fill ;
: var-name. ( max name -- )
tuck unparse pad-string write dup link-style
swap unparse swap write-attr ;
: value. ( max name value -- )
>r var-name. ": " write r> . ;
: max-str-length ( list -- len )
#! Returns the length of the longest string in the given
#! list.
0 swap [ str-length max ] each ;
: name-padding ( alist -- col )
[ car unparse ] map max-str-length ;
: describe-assoc ( alist -- )
dup name-padding swap
[ dupd uncons value. ] each drop ;
: alist-sort ( list -- list )
[ swap car unparse swap car unparse str-lexi> ] sort ;
: describe-hashtable ( hashtables -- )
hash>alist alist-sort describe-assoc ;
: describe ( obj -- )
[
[ word? ]
[ see ]
[ string? ]
[ print ]
[ assoc? ]
[ describe-assoc ]
[ hashtable? ]
[ describe-hashtable ]
[ drop t ]
[ prettyprint ]
] cond ;
: lookup ( str -- object )
global [ "'" split object-path ] bind ;
: describe-path ( string -- )
[ dup "object-path" set lookup describe ] with-scope ;

40
library/vectors.factor
View File

@ -25,18 +25,41 @@
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: kernel-internals
USE: generic
BUILTIN: array 8
IN: vectors
USE: kernel
USE: lists
USE: math
IN: errors
DEFER: throw
IN: kernel-internals
BUILTIN: array 8
! UNSAFE!
: array-capacity ( array -- n ) 1 integer-slot ; inline
: vector-array ( vec -- array ) 2 slot ; inline
: set-vector-array ( array vec -- ) 2 set-slot ; inline
: grow-vector-array ( len vec -- )
[ vector-array grow-array ] keep set-vector-array ; inline
: (set-vector-length) ( len vec -- ) 1 set-integer-slot ; inline
IN: vectors
BUILTIN: vector 11
: vector-length ( vec -- len ) >vector 1 integer-slot ; inline
: set-vector-length ( len vec -- )
>vector over 0 < [
"Vector length must be positive" throw 2drop
] [
2dup (set-vector-length) grow-vector-array
] ifte ;
: empty-vector ( len -- vec )
#! Creates a vector with 'len' elements set to f. Unlike
#! <vector>, which gives an empty vector with a certain
@ -162,3 +185,10 @@ M: vector hashcode ( vec -- n )
#! vector. For example, if n=1, this returns a vector of
#! one element.
[ vector-length swap - ] keep vector-tail ;
! Find a better place for this
IN: kernel
: depth ( -- n )
#! Push the number of elements on the datastack.
datastack vector-length ;

9
library/vocabularies.factor
View File

@ -77,14 +77,14 @@ USE: strings
: (create) ( name vocab -- word )
#! Create an undefined word without adding to a vocabulary.
<plist> 0 f rot <word> ;
<plist> <word> [ set-word-plist ] keep ;
: reveal ( word -- )
#! Add a new word to its vocabulary.
vocabularies get [
dup word-vocabulary
over word-name
2list set-object-path
dup word-vocabulary nest [
dup word-name set
] bind
] bind ;
: create ( name vocab -- word )
@ -115,7 +115,6 @@ USE: strings
"inference"
"inferior"
"interpreter"
"inspector"
"jedit"
"kernel"
"listener"

26
library/words.factor
View File

@ -29,6 +29,7 @@ IN: words
USE: generic
USE: hashtables
USE: kernel
USE: kernel-internals
USE: lists
USE: math
USE: namespaces
@ -36,17 +37,36 @@ USE: strings
BUILTIN: word 1
M: word hashcode word-hashcode ;
M: word hashcode 1 integer-slot ;
: word-xt ( w -- xt ) >word 2 integer-slot ; inline
: set-word-xt ( xt w -- ) >word 2 set-integer-slot ; inline
: word-primitive ( w -- n ) >word 3 integer-slot ; inline
: set-word-primitive ( n w -- )
>word [ 3 set-integer-slot ] keep update-xt ; inline
: word-parameter ( w -- obj ) >word 4 slot ; inline
: set-word-parameter ( obj w -- ) >word 4 set-slot ; inline
: word-plist ( w -- obj ) >word 5 slot ; inline
: set-word-plist ( obj w -- ) >word 5 set-slot ; inline
: call-count ( w -- n ) >word 6 integer-slot ; inline
: set-call-count ( n w -- ) >word 6 set-integer-slot ; inline
: allot-count ( w -- n ) >word 7 integer-slot ; inline
: set-allot-count ( n w -- ) >word 7 set-integer-slot ; inline
SYMBOL: vocabularies
: word-property ( word pname -- pvalue )
swap word-plist assoc ;
swap word-plist assoc ; inline
: set-word-property ( word pvalue pname -- )
pick word-plist
pick [ set-assoc ] [ remove-assoc nip ] ifte
swap set-word-plist ;
swap set-word-plist ; inline
PREDICATE: word compound ( obj -- ? ) word-primitive 1 = ;
PREDICATE: word primitive ( obj -- ? ) word-primitive 2 > ;

54
native/arithmetic.c
View File

@ -91,57 +91,3 @@ void primitive_arithmetic_type(void)
dpush(tag_fixnum(type));
}
bool realp(CELL tagged)
{
switch(type_of(tagged))
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
case RATIO_TYPE:
case FLOAT_TYPE:
return true;
break;
default:
return false;
break;
}
}
bool zerop(CELL tagged)
{
switch(type_of(tagged))
{
case FIXNUM_TYPE:
return tagged == 0;
case BIGNUM_TYPE:
return BIGNUM_ZERO_P((F_ARRAY*)UNTAG(tagged));
case FLOAT_TYPE:
return ((F_FLOAT*)UNTAG(tagged))->n == 0.0;
case RATIO_TYPE:
case COMPLEX_TYPE:
return false;
default:
type_error(NUMBER_TYPE,tagged);
return false; /* Can't happen */
}
}
bool onep(CELL tagged)
{
switch(type_of(tagged))
{
case FIXNUM_TYPE:
return tagged == tag_fixnum(1);
case BIGNUM_TYPE:
return BIGNUM_ONE_P((F_ARRAY*)UNTAG(tagged),0);
case FLOAT_TYPE:
return ((F_FLOAT*)UNTAG(tagged))->n == 1.0;
case RATIO_TYPE:
case COMPLEX_TYPE:
return false;
default:
type_error(NUMBER_TYPE,tagged);
return false; /* Can't happen */
}
}

5
native/arithmetic.h
View File

@ -1,8 +1,3 @@
#include "factor.h"
void primitive_arithmetic_type(void);
bool realp(CELL tagged);
bool zerop(CELL tagged);
bool onep(CELL tagged);

21
native/array.c
View File

@ -1,7 +1,7 @@
#include "factor.h"
/* untagged */
F_ARRAY* allot_array(CELL type, F_FIXNUM capacity)
F_ARRAY* allot_array(CELL type, CELL capacity)
{
F_ARRAY* array;
if(capacity < 0)
@ -12,7 +12,7 @@ F_ARRAY* allot_array(CELL type, F_FIXNUM capacity)
}
/* untagged */
F_ARRAY* array(F_FIXNUM capacity, CELL fill)
F_ARRAY* array(CELL capacity, CELL fill)
{
int i;
@ -24,12 +24,16 @@ F_ARRAY* array(F_FIXNUM capacity, CELL fill)
return array;
}
F_ARRAY* grow_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill)
F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill)
{
/* later on, do an optimization: if end of array is here, just grow */
int i;
F_ARRAY* new_array;
F_ARRAY* new_array = allot_array(untag_header(array->header),capacity);
if(array->capacity >= capacity)
return array;
new_array = allot_array(untag_header(array->header),capacity);
memcpy(new_array + 1,array + 1,array->capacity * CELLS);
@ -39,7 +43,14 @@ F_ARRAY* grow_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill)
return new_array;
}
F_ARRAY* shrink_array(F_ARRAY* array, F_FIXNUM capacity)
void primitive_grow_array(void)
{
F_ARRAY* array = untag_array(dpop());
CELL capacity = to_fixnum(dpop());
dpush(tag_object(grow_array(array,capacity,F)));
}
F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity)
{
F_ARRAY* new_array = allot_array(untag_header(array->header),capacity);
memcpy(new_array + 1,array + 1,capacity * CELLS);

9
native/array.h
View File

@ -10,10 +10,11 @@ INLINE F_ARRAY* untag_array(CELL tagged)
return (F_ARRAY*)UNTAG(tagged); /* FIXME */
}
F_ARRAY* allot_array(CELL type, F_FIXNUM capacity);
F_ARRAY* array(F_FIXNUM capacity, CELL fill);
F_ARRAY* grow_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill);
F_ARRAY* shrink_array(F_ARRAY* array, F_FIXNUM capacity);
F_ARRAY* allot_array(CELL type, CELL capacity);
F_ARRAY* array(CELL capacity, CELL fill);
F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill);
void primitive_grow_array(void);
F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity);
#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)

31
native/compiler.c
View File

@ -6,28 +6,6 @@ void init_compiler(void)
literal_top = compiling.base;
}
void check_compiled_offset(CELL offset)
{
if(offset < compiling.base || offset >= compiling.limit)
range_error(F,0,to_integer(offset),compiling.limit);
}
void primitive_set_compiled_byte(void)
{
CELL offset = unbox_integer();
BYTE b = to_fixnum(dpop());
check_compiled_offset(offset);
bput(offset,b);
}
void primitive_set_compiled_cell(void)
{
CELL offset = unbox_integer();
CELL c = to_fixnum(dpop());
check_compiled_offset(offset);
put(offset,c);
}
void primitive_compiled_offset(void)
{
box_integer(compiling.here);
@ -36,7 +14,6 @@ void primitive_compiled_offset(void)
void primitive_set_compiled_offset(void)
{
CELL offset = unbox_integer();
check_compiled_offset(offset);
compiling.here = offset;
}
@ -48,16 +25,12 @@ void primitive_literal_top(void)
void primitive_set_literal_top(void)
{
CELL offset = unbox_integer();
check_compiled_offset(offset);
literal_top = offset;
}
void collect_literals(void)
{
CELL i = compiling.base;
while(i < literal_top)
{
CELL i;
for(i = compiling.base; i < literal_top; i += CELLS)
copy_object((CELL*)i);
i += CELLS;
}
}

2
native/compiler.h
View File

@ -2,8 +2,6 @@ ZONE compiling;
CELL literal_top;
void init_compiler(void);
void primitive_set_compiled_byte(void);
void primitive_set_compiled_cell(void);
void primitive_compiled_offset(void);
void primitive_set_compiled_offset(void);
void primitive_literal_top(void);

64
native/complex.c
View File

@ -1,65 +1,15 @@
#include "factor.h"
void primitive_real(void)
{
switch(type_of(dpeek()))
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
case FLOAT_TYPE:
case RATIO_TYPE:
/* No op */
break;
case COMPLEX_TYPE:
drepl(untag_complex(dpeek())->real);
break;
default:
type_error(NUMBER_TYPE,dpeek());
break;
}
}
void primitive_imaginary(void)
{
switch(type_of(dpeek()))
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
case FLOAT_TYPE:
case RATIO_TYPE:
drepl(tag_fixnum(0));
break;
case COMPLEX_TYPE:
drepl(untag_complex(dpeek())->imaginary);
break;
default:
type_error(NUMBER_TYPE,dpeek());
break;
}
}
void primitive_from_rect(void)
{
CELL imaginary, real;
CELL imaginary = dpop();
CELL real = dpop();
F_COMPLEX* complex;
maybe_garbage_collection();
imaginary = dpop();
real = dpop();
if(!realp(imaginary))
type_error(REAL_TYPE,imaginary);
if(!realp(real))
type_error(REAL_TYPE,real);
if(zerop(imaginary))
dpush(real);
else
{
F_COMPLEX* complex = allot(sizeof(F_COMPLEX));
complex->real = real;
complex->imaginary = imaginary;
dpush(tag_complex(complex));
}
complex = allot(sizeof(F_COMPLEX));
complex->real = real;
complex->imaginary = imaginary;
dpush(tag_complex(complex));
}

8
native/complex.h
View File

@ -3,17 +3,9 @@ typedef struct {
CELL imaginary;
} F_COMPLEX;
INLINE F_COMPLEX* untag_complex(CELL tagged)
{
type_check(COMPLEX_TYPE,tagged);
return (F_COMPLEX*)UNTAG(tagged);
}
INLINE CELL tag_complex(F_COMPLEX* complex)
{
return RETAG(complex,COMPLEX_TYPE);
}
void primitive_real(void);
void primitive_imaginary(void);
void primitive_from_rect(void);

9
native/cons.c
View File

@ -17,12 +17,7 @@ void primitive_cons(void)
dpush(cons(car,cdr));
}
void primitive_car(void)
void primitive_to_cons(void)
{
drepl(car(dpeek()));
}
void primitive_cdr(void)
{
drepl(cdr(dpeek()));
type_check(CONS_TYPE,dpeek());
}

3
native/cons.h
View File

@ -27,5 +27,4 @@ INLINE CELL cdr(CELL cons)
}
void primitive_cons(void);
void primitive_car(void);
void primitive_cdr(void);
void primitive_to_cons(void);

2
native/factor.h
View File

@ -113,6 +113,7 @@ typedef unsigned char BYTE;
#include "word.h"
#include "run.h"
#include "signal.h"
#include "cons.h"
#include "fixnum.h"
#include "array.h"
#include "s48_bignumint.h"
@ -132,7 +133,6 @@ typedef unsigned char BYTE;
#include "write.h"
#include "file.h"
#include "socket.h"
#include "cons.h"
#include "image.h"
#include "primitives.h"
#include "vector.h"

12
native/float.c
View File

@ -59,18 +59,6 @@ void primitive_float_to_str(void)
box_c_string(tmp);
}
void primitive_float_to_bits(void)
{
double f;
int64_t f_raw;
maybe_garbage_collection();
f = untag_float(dpeek());
f_raw = *(int64_t*)&f;
drepl(tag_object(s48_long_long_to_bignum(f_raw)));
}
#define GC_AND_POP_FLOATS(x,y) \
double x, y; \
maybe_garbage_collection(); \

35
native/primitives.c
View File

@ -8,14 +8,9 @@ XT primitives[] = {
primitive_call,
primitive_ifte,
primitive_cons,
primitive_car,
primitive_cdr,
primitive_vector,
primitive_vector_length,
primitive_set_vector_length,
primitive_vector_nth,
primitive_set_vector_nth,
primitive_string_length,
primitive_string_nth,
primitive_string_compare,
primitive_string_eq,
@ -38,14 +33,9 @@ XT primitives[] = {
primitive_to_fixnum,
primitive_to_bignum,
primitive_to_float,
primitive_numerator,
primitive_denominator,
primitive_from_fraction,
primitive_str_to_float,
primitive_float_to_str,
primitive_float_to_bits,
primitive_real,
primitive_imaginary,
primitive_from_rect,
primitive_fixnum_eq,
primitive_fixnum_add,
@ -103,21 +93,9 @@ XT primitives[] = {
primitive_fsinh,
primitive_fsqrt,
primitive_word,
primitive_word_hashcode,
primitive_word_xt,
primitive_set_word_xt,
primitive_word_primitive,
primitive_set_word_primitive,
primitive_word_parameter,
primitive_set_word_parameter,
primitive_word_plist,
primitive_set_word_plist,
primitive_update_xt,
primitive_call_profiling,
primitive_word_call_count,
primitive_set_word_call_count,
primitive_allot_profiling,
primitive_word_allot_count,
primitive_set_word_allot_count,
primitive_word_compiledp,
primitive_drop,
primitive_dup,
@ -167,8 +145,6 @@ XT primitives[] = {
primitive_cd,
primitive_compiled_offset,
primitive_set_compiled_offset,
primitive_set_compiled_cell,
primitive_set_compiled_byte,
primitive_literal_top,
primitive_set_literal_top,
primitive_address,
@ -192,6 +168,15 @@ XT primitives[] = {
primitive_memory_to_string,
primitive_local_alienp,
primitive_alien_address,
primitive_to_cons,
primitive_to_vector,
primitive_to_string,
primitive_to_word,
primitive_slot,
primitive_set_slot,
primitive_integer_slot,
primitive_set_integer_slot,
primitive_grow_array
};
CELL primitive_to_xt(CELL primitive)

2
native/primitives.h
View File

@ -1,4 +1,4 @@
extern XT primitives[];
#define PRIMITIVE_COUNT 192
#define PRIMITIVE_COUNT 195
CELL primitive_to_xt(CELL primitive);

55
native/ratio.c
View File

@ -4,55 +4,14 @@
library implementation, to avoid breaking invariants. */
void primitive_from_fraction(void)
{
CELL numerator, denominator;
CELL denominator = dpop();
CELL numerator = dpop();
F_RATIO* ratio;
maybe_garbage_collection();
denominator = dpop();
numerator = dpop();
if(zerop(denominator))
raise(SIGFPE);
if(onep(denominator))
dpush(numerator);
else
{
F_RATIO* ratio = allot(sizeof(F_RATIO));
ratio->numerator = numerator;
ratio->denominator = denominator;
dpush(tag_ratio(ratio));
}
}
void primitive_numerator(void)
{
switch(type_of(dpeek()))
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
/* No op */
break;
case RATIO_TYPE:
drepl(untag_ratio(dpeek())->numerator);
break;
default:
type_error(RATIONAL_TYPE,dpeek());
break;
}
}
void primitive_denominator(void)
{
switch(type_of(dpeek()))
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
drepl(tag_fixnum(1));
break;
case RATIO_TYPE:
drepl(untag_ratio(dpeek())->denominator);
break;
default:
type_error(RATIONAL_TYPE,dpeek());
break;
}
ratio = allot(sizeof(F_RATIO));
ratio->numerator = numerator;
ratio->denominator = denominator;
dpush(tag_ratio(ratio));
}

8
native/ratio.h
View File

@ -3,17 +3,9 @@ typedef struct {
CELL denominator;
} F_RATIO;
INLINE F_RATIO* untag_ratio(CELL tagged)
{
type_check(RATIO_TYPE,tagged);
return (F_RATIO*)UNTAG(tagged);
}
INLINE CELL tag_ratio(F_RATIO* ratio)
{
return RETAG(ratio,RATIO_TYPE);
}
void primitive_numerator(void);
void primitive_denominator(void);
void primitive_from_fraction(void);

2
native/sbuf.c
View File

@ -168,7 +168,7 @@ void primitive_sbuf_eq(void)
{
F_SBUF* s1 = untag_sbuf(dpop());
CELL with = dpop();
if(typep(SBUF_TYPE,with))
if(type_of(with) == SBUF_TYPE)
dpush(tag_boolean(sbuf_eq(s1,(F_SBUF*)UNTAG(with))));
else
dpush(F);

12
native/string.c
View File

@ -139,11 +139,6 @@ BYTE* unbox_c_string(void)
return to_c_string(untag_string(dpop()));
}
void primitive_string_length(void)
{
drepl(tag_fixnum(untag_string(dpeek())->capacity));
}
void primitive_string_nth(void)
{
F_STRING* string = untag_string(dpop());
@ -205,7 +200,7 @@ void primitive_string_eq(void)
{
F_STRING* s1 = untag_string(dpop());
CELL with = dpop();
if(typep(STRING_TYPE,with))
if(type_of(with) == STRING_TYPE)
dpush(tag_boolean(string_eq(s1,(F_STRING*)UNTAG(with))));
else
dpush(F);
@ -349,3 +344,8 @@ void primitive_string_reverse(void)
rehash_string(s);
drepl(tag_object(s));
}
void primitive_to_string(void)
{
type_check(STRING_TYPE,dpeek());
}

2
native/string.h
View File

@ -42,7 +42,6 @@ INLINE void set_string_nth(F_STRING* string, CELL index, uint16_t value)
cput(SREF(string,index),value);
}
void primitive_string_length(void);
void primitive_string_nth(void);
F_FIXNUM string_compare_head(F_STRING* s1, F_STRING* s2, CELL len);
F_FIXNUM string_compare(F_STRING* s1, F_STRING* s2);
@ -54,3 +53,4 @@ void primitive_substring(void);
void string_reverse(F_STRING* s, int len);
F_STRING* string_clone(F_STRING* s, int len);
void primitive_string_reverse(void);
void primitive_to_string(void);

37
native/types.c
View File

@ -1,10 +1,5 @@
#include "factor.h"
bool typep(CELL type, CELL tagged)
{
return type_of(tagged) == type;
}
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
@ -102,3 +97,35 @@ void primitive_type(void)
{
drepl(tag_fixnum(type_of(dpeek())));
}
#define SLOT(obj,slot) UNTAG(obj) + slot * CELLS
void primitive_slot(void)
{
F_FIXNUM slot = untag_fixnum_fast(dpop());
CELL obj = dpop();
dpush(get(SLOT(obj,slot)));
}
void primitive_set_slot(void)
{
F_FIXNUM slot = untag_fixnum_fast(dpop());
CELL obj = dpop();
CELL value = dpop();
put(SLOT(obj,slot),value);
}
void primitive_integer_slot(void)
{
F_FIXNUM slot = untag_fixnum_fast(dpop());
CELL obj = dpop();
dpush(tag_integer(get(SLOT(obj,slot))));
}
void primitive_set_integer_slot(void)
{
F_FIXNUM slot = untag_fixnum_fast(dpop());
CELL obj = dpop();
F_FIXNUM value = to_integer(dpop());
put(SLOT(obj,slot),value);
}

10
native/types.h
View File

@ -38,13 +38,8 @@ CELL T;
/* Pseudo-types. For error reporting only. */
#define INTEGER_TYPE 100 /* F_FIXNUM or BIGNUM */
#define RATIONAL_TYPE 101 /* INTEGER or F_RATIO */
#define REAL_TYPE 102 /* RATIONAL or F_FLOAT */
#define NUMBER_TYPE 103 /* F_COMPLEX or REAL */
#define TEXT_TYPE 104 /* F_FIXNUM or F_STRING */
bool typep(CELL type, CELL tagged);
INLINE CELL tag_header(CELL cell)
{
return RETAG(cell << TAG_BITS,HEADER_TYPE);
@ -117,3 +112,8 @@ INLINE CELL type_of(CELL tagged)
else
return tag;
}
void primitive_slot(void);
void primitive_set_slot(void);
void primitive_integer_slot(void);
void primitive_set_integer_slot(void);

4
native/unix/io.c
View File

@ -126,7 +126,7 @@ bool set_up_fd_set(fd_set* fdset, int fd_count, IO_TASK* io_tasks,
for(i = 0; i < fd_count; i++)
{
if(typep(PORT_TYPE,io_tasks[i].port))
if(type_of(io_tasks[i].port) == PORT_TYPE)
{
if(untag_port(io_tasks[i].port)->closed)
*closed = true;
@ -205,7 +205,7 @@ CELL perform_io_tasks(fd_set* fdset, IO_TASK* io_tasks, int* fd_count)
{
IO_TASK io_task = io_tasks[i];
if(typep(PORT_TYPE,io_task.port))
if(type_of(io_task.port) == PORT_TYPE)
{
F_PORT* port = untag_port(io_task.port);
if(port->closed)

23
native/vector.c
View File

@ -14,28 +14,9 @@ void primitive_vector(void)
drepl(tag_object(vector(to_fixnum(dpeek()))));
}
void primitive_vector_length(void)
void primitive_to_vector(void)
{
drepl(tag_fixnum(untag_vector(dpeek())->top));
}
void primitive_set_vector_length(void)
{
F_VECTOR* vector;
F_FIXNUM length;
F_ARRAY* array;
maybe_garbage_collection();
vector = untag_vector(dpop());
length = to_fixnum(dpop());
array = untag_array(vector->array);
if(length < 0)
range_error(tag_object(vector),0,tag_fixnum(length),vector->top);
vector->top = length;
if(length > array->capacity)
vector->array = tag_object(grow_array(array,length,F));
type_check(VECTOR_TYPE,dpeek());
}
void primitive_vector_nth(void)

3
native/vector.h
View File

@ -16,8 +16,7 @@ INLINE F_VECTOR* untag_vector(CELL tagged)
F_VECTOR* vector(F_FIXNUM capacity);
void primitive_vector(void);
void primitive_vector_length(void);
void primitive_set_vector_length(void);
void primitive_to_vector(void);
void primitive_vector_nth(void);
void vector_ensure_capacity(F_VECTOR* vector, CELL index);
void primitive_set_vector_nth(void);

106
native/word.c
View File

@ -1,19 +1,5 @@
#include "factor.h"
F_WORD* word(CELL primitive, CELL parameter, CELL plist)
{
F_WORD* word = allot_object(WORD_TYPE,sizeof(F_WORD));
word->hashcode = (CELL)word; /* initial address */
word->xt = primitive_to_xt(primitive);
word->primitive = primitive;
word->parameter = parameter;
word->plist = plist;
word->call_count = 0;
word->allot_count = 0;
return word;
}
/* When a word is executed we jump to the value of the xt field. However this
value is an unportable function pointer, so in the image we store a primitive
number that indexes a list of xts. */
@ -25,87 +11,24 @@ void update_xt(F_WORD* word)
/* <word> ( primitive parameter plist -- word ) */
void primitive_word(void)
{
CELL plist, parameter;
F_FIXNUM primitive;
F_WORD* word;
maybe_garbage_collection();
plist = dpop();
parameter = dpop();
primitive = to_fixnum(dpop());
dpush(tag_word(word(primitive,parameter,plist)));
word = allot_object(WORD_TYPE,sizeof(F_WORD));
word->hashcode = (CELL)word; /* initial address */
word->xt = (CELL)undefined;
word->primitive = 0;
word->parameter = F;
word->plist = F;
word->call_count = 0;
word->allot_count = 0;
dpush(tag_word(word));
}
void primitive_word_hashcode(void)
void primitive_update_xt(void)
{
drepl(tag_fixnum(untag_word(dpeek())->hashcode));
}
void primitive_word_xt(void)
{
drepl(tag_cell(untag_word(dpeek())->xt));
}
void primitive_set_word_xt(void)
{
F_WORD* word = untag_word(dpop());
word->xt = unbox_integer();
}
void primitive_word_primitive(void)
{
drepl(tag_fixnum(untag_word(dpeek())->primitive));
}
void primitive_set_word_primitive(void)
{
F_WORD* word = untag_word(dpop());
word->primitive = to_fixnum(dpop());
update_xt(word);
}
void primitive_word_parameter(void)
{
drepl(untag_word(dpeek())->parameter);
}
void primitive_set_word_parameter(void)
{
F_WORD* word = untag_word(dpop());
word->parameter = dpop();
}
void primitive_word_plist(void)
{
drepl(untag_word(dpeek())->plist);
}
void primitive_set_word_plist(void)
{
F_WORD* word = untag_word(dpop());
word->plist = dpop();
}
void primitive_word_call_count(void)
{
drepl(tag_cell(untag_word(dpeek())->call_count));
}
void primitive_set_word_call_count(void)
{
F_WORD* word = untag_word(dpop());
word->call_count = to_fixnum(dpop());
}
void primitive_word_allot_count(void)
{
drepl(tag_cell(untag_word(dpeek())->allot_count));
}
void primitive_set_word_allot_count(void)
{
F_WORD* word = untag_word(dpop());
word->allot_count = to_fixnum(dpop());
update_xt(untag_word(dpop()));
}
void primitive_word_compiledp(void)
@ -114,6 +37,11 @@ void primitive_word_compiledp(void)
box_boolean(word->xt != (CELL)docol && word->xt != (CELL)dosym);
}
void primitive_to_word(void)
{
type_check(WORD_TYPE,dpeek());
}
void fixup_word(F_WORD* word)
{
update_xt(word);

16
native/word.h
View File

@ -30,22 +30,10 @@ INLINE CELL tag_word(F_WORD* word)
return RETAG(word,WORD_TYPE);
}
F_WORD* word(CELL primitive, CELL parameter, CELL plist);
void update_xt(F_WORD* word);
void primitive_word(void);
void primitive_word_hashcode(void);
void primitive_word_primitive(void);
void primitive_set_word_primitive(void);
void primitive_word_xt(void);
void primitive_set_word_xt(void);
void primitive_word_parameter(void);
void primitive_set_word_parameter(void);
void primitive_word_plist(void);
void primitive_set_word_plist(void);
void primitive_word_call_count(void);
void primitive_set_word_call_count(void);
void primitive_word_allot_count(void);
void primitive_set_word_allot_count(void);
void primitive_update_xt(void);
void primitive_word_compiledp(void);
void primitive_to_word(void);
void fixup_word(F_WORD* word);
void collect_word(F_WORD* word);