From 1fe15b322d4811d8323c9333d7c7dcdb12fc2c1a Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Fri, 21 Dec 2007 11:38:25 +1300
Subject: [PATCH 01/65] Fix number/sequence error in match-replace
---
extra/match/match.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/extra/match/match.factor b/extra/match/match.factor
index 527d7f2465..a80001e724 100755
--- a/extra/match/match.factor
+++ b/extra/match/match.factor
@@ -54,6 +54,7 @@ MACRO: match-cond ( assoc -- )
: replace-patterns ( object -- result )
{
+ { [ dup number? ] [ ] }
{ [ dup match-var? ] [ get ] }
{ [ dup sequence? ] [ [ replace-patterns ] map ] }
{ [ dup tuple? ] [ tuple>array replace-patterns >tuple ] }
From e7cf83a57a16ae4bb34be7c04b0f26a8c1672561 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Fri, 21 Dec 2007 13:16:14 +1300
Subject: [PATCH 02/65] First attempt at compiling peg parsers to quotations
---
extra/peg/peg.factor | 266 +++++++++++++++++++++++++++----------------
1 file changed, 169 insertions(+), 97 deletions(-)
diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor
index 411a47b9bd..3d9128fec9 100644
--- a/extra/peg/peg.factor
+++ b/extra/peg/peg.factor
@@ -1,12 +1,16 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle
- vectors arrays combinators.lib memoize math.parser ;
+ vectors arrays combinators.lib memoize math.parser match ;
IN: peg
TUPLE: parse-result remaining ast ;
-GENERIC: (parse) ( state parser -- result )
+GENERIC: compile ( parser -- quot )
+
+: (parse) ( state parser -- result )
+ compile call ;
+
<PRIVATE
@@ -72,135 +76,199 @@ PRIVATE>
TUPLE: token-parser symbol ;
-M: token-parser (parse) ( input parser -- result )
- token-parser-symbol 2dup head? [
- dup >r length tail-slice r> <parse-result>
- ] [
- 2drop f
- ] if ;
-
-TUPLE: satisfy-parser quot ;
+MATCH-VARS: ?token ;
-M: satisfy-parser (parse) ( state parser -- result )
- over empty? [
- 2drop f
- ] [
- satisfy-parser-quot [ unclip-slice dup ] dip call [
- <parse-result>
+: token-pattern ( -- quot )
+ [
+ ?token 2dup head? [
+ dup >r length tail-slice r> <parse-result>
] [
2drop f
- ] if
- ] if ;
+ ] if
+ ] ;
+
+M: token-parser compile ( parser -- quot )
+ token-parser-symbol \ ?token token-pattern match-replace ;
+
+TUPLE: satisfy-parser quot ;
+
+MATCH-VARS: ?quot ;
+
+: satisfy-pattern ( -- quot )
+ [
+ dup empty? [
+ drop f
+ ] [
+ unclip-slice dup ?quot call [
+ <parse-result>
+ ] [
+ 2drop f
+ ] if
+ ] if
+ ] ;
+
+M: satisfy-parser compile ( parser -- quot )
+ satisfy-parser-quot \ ?quot satisfy-pattern match-replace ;
TUPLE: range-parser min max ;
-M: range-parser (parse) ( state parser -- result )
- over empty? [
- 2drop f
- ] [
- 0 pick nth dup rot
- { range-parser-min range-parser-max } get-slots between? [
- [ 1 tail-slice ] dip <parse-result>
+MATCH-VARS: ?min ?max ;
+
+: range-pattern ( -- quot )
+ [
+ dup empty? [
+ drop f
] [
- 2drop f
- ] if
- ] if ;
+ 0 over nth dup
+ ?min ?max between? [
+ [ 1 tail-slice ] dip <parse-result>
+ ] [
+ 2drop f
+ ] if
+ ] if
+ ] ;
+
+M: range-parser compile ( parser -- quot )
+ T{ range-parser _ ?min ?max } range-pattern match-replace ;
TUPLE: seq-parser parsers ;
-: do-seq-parser ( result parser -- result )
- [ dup parse-result-remaining ] dip parse [
- [ parse-result-remaining swap set-parse-result-remaining ] 2keep
- parse-result-ast dup ignore = [ drop ] [ swap [ parse-result-ast push ] keep ] if
- ] [
- drop f
- ] if* ;
+: seq-pattern ( -- quot )
+ [
+ dup [
+ dup parse-result-remaining ?quot call [
+ [ parse-result-remaining swap set-parse-result-remaining ] 2keep
+ parse-result-ast dup ignore = [
+ drop
+ ] [
+ swap [ parse-result-ast push ] keep
+ ] if
+ ] [
+ drop f
+ ] if*
+ ] [
+ drop f
+ ] if
+ ] ;
-: (seq-parser) ( result parsers -- result )
- dup empty? not pick and [
- unclip swap [ do-seq-parser ] dip (seq-parser)
- ] [
- drop
- ] if ;
-
-M: seq-parser (parse) ( state parser -- result )
- seq-parser-parsers [ V{ } clone <parse-result> ] dip (seq-parser) ;
+M: seq-parser compile ( parser -- quot )
+ [
+ [ V{ } clone <parse-result> ] %
+ seq-parser-parsers [ compile \ ?quot seq-pattern match-replace % ] each
+ ] [ ] make ;
TUPLE: choice-parser parsers ;
-
-: (choice-parser) ( state parsers -- result )
- dup empty? [
- 2drop f
- ] [
- unclip pick swap parse [
- 2nip
- ] [
- (choice-parser)
- ] if*
- ] if ;
-M: choice-parser (parse) ( state parser -- result )
- choice-parser-parsers (choice-parser) ;
+: choice-pattern ( -- quot )
+ [
+ dup [
+
+ ] [
+ drop dup ?quot call
+ ] if
+ ] ;
+
+M: choice-parser compile ( parser -- quot )
+ [
+ f ,
+ choice-parser-parsers [ compile \ ?quot choice-pattern match-replace % ] each
+ \ nip ,
+ ] [ ] make ;
TUPLE: repeat0-parser p1 ;
-: (repeat-parser) ( parser result -- result )
- 2dup parse-result-remaining swap parse [
+: (repeat0) ( quot result -- result )
+ 2dup parse-result-remaining swap call [
[ parse-result-remaining swap set-parse-result-remaining ] 2keep
parse-result-ast swap [ parse-result-ast push ] keep
- (repeat-parser)
+ (repeat0)
] [
nip
- ] if* ;
+ ] if* ; inline
-: clone-result ( result -- result )
- { parse-result-remaining parse-result-ast }
- get-slots 1vector <parse-result> ;
+: repeat0-pattern ( -- quot )
+ [
+ ?quot swap (repeat0)
+ ] ;
-M: repeat0-parser (parse) ( state parser -- result )
- repeat0-parser-p1 2dup parse [
- nipd clone-result (repeat-parser)
- ] [
- drop V{ } clone <parse-result>
- ] if* ;
+M: repeat0-parser compile ( parser -- quot )
+ [
+ [ V{ } clone <parse-result> ] %
+ repeat0-parser-p1 compile \ ?quot repeat0-pattern match-replace %
+ ] [ ] make ;
TUPLE: repeat1-parser p1 ;
-M: repeat1-parser (parse) ( state parser -- result )
- repeat1-parser-p1 tuck parse dup [ clone-result (repeat-parser) ] [ nip ] if ;
+: repeat1-pattern ( -- quot )
+ [
+ ?quot swap (repeat0) [
+ dup parse-result-ast empty? [
+ drop f
+ ] when
+ ] [
+ f
+ ] if*
+ ] ;
+
+M: repeat1-parser compile ( parser -- quot )
+ [
+ [ V{ } clone <parse-result> ] %
+ repeat1-parser-p1 compile \ ?quot repeat1-pattern match-replace %
+ ] [ ] make ;
TUPLE: optional-parser p1 ;
-M: optional-parser (parse) ( state parser -- result )
- dupd optional-parser-p1 parse swap f <parse-result> or ;
+: optional-pattern ( -- quot )
+ [
+ dup ?quot call swap f <parse-result> or
+ ] ;
+
+M: optional-parser compile ( parser -- quot )
+ optional-parser-p1 compile \ ?quot optional-pattern match-replace ;
TUPLE: ensure-parser p1 ;
-M: ensure-parser (parse) ( state parser -- result )
- dupd ensure-parser-p1 parse [
- ignore <parse-result>
- ] [
- drop f
- ] if ;
+: ensure-pattern ( -- quot )
+ [
+ dup ?quot call [
+ ignore <parse-result>
+ ] [
+ drop f
+ ] if
+ ] ;
+
+M: ensure-parser compile ( parser -- quot )
+ ensure-parser-p1 compile \ ?quot ensure-pattern match-replace ;
TUPLE: ensure-not-parser p1 ;
-M: ensure-not-parser (parse) ( state parser -- result )
- dupd ensure-not-parser-p1 parse [
- drop f
- ] [
- ignore <parse-result>
- ] if ;
+: ensure-not-pattern ( -- quot )
+ [
+ dup ?quot call [
+ drop f
+ ] [
+ ignore <parse-result>
+ ] if
+ ] ;
+
+M: ensure-not-parser compile ( parser -- quot )
+ ensure-not-parser-p1 compile \ ?quot ensure-not-pattern match-replace ;
TUPLE: action-parser p1 quot ;
-M: action-parser (parse) ( state parser -- result )
- tuck action-parser-p1 parse dup [
- dup parse-result-ast rot action-parser-quot call
- swap [ set-parse-result-ast ] keep
- ] [
- nip
- ] if ;
+MATCH-VARS: ?action ;
+
+: action-pattern ( -- quot )
+ [
+ ?quot call dup [
+ dup parse-result-ast ?action call
+ swap [ set-parse-result-ast ] keep
+ ] when
+ ] ;
+
+M: action-parser compile ( parser -- quot )
+ { action-parser-p1 action-parser-quot } get-slots [ compile ] dip
+ 2array { ?quot ?action } action-pattern match-replace ;
: left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace
@@ -211,13 +279,17 @@ M: action-parser (parse) ( state parser -- result )
TUPLE: sp-parser p1 ;
-M: sp-parser (parse) ( state parser -- result )
- [ left-trim-slice ] dip sp-parser-p1 parse ;
+M: sp-parser compile ( parser -- quot )
+ [
+ \ left-trim-slice , sp-parser-p1 compile %
+ ] [ ] make ;
TUPLE: delay-parser quot ;
-M: delay-parser (parse) ( state parser -- result )
- delay-parser-quot call parse ;
+M: delay-parser compile ( parser -- quot )
+ [
+ delay-parser-quot % \ compile , \ call ,
+ ] [ ] make ;
PRIVATE>
From ffd25ce5a81628c9a0f012188dc87c9c78aee261 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Fri, 21 Dec 2007 13:24:14 +1300
Subject: [PATCH 03/65] Fix missing vocab in match
---
extra/match/match.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/match/match.factor b/extra/match/match.factor
index a80001e724..421aa926f9 100755
--- a/extra/match/match.factor
+++ b/extra/match/match.factor
@@ -3,7 +3,7 @@
!
! Based on pattern matching code from Paul Graham's book 'On Lisp'.
USING: parser kernel words namespaces sequences tuples
-combinators macros assocs ;
+combinators macros assocs math ;
IN: match
SYMBOL: _
From e0caf654e6c56de827cf6ae98565873909cc2409 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 12 Jan 2008 22:58:56 -0800
Subject: [PATCH 04/65] OpenGL 2.1 support
---
core/alien/syntax/syntax.factor | 9 +
extra/opengl/gl/gl.factor | 858 +++++++++++++++++++------
extra/opengl/gl/unix/unix.factor | 5 +
extra/opengl/gl/windows/windows.factor | 18 +
extra/opengl/opengl.factor | 101 ++-
5 files changed, 809 insertions(+), 182 deletions(-)
create mode 100644 extra/opengl/gl/unix/unix.factor
create mode 100644 extra/opengl/gl/windows/windows.factor
diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor
index 99275d02bf..bc3bc911ef 100755
--- a/core/alien/syntax/syntax.factor
+++ b/core/alien/syntax/syntax.factor
@@ -23,6 +23,15 @@ IN: alien.syntax
PRIVATE>
+: indirect-quot ( function-ptr-quot return types abi -- quot )
+ [ alien-indirect ] 3curry compose ;
+
+: define-indirect ( abi return function-ptr-quot function-name parameters -- )
+ >r pick r> parse-arglist
+ rot create-in dup reset-generic
+ >r >r swapd roll indirect-quot r> r>
+ -rot define-declared ;
+
: DLL" skip-blank parse-string dlopen parsed ; parsing
: ALIEN: scan string>number <alien> parsed ; parsing
diff --git a/extra/opengl/gl/gl.factor b/extra/opengl/gl/gl.factor
index 40ead55ddd..c7ce176aca 100644
--- a/extra/opengl/gl/gl.factor
+++ b/extra/opengl/gl/gl.factor
@@ -3,7 +3,10 @@
! This file is based on the gl.h that comes with xorg-x11 6.8.2
-USING: alien alien.syntax kernel sequences words ;
+USING: alien alien.syntax kernel sequences system words ;
+USE-IF: windows? opengl.gl.windows
+USE-IF: unix? opengl.gl.unix
+
IN: opengl.gl
TYPEDEF: uint GLenum
@@ -1118,195 +1121,690 @@ FUNCTION: void glPushName ( GLuint name ) ;
FUNCTION: void glPopName ( ) ;
+! OpenGL extension functions
+
+
+
+
+
! OpenGL 1.2
-: GL_PACK_SKIP_IMAGES HEX: 806B ; inline
-: GL_PACK_IMAGE_HEIGHT HEX: 806C ; inline
-: GL_UNPACK_SKIP_IMAGES HEX: 806D ; inline
-: GL_UNPACK_IMAGE_HEIGHT HEX: 806E ; inline
-: GL_TEXTURE_3D HEX: 806F ; inline
-: GL_PROXY_TEXTURE_3D HEX: 8070 ; inline
-: GL_TEXTURE_DEPTH HEX: 8071 ; inline
-: GL_TEXTURE_WRAP_R HEX: 8072 ; inline
-: GL_MAX_3D_TEXTURE_SIZE HEX: 8073 ; inline
-: GL_BGR HEX: 80E0 ; inline
-: GL_BGRA HEX: 80E1 ; inline
-: GL_UNSIGNED_BYTE_3_3_2 HEX: 8032 ; inline
-: GL_UNSIGNED_BYTE_2_3_3_REV HEX: 8362 ; inline
-: GL_UNSIGNED_SHORT_5_6_5 HEX: 8363 ; inline
-: GL_UNSIGNED_SHORT_5_6_5_REV HEX: 8364 ; inline
-: GL_UNSIGNED_SHORT_4_4_4_4 HEX: 8033 ; inline
-: GL_UNSIGNED_SHORT_4_4_4_4_REV HEX: 8365 ; inline
-: GL_UNSIGNED_SHORT_5_5_5_1 HEX: 8034 ; inline
-: GL_UNSIGNED_SHORT_1_5_5_5_REV HEX: 8366 ; inline
-: GL_UNSIGNED_INT_8_8_8_8 HEX: 8035 ; inline
-: GL_UNSIGNED_INT_8_8_8_8_REV HEX: 8367 ; inline
-: GL_UNSIGNED_INT_10_10_10_2 HEX: 8036 ; inline
-: GL_UNSIGNED_INT_2_10_10_10_REV HEX: 8368 ; inline
-: GL_RESCALE_NORMAL HEX: 803A ; inline
-: GL_LIGHT_MODEL_COLOR_CONTROL HEX: 81F8 ; inline
-: GL_SINGLE_COLOR HEX: 81F9 ; inline
-: GL_SEPARATE_SPECULAR_COLOR HEX: 81FA ; inline
-: GL_CLAMP_TO_EDGE HEX: 812F ; inline
-: GL_TEXTURE_MIN_LOD HEX: 813A ; inline
-: GL_TEXTURE_MAX_LOD HEX: 813B ; inline
-: GL_TEXTURE_BASE_LEVEL HEX: 813C ; inline
-: GL_TEXTURE_MAX_LEVEL HEX: 813D ; inline
-: GL_MAX_ELEMENTS_VERTICES HEX: 80E8 ; inline
-: GL_MAX_ELEMENTS_INDICES HEX: 80E9 ; inline
-: GL_ALIASED_POINT_SIZE_RANGE HEX: 846D ; inline
-: GL_ALIASED_LINE_WIDTH_RANGE HEX: 846E ; inline
+: GL_SMOOTH_POINT_SIZE_RANGE HEX: 0B12 ; inline
+: GL_SMOOTH_POINT_SIZE_GRANULARITY HEX: 0B13 ; inline
+: GL_SMOOTH_LINE_WIDTH_RANGE HEX: 0B22 ; inline
+: GL_SMOOTH_LINE_WIDTH_GRANULARITY HEX: 0B23 ; inline
+: GL_UNSIGNED_BYTE_3_3_2 HEX: 8032 ; inline
+: GL_UNSIGNED_SHORT_4_4_4_4 HEX: 8033 ; inline
+: GL_UNSIGNED_SHORT_5_5_5_1 HEX: 8034 ; inline
+: GL_UNSIGNED_INT_8_8_8_8 HEX: 8035 ; inline
+: GL_UNSIGNED_INT_10_10_10_2 HEX: 8036 ; inline
+: GL_RESCALE_NORMAL HEX: 803A ; inline
+: GL_TEXTURE_BINDING_3D HEX: 806A ; inline
+: GL_PACK_SKIP_IMAGES HEX: 806B ; inline
+: GL_PACK_IMAGE_HEIGHT HEX: 806C ; inline
+: GL_UNPACK_SKIP_IMAGES HEX: 806D ; inline
+: GL_UNPACK_IMAGE_HEIGHT HEX: 806E ; inline
+: GL_TEXTURE_3D HEX: 806F ; inline
+: GL_PROXY_TEXTURE_3D HEX: 8070 ; inline
+: GL_TEXTURE_DEPTH HEX: 8071 ; inline
+: GL_TEXTURE_WRAP_R HEX: 8072 ; inline
+: GL_MAX_3D_TEXTURE_SIZE HEX: 8073 ; inline
+: GL_BGR HEX: 80E0 ; inline
+: GL_BGRA HEX: 80E1 ; inline
+: GL_MAX_ELEMENTS_VERTICES HEX: 80E8 ; inline
+: GL_MAX_ELEMENTS_INDICES HEX: 80E9 ; inline
+: GL_CLAMP_TO_EDGE HEX: 812F ; inline
+: GL_TEXTURE_MIN_LOD HEX: 813A ; inline
+: GL_TEXTURE_MAX_LOD HEX: 813B ; inline
+: GL_TEXTURE_BASE_LEVEL HEX: 813C ; inline
+: GL_TEXTURE_MAX_LEVEL HEX: 813D ; inline
+: GL_LIGHT_MODEL_COLOR_CONTROL HEX: 81F8 ; inline
+: GL_SINGLE_COLOR HEX: 81F9 ; inline
+: GL_SEPARATE_SPECULAR_COLOR HEX: 81FA ; inline
+: GL_UNSIGNED_BYTE_2_3_3_REV HEX: 8362 ; inline
+: GL_UNSIGNED_SHORT_5_6_5 HEX: 8363 ; inline
+: GL_UNSIGNED_SHORT_5_6_5_REV HEX: 8364 ; inline
+: GL_UNSIGNED_SHORT_4_4_4_4_REV HEX: 8365 ; inline
+: GL_UNSIGNED_SHORT_1_5_5_5_REV HEX: 8366 ; inline
+: GL_UNSIGNED_INT_8_8_8_8_REV HEX: 8367 ; inline
+: GL_UNSIGNED_INT_2_10_10_10_REV HEX: 8368 ; inline
+: GL_ALIASED_POINT_SIZE_RANGE HEX: 846D ; inline
+: GL_ALIASED_LINE_WIDTH_RANGE HEX: 846E ; inline
-! Not present on Windows
-! FUNCTION: void glDrawRangeElements ( GLenum mode, GLuint start, GLuint end, GLsizei count, GLenum type, GLvoid* indices ) ;
+GL-FUNCTION: void glCopyTexSubImage3D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLint x, GLint y, GLsizei width, GLsizei height ) ;
+GL-FUNCTION: void glDrawRangeElements ( GLenum mode, GLuint start, GLuint end, GLsizei count, GLenum type, GLvoid* indices ) ;
+GL-FUNCTION: void glTexImage3D ( GLenum target, GLint level, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLenum format, GLenum type, GLvoid* pixels ) ;
+GL-FUNCTION: void glTexSubImage3D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, GLvoid* pixels ) ;
-! FUNCTION: void glTexImage3D ( GLenum target, GLint level, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLenum format, GLenum type, GLvoid* pixels ) ;
-
-! FUNCTION: void glTexSubImage3D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, GLvoid* pixels ) ;
-
-! FUNCTION: void glCopyTexSubImage3D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLint x, GLint y, GLsizei width, GLsizei height ) ;
-
-! TODO: the rest. looks fiddly
! OpenGL 1.3
-: GL_ACTIVE_TEXTURE HEX: 84E0 ; inline
-: GL_CLIENT_ACTIVE_TEXTURE HEX: 84E1 ; inline
-: GL_MAX_TEXTURE_UNITS HEX: 84E2 ; inline
-: GL_TEXTURE0 HEX: 84C0 ; inline
-: GL_TEXTURE1 HEX: 84C1 ; inline
-: GL_TEXTURE2 HEX: 84C2 ; inline
-: GL_TEXTURE3 HEX: 84C3 ; inline
-: GL_TEXTURE4 HEX: 84C4 ; inline
-: GL_TEXTURE5 HEX: 84C5 ; inline
-: GL_TEXTURE6 HEX: 84C6 ; inline
-: GL_TEXTURE7 HEX: 84C7 ; inline
-: GL_TEXTURE8 HEX: 84C8 ; inline
-: GL_TEXTURE9 HEX: 84C9 ; inline
-: GL_TEXTURE10 HEX: 84CA ; inline
-: GL_TEXTURE11 HEX: 84CB ; inline
-: GL_TEXTURE12 HEX: 84CC ; inline
-: GL_TEXTURE13 HEX: 84CD ; inline
-: GL_TEXTURE14 HEX: 84CE ; inline
-: GL_TEXTURE15 HEX: 84CF ; inline
-: GL_TEXTURE16 HEX: 84D0 ; inline
-: GL_TEXTURE17 HEX: 84D1 ; inline
-: GL_TEXTURE18 HEX: 84D2 ; inline
-: GL_TEXTURE19 HEX: 84D3 ; inline
-: GL_TEXTURE20 HEX: 84D4 ; inline
-: GL_TEXTURE21 HEX: 84D5 ; inline
-: GL_TEXTURE22 HEX: 84D6 ; inline
-: GL_TEXTURE23 HEX: 84D7 ; inline
-: GL_TEXTURE24 HEX: 84D8 ; inline
-: GL_TEXTURE25 HEX: 84D9 ; inline
-: GL_TEXTURE26 HEX: 84DA ; inline
-: GL_TEXTURE27 HEX: 84DB ; inline
-: GL_TEXTURE28 HEX: 84DC ; inline
-: GL_TEXTURE29 HEX: 84DD ; inline
-: GL_TEXTURE30 HEX: 84DE ; inline
-: GL_TEXTURE31 HEX: 84DF ; inline
-: GL_NORMAL_MAP HEX: 8511 ; inline
-: GL_REFLECTION_MAP HEX: 8512 ; inline
-: GL_TEXTURE_CUBE_MAP HEX: 8513 ; inline
-: GL_TEXTURE_BINDING_CUBE_MAP HEX: 8514 ; inline
-: GL_TEXTURE_CUBE_MAP_POSITIVE_X HEX: 8515 ; inline
-: GL_TEXTURE_CUBE_MAP_NEGATIVE_X HEX: 8516 ; inline
-: GL_TEXTURE_CUBE_MAP_POSITIVE_Y HEX: 8517 ; inline
-: GL_TEXTURE_CUBE_MAP_NEGATIVE_Y HEX: 8518 ; inline
-: GL_TEXTURE_CUBE_MAP_POSITIVE_Z HEX: 8519 ; inline
-: GL_TEXTURE_CUBE_MAP_NEGATIVE_Z HEX: 851A ; inline
-: GL_PROXY_TEXTURE_CUBE_MAP HEX: 851B ; inline
-: GL_MAX_CUBE_MAP_TEXTURE_SIZE HEX: 851C ; inline
-: GL_COMBINE HEX: 8570 ; inline
-: GL_COMBINE_RGB HEX: 8571 ; inline
-: GL_COMBINE_ALPHA HEX: 8572 ; inline
-: GL_RGB_SCALE HEX: 8573 ; inline
-: GL_ADD_SIGNED HEX: 8574 ; inline
-: GL_INTERPOLATE HEX: 8575 ; inline
-: GL_CONSTANT HEX: 8576 ; inline
-: GL_PRIMARY_COLOR HEX: 8577 ; inline
-: GL_PREVIOUS HEX: 8578 ; inline
-: GL_SOURCE0_RGB HEX: 8580 ; inline
-: GL_SOURCE1_RGB HEX: 8581 ; inline
-: GL_SOURCE2_RGB HEX: 8582 ; inline
-: GL_SOURCE0_ALPHA HEX: 8588 ; inline
-: GL_SOURCE1_ALPHA HEX: 8589 ; inline
-: GL_SOURCE2_ALPHA HEX: 858A ; inline
-: GL_OPERAND0_RGB HEX: 8590 ; inline
-: GL_OPERAND1_RGB HEX: 8591 ; inline
-: GL_OPERAND2_RGB HEX: 8592 ; inline
-: GL_OPERAND0_ALPHA HEX: 8598 ; inline
-: GL_OPERAND1_ALPHA HEX: 8599 ; inline
-: GL_OPERAND2_ALPHA HEX: 859A ; inline
-: GL_SUBTRACT HEX: 84E7 ; inline
-: GL_TRANSPOSE_MODELVIEW_MATRIX HEX: 84E3 ; inline
-: GL_TRANSPOSE_PROJECTION_MATRIX HEX: 84E4 ; inline
-: GL_TRANSPOSE_TEXTURE_MATRIX HEX: 84E5 ; inline
-: GL_TRANSPOSE_COLOR_MATRIX HEX: 84E6 ; inline
-: GL_COMPRESSED_ALPHA HEX: 84E9 ; inline
-: GL_COMPRESSED_LUMINANCE HEX: 84EA ; inline
-: GL_COMPRESSED_LUMINANCE_ALPHA HEX: 84EB ; inline
-: GL_COMPRESSED_INTENSITY HEX: 84EC ; inline
-: GL_COMPRESSED_RGB HEX: 84ED ; inline
-: GL_COMPRESSED_RGBA HEX: 84EE ; inline
-: GL_TEXTURE_COMPRESSION_HINT HEX: 84EF ; inline
-: GL_TEXTURE_COMPRESSED_IMAGE_SIZE HEX: 86A0 ; inline
-: GL_TEXTURE_COMPRESSED HEX: 86A1 ; inline
+
+: GL_MULTISAMPLE HEX: 809D ; inline
+: GL_SAMPLE_ALPHA_TO_COVERAGE HEX: 809E ; inline
+: GL_SAMPLE_ALPHA_TO_ONE HEX: 809F ; inline
+: GL_SAMPLE_COVERAGE HEX: 80A0 ; inline
+: GL_SAMPLE_BUFFERS HEX: 80A8 ; inline
+: GL_SAMPLES HEX: 80A9 ; inline
+: GL_SAMPLE_COVERAGE_VALUE HEX: 80AA ; inline
+: GL_SAMPLE_COVERAGE_INVERT HEX: 80AB ; inline
+: GL_CLAMP_TO_BORDER HEX: 812D ; inline
+: GL_TEXTURE0 HEX: 84C0 ; inline
+: GL_TEXTURE1 HEX: 84C1 ; inline
+: GL_TEXTURE2 HEX: 84C2 ; inline
+: GL_TEXTURE3 HEX: 84C3 ; inline
+: GL_TEXTURE4 HEX: 84C4 ; inline
+: GL_TEXTURE5 HEX: 84C5 ; inline
+: GL_TEXTURE6 HEX: 84C6 ; inline
+: GL_TEXTURE7 HEX: 84C7 ; inline
+: GL_TEXTURE8 HEX: 84C8 ; inline
+: GL_TEXTURE9 HEX: 84C9 ; inline
+: GL_TEXTURE10 HEX: 84CA ; inline
+: GL_TEXTURE11 HEX: 84CB ; inline
+: GL_TEXTURE12 HEX: 84CC ; inline
+: GL_TEXTURE13 HEX: 84CD ; inline
+: GL_TEXTURE14 HEX: 84CE ; inline
+: GL_TEXTURE15 HEX: 84CF ; inline
+: GL_TEXTURE16 HEX: 84D0 ; inline
+: GL_TEXTURE17 HEX: 84D1 ; inline
+: GL_TEXTURE18 HEX: 84D2 ; inline
+: GL_TEXTURE19 HEX: 84D3 ; inline
+: GL_TEXTURE20 HEX: 84D4 ; inline
+: GL_TEXTURE21 HEX: 84D5 ; inline
+: GL_TEXTURE22 HEX: 84D6 ; inline
+: GL_TEXTURE23 HEX: 84D7 ; inline
+: GL_TEXTURE24 HEX: 84D8 ; inline
+: GL_TEXTURE25 HEX: 84D9 ; inline
+: GL_TEXTURE26 HEX: 84DA ; inline
+: GL_TEXTURE27 HEX: 84DB ; inline
+: GL_TEXTURE28 HEX: 84DC ; inline
+: GL_TEXTURE29 HEX: 84DD ; inline
+: GL_TEXTURE30 HEX: 84DE ; inline
+: GL_TEXTURE31 HEX: 84DF ; inline
+: GL_ACTIVE_TEXTURE HEX: 84E0 ; inline
+: GL_CLIENT_ACTIVE_TEXTURE HEX: 84E1 ; inline
+: GL_MAX_TEXTURE_UNITS HEX: 84E2 ; inline
+: GL_TRANSPOSE_MODELVIEW_MATRIX HEX: 84E3 ; inline
+: GL_TRANSPOSE_PROJECTION_MATRIX HEX: 84E4 ; inline
+: GL_TRANSPOSE_TEXTURE_MATRIX HEX: 84E5 ; inline
+: GL_TRANSPOSE_COLOR_MATRIX HEX: 84E6 ; inline
+: GL_SUBTRACT HEX: 84E7 ; inline
+: GL_COMPRESSED_ALPHA HEX: 84E9 ; inline
+: GL_COMPRESSED_LUMINANCE HEX: 84EA ; inline
+: GL_COMPRESSED_LUMINANCE_ALPHA HEX: 84EB ; inline
+: GL_COMPRESSED_INTENSITY HEX: 84EC ; inline
+: GL_COMPRESSED_RGB HEX: 84ED ; inline
+: GL_COMPRESSED_RGBA HEX: 84EE ; inline
+: GL_TEXTURE_COMPRESSION_HINT HEX: 84EF ; inline
+: GL_NORMAL_MAP HEX: 8511 ; inline
+: GL_REFLECTION_MAP HEX: 8512 ; inline
+: GL_TEXTURE_CUBE_MAP HEX: 8513 ; inline
+: GL_TEXTURE_BINDING_CUBE_MAP HEX: 8514 ; inline
+: GL_TEXTURE_CUBE_MAP_POSITIVE_X HEX: 8515 ; inline
+: GL_TEXTURE_CUBE_MAP_NEGATIVE_X HEX: 8516 ; inline
+: GL_TEXTURE_CUBE_MAP_POSITIVE_Y HEX: 8517 ; inline
+: GL_TEXTURE_CUBE_MAP_NEGATIVE_Y HEX: 8518 ; inline
+: GL_TEXTURE_CUBE_MAP_POSITIVE_Z HEX: 8519 ; inline
+: GL_TEXTURE_CUBE_MAP_NEGATIVE_Z HEX: 851A ; inline
+: GL_PROXY_TEXTURE_CUBE_MAP HEX: 851B ; inline
+: GL_MAX_CUBE_MAP_TEXTURE_SIZE HEX: 851C ; inline
+: GL_COMBINE HEX: 8570 ; inline
+: GL_COMBINE_RGB HEX: 8571 ; inline
+: GL_COMBINE_ALPHA HEX: 8572 ; inline
+: GL_RGB_SCALE HEX: 8573 ; inline
+: GL_ADD_SIGNED HEX: 8574 ; inline
+: GL_INTERPOLATE HEX: 8575 ; inline
+: GL_CONSTANT HEX: 8576 ; inline
+: GL_PRIMARY_COLOR HEX: 8577 ; inline
+: GL_PREVIOUS HEX: 8578 ; inline
+: GL_SOURCE0_RGB HEX: 8580 ; inline
+: GL_SOURCE1_RGB HEX: 8581 ; inline
+: GL_SOURCE2_RGB HEX: 8582 ; inline
+: GL_SOURCE0_ALPHA HEX: 8588 ; inline
+: GL_SOURCE1_ALPHA HEX: 8589 ; inline
+: GL_SOURCE2_ALPHA HEX: 858A ; inline
+: GL_OPERAND0_RGB HEX: 8590 ; inline
+: GL_OPERAND1_RGB HEX: 8591 ; inline
+: GL_OPERAND2_RGB HEX: 8592 ; inline
+: GL_OPERAND0_ALPHA HEX: 8598 ; inline
+: GL_OPERAND1_ALPHA HEX: 8599 ; inline
+: GL_OPERAND2_ALPHA HEX: 859A ; inline
+: GL_TEXTURE_COMPRESSED_IMAGE_SIZE HEX: 86A0 ; inline
+: GL_TEXTURE_COMPRESSED HEX: 86A1 ; inline
: GL_NUM_COMPRESSED_TEXTURE_FORMATS HEX: 86A2 ; inline
-: GL_COMPRESSED_TEXTURE_FORMATS HEX: 86A3 ; inline
-: GL_DOT3_RGB HEX: 86AE ; inline
-: GL_DOT3_RGBA HEX: 86AF ; inline
-: GL_CLAMP_TO_BORDER HEX: 812D ; inline
-: GL_MULTISAMPLE HEX: 809D ; inline
-: GL_SAMPLE_ALPHA_TO_COVERAGE HEX: 809E ; inline
-: GL_SAMPLE_ALPHA_TO_ONE HEX: 809F ; inline
-: GL_SAMPLE_COVERAGE HEX: 80A0 ; inline
-: GL_SAMPLE_BUFFERS HEX: 80A8 ; inline
-: GL_SAMPLES HEX: 80A9 ; inline
-: GL_SAMPLE_COVERAGE_VALUE HEX: 80AA ; inline
-: GL_SAMPLE_COVERAGE_INVERT HEX: 80AB ; inline
-: GL_MULTISAMPLE_BIT HEX: 20000000 ; inline
+: GL_COMPRESSED_TEXTURE_FORMATS HEX: 86A3 ; inline
+: GL_DOT3_RGB HEX: 86AE ; inline
+: GL_DOT3_RGBA HEX: 86AF ; inline
+: GL_MULTISAMPLE_BIT HEX: 20000000 ; inline
+
+GL-FUNCTION: void glActiveTexture ( GLenum texture ) ;
+GL-FUNCTION: void glClientActiveTexture ( GLenum texture ) ;
+GL-FUNCTION: void glCompressedTexImage1D ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLint border, GLsizei imageSize, GLvoid* data ) ;
+GL-FUNCTION: void glCompressedTexImage2D ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLsizei height, GLint border, GLsizei imageSize, GLvoid* data ) ;
+GL-FUNCTION: void glCompressedTexImage3D ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLsizei imageSize, GLvoid* data ) ;
+GL-FUNCTION: void glCompressedTexSubImage1D ( GLenum target, GLint level, GLint xoffset, GLsizei width, GLenum format, GLsizei imageSize, GLvoid* data ) ;
+GL-FUNCTION: void glCompressedTexSubImage2D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLsizei width, GLsizei height, GLenum format, GLsizei imageSize, GLvoid* data ) ;
+GL-FUNCTION: void glCompressedTexSubImage3D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLsizei imageSize, GLvoid* data ) ;
+GL-FUNCTION: void glGetCompressedTexImage ( GLenum target, GLint lod, GLvoid* img ) ;
+GL-FUNCTION: void glLoadTransposeMatrixd ( GLdouble m[16] ) ;
+GL-FUNCTION: void glLoadTransposeMatrixf ( GLfloat m[16] ) ;
+GL-FUNCTION: void glMultTransposeMatrixd ( GLdouble m[16] ) ;
+GL-FUNCTION: void glMultTransposeMatrixf ( GLfloat m[16] ) ;
+GL-FUNCTION: void glMultiTexCoord1d ( GLenum target, GLdouble s ) ;
+GL-FUNCTION: void glMultiTexCoord1dv ( GLenum target, GLdouble* v ) ;
+GL-FUNCTION: void glMultiTexCoord1f ( GLenum target, GLfloat s ) ;
+GL-FUNCTION: void glMultiTexCoord1fv ( GLenum target, GLfloat* v ) ;
+GL-FUNCTION: void glMultiTexCoord1i ( GLenum target, GLint s ) ;
+GL-FUNCTION: void glMultiTexCoord1iv ( GLenum target, GLint* v ) ;
+GL-FUNCTION: void glMultiTexCoord1s ( GLenum target, GLshort s ) ;
+GL-FUNCTION: void glMultiTexCoord1sv ( GLenum target, GLshort* v ) ;
+GL-FUNCTION: void glMultiTexCoord2d ( GLenum target, GLdouble s, GLdouble t ) ;
+GL-FUNCTION: void glMultiTexCoord2dv ( GLenum target, GLdouble* v ) ;
+GL-FUNCTION: void glMultiTexCoord2f ( GLenum target, GLfloat s, GLfloat t ) ;
+GL-FUNCTION: void glMultiTexCoord2fv ( GLenum target, GLfloat* v ) ;
+GL-FUNCTION: void glMultiTexCoord2i ( GLenum target, GLint s, GLint t ) ;
+GL-FUNCTION: void glMultiTexCoord2iv ( GLenum target, GLint* v ) ;
+GL-FUNCTION: void glMultiTexCoord2s ( GLenum target, GLshort s, GLshort t ) ;
+GL-FUNCTION: void glMultiTexCoord2sv ( GLenum target, GLshort* v ) ;
+GL-FUNCTION: void glMultiTexCoord3d ( GLenum target, GLdouble s, GLdouble t, GLdouble r ) ;
+GL-FUNCTION: void glMultiTexCoord3dv ( GLenum target, GLdouble* v ) ;
+GL-FUNCTION: void glMultiTexCoord3f ( GLenum target, GLfloat s, GLfloat t, GLfloat r ) ;
+GL-FUNCTION: void glMultiTexCoord3fv ( GLenum target, GLfloat* v ) ;
+GL-FUNCTION: void glMultiTexCoord3i ( GLenum target, GLint s, GLint t, GLint r ) ;
+GL-FUNCTION: void glMultiTexCoord3iv ( GLenum target, GLint* v ) ;
+GL-FUNCTION: void glMultiTexCoord3s ( GLenum target, GLshort s, GLshort t, GLshort r ) ;
+GL-FUNCTION: void glMultiTexCoord3sv ( GLenum target, GLshort* v ) ;
+GL-FUNCTION: void glMultiTexCoord4d ( GLenum target, GLdouble s, GLdouble t, GLdouble r, GLdouble q ) ;
+GL-FUNCTION: void glMultiTexCoord4dv ( GLenum target, GLdouble* v ) ;
+GL-FUNCTION: void glMultiTexCoord4f ( GLenum target, GLfloat s, GLfloat t, GLfloat r, GLfloat q ) ;
+GL-FUNCTION: void glMultiTexCoord4fv ( GLenum target, GLfloat* v ) ;
+GL-FUNCTION: void glMultiTexCoord4i ( GLenum target, GLint s, GLint t, GLint r, GLint q ) ;
+GL-FUNCTION: void glMultiTexCoord4iv ( GLenum target, GLint* v ) ;
+GL-FUNCTION: void glMultiTexCoord4s ( GLenum target, GLshort s, GLshort t, GLshort r, GLshort q ) ;
+GL-FUNCTION: void glMultiTexCoord4sv ( GLenum target, GLshort* v ) ;
+GL-FUNCTION: void glSampleCoverage ( GLclampf value, GLboolean invert ) ;
! OpenGL 1.4
-: GL_POINT_SIZE_MIN HEX: 8126 ; inline
-: GL_POINT_SIZE_MAX HEX: 8127 ; inline
-: GL_POINT_FADE_THRESHOLD_SIZE HEX: 8128 ; inline
-: GL_POINT_DISTANCE_ATTENUATION HEX: 8129 ; inline
-: GL_FOG_COORDINATE_SOURCE HEX: 8450 ; inline
-: GL_FOG_COORDINATE HEX: 8451 ; inline
-: GL_FRAGMENT_DEPTH HEX: 8452 ; inline
-: GL_CURRENT_FOG_COORDINATE HEX: 8453 ; inline
-: GL_FOG_COORDINATE_ARRAY_TYPE HEX: 8454 ; inline
-: GL_FOG_COORDINATE_ARRAY_STRIDE HEX: 8455 ; inline
-: GL_FOG_COORDINATE_ARRAY_POINTER HEX: 8456 ; inline
-: GL_FOG_COORDINATE_ARRAY HEX: 8457 ; inline
-: GL_COLOR_SUM HEX: 8458 ; inline
-: GL_CURRENT_SECONDARY_COLOR HEX: 8459 ; inline
-: GL_SECONDARY_COLOR_ARRAY_SIZE HEX: 845A ; inline
-: GL_SECONDARY_COLOR_ARRAY_TYPE HEX: 845B ; inline
-: GL_SECONDARY_COLOR_ARRAY_STRIDE HEX: 845C ; inline
-: GL_SECONDARY_COLOR_ARRAY_POINTER HEX: 845D ; inline
-: GL_SECONDARY_COLOR_ARRAY HEX: 845E ; inline
-: GL_INCR_WRAP HEX: 8507 ; inline
-: GL_DECR_WRAP HEX: 8508 ; inline
-: GL_MAX_TEXTURE_LOD_BIAS HEX: 84FD ; inline
-: GL_TEXTURE_FILTER_CONTROL HEX: 8500 ; inline
-: GL_TEXTURE_LOD_BIAS HEX: 8501 ; inline
-: GL_GENERATE_MIPMAP HEX: 8191 ; inline
-: GL_GENERATE_MIPMAP_HINT HEX: 8192 ; inline
-: GL_BLEND_DST_RGB HEX: 80C8 ; inline
-: GL_BLEND_SRC_RGB HEX: 80C9 ; inline
-: GL_BLEND_DST_ALPHA HEX: 80CA ; inline
-: GL_BLEND_SRC_ALPHA HEX: 80CB ; inline
-: GL_MIRRORED_REPEAT HEX: 8370 ; inline
-: GL_DEPTH_COMPONENT16 HEX: 81A5 ; inline
-: GL_DEPTH_COMPONENT24 HEX: 81A6 ; inline
-: GL_DEPTH_COMPONENT32 HEX: 81A7 ; inline
-: GL_TEXTURE_DEPTH_SIZE HEX: 884A ; inline
-: GL_DEPTH_TEXTURE_MODE HEX: 884B ; inline
-: GL_TEXTURE_COMPARE_MODE HEX: 884C ; inline
-: GL_TEXTURE_COMPARE_FUNC HEX: 884D ; inline
-: GL_COMPARE_R_TO_TEXTURE HEX: 884E ; inline
+
+: GL_BLEND_DST_RGB HEX: 80C8 ; inline
+: GL_BLEND_SRC_RGB HEX: 80C9 ; inline
+: GL_BLEND_DST_ALPHA HEX: 80CA ; inline
+: GL_BLEND_SRC_ALPHA HEX: 80CB ; inline
+: GL_POINT_SIZE_MIN HEX: 8126 ; inline
+: GL_POINT_SIZE_MAX HEX: 8127 ; inline
+: GL_POINT_FADE_THRESHOLD_SIZE HEX: 8128 ; inline
+: GL_POINT_DISTANCE_ATTENUATION HEX: 8129 ; inline
+: GL_GENERATE_MIPMAP HEX: 8191 ; inline
+: GL_GENERATE_MIPMAP_HINT HEX: 8192 ; inline
+: GL_DEPTH_COMPONENT16 HEX: 81A5 ; inline
+: GL_DEPTH_COMPONENT24 HEX: 81A6 ; inline
+: GL_DEPTH_COMPONENT32 HEX: 81A7 ; inline
+: GL_MIRRORED_REPEAT HEX: 8370 ; inline
+: GL_FOG_COORDINATE_SOURCE HEX: 8450 ; inline
+: GL_FOG_COORDINATE HEX: 8451 ; inline
+: GL_FRAGMENT_DEPTH HEX: 8452 ; inline
+: GL_CURRENT_FOG_COORDINATE HEX: 8453 ; inline
+: GL_FOG_COORDINATE_ARRAY_TYPE HEX: 8454 ; inline
+: GL_FOG_COORDINATE_ARRAY_STRIDE HEX: 8455 ; inline
+: GL_FOG_COORDINATE_ARRAY_POINTER HEX: 8456 ; inline
+: GL_FOG_COORDINATE_ARRAY HEX: 8457 ; inline
+: GL_COLOR_SUM HEX: 8458 ; inline
+: GL_CURRENT_SECONDARY_COLOR HEX: 8459 ; inline
+: GL_SECONDARY_COLOR_ARRAY_SIZE HEX: 845A ; inline
+: GL_SECONDARY_COLOR_ARRAY_TYPE HEX: 845B ; inline
+: GL_SECONDARY_COLOR_ARRAY_STRIDE HEX: 845C ; inline
+: GL_SECONDARY_COLOR_ARRAY_POINTER HEX: 845D ; inline
+: GL_SECONDARY_COLOR_ARRAY HEX: 845E ; inline
+: GL_MAX_TEXTURE_LOD_BIAS HEX: 84FD ; inline
+: GL_TEXTURE_FILTER_CONTROL HEX: 8500 ; inline
+: GL_TEXTURE_LOD_BIAS HEX: 8501 ; inline
+: GL_INCR_WRAP HEX: 8507 ; inline
+: GL_DECR_WRAP HEX: 8508 ; inline
+: GL_TEXTURE_DEPTH_SIZE HEX: 884A ; inline
+: GL_DEPTH_TEXTURE_MODE HEX: 884B ; inline
+: GL_TEXTURE_COMPARE_MODE HEX: 884C ; inline
+: GL_TEXTURE_COMPARE_FUNC HEX: 884D ; inline
+: GL_COMPARE_R_TO_TEXTURE HEX: 884E ; inline
+
+GL-FUNCTION: void glBlendColor ( GLclampf red, GLclampf green, GLclampf blue, GLclampf alpha ) ;
+GL-FUNCTION: void glBlendEquation ( GLenum mode ) ;
+GL-FUNCTION: void glBlendFuncSeparate ( GLenum sfactorRGB, GLenum dfactorRGB, GLenum sfactorAlpha, GLenum dfactorAlpha ) ;
+GL-FUNCTION: void glFogCoordPointer ( GLenum type, GLsizei stride, GLvoid* pointer ) ;
+GL-FUNCTION: void glFogCoordd ( GLdouble coord ) ;
+GL-FUNCTION: void glFogCoorddv ( GLdouble* coord ) ;
+GL-FUNCTION: void glFogCoordf ( GLfloat coord ) ;
+GL-FUNCTION: void glFogCoordfv ( GLfloat* coord ) ;
+GL-FUNCTION: void glMultiDrawArrays ( GLenum mode, GLint* first, GLsizei* count, GLsizei primcount ) ;
+GL-FUNCTION: void glMultiDrawElements ( GLenum mode, GLsizei* count, GLenum type, GLvoid** indices, GLsizei primcount ) ;
+GL-FUNCTION: void glPointParameterf ( GLenum pname, GLfloat param ) ;
+GL-FUNCTION: void glPointParameterfv ( GLenum pname, GLfloat* params ) ;
+GL-FUNCTION: void glSecondaryColor3b ( GLbyte red, GLbyte green, GLbyte blue ) ;
+GL-FUNCTION: void glSecondaryColor3bv ( GLbyte* v ) ;
+GL-FUNCTION: void glSecondaryColor3d ( GLdouble red, GLdouble green, GLdouble blue ) ;
+GL-FUNCTION: void glSecondaryColor3dv ( GLdouble* v ) ;
+GL-FUNCTION: void glSecondaryColor3f ( GLfloat red, GLfloat green, GLfloat blue ) ;
+GL-FUNCTION: void glSecondaryColor3fv ( GLfloat* v ) ;
+GL-FUNCTION: void glSecondaryColor3i ( GLint red, GLint green, GLint blue ) ;
+GL-FUNCTION: void glSecondaryColor3iv ( GLint* v ) ;
+GL-FUNCTION: void glSecondaryColor3s ( GLshort red, GLshort green, GLshort blue ) ;
+GL-FUNCTION: void glSecondaryColor3sv ( GLshort* v ) ;
+GL-FUNCTION: void glSecondaryColor3ub ( GLubyte red, GLubyte green, GLubyte blue ) ;
+GL-FUNCTION: void glSecondaryColor3ubv ( GLubyte* v ) ;
+GL-FUNCTION: void glSecondaryColor3ui ( GLuint red, GLuint green, GLuint blue ) ;
+GL-FUNCTION: void glSecondaryColor3uiv ( GLuint* v ) ;
+GL-FUNCTION: void glSecondaryColor3us ( GLushort red, GLushort green, GLushort blue ) ;
+GL-FUNCTION: void glSecondaryColor3usv ( GLushort* v ) ;
+GL-FUNCTION: void glSecondaryColorPointer ( GLint size, GLenum type, GLsizei stride, GLvoid* pointer ) ;
+GL-FUNCTION: void glWindowPos2d ( GLdouble x, GLdouble y ) ;
+GL-FUNCTION: void glWindowPos2dv ( GLdouble* p ) ;
+GL-FUNCTION: void glWindowPos2f ( GLfloat x, GLfloat y ) ;
+GL-FUNCTION: void glWindowPos2fv ( GLfloat* p ) ;
+GL-FUNCTION: void glWindowPos2i ( GLint x, GLint y ) ;
+GL-FUNCTION: void glWindowPos2iv ( GLint* p ) ;
+GL-FUNCTION: void glWindowPos2s ( GLshort x, GLshort y ) ;
+GL-FUNCTION: void glWindowPos2sv ( GLshort* p ) ;
+GL-FUNCTION: void glWindowPos3d ( GLdouble x, GLdouble y, GLdouble z ) ;
+GL-FUNCTION: void glWindowPos3dv ( GLdouble* p ) ;
+GL-FUNCTION: void glWindowPos3f ( GLfloat x, GLfloat y, GLfloat z ) ;
+GL-FUNCTION: void glWindowPos3fv ( GLfloat* p ) ;
+GL-FUNCTION: void glWindowPos3i ( GLint x, GLint y, GLint z ) ;
+GL-FUNCTION: void glWindowPos3iv ( GLint* p ) ;
+GL-FUNCTION: void glWindowPos3s ( GLshort x, GLshort y, GLshort z ) ;
+GL-FUNCTION: void glWindowPos3sv ( GLshort* p ) ;
+
+
+! OpenGL 1.5
+
+: GL_BUFFER_SIZE HEX: 8764 ; inline
+: GL_BUFFER_USAGE HEX: 8765 ; inline
+: GL_QUERY_COUNTER_BITS HEX: 8864 ; inline
+: GL_CURRENT_QUERY HEX: 8865 ; inline
+: GL_QUERY_RESULT HEX: 8866 ; inline
+: GL_QUERY_RESULT_AVAILABLE HEX: 8867 ; inline
+: GL_ARRAY_BUFFER HEX: 8892 ; inline
+: GL_ELEMENT_ARRAY_BUFFER HEX: 8893 ; inline
+: GL_ARRAY_BUFFER_BINDING HEX: 8894 ; inline
+: GL_ELEMENT_ARRAY_BUFFER_BINDING HEX: 8895 ; inline
+: GL_VERTEX_ARRAY_BUFFER_BINDING HEX: 8896 ; inline
+: GL_NORMAL_ARRAY_BUFFER_BINDING HEX: 8897 ; inline
+: GL_COLOR_ARRAY_BUFFER_BINDING HEX: 8898 ; inline
+: GL_INDEX_ARRAY_BUFFER_BINDING HEX: 8899 ; inline
+: GL_TEXTURE_COORD_ARRAY_BUFFER_BINDING HEX: 889A ; inline
+: GL_EDGE_FLAG_ARRAY_BUFFER_BINDING HEX: 889B ; inline
+: GL_SECONDARY_COLOR_ARRAY_BUFFER_BINDING HEX: 889C ; inline
+: GL_FOG_COORDINATE_ARRAY_BUFFER_BINDING HEX: 889D ; inline
+: GL_WEIGHT_ARRAY_BUFFER_BINDING HEX: 889E ; inline
+: GL_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING HEX: 889F ; inline
+: GL_READ_ONLY HEX: 88B8 ; inline
+: GL_WRITE_ONLY HEX: 88B9 ; inline
+: GL_READ_WRITE HEX: 88BA ; inline
+: GL_BUFFER_ACCESS HEX: 88BB ; inline
+: GL_BUFFER_MAPPED HEX: 88BC ; inline
+: GL_BUFFER_MAP_POINTER HEX: 88BD ; inline
+: GL_STREAM_DRAW HEX: 88E0 ; inline
+: GL_STREAM_READ HEX: 88E1 ; inline
+: GL_STREAM_COPY HEX: 88E2 ; inline
+: GL_STATIC_DRAW HEX: 88E4 ; inline
+: GL_STATIC_READ HEX: 88E5 ; inline
+: GL_STATIC_COPY HEX: 88E6 ; inline
+: GL_DYNAMIC_DRAW HEX: 88E8 ; inline
+: GL_DYNAMIC_READ HEX: 88E9 ; inline
+: GL_DYNAMIC_COPY HEX: 88EA ; inline
+: GL_SAMPLES_PASSED HEX: 8914 ; inline
+: GL_FOG_COORD_SRC GL_FOG_COORDINATE_SOURCE ; inline
+: GL_FOG_COORD GL_FOG_COORDINATE ; inline
+: GL_FOG_COORD_ARRAY GL_FOG_COORDINATE_ARRAY ; inline
+: GL_SRC0_RGB GL_SOURCE0_RGB ; inline
+: GL_FOG_COORD_ARRAY_POINTER GL_FOG_COORDINATE_ARRAY_POINTER ; inline
+: GL_FOG_COORD_ARRAY_TYPE GL_FOG_COORDINATE_ARRAY_TYPE ; inline
+: GL_SRC1_ALPHA GL_SOURCE1_ALPHA ; inline
+: GL_CURRENT_FOG_COORD GL_CURRENT_FOG_COORDINATE ; inline
+: GL_FOG_COORD_ARRAY_STRIDE GL_FOG_COORDINATE_ARRAY_STRIDE ; inline
+: GL_SRC0_ALPHA GL_SOURCE0_ALPHA ; inline
+: GL_SRC1_RGB GL_SOURCE1_RGB ; inline
+: GL_FOG_COORD_ARRAY_BUFFER_BINDING GL_FOG_COORDINATE_ARRAY_BUFFER_BINDING ; inline
+: GL_SRC2_ALPHA GL_SOURCE2_ALPHA ; inline
+: GL_SRC2_RGB GL_SOURCE2_RGB ; inline
+
+TYPEDEF: long ptrdiff_t
+
+TYPEDEF: ptrdiff_t GLsizeiptr
+TYPEDEF: ptrdiff_t GLintptr
+
+GL-FUNCTION: void glBeginQuery ( GLenum target, GLuint id ) ;
+GL-FUNCTION: void glBindBuffer ( GLenum target, GLuint buffer ) ;
+GL-FUNCTION: void glBufferData ( GLenum target, GLsizeiptr size, GLvoid* data, GLenum usage ) ;
+GL-FUNCTION: void glBufferSubData ( GLenum target, GLintptr offset, GLsizeiptr size, GLvoid* data ) ;
+GL-FUNCTION: void glDeleteBuffers ( GLsizei n, GLuint* buffers ) ;
+GL-FUNCTION: void glDeleteQueries ( GLsizei n, GLuint* ids ) ;
+GL-FUNCTION: void glEndQuery ( GLenum target ) ;
+GL-FUNCTION: void glGenBuffers ( GLsizei n, GLuint* buffers ) ;
+GL-FUNCTION: void glGenQueries ( GLsizei n, GLuint* ids ) ;
+GL-FUNCTION: void glGetBufferParameteriv ( GLenum target, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetBufferPointerv ( GLenum target, GLenum pname, GLvoid** params ) ;
+GL-FUNCTION: void glGetBufferSubData ( GLenum target, GLintptr offset, GLsizeiptr size, GLvoid* data ) ;
+GL-FUNCTION: void glGetQueryObjectiv ( GLuint id, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetQueryObjectuiv ( GLuint id, GLenum pname, GLuint* params ) ;
+GL-FUNCTION: void glGetQueryiv ( GLenum target, GLenum pname, GLint* params ) ;
+GL-FUNCTION: GLboolean glIsBuffer ( GLuint buffer ) ;
+GL-FUNCTION: GLboolean glIsQuery ( GLuint id ) ;
+GL-FUNCTION: GLvoid* glMapBuffer ( GLenum target, GLenum access ) ;
+GL-FUNCTION: GLboolean glUnmapBuffer ( GLenum target ) ;
+
+
+! OpenGL 2.0
+
+
+: GL_VERTEX_ATTRIB_ARRAY_ENABLED HEX: 8622 ; inline
+: GL_VERTEX_ATTRIB_ARRAY_SIZE HEX: 8623 ; inline
+: GL_VERTEX_ATTRIB_ARRAY_STRIDE HEX: 8624 ; inline
+: GL_VERTEX_ATTRIB_ARRAY_TYPE HEX: 8625 ; inline
+: GL_CURRENT_VERTEX_ATTRIB HEX: 8626 ; inline
+: GL_VERTEX_PROGRAM_POINT_SIZE HEX: 8642 ; inline
+: GL_VERTEX_PROGRAM_TWO_SIDE HEX: 8643 ; inline
+: GL_VERTEX_ATTRIB_ARRAY_POINTER HEX: 8645 ; inline
+: GL_STENCIL_BACK_FUNC HEX: 8800 ; inline
+: GL_STENCIL_BACK_FAIL HEX: 8801 ; inline
+: GL_STENCIL_BACK_PASS_DEPTH_FAIL HEX: 8802 ; inline
+: GL_STENCIL_BACK_PASS_DEPTH_PASS HEX: 8803 ; inline
+: GL_MAX_DRAW_BUFFERS HEX: 8824 ; inline
+: GL_DRAW_BUFFER0 HEX: 8825 ; inline
+: GL_DRAW_BUFFER1 HEX: 8826 ; inline
+: GL_DRAW_BUFFER2 HEX: 8827 ; inline
+: GL_DRAW_BUFFER3 HEX: 8828 ; inline
+: GL_DRAW_BUFFER4 HEX: 8829 ; inline
+: GL_DRAW_BUFFER5 HEX: 882A ; inline
+: GL_DRAW_BUFFER6 HEX: 882B ; inline
+: GL_DRAW_BUFFER7 HEX: 882C ; inline
+: GL_DRAW_BUFFER8 HEX: 882D ; inline
+: GL_DRAW_BUFFER9 HEX: 882E ; inline
+: GL_DRAW_BUFFER10 HEX: 882F ; inline
+: GL_DRAW_BUFFER11 HEX: 8830 ; inline
+: GL_DRAW_BUFFER12 HEX: 8831 ; inline
+: GL_DRAW_BUFFER13 HEX: 8832 ; inline
+: GL_DRAW_BUFFER14 HEX: 8833 ; inline
+: GL_DRAW_BUFFER15 HEX: 8834 ; inline
+: GL_BLEND_EQUATION_ALPHA HEX: 883D ; inline
+: GL_POINT_SPRITE HEX: 8861 ; inline
+: GL_COORD_REPLACE HEX: 8862 ; inline
+: GL_MAX_VERTEX_ATTRIBS HEX: 8869 ; inline
+: GL_VERTEX_ATTRIB_ARRAY_NORMALIZED HEX: 886A ; inline
+: GL_MAX_TEXTURE_COORDS HEX: 8871 ; inline
+: GL_MAX_TEXTURE_IMAGE_UNITS HEX: 8872 ; inline
+: GL_FRAGMENT_SHADER HEX: 8B30 ; inline
+: GL_VERTEX_SHADER HEX: 8B31 ; inline
+: GL_MAX_FRAGMENT_UNIFORM_COMPONENTS HEX: 8B49 ; inline
+: GL_MAX_VERTEX_UNIFORM_COMPONENTS HEX: 8B4A ; inline
+: GL_MAX_VARYING_FLOATS HEX: 8B4B ; inline
+: GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS HEX: 8B4C ; inline
+: GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS HEX: 8B4D ; inline
+: GL_SHADER_TYPE HEX: 8B4F ; inline
+: GL_FLOAT_VEC2 HEX: 8B50 ; inline
+: GL_FLOAT_VEC3 HEX: 8B51 ; inline
+: GL_FLOAT_VEC4 HEX: 8B52 ; inline
+: GL_INT_VEC2 HEX: 8B53 ; inline
+: GL_INT_VEC3 HEX: 8B54 ; inline
+: GL_INT_VEC4 HEX: 8B55 ; inline
+: GL_BOOL HEX: 8B56 ; inline
+: GL_BOOL_VEC2 HEX: 8B57 ; inline
+: GL_BOOL_VEC3 HEX: 8B58 ; inline
+: GL_BOOL_VEC4 HEX: 8B59 ; inline
+: GL_FLOAT_MAT2 HEX: 8B5A ; inline
+: GL_FLOAT_MAT3 HEX: 8B5B ; inline
+: GL_FLOAT_MAT4 HEX: 8B5C ; inline
+: GL_SAMPLER_1D HEX: 8B5D ; inline
+: GL_SAMPLER_2D HEX: 8B5E ; inline
+: GL_SAMPLER_3D HEX: 8B5F ; inline
+: GL_SAMPLER_CUBE HEX: 8B60 ; inline
+: GL_SAMPLER_1D_SHADOW HEX: 8B61 ; inline
+: GL_SAMPLER_2D_SHADOW HEX: 8B62 ; inline
+: GL_DELETE_STATUS HEX: 8B80 ; inline
+: GL_COMPILE_STATUS HEX: 8B81 ; inline
+: GL_LINK_STATUS HEX: 8B82 ; inline
+: GL_VALIDATE_STATUS HEX: 8B83 ; inline
+: GL_INFO_LOG_LENGTH HEX: 8B84 ; inline
+: GL_ATTACHED_SHADERS HEX: 8B85 ; inline
+: GL_ACTIVE_UNIFORMS HEX: 8B86 ; inline
+: GL_ACTIVE_UNIFORM_MAX_LENGTH HEX: 8B87 ; inline
+: GL_SHADER_SOURCE_LENGTH HEX: 8B88 ; inline
+: GL_ACTIVE_ATTRIBUTES HEX: 8B89 ; inline
+: GL_ACTIVE_ATTRIBUTE_MAX_LENGTH HEX: 8B8A ; inline
+: GL_FRAGMENT_SHADER_DERIVATIVE_HINT HEX: 8B8B ; inline
+: GL_SHADING_LANGUAGE_VERSION HEX: 8B8C ; inline
+: GL_CURRENT_PROGRAM HEX: 8B8D ; inline
+: GL_POINT_SPRITE_COORD_ORIGIN HEX: 8CA0 ; inline
+: GL_LOWER_LEFT HEX: 8CA1 ; inline
+: GL_UPPER_LEFT HEX: 8CA2 ; inline
+: GL_STENCIL_BACK_REF HEX: 8CA3 ; inline
+: GL_STENCIL_BACK_VALUE_MASK HEX: 8CA4 ; inline
+: GL_STENCIL_BACK_WRITEMASK HEX: 8CA5 ; inline
+: GL_BLEND_EQUATION HEX: 8009 ; inline
+: GL_BLEND_EQUATION_RGB GL_BLEND_EQUATION ; inline
+
+TYPEDEF: char GLchar
+
+GL-FUNCTION: void glAttachShader ( GLuint program, GLuint shader ) ;
+GL-FUNCTION: void glBindAttribLocation ( GLuint program, GLuint index, GLchar* name ) ;
+GL-FUNCTION: void glBlendEquationSeparate ( GLenum modeRGB, GLenum modeAlpha ) ;
+GL-FUNCTION: void glCompileShader ( GLuint shader ) ;
+GL-FUNCTION: GLuint glCreateProgram ( ) ;
+GL-FUNCTION: GLuint glCreateShader ( GLenum type ) ;
+GL-FUNCTION: void glDeleteProgram ( GLuint program ) ;
+GL-FUNCTION: void glDeleteShader ( GLuint shader ) ;
+GL-FUNCTION: void glDetachShader ( GLuint program, GLuint shader ) ;
+GL-FUNCTION: void glDisableVertexAttribArray ( GLuint index ) ;
+GL-FUNCTION: void glDrawBuffers ( GLsizei n, GLenum* bufs ) ;
+GL-FUNCTION: void glEnableVertexAttribArray ( GLuint index ) ;
+GL-FUNCTION: void glGetActiveAttrib ( GLuint program, GLuint index, GLsizei maxLength, GLsizei* length, GLint* size, GLenum* type, GLchar* name ) ;
+GL-FUNCTION: void glGetActiveUniform ( GLuint program, GLuint index, GLsizei maxLength, GLsizei* length, GLint* size, GLenum* type, GLchar* name ) ;
+GL-FUNCTION: void glGetAttachedShaders ( GLuint program, GLsizei maxCount, GLsizei* count, GLuint* shaders ) ;
+GL-FUNCTION: GLint glGetAttribLocation ( GLuint program, GLchar* name ) ;
+GL-FUNCTION: void glGetProgramInfoLog ( GLuint program, GLsizei bufSize, GLsizei* length, GLchar* infoLog ) ;
+GL-FUNCTION: void glGetProgramiv ( GLuint program, GLenum pname, GLint* param ) ;
+GL-FUNCTION: void glGetShaderInfoLog ( GLuint shader, GLsizei bufSize, GLsizei* length, GLchar* infoLog ) ;
+GL-FUNCTION: void glGetShaderSource ( GLint obj, GLsizei maxLength, GLsizei* length, GLchar* source ) ;
+GL-FUNCTION: void glGetShaderiv ( GLuint shader, GLenum pname, GLint* param ) ;
+GL-FUNCTION: GLint glGetUniformLocation ( GLint programObj, GLchar* name ) ;
+GL-FUNCTION: void glGetUniformfv ( GLuint program, GLint location, GLfloat* params ) ;
+GL-FUNCTION: void glGetUniformiv ( GLuint program, GLint location, GLint* params ) ;
+GL-FUNCTION: void glGetVertexAttribPointerv ( GLuint index, GLenum pname, GLvoid** pointer ) ;
+GL-FUNCTION: void glGetVertexAttribdv ( GLuint index, GLenum pname, GLdouble* params ) ;
+GL-FUNCTION: void glGetVertexAttribfv ( GLuint index, GLenum pname, GLfloat* params ) ;
+GL-FUNCTION: void glGetVertexAttribiv ( GLuint index, GLenum pname, GLint* params ) ;
+GL-FUNCTION: GLboolean glIsProgram ( GLuint program ) ;
+GL-FUNCTION: GLboolean glIsShader ( GLuint shader ) ;
+GL-FUNCTION: void glLinkProgram ( GLuint program ) ;
+GL-FUNCTION: void glShaderSource ( GLuint shader, GLsizei count, GLchar** strings, GLint* lengths ) ;
+GL-FUNCTION: void glStencilFuncSeparate ( GLenum frontfunc, GLenum backfunc, GLint ref, GLuint mask ) ;
+GL-FUNCTION: void glStencilMaskSeparate ( GLenum face, GLuint mask ) ;
+GL-FUNCTION: void glStencilOpSeparate ( GLenum face, GLenum sfail, GLenum dpfail, GLenum dppass ) ;
+GL-FUNCTION: void glUniform1f ( GLint location, GLfloat v0 ) ;
+GL-FUNCTION: void glUniform1fv ( GLint location, GLsizei count, GLfloat* value ) ;
+GL-FUNCTION: void glUniform1i ( GLint location, GLint v0 ) ;
+GL-FUNCTION: void glUniform1iv ( GLint location, GLsizei count, GLint* value ) ;
+GL-FUNCTION: void glUniform2f ( GLint location, GLfloat v0, GLfloat v1 ) ;
+GL-FUNCTION: void glUniform2fv ( GLint location, GLsizei count, GLfloat* value ) ;
+GL-FUNCTION: void glUniform2i ( GLint location, GLint v0, GLint v1 ) ;
+GL-FUNCTION: void glUniform2iv ( GLint location, GLsizei count, GLint* value ) ;
+GL-FUNCTION: void glUniform3f ( GLint location, GLfloat v0, GLfloat v1, GLfloat v2 ) ;
+GL-FUNCTION: void glUniform3fv ( GLint location, GLsizei count, GLfloat* value ) ;
+GL-FUNCTION: void glUniform3i ( GLint location, GLint v0, GLint v1, GLint v2 ) ;
+GL-FUNCTION: void glUniform3iv ( GLint location, GLsizei count, GLint* value ) ;
+GL-FUNCTION: void glUniform4f ( GLint location, GLfloat v0, GLfloat v1, GLfloat v2, GLfloat v3 ) ;
+GL-FUNCTION: void glUniform4fv ( GLint location, GLsizei count, GLfloat* value ) ;
+GL-FUNCTION: void glUniform4i ( GLint location, GLint v0, GLint v1, GLint v2, GLint v3 ) ;
+GL-FUNCTION: void glUniform4iv ( GLint location, GLsizei count, GLint* value ) ;
+GL-FUNCTION: void glUniformMatrix2fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
+GL-FUNCTION: void glUniformMatrix3fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
+GL-FUNCTION: void glUniformMatrix4fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
+GL-FUNCTION: void glUseProgram ( GLuint program ) ;
+GL-FUNCTION: void glValidateProgram ( GLuint program ) ;
+GL-FUNCTION: void glVertexAttrib1d ( GLuint index, GLdouble x ) ;
+GL-FUNCTION: void glVertexAttrib1dv ( GLuint index, GLdouble* v ) ;
+GL-FUNCTION: void glVertexAttrib1f ( GLuint index, GLfloat x ) ;
+GL-FUNCTION: void glVertexAttrib1fv ( GLuint index, GLfloat* v ) ;
+GL-FUNCTION: void glVertexAttrib1s ( GLuint index, GLshort x ) ;
+GL-FUNCTION: void glVertexAttrib1sv ( GLuint index, GLshort* v ) ;
+GL-FUNCTION: void glVertexAttrib2d ( GLuint index, GLdouble x, GLdouble y ) ;
+GL-FUNCTION: void glVertexAttrib2dv ( GLuint index, GLdouble* v ) ;
+GL-FUNCTION: void glVertexAttrib2f ( GLuint index, GLfloat x, GLfloat y ) ;
+GL-FUNCTION: void glVertexAttrib2fv ( GLuint index, GLfloat* v ) ;
+GL-FUNCTION: void glVertexAttrib2s ( GLuint index, GLshort x, GLshort y ) ;
+GL-FUNCTION: void glVertexAttrib2sv ( GLuint index, GLshort* v ) ;
+GL-FUNCTION: void glVertexAttrib3d ( GLuint index, GLdouble x, GLdouble y, GLdouble z ) ;
+GL-FUNCTION: void glVertexAttrib3dv ( GLuint index, GLdouble* v ) ;
+GL-FUNCTION: void glVertexAttrib3f ( GLuint index, GLfloat x, GLfloat y, GLfloat z ) ;
+GL-FUNCTION: void glVertexAttrib3fv ( GLuint index, GLfloat* v ) ;
+GL-FUNCTION: void glVertexAttrib3s ( GLuint index, GLshort x, GLshort y, GLshort z ) ;
+GL-FUNCTION: void glVertexAttrib3sv ( GLuint index, GLshort* v ) ;
+GL-FUNCTION: void glVertexAttrib4Nbv ( GLuint index, GLbyte* v ) ;
+GL-FUNCTION: void glVertexAttrib4Niv ( GLuint index, GLint* v ) ;
+GL-FUNCTION: void glVertexAttrib4Nsv ( GLuint index, GLshort* v ) ;
+GL-FUNCTION: void glVertexAttrib4Nub ( GLuint index, GLubyte x, GLubyte y, GLubyte z, GLubyte w ) ;
+GL-FUNCTION: void glVertexAttrib4Nubv ( GLuint index, GLubyte* v ) ;
+GL-FUNCTION: void glVertexAttrib4Nuiv ( GLuint index, GLuint* v ) ;
+GL-FUNCTION: void glVertexAttrib4Nusv ( GLuint index, GLushort* v ) ;
+GL-FUNCTION: void glVertexAttrib4bv ( GLuint index, GLbyte* v ) ;
+GL-FUNCTION: void glVertexAttrib4d ( GLuint index, GLdouble x, GLdouble y, GLdouble z, GLdouble w ) ;
+GL-FUNCTION: void glVertexAttrib4dv ( GLuint index, GLdouble* v ) ;
+GL-FUNCTION: void glVertexAttrib4f ( GLuint index, GLfloat x, GLfloat y, GLfloat z, GLfloat w ) ;
+GL-FUNCTION: void glVertexAttrib4fv ( GLuint index, GLfloat* v ) ;
+GL-FUNCTION: void glVertexAttrib4iv ( GLuint index, GLint* v ) ;
+GL-FUNCTION: void glVertexAttrib4s ( GLuint index, GLshort x, GLshort y, GLshort z, GLshort w ) ;
+GL-FUNCTION: void glVertexAttrib4sv ( GLuint index, GLshort* v ) ;
+GL-FUNCTION: void glVertexAttrib4ubv ( GLuint index, GLubyte* v ) ;
+GL-FUNCTION: void glVertexAttrib4uiv ( GLuint index, GLuint* v ) ;
+GL-FUNCTION: void glVertexAttrib4usv ( GLuint index, GLushort* v ) ;
+GL-FUNCTION: void glVertexAttribPointer ( GLuint index, GLint size, GLenum type, GLboolean normalized, GLsizei stride, GLvoid* pointer ) ;
+
+
+! OpenGL 2.1
+
+
+: GL_CURRENT_RASTER_SECONDARY_COLOR HEX: 845F ; inline
+: GL_PIXEL_PACK_BUFFER HEX: 88EB ; inline
+: GL_PIXEL_UNPACK_BUFFER HEX: 88EC ; inline
+: GL_PIXEL_PACK_BUFFER_BINDING HEX: 88ED ; inline
+: GL_PIXEL_UNPACK_BUFFER_BINDING HEX: 88EF ; inline
+: GL_SRGB HEX: 8C40 ; inline
+: GL_SRGB8 HEX: 8C41 ; inline
+: GL_SRGB_ALPHA HEX: 8C42 ; inline
+: GL_SRGB8_ALPHA8 HEX: 8C43 ; inline
+: GL_SLUMINANCE_ALPHA HEX: 8C44 ; inline
+: GL_SLUMINANCE8_ALPHA8 HEX: 8C45 ; inline
+: GL_SLUMINANCE HEX: 8C46 ; inline
+: GL_SLUMINANCE8 HEX: 8C47 ; inline
+: GL_COMPRESSED_SRGB HEX: 8C48 ; inline
+: GL_COMPRESSED_SRGB_ALPHA HEX: 8C49 ; inline
+: GL_COMPRESSED_SLUMINANCE HEX: 8C4A ; inline
+: GL_COMPRESSED_SLUMINANCE_ALPHA HEX: 8C4B ; inline
+
+GL-FUNCTION: void glUniformMatrix2x3fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
+GL-FUNCTION: void glUniformMatrix2x4fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
+GL-FUNCTION: void glUniformMatrix3x2fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
+GL-FUNCTION: void glUniformMatrix3x4fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
+GL-FUNCTION: void glUniformMatrix4x2fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
+GL-FUNCTION: void glUniformMatrix4x3fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
+
+
+! GL_EXT_framebuffer_object
+
+
+: GL_INVALID_FRAMEBUFFER_OPERATION_EXT HEX: 0506 ; inline
+: GL_MAX_RENDERBUFFER_SIZE_EXT HEX: 84E8 ; inline
+: GL_FRAMEBUFFER_BINDING_EXT HEX: 8CA6 ; inline
+: GL_RENDERBUFFER_BINDING_EXT HEX: 8CA7 ; inline
+: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE_EXT HEX: 8CD0 ; inline
+: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT HEX: 8CD1 ; inline
+: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL_EXT HEX: 8CD2 ; inline
+: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE_EXT HEX: 8CD3 ; inline
+: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_3D_ZOFFSET_EXT HEX: 8CD4 ; inline
+: GL_FRAMEBUFFER_COMPLETE_EXT HEX: 8CD5 ; inline
+: GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT HEX: 8CD6 ; inline
+: GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT HEX: 8CD7 ; inline
+: GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT HEX: 8CD9 ; inline
+: GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT HEX: 8CDA ; inline
+: GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT HEX: 8CDB ; inline
+: GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT HEX: 8CDC ; inline
+: GL_FRAMEBUFFER_UNSUPPORTED_EXT HEX: 8CDD ; inline
+: GL_MAX_COLOR_ATTACHMENTS_EXT HEX: 8CDF ; inline
+: GL_COLOR_ATTACHMENT0_EXT HEX: 8CE0 ; inline
+: GL_COLOR_ATTACHMENT1_EXT HEX: 8CE1 ; inline
+: GL_COLOR_ATTACHMENT2_EXT HEX: 8CE2 ; inline
+: GL_COLOR_ATTACHMENT3_EXT HEX: 8CE3 ; inline
+: GL_COLOR_ATTACHMENT4_EXT HEX: 8CE4 ; inline
+: GL_COLOR_ATTACHMENT5_EXT HEX: 8CE5 ; inline
+: GL_COLOR_ATTACHMENT6_EXT HEX: 8CE6 ; inline
+: GL_COLOR_ATTACHMENT7_EXT HEX: 8CE7 ; inline
+: GL_COLOR_ATTACHMENT8_EXT HEX: 8CE8 ; inline
+: GL_COLOR_ATTACHMENT9_EXT HEX: 8CE9 ; inline
+: GL_COLOR_ATTACHMENT10_EXT HEX: 8CEA ; inline
+: GL_COLOR_ATTACHMENT11_EXT HEX: 8CEB ; inline
+: GL_COLOR_ATTACHMENT12_EXT HEX: 8CEC ; inline
+: GL_COLOR_ATTACHMENT13_EXT HEX: 8CED ; inline
+: GL_COLOR_ATTACHMENT14_EXT HEX: 8CEE ; inline
+: GL_COLOR_ATTACHMENT15_EXT HEX: 8CEF ; inline
+: GL_DEPTH_ATTACHMENT_EXT HEX: 8D00 ; inline
+: GL_STENCIL_ATTACHMENT_EXT HEX: 8D20 ; inline
+: GL_FRAMEBUFFER_EXT HEX: 8D40 ; inline
+: GL_RENDERBUFFER_EXT HEX: 8D41 ; inline
+: GL_RENDERBUFFER_WIDTH_EXT HEX: 8D42 ; inline
+: GL_RENDERBUFFER_HEIGHT_EXT HEX: 8D43 ; inline
+: GL_RENDERBUFFER_INTERNAL_FORMAT_EXT HEX: 8D44 ; inline
+: GL_STENCIL_INDEX1_EXT HEX: 8D46 ; inline
+: GL_STENCIL_INDEX4_EXT HEX: 8D47 ; inline
+: GL_STENCIL_INDEX8_EXT HEX: 8D48 ; inline
+: GL_STENCIL_INDEX16_EXT HEX: 8D49 ; inline
+: GL_RENDERBUFFER_RED_SIZE_EXT HEX: 8D50 ; inline
+: GL_RENDERBUFFER_GREEN_SIZE_EXT HEX: 8D51 ; inline
+: GL_RENDERBUFFER_BLUE_SIZE_EXT HEX: 8D52 ; inline
+: GL_RENDERBUFFER_ALPHA_SIZE_EXT HEX: 8D53 ; inline
+: GL_RENDERBUFFER_DEPTH_SIZE_EXT HEX: 8D54 ; inline
+: GL_RENDERBUFFER_STENCIL_SIZE_EXT HEX: 8D55 ; inline
+
+GL-FUNCTION: void glBindFramebufferEXT ( GLenum target, GLuint framebuffer ) ;
+GL-FUNCTION: void glBindRenderbufferEXT ( GLenum target, GLuint renderbuffer ) ;
+GL-FUNCTION: GLenum glCheckFramebufferStatusEXT ( GLenum target ) ;
+GL-FUNCTION: void glDeleteFramebuffersEXT ( GLsizei n, GLuint* framebuffers ) ;
+GL-FUNCTION: void glDeleteRenderbuffersEXT ( GLsizei n, GLuint* renderbuffers ) ;
+GL-FUNCTION: void glFramebufferRenderbufferEXT ( GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer ) ;
+GL-FUNCTION: void glFramebufferTexture1DEXT ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ;
+GL-FUNCTION: void glFramebufferTexture2DEXT ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ;
+GL-FUNCTION: void glFramebufferTexture3DEXT ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level, GLint zoffset ) ;
+GL-FUNCTION: void glGenFramebuffersEXT ( GLsizei n, GLuint* framebuffers ) ;
+GL-FUNCTION: void glGenRenderbuffersEXT ( GLsizei n, GLuint* renderbuffers ) ;
+GL-FUNCTION: void glGenerateMipmapEXT ( GLenum target ) ;
+GL-FUNCTION: void glGetFramebufferAttachmentParameterivEXT ( GLenum target, GLenum attachment, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetRenderbufferParameterivEXT ( GLenum target, GLenum pname, GLint* params ) ;
+GL-FUNCTION: GLboolean glIsFramebufferEXT ( GLuint framebuffer ) ;
+GL-FUNCTION: GLboolean glIsRenderbufferEXT ( GLuint renderbuffer ) ;
+GL-FUNCTION: void glRenderbufferStorageEXT ( GLenum target, GLenum internalformat, GLsizei width, GLsizei height ) ;
+
+
+! GL_ARB_texture_float
+
+
+: GL_RGBA32F_ARB HEX: 8814 ; inline
+: GL_RGB32F_ARB HEX: 8815 ; inline
+: GL_ALPHA32F_ARB HEX: 8816 ; inline
+: GL_INTENSITY32F_ARB HEX: 8817 ; inline
+: GL_LUMINANCE32F_ARB HEX: 8818 ; inline
+: GL_LUMINANCE_ALPHA32F_ARB HEX: 8819 ; inline
+: GL_RGBA16F_ARB HEX: 881A ; inline
+: GL_RGB16F_ARB HEX: 881B ; inline
+: GL_ALPHA16F_ARB HEX: 881C ; inline
+: GL_INTENSITY16F_ARB HEX: 881D ; inline
+: GL_LUMINANCE16F_ARB HEX: 881E ; inline
+: GL_LUMINANCE_ALPHA16F_ARB HEX: 881F ; inline
+: GL_TEXTURE_RED_TYPE_ARB HEX: 8C10 ; inline
+: GL_TEXTURE_GREEN_TYPE_ARB HEX: 8C11 ; inline
+: GL_TEXTURE_BLUE_TYPE_ARB HEX: 8C12 ; inline
+: GL_TEXTURE_ALPHA_TYPE_ARB HEX: 8C13 ; inline
+: GL_TEXTURE_LUMINANCE_TYPE_ARB HEX: 8C14 ; inline
+: GL_TEXTURE_INTENSITY_TYPE_ARB HEX: 8C15 ; inline
+: GL_TEXTURE_DEPTH_TYPE_ARB HEX: 8C16 ; inline
+: GL_UNSIGNED_NORMALIZED_ARB HEX: 8C17 ; inline
+
diff --git a/extra/opengl/gl/unix/unix.factor b/extra/opengl/gl/unix/unix.factor
new file mode 100644
index 0000000000..08141ad81d
--- /dev/null
+++ b/extra/opengl/gl/unix/unix.factor
@@ -0,0 +1,5 @@
+USING: alien.syntax kernel syntax words ;
+
+IN: opengl.gl.unix
+
+: GL-FUNCTION: \ FUNCTION: word-def call ; parsing
diff --git a/extra/opengl/gl/windows/windows.factor b/extra/opengl/gl/windows/windows.factor
new file mode 100644
index 0000000000..96fb91793d
--- /dev/null
+++ b/extra/opengl/gl/windows/windows.factor
@@ -0,0 +1,18 @@
+USING: alien alien.syntax kernel libc namespaces parser
+ sequences syntax system vectors ;
+
+IN: opengl.gl.windows
+
+SYMBOL: gl-function-pointers
+
+LIBRARY: gl
+FUNCTION: void* wglGetProcAddress ( char* name ) ;
+
+: GL-FUNCTION:
+ "stdcall"
+ scan
+ scan
+ dup [ wglGetProcAddress check-ptr ] curry swap
+ ";" parse-tokens [ "()" subseq? not ] subset
+ define-indirect
+ ; parsing
diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor
index aabdccd1fb..dd9d6b8ccd 100644
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Portions copyright (C) 2007 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types kernel math namespaces sequences
+USING: alien alien.c-types kernel libc math namespaces sequences
math.vectors math.constants math.functions opengl.gl opengl.glu
combinators arrays ;
IN: opengl
@@ -20,7 +20,7 @@ IN: opengl
: gl-error ( -- )
glGetError dup zero? [
- "GL error: " dup gluErrorString append throw
+ "GL error: " over gluErrorString append throw
] unless drop ;
: do-state ( what quot -- )
@@ -185,3 +185,100 @@ TUPLE: sprite loc dim dim2 dlist texture ;
glLoadIdentity
GL_MODELVIEW glMatrixMode
glLoadIdentity ;
+
+! Shaders
+
+: c-true? ( int -- ? ) zero? not ; inline
+
+: with-gl-shader-source-ptr ( string quot -- )
+ swap dup length 1+ [ tuck string>memory <void*> swap call ] with-malloc ; inline
+
+: <gl-shader> ( source kind -- shader )
+ glCreateShader dup rot [ 1 swap f glShaderSource ] with-gl-shader-source-ptr
+ [ glCompileShader ] keep
+ gl-error ;
+
+: (gl-shader?) ( object -- ? )
+ dup integer? [ glIsShader c-true? ] [ drop f ] if ;
+
+: gl-shader-get-int ( shader enum -- value )
+ 0 <int> [ glGetShaderiv ] keep *int ;
+
+: gl-shader-ok? ( shader -- ? )
+ GL_COMPILE_STATUS gl-shader-get-int c-true? ;
+
+: <vertex-shader> ( source -- vertex-shader )
+ GL_VERTEX_SHADER <gl-shader> ; inline
+
+: (vertex-shader?) ( object -- ? )
+ dup (gl-shader?) [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ] [ drop f ] if ;
+
+: <fragment-shader> ( source -- fragment-shader )
+ GL_FRAGMENT_SHADER <gl-shader> ; inline
+
+: (fragment-shader?) ( object -- ? )
+ dup (gl-shader?) [ GL_SHADER_TYPE gl-shader-get-int GL_FRAGMENT_SHADER = ] [ drop f ] if ;
+
+: gl-shader-info-log-length ( shader -- log-length )
+ GL_INFO_LOG_LENGTH gl-shader-get-int ; inline
+
+: gl-shader-info-log ( shader -- log )
+ dup gl-shader-info-log-length dup [ [ 0 <int> swap glGetShaderInfoLog ] keep alien>char-string ] with-malloc ;
+
+: check-gl-shader ( shader -- shader* )
+ dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ;
+
+: delete-gl-shader ( shader -- ) glDeleteShader ; inline
+
+PREDICATE: integer gl-shader (gl-shader?) ;
+PREDICATE: gl-shader vertex-shader (vertex-shader?) ;
+PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
+
+! Programs
+
+: <gl-program> ( shaders -- program )
+ glCreateProgram swap
+ [ dupd glAttachShader ] each
+ [ glLinkProgram ] keep
+ gl-error ;
+
+: (gl-program?) ( object -- ? )
+ dup integer? [ glIsProgram c-true? ] [ drop f ] if ;
+
+: gl-program-get-int ( program enum -- value )
+ 0 <int> [ glGetProgramiv ] keep *int ;
+
+: gl-program-ok? ( program -- ? )
+ GL_LINK_STATUS gl-program-get-int c-true? ;
+
+: gl-program-info-log-length ( program -- log-length )
+ GL_INFO_LOG_LENGTH gl-program-get-int ; inline
+
+: gl-program-info-log ( program -- log )
+ dup gl-program-info-log-length
+ dup [ [ 0 <int> swap glGetProgramInfoLog ] keep
+ alien>char-string ] with-malloc ;
+
+: check-gl-program ( program -- program* )
+ dup gl-program-ok? [ dup gl-program-info-log throw ] unless ;
+
+: gl-program-shaders-length ( program -- shaders-length )
+ GL_ATTACHED_SHADERS gl-program-get-int ; inline
+
+: gl-program-shaders ( program -- shaders )
+ dup gl-program-shaders-length
+ [ dup "GLuint" <c-array> [ 0 <int> swap glGetAttachedShaders ] keep ] keep
+ c-uint-array> ;
+
+: delete-gl-program-only ( program -- ) glDeleteProgram ; inline
+
+: detach-gl-program-shader ( program shader -- ) glDetachShader ; inline
+
+: delete-gl-program ( program -- )
+ dup gl-program-shaders [ 2dup detach-gl-program-shader delete-gl-shader ] each
+ delete-gl-program-only ;
+
+: with-gl-program ( program quot -- )
+ swap glUseProgram call 0 glUseProgram ; inline
+
+PREDICATE: integer gl-program (gl-program?) ;
From 606b0be95b7d9e3b46ab0430022af48c21efee9b Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 12 Jan 2008 23:00:52 -0800
Subject: [PATCH 05/65] TextMate bundle commands: Eval, Help, Infer, Run, See
---
.../Commands/Eval Selection:Line.tmCommand | 27 +++++++++++++
.../Commands/Help for Word.tmCommand | 30 +++++++++++++++
.../Infer Effect of Selection.tmCommand | 27 +++++++++++++
.../Commands/Run File in Listener.tmCommand | 25 ++++++++++++
.../Run Selection:Line in Listener.tmCommand | 27 +++++++++++++
.../Commands/See Word.tmCommand | 30 +++++++++++++++
misc/Factor.tmbundle/Support/lib/tm_factor.rb | 38 +++++++++++++++++++
.../Syntaxes/Factor.tmLanguage | 6 +--
.../Syntaxes/HTML (Factor).tmLanguage | 2 +-
misc/Factor.tmbundle/info.plist | 13 ++++++-
10 files changed, 220 insertions(+), 5 deletions(-)
create mode 100644 misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand
create mode 100644 misc/Factor.tmbundle/Commands/Help for Word.tmCommand
create mode 100644 misc/Factor.tmbundle/Commands/Infer Effect of Selection.tmCommand
create mode 100644 misc/Factor.tmbundle/Commands/Run File in Listener.tmCommand
create mode 100644 misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand
create mode 100644 misc/Factor.tmbundle/Commands/See Word.tmCommand
create mode 100644 misc/Factor.tmbundle/Support/lib/tm_factor.rb
diff --git a/misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand b/misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand
new file mode 100644
index 0000000000..37867a2737
--- /dev/null
+++ b/misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand
@@ -0,0 +1,27 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+puts factor_eval(STDIN.read)</string>
+ <key>fallbackInput</key>
+ <string>line</string>
+ <key>input</key>
+ <string>selection</string>
+ <key>keyEquivalent</key>
+ <string>^E</string>
+ <key>name</key>
+ <string>Eval Selection/Line</string>
+ <key>output</key>
+ <string>replaceSelectedText</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>8E01DDAF-959B-4237-ADB9-C133A4ACCE90</string>
+</dict>
+</plist>
diff --git a/misc/Factor.tmbundle/Commands/Help for Word.tmCommand b/misc/Factor.tmbundle/Commands/Help for Word.tmCommand
new file mode 100644
index 0000000000..a3d77d2f0c
--- /dev/null
+++ b/misc/Factor.tmbundle/Commands/Help for Word.tmCommand
@@ -0,0 +1,30 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+factor_run(%Q(#{doc_using_statements(doc)} \\ #{word} help))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>^H</string>
+ <key>name</key>
+ <string>Help for Word</string>
+ <key>output</key>
+ <string>showAsTooltip</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>BC5BE120-734B-40DF-8B6B-5D3243614B27</string>
+</dict>
+</plist>
diff --git a/misc/Factor.tmbundle/Commands/Infer Effect of Selection.tmCommand b/misc/Factor.tmbundle/Commands/Infer Effect of Selection.tmCommand
new file mode 100644
index 0000000000..378294e6c1
--- /dev/null
+++ b/misc/Factor.tmbundle/Commands/Infer Effect of Selection.tmCommand
@@ -0,0 +1,27 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: inference\n [ #{ENV["TM_SELECTED_TEXT"]} ] infer.))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>name</key>
+ <string>Infer Effect of Selection</string>
+ <key>output</key>
+ <string>showAsTooltip</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>B619FCC0-2DF2-4657-82A8-0E5676A10254</string>
+</dict>
+</plist>
diff --git a/misc/Factor.tmbundle/Commands/Run File in Listener.tmCommand b/misc/Factor.tmbundle/Commands/Run File in Listener.tmCommand
new file mode 100644
index 0000000000..bc8c84ec13
--- /dev/null
+++ b/misc/Factor.tmbundle/Commands/Run File in Listener.tmCommand
@@ -0,0 +1,25 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+factor_run(%Q("#{ENV["TM_FILEPATH"]}" run-file))</string>
+ <key>input</key>
+ <string>none</string>
+ <key>keyEquivalent</key>
+ <string>@r</string>
+ <key>name</key>
+ <string>Run File in Listener</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>CAD3BB10-C480-4C0E-9518-94D61F7A0C0B</string>
+</dict>
+</plist>
diff --git a/misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand b/misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand
new file mode 100644
index 0000000000..5028bd8db3
--- /dev/null
+++ b/misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand
@@ -0,0 +1,27 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+factor_run(STDIN.read)</string>
+ <key>fallbackInput</key>
+ <string>line</string>
+ <key>input</key>
+ <string>selection</string>
+ <key>keyEquivalent</key>
+ <string>^~e</string>
+ <key>name</key>
+ <string>Run Selection/Line in Listener</string>
+ <key>output</key>
+ <string>discard</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>15A984BD-BC65-43E8-878A-267788C8DA70</string>
+</dict>
+</plist>
diff --git a/misc/Factor.tmbundle/Commands/See Word.tmCommand b/misc/Factor.tmbundle/Commands/See Word.tmCommand
new file mode 100644
index 0000000000..b9dd2e5e90
--- /dev/null
+++ b/misc/Factor.tmbundle/Commands/See Word.tmCommand
@@ -0,0 +1,30 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>beforeRunningCommand</key>
+ <string>nop</string>
+ <key>command</key>
+ <string>#!/usr/bin/env ruby
+
+require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
+
+doc = STDIN.read
+word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
+puts factor_eval(%Q(#{doc_using_statements(doc)} \\ #{word} see))</string>
+ <key>fallbackInput</key>
+ <string>word</string>
+ <key>input</key>
+ <string>document</string>
+ <key>keyEquivalent</key>
+ <string>^h</string>
+ <key>name</key>
+ <string>See Word</string>
+ <key>output</key>
+ <string>showAsTooltip</string>
+ <key>scope</key>
+ <string>source.factor</string>
+ <key>uuid</key>
+ <string>35484754-DBF9-4381-BB25-00CAB64DF4A1</string>
+</dict>
+</plist>
diff --git a/misc/Factor.tmbundle/Support/lib/tm_factor.rb b/misc/Factor.tmbundle/Support/lib/tm_factor.rb
new file mode 100644
index 0000000000..54272e5e36
--- /dev/null
+++ b/misc/Factor.tmbundle/Support/lib/tm_factor.rb
@@ -0,0 +1,38 @@
+require 'osx/cocoa'
+
+def _wait_for_return_value(pb)
+ origCount = pb.changeCount
+ sleep 0.125 while pb.changeCount == origCount
+end
+
+def perform_service(service, in_string, wait_for_return_value=false)
+ p = OSX::NSPasteboard.pasteboardWithUniqueName
+ p.declareTypes_owner([OSX::NSStringPboardType], nil)
+ p.setString_forType(in_string, OSX::NSStringPboardType)
+ raise "Unable to call service #{service}" unless OSX::NSPerformService(service, p)
+ _wait_for_return_value(p) if wait_for_return_value
+ p.stringForType(OSX::NSStringPboardType)
+end
+
+def textmate_front()
+ system %Q{osascript -e 'tell app "TextMate" to activate'};
+end
+
+def factor_run(code)
+ perform_service("Factor/Evaluate in Listener", code)
+end
+
+def factor_eval(code)
+ r = perform_service("Factor/Evaluate Selection", code, true)
+ textmate_front
+ r
+end
+
+def doc_using_statements(document)
+ document.scan(/\b(USING:\s[^;]*\s;|USE:\s+\S+|IN:\s\S+)/).join("\n") << "\n"
+end
+
+def line_current_word(line, point)
+ left = line.rindex(/\s|^/, point - 1) + 1; right = line.index(/\s|$/, point) - 1
+ line[left..right]
+end
diff --git a/misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage b/misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage
index ec4961f312..304af129ce 100644
--- a/misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage
+++ b/misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage
@@ -1,5 +1,5 @@
<?xml version="1.0" encoding="UTF-8"?>
-<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0">
<dict>
<key>fileTypes</key>
@@ -254,9 +254,9 @@
</dict>
<dict>
<key>begin</key>
- <string>\(\s</string>
+ <string>\((?=\s)</string>
<key>end</key>
- <string>\s\)</string>
+ <string>(^|(?<=\s))\)</string>
<key>name</key>
<string>comment.parens.factor</string>
</dict>
diff --git a/misc/Factor.tmbundle/Syntaxes/HTML (Factor).tmLanguage b/misc/Factor.tmbundle/Syntaxes/HTML (Factor).tmLanguage
index 89c0f191b9..03394b933c 100644
--- a/misc/Factor.tmbundle/Syntaxes/HTML (Factor).tmLanguage
+++ b/misc/Factor.tmbundle/Syntaxes/HTML (Factor).tmLanguage
@@ -1,5 +1,5 @@
<?xml version="1.0" encoding="UTF-8"?>
-<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0">
<dict>
<key>fileTypes</key>
diff --git a/misc/Factor.tmbundle/info.plist b/misc/Factor.tmbundle/info.plist
index 8def3807d7..1ea756a1a5 100644
--- a/misc/Factor.tmbundle/info.plist
+++ b/misc/Factor.tmbundle/info.plist
@@ -1,9 +1,20 @@
<?xml version="1.0" encoding="UTF-8"?>
-<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0">
<dict>
<key>name</key>
<string>Factor</string>
+ <key>ordering</key>
+ <array>
+ <string>3C9C9C2A-314A-475B-A4E4-A68BAAF3F36E</string>
+ <string>141517D7-73E0-4475-A481-71102575A175</string>
+ <string>CAD3BB10-C480-4C0E-9518-94D61F7A0C0B</string>
+ <string>15A984BD-BC65-43E8-878A-267788C8DA70</string>
+ <string>8E01DDAF-959B-4237-ADB9-C133A4ACCE90</string>
+ <string>35484754-DBF9-4381-BB25-00CAB64DF4A1</string>
+ <string>BC5BE120-734B-40DF-8B6B-5D3243614B27</string>
+ <string>B619FCC0-2DF2-4657-82A8-0E5676A10254</string>
+ </array>
<key>uuid</key>
<string>8061D2F3-B603-411D-AFFE-61784A07906D</string>
</dict>
From 4044cd293a66877d3c6c41cf7cf61d2aba60fc87 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 13 Jan 2008 00:09:08 -0800
Subject: [PATCH 06/65] TYPEDEF-IF: and USE-IF: words; ptrdiff_t C type moved
to alien.c-types and special-cased for win64
---
core/alien/c-types/c-types.factor | 3 +++
core/alien/syntax/syntax-docs.factor | 10 ++++++++--
core/alien/syntax/syntax.factor | 3 +++
core/syntax/syntax-docs.factor | 6 ++++++
core/syntax/syntax.factor | 1 +
extra/opengl/gl/gl.factor | 2 --
extra/opengl/gl/unix/unix.factor | 2 +-
7 files changed, 22 insertions(+), 5 deletions(-)
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index b665300bee..6d9c2cec14 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -358,4 +358,7 @@ M: long-long-type box-return ( type -- )
"ushort*" define-primitive-type
[ string>u16-alien ] "ushort*" c-type set-c-type-prep
+
+ win64? "longlong" "long" ? "ptrdiff_t" typedef
+
] with-compilation-unit
diff --git a/core/alien/syntax/syntax-docs.factor b/core/alien/syntax/syntax-docs.factor
index d87b67eb59..00ee6345dc 100755
--- a/core/alien/syntax/syntax-docs.factor
+++ b/core/alien/syntax/syntax-docs.factor
@@ -49,8 +49,14 @@ $nl
HELP: TYPEDEF:
{ $syntax "TYPEDEF: old new" }
-{ $values { "old" "a C type" } { "new" "a C type" } }
-{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
+{ $values { "word" "a word with stack effect " { $snippet "( -- ? )" } } { "old" "a C type" } { "new" "a C type" } }
+{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
+{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
+
+HELP: TYPEDEF-IF:
+{ $syntax "TYPEDEF-IF: word old new" }
+{ $values { "word" "a word with stack effect " { $snippet "( -- ? )" } } { "old" "a C type" } { "new" "a C type" } }
+{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } " if " { $snippet "word" } " evaluates to a true value." }
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
HELP: C-STRUCT:
diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor
index bc3bc911ef..b81a91efcb 100755
--- a/core/alien/syntax/syntax.factor
+++ b/core/alien/syntax/syntax.factor
@@ -46,6 +46,9 @@ PRIVATE>
: TYPEDEF:
scan scan typedef ; parsing
+: TYPEDEF-IF:
+ scan-word execute scan scan rot [ typedef ] [ 2drop ] if ; parsing
+
: C-STRUCT:
scan in get
parse-definition
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index 9cf9647e41..f4efc3b6bb 100755
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -363,6 +363,12 @@ HELP: USE:
{ $description "Adds a new vocabulary at the front of the search path. Subsequent word lookups by the parser will search this vocabulary first." }
{ $errors "Throws an error if the vocabulary does not exist." } ;
+HELP: USE-IF:
+{ $syntax "USE-IF: word vocabulary" }
+{ $values { "word" "a word with stack effect " { $snippet "( -- ? )" } } { "vocabulary" "a vocabulary name" } }
+{ $description "Adds " { $snippet "vocabulary" } " at the front of the search path if " { $snippet "word" } " evaluates to a true value." }
+{ $errors "Throws an error if the vocabulary does not exist." } ;
+
HELP: USING:
{ $syntax "USING: vocabularies... ;" }
{ $values { "vocabularies" "a list of vocabulary names" } }
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index b0a7ea19bd..cd97aea9eb 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -46,6 +46,7 @@ IN: bootstrap.syntax
] define-syntax
"USE:" [ scan use+ ] define-syntax
+ "USE-IF:" [ scan-word execute scan swap [ use+ ] [ drop ] if ] define-syntax
"USING:" [ ";" parse-tokens add-use ] define-syntax
diff --git a/extra/opengl/gl/gl.factor b/extra/opengl/gl/gl.factor
index c7ce176aca..4a9d9c84d5 100644
--- a/extra/opengl/gl/gl.factor
+++ b/extra/opengl/gl/gl.factor
@@ -1469,8 +1469,6 @@ GL-FUNCTION: void glWindowPos3sv ( GLshort* p ) ;
: GL_SRC2_ALPHA GL_SOURCE2_ALPHA ; inline
: GL_SRC2_RGB GL_SOURCE2_RGB ; inline
-TYPEDEF: long ptrdiff_t
-
TYPEDEF: ptrdiff_t GLsizeiptr
TYPEDEF: ptrdiff_t GLintptr
diff --git a/extra/opengl/gl/unix/unix.factor b/extra/opengl/gl/unix/unix.factor
index 08141ad81d..16cd38f92f 100644
--- a/extra/opengl/gl/unix/unix.factor
+++ b/extra/opengl/gl/unix/unix.factor
@@ -2,4 +2,4 @@ USING: alien.syntax kernel syntax words ;
IN: opengl.gl.unix
-: GL-FUNCTION: \ FUNCTION: word-def call ; parsing
+: GL-FUNCTION: POSTPONE: FUNCTION: ; parsing
From c27d17e1ec7e15672ece8e258c7b82ee0d0e54f2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Sun, 13 Jan 2008 10:33:36 -1000
Subject: [PATCH 07/65] unbreak singleton?
---
extra/sequences/lib/lib.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 37b00042d2..e46ce3b107 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -59,7 +59,7 @@ IN: sequences.lib
] { } make ;
: singleton? ( seq -- ? )
- length 1 = ; foldable
+ length 1 = ;
: delete-random ( seq -- value )
[ length random ] keep [ nth ] 2keep delete-nth ;
From 952c559b52a52e92a299fcec1bd769a4d9128698 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 13 Jan 2008 17:07:59 -0500
Subject: [PATCH 08/65] Faster compilation of dispatch primitive
---
core/compiler/test/simple.factor | 6 ++
core/cpu/architecture/architecture.factor | 15 ++++-
core/cpu/ppc/architecture/architecture.factor | 55 +++++++++++++------
core/cpu/ppc/intrinsics/intrinsics.factor | 38 ++++++-------
core/generator/fixup/fixup.factor | 7 +++
core/generator/generator.factor | 47 +++++++++-------
core/inference/class/class-tests.factor | 21 ++++---
core/optimizer/known-words/known-words.factor | 6 +-
vm/code_heap.c | 2 +
vm/code_heap.h | 4 +-
10 files changed, 129 insertions(+), 72 deletions(-)
diff --git a/core/compiler/test/simple.factor b/core/compiler/test/simple.factor
index 7ce82c9a1f..9f831bb1f8 100755
--- a/core/compiler/test/simple.factor
+++ b/core/compiler/test/simple.factor
@@ -63,3 +63,9 @@ IN: temporary
! Regression
[ ] [ [ callstack ] compile-call drop ] unit-test
+
+! Regression
+
+: empty ;
+
+[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test
diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor
index 3550dcadc0..2409eafaf0 100755
--- a/core/cpu/architecture/architecture.factor
+++ b/core/cpu/architecture/architecture.factor
@@ -51,19 +51,28 @@ HOOK: %save-dispatch-xt compiler-backend ( -- )
M: object %save-dispatch-xt %save-word-xt ;
+! Call C primitive
+HOOK: %call-primitive compiler-backend ( label -- )
+
! Call another label
HOOK: %call-label compiler-backend ( label -- )
+! Far jump to C primitive
+HOOK: %jump-primitive compiler-backend ( label -- )
+
! Local jump for branches
HOOK: %jump-label compiler-backend ( label -- )
! Test if vreg is 'f' or not
HOOK: %jump-t compiler-backend ( label -- )
-! We pass the offset of the jump table start in the world table
-HOOK: %call-dispatch compiler-backend ( word-table# -- )
+HOOK: %call-dispatch compiler-backend ( -- label )
-HOOK: %jump-dispatch compiler-backend ( word-table# -- )
+HOOK: %jump-dispatch compiler-backend ( -- )
+
+HOOK: %dispatch-label compiler-backend ( word -- )
+
+HOOK: %end-dispatch compiler-backend ( label -- )
! Return to caller
HOOK: %return compiler-backend ( -- )
diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor
index e93d092b10..a156c173a1 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/core/cpu/ppc/architecture/architecture.factor
@@ -97,6 +97,22 @@ M: ppc-backend %epilogue ( n -- )
1 1 rot ADDI
0 MTLR ;
+: %prepare-primitive ( word -- )
+ #! Save stack pointer to stack_chain->callstack_top, load XT
+ 4 1 MR
+ 0 11 LOAD32
+ rc-absolute-ppc-2/2 rel-primitive ;
+
+: (%call) 11 MTLR BLRL ;
+
+M: ppc-backend %call-primitive ( word -- )
+ %prepare-primitive (%call) ;
+
+: (%jump) 11 MTCTR BCTR ;
+
+M: ppc-backend %jump-primitive ( word -- )
+ %prepare-primitive (%jump) ;
+
: %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
@@ -107,26 +123,29 @@ M: ppc-backend %jump-label ( label -- ) B ;
M: ppc-backend %jump-t ( label -- )
0 "flag" operand f v>operand CMPI BNE ;
-: (%call) 11 MTLR BLRL ;
-
-: dispatch-template ( word-table# quot -- )
- [
- >r
- "offset" operand "n" operand 1 SRAWI
- 0 11 LOAD32 rc-absolute-ppc-2/2 rel-dispatch
- 11 dup "offset" operand LWZX
- 11 dup word-xt-offset LWZ
- r> call
- ] H{
- { +input+ { { f "n" } } }
- { +scratch+ { { f "offset" } } }
- } with-template ; inline
+: (%dispatch) ( len -- )
+ 0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
+ "offset" operand "n" operand 1 SRAWI
+ 11 11 "offset" operand ADD
+ 11 dup rot cells LWZ ;
M: ppc-backend %call-dispatch ( word-table# -- )
- [ (%call) ] dispatch-template ;
+ [ 7 (%dispatch) (%call) <label> dup B ] H{
+ { +input+ { { f "n" } } }
+ { +scratch+ { { f "offset" } } }
+ } with-template ;
-M: ppc-backend %jump-dispatch ( word-table# -- )
- [ %epilogue-later 11 MTCTR BCTR ] dispatch-template ;
+M: ppc-backend %jump-dispatch ( -- )
+ [ %epilogue-later 6 (%dispatch) (%jump) ] H{
+ { +input+ { { f "n" } } }
+ { +scratch+ { { f "offset" } } }
+ } with-template ;
+
+M: ppc-backend %dispatch-label ( word -- )
+ 0 , rc-absolute-cell rel-word ;
+
+M: ppc-backend %end-dispatch ( label -- )
+ resolve-label ;
M: ppc-backend %return ( -- ) %epilogue-later BLR ;
@@ -271,7 +290,7 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ;
: %tag-fixnum ( src dest -- ) tag-bits get SLWI ;
-: %untag-fixnum ( src dest -- ) tag-bits get SRAWI ;
+: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
M: ppc-backend value-structs?
#! On Linux/PPC, value structs are passed in the same way
diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index 34197fdef3..0773dae947 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/core/cpu/ppc/intrinsics/intrinsics.factor
@@ -23,8 +23,8 @@ IN: cpu.ppc.intrinsics
: %slot-any
"obj" operand "scratch" operand %untag
- "n" operand dup 1 SRAWI
- "scratch" operand "val" operand "n" operand ;
+ "offset" operand "n" operand 1 SRAWI
+ "scratch" operand "val" operand "offset" operand ;
\ slot {
! Slot number is literal and the tag is known
@@ -47,9 +47,8 @@ IN: cpu.ppc.intrinsics
{
[ %slot-any LWZX ] H{
{ +input+ { { f "obj" } { f "n" } } }
- { +scratch+ { { f "val" } { f "scratch" } } }
+ { +scratch+ { { f "val" } { f "scratch" } { f "offset" } } }
{ +output+ { "val" } }
- { +clobber+ { "n" } }
}
}
} define-intrinsics
@@ -88,33 +87,34 @@ IN: cpu.ppc.intrinsics
{
[ %slot-any STWX %write-barrier ] H{
{ +input+ { { f "val" } { f "obj" } { f "n" } } }
- { +scratch+ { { f "scratch" } } }
- { +clobber+ { "val" "n" } }
+ { +scratch+ { { f "scratch" } { f "offset" } } }
+ { +clobber+ { "val" } }
}
}
} define-intrinsics
+: (%char-slot)
+ "offset" operand "n" operand 2 SRAWI
+ "offset" operand dup "obj" operand ADD ;
+
\ char-slot [
- "out" operand "obj" operand MR
- "n" operand dup 2 SRAWI
- "n" operand "obj" operand "n" operand ADD
- "out" operand "n" operand string-offset LHZ
+ (%char-slot)
+ "out" operand "offset" operand string-offset LHZ
"out" operand dup %tag-fixnum
] H{
{ +input+ { { f "n" } { f "obj" } } }
- { +scratch+ { { f "out" } } }
+ { +scratch+ { { f "out" } { f "offset" } } }
{ +output+ { "out" } }
- { +clobber+ { "n" } }
} define-intrinsic
\ set-char-slot [
+ (%char-slot)
"val" operand dup %untag-fixnum
- "slot" operand dup 2 SRAWI
- "slot" operand dup "obj" operand ADD
- "val" operand "slot" operand string-offset STH
+ "val" operand "offset" operand string-offset STH
] H{
- { +input+ { { f "val" } { f "slot" } { f "obj" } } }
- { +clobber+ { "val" "slot" } }
+ { +input+ { { f "val" } { f "n" } { f "obj" } } }
+ { +scratch+ { { f "offset" } } }
+ { +clobber+ { "val" } }
} define-intrinsic
: fixnum-register-op ( op -- pair )
@@ -185,10 +185,10 @@ IN: cpu.ppc.intrinsics
{
[
{ "positive" "end" } [ define-label ] each
- "y" operand "out" operand swap %untag-fixnum
+ "out" operand "y" operand %untag-fixnum
0 "y" operand 0 CMPI
"positive" get BGE
- "y" operand dup NEG
+ "out" operand dup NEG
"out" operand "x" operand "out" operand SRAW
"end" get B
"positive" resolve-label
diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor
index 78dd3f73df..3a30a51d09 100755
--- a/core/generator/fixup/fixup.factor
+++ b/core/generator/fixup/fixup.factor
@@ -69,6 +69,7 @@ SYMBOL: label-table
: rt-literal 2 ;
: rt-dispatch 3 ;
: rt-xt 4 ;
+: rt-here 5 ;
: rt-label 6 ;
TUPLE: label-fixup label class ;
@@ -129,12 +130,18 @@ SYMBOL: word-table
: rel-word ( word class -- )
>r add-word r> rt-xt rel-fixup ;
+: rel-primitive ( word class -- )
+ >r word-def first r> rt-primitive rel-fixup ;
+
: rel-literal ( literal class -- )
>r add-literal r> rt-literal rel-fixup ;
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
+: rel-here ( class -- )
+ 0 swap rt-here rel-fixup ;
+
: init-fixup ( -- )
V{ } clone relocation-table set
V{ } clone label-table set ;
diff --git a/core/generator/generator.factor b/core/generator/generator.factor
index 888cbdccaf..1c23e51e12 100755
--- a/core/generator/generator.factor
+++ b/core/generator/generator.factor
@@ -104,14 +104,21 @@ UNION: #terminal
! node
M: node generate-node drop iterate-next ;
-: %call ( word -- ) %call-label ;
+: %call ( word -- )
+ dup primitive? [ %call-primitive ] [ %call-label ] if ;
: %jump ( word -- )
- dup compiling-label get eq? [
- drop current-label-start get %jump-label
- ] [
- %epilogue-later %jump-label
- ] if ;
+ {
+ { [ dup compiling-label get eq? ] [
+ drop current-label-start get %jump-label
+ ] }
+ { [ dup primitive? ] [
+ %epilogue-later %jump-primitive
+ ] }
+ { [ t ] [
+ %epilogue-later %jump-label
+ ] }
+ } cond ;
: generate-call ( label -- next )
dup maybe-compile
@@ -162,22 +169,22 @@ M: #if generate-node
] generate-1
] keep ;
-: dispatch-branches ( node -- syms )
- node-children
- [ compiling-word get dispatch-branch ] map
- word-table get push-all ;
-
-: %dispatch ( word-table# -- )
- tail-call? [
- %jump-dispatch
- ] [
- 0 frame-required
- %call-dispatch
- ] if ;
+: dispatch-branches ( node -- )
+ node-children [
+ compiling-word get dispatch-branch %dispatch-label
+ ] each ;
M: #dispatch generate-node
- word-table get length %dispatch
- dispatch-branches init-templates iterate-next ;
+ #! The order here is important, dispatch-branches must
+ #! run after %dispatch, so that each branch gets the
+ #! correct register state
+ tail-call? [
+ %jump-dispatch dispatch-branches
+ ] [
+ 0 frame-required
+ %call-dispatch >r dispatch-branches r> %end-dispatch
+ ] if
+ init-templates iterate-next ;
! #call
: define-intrinsics ( word intrinsics -- )
diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor
index 16d9fae36a..3bd90a3aca 100755
--- a/core/inference/class/class-tests.factor
+++ b/core/inference/class/class-tests.factor
@@ -3,7 +3,8 @@ USING: arrays math.private kernel math compiler inference
inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
-slots.private combinators definitions compiler.units ;
+slots.private combinators definitions compiler.units
+system ;
! Make sure these compile even though this is invalid code
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
@@ -251,12 +252,14 @@ M: fixnum annotate-entry-test-1 drop ;
\ fixnum-shift inlined?
] unit-test
-[ t ] [
- [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
- \ shift inlined?
-] unit-test
+cell-bits 32 = [
+ [ t ] [
+ [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
+ \ shift inlined?
+ ] unit-test
-[ f ] [
- [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
- \ fixnum-shift inlined?
-] unit-test
+ [ f ] [
+ [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
+ \ fixnum-shift inlined?
+ ] unit-test
+] when
diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor
index e9e4c53632..1d8395d667 100755
--- a/core/optimizer/known-words/known-words.factor
+++ b/core/optimizer/known-words/known-words.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.known-words
USING: alien arrays generic hashtables inference.dataflow
@@ -149,6 +149,10 @@ float-arrays combinators.private combinators ;
\ >array { { string vector } } "specializer" set-word-prop
+\ >vector { { array vector } } "specializer" set-word-prop
+
+\ >sbuf { string } "specializer" set-word-prop
+
\ crc32 { string } "specializer" set-word-prop
\ split, { string string } "specializer" set-word-prop
diff --git a/vm/code_heap.c b/vm/code_heap.c
index 7cfdffe8ca..ddd7efb4a0 100755
--- a/vm/code_heap.c
+++ b/vm/code_heap.c
@@ -52,6 +52,8 @@ INLINE CELL compute_code_rel(F_REL *rel,
return CREF(words_start,REL_ARGUMENT(rel));
case RT_XT:
return (CELL)untag_word(get(CREF(words_start,REL_ARGUMENT(rel))))->xt;
+ case RT_HERE:
+ return rel->offset + code_start;
case RT_LABEL:
return code_start + REL_ARGUMENT(rel);
default:
diff --git a/vm/code_heap.h b/vm/code_heap.h
index c8e41d3fbe..d5b361e693 100755
--- a/vm/code_heap.h
+++ b/vm/code_heap.h
@@ -9,8 +9,8 @@ typedef enum {
RT_DISPATCH,
/* a compiled word reference */
RT_XT,
- /* reserved */
- RT_RESERVED,
+ /* current offset */
+ RT_HERE,
/* a local label */
RT_LABEL
} F_RELTYPE;
From 2f32823690b99ce6ffda24aedb7fd82d882450e0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 13 Jan 2008 17:08:32 -0500
Subject: [PATCH 09/65] flushable declaration wasn't being printed
---
core/prettyprint/prettyprint-tests.factor | 9 ++++++++-
core/prettyprint/prettyprint.factor | 1 +
2 files changed, 9 insertions(+), 1 deletion(-)
diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor
index 595dfa88da..9c5ec885ae 100755
--- a/core/prettyprint/prettyprint-tests.factor
+++ b/core/prettyprint/prettyprint-tests.factor
@@ -290,6 +290,14 @@ unit-test
[ ] [ \ effect-in synopsis drop ] unit-test
+! Regression
+[ t ] [
+ "IN: temporary\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
+ dup eval
+ "generic-decl-test" "temporary" lookup
+ [ see ] string-out =
+] unit-test
+
[ [ + ] ] [
[ \ + (step-into) ] (remove-breakpoints)
] unit-test
@@ -313,4 +321,3 @@ unit-test
[ [ 2 . ] ] [
[ 2 \ break (step-into) . ] (remove-breakpoints)
] unit-test
-
diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor
index 21104de5b6..45ff0c0572 100755
--- a/core/prettyprint/prettyprint.factor
+++ b/core/prettyprint/prettyprint.factor
@@ -207,6 +207,7 @@ M: word declarations.
POSTPONE: delimiter
POSTPONE: inline
POSTPONE: foldable
+ POSTPONE: flushable
} [ declaration. ] with each ;
: pprint-; \ ; pprint-word ;
From b870bce81d78170f7cb52346b98d1e09ee87e54a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 13 Jan 2008 17:09:01 -0500
Subject: [PATCH 10/65] Add inline declarations
---
core/sequences/sequences.factor | 2 +-
core/vectors/vectors.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index a0c909bf56..151777b0c7 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -199,7 +199,7 @@ TUPLE: slice-error reason ;
: <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when
check-slice
- slice construct-boa ;
+ slice construct-boa ; inline
M: slice virtual-seq slice-seq ;
M: slice virtual@ [ slice-from + ] keep slice-seq ;
diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor
index 661ef9ddc8..8d52b8fa9c 100755
--- a/core/vectors/vectors.factor
+++ b/core/vectors/vectors.factor
@@ -7,7 +7,7 @@ IN: vectors
: <vector> ( n -- vector ) f <array> 0 array>vector ; inline
-: >vector ( seq -- vector ) V{ } clone-like ; inline
+: >vector ( seq -- vector ) V{ } clone-like ;
M: vector like
drop dup vector? [
From 472cde4f75335f9a5558a89122fb9f7870d6c0ba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 13 Jan 2008 18:52:14 -0500
Subject: [PATCH 11/65] Add unit test for regression
---
core/kernel/kernel-tests.factor | 10 ++++++++++
1 file changed, 10 insertions(+)
diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor
index 1c4c529749..2cb308b619 100755
--- a/core/kernel/kernel-tests.factor
+++ b/core/kernel/kernel-tests.factor
@@ -108,3 +108,13 @@ IN: temporary
[ drop foo ] unit-test-fails
[ ] [ :c ] unit-test
+
+! Regression
+: (loop) ( a b c d -- )
+ >r pick r> swap >r pick r> swap
+ < [ >r >r >r 1+ r> r> r> (loop) ] [ 2drop 2drop ] if ; inline
+
+: loop ( obj obj -- )
+ H{ } values swap >r dup length swap r> 0 -roll (loop) ;
+
+[ loop ] unit-test-fails
From 8f69f864382af35dbd410a50f722a04ac76139c7 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 13 Jan 2008 17:35:26 -0800
Subject: [PATCH 12/65] Cel shading demo. Caching implementation of
GL-FUNCTION: for windows.
---
Makefile | 2 +-
core/strings/strings-docs.factor | 0
extra/cel-shading/cel-shading.factor | 152 +++++++++++++++++++++++++
extra/opengl/gl/windows/windows.factor | 26 ++++-
extra/windows/opengl32/opengl32.factor | 4 +-
5 files changed, 176 insertions(+), 8 deletions(-)
mode change 100644 => 100755 core/strings/strings-docs.factor
create mode 100644 extra/cel-shading/cel-shading.factor
mode change 100644 => 100755 extra/opengl/gl/windows/windows.factor
mode change 100644 => 100755 extra/windows/opengl32/opengl32.factor
diff --git a/Makefile b/Makefile
index 1042731065..e02b6a672b 100755
--- a/Makefile
+++ b/Makefile
@@ -140,7 +140,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
clean:
rm -f vm/*.o
- rm -f libfactor.a
+ rm -f factor*.dll libfactor*.*
vm/resources.o:
windres vm/factor.rs vm/resources.o
diff --git a/core/strings/strings-docs.factor b/core/strings/strings-docs.factor
old mode 100644
new mode 100755
diff --git a/extra/cel-shading/cel-shading.factor b/extra/cel-shading/cel-shading.factor
new file mode 100644
index 0000000000..e21638b75b
--- /dev/null
+++ b/extra/cel-shading/cel-shading.factor
@@ -0,0 +1,152 @@
+USING: arrays bunny io io.files kernel
+ math math.functions math.vectors
+ namespaces
+ opengl opengl.gl
+ prettyprint
+ sequences ui ui.gadgets ui.gestures ui.render ;
+IN: cel-shading
+
+: NEAR-PLANE 1.0 64.0 / ; inline
+: FAR-PLANE 4.0 ; inline
+: FOV 2.0 sqrt 1+ ; inline
+: MOUSE-MOTION-SCALE 0.5 ; inline
+: MOUSE-DISTANCE-SCALE 1.0 64.0 / ; inline
+: KEY-ROTATE-STEP 1.0 ; inline
+: KEY-DISTANCE-STEP 1.0 64.0 / ; inline
+: DIMS { 640 480 } ; inline
+
+: FOV-RATIO ( -- fov ) DIMS dup first2 min v/n ;
+
+SYMBOL: last-drag-loc
+
+TUPLE: cel-shading-gadget yaw pitch distance model program ;
+
+: <cel-shading-gadget> ( -- cel-shading-gadget )
+ cel-shading-gadget construct-gadget
+ 0.0 over set-cel-shading-gadget-yaw
+ 0.0 over set-cel-shading-gadget-pitch
+ 0.375 over set-cel-shading-gadget-distance
+ maybe-download read-model over set-cel-shading-gadget-model ;
+
+: yaw-cel-shading-gadget ( yaw gadget -- )
+ [ [ cel-shading-gadget-yaw + ] keep set-cel-shading-gadget-yaw ] keep relayout-1 ;
+
+: pitch-cel-shading-gadget ( pitch gadget -- )
+ [ [ cel-shading-gadget-pitch + ] keep set-cel-shading-gadget-pitch ] keep relayout-1 ;
+
+: zoom-cel-shading-gadget ( distance gadget -- )
+ [ [ cel-shading-gadget-distance + ] keep set-cel-shading-gadget-distance ] keep relayout-1 ;
+
+M: cel-shading-gadget pref-dim* ( gadget -- dim )
+ drop DIMS ;
+
+: -+ ( x -- -x x )
+ dup neg swap ;
+
+: cel-shading-frustum ( -- -x x -y y near far )
+ FOV-RATIO NEAR-PLANE FOV / v*n
+ first2 [ -+ ] 2apply NEAR-PLANE FAR-PLANE ;
+
+: cel-shading-vertex-shader-source
+ {
+ "varying vec3 position, normal;"
+ ""
+ "void"
+ "main()"
+ "{"
+ "gl_Position = ftransform();"
+ ""
+ "position = gl_Vertex.xyz;"
+ "normal = gl_Normal;"
+ "}"
+ } "\n" join ;
+
+: cel-shading-fragment-shader-source
+ {
+ "varying vec3 position, normal;"
+ "uniform vec3 light_direction;"
+ "uniform vec4 color;"
+ "uniform vec4 ambient, diffuse;"
+ ""
+ "float"
+ "smooth_modulate(vec3 direction, vec3 normal)"
+ "{"
+ "return clamp(dot(direction, normal), 0.0, 1.0);"
+ "}"
+ ""
+ "float"
+ "modulate(vec3 direction, vec3 normal)"
+ "{"
+ "float m = smooth_modulate(direction, normal);"
+ "return smoothstep(0.0, 0.01, m) * 0.4 + smoothstep(0.49, 0.5, m) * 0.5;"
+ "}"
+ ""
+ "void"
+ "main()"
+ "{"
+ "vec3 direction = normalize(light_direction - position);"
+ "gl_FragColor = ambient + diffuse * color * vec4(vec3(modulate(direction, normal)), 1); "
+ "}"
+ } "\n" join ;
+
+: cel-shading-program ( -- program )
+ cel-shading-vertex-shader-source <vertex-shader> check-gl-shader
+ cel-shading-fragment-shader-source <fragment-shader> check-gl-shader
+ 2array <gl-program> check-gl-program ;
+
+M: cel-shading-gadget graft* ( gadget -- )
+ 0.0 0.0 0.0 1.0 glClearColor
+ GL_CULL_FACE glEnable
+ GL_DEPTH_TEST glEnable
+ cel-shading-program swap set-cel-shading-gadget-program ;
+
+M: cel-shading-gadget ungraft* ( gadget -- )
+ cel-shading-gadget-program delete-gl-program ;
+
+: cel-shading-draw-setup ( gadget -- gadget )
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ cel-shading-frustum glFrustum
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+ [ >r 0.0 0.0 r> cel-shading-gadget-distance neg glTranslatef ] keep
+ [ cel-shading-gadget-pitch 1.0 0.0 0.0 glRotatef ] keep
+ [ cel-shading-gadget-yaw 0.0 1.0 0.0 glRotatef ] keep
+ [ cel-shading-gadget-program [ "light_direction" glGetUniformLocation -25.0 45.0 80.0 glUniform3f ] keep
+ [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ] keep
+ [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ] keep
+ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ] keep ;
+
+M: cel-shading-gadget draw-gadget* ( gadget -- )
+ dup cel-shading-gadget-program [
+ cel-shading-draw-setup
+ 0.0 -0.12 0.0 glTranslatef
+ cel-shading-gadget-model first3 draw-bunny
+ ] with-gl-program ;
+
+: reset-last-drag-rel ( -- )
+ { 0 0 } last-drag-loc set ;
+: last-drag-rel ( -- rel )
+ drag-loc [ last-drag-loc get v- ] keep last-drag-loc set ;
+
+: drag-yaw-pitch ( -- yaw pitch )
+ last-drag-rel MOUSE-MOTION-SCALE v*n first2 ;
+
+cel-shading-gadget H{
+ { T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-cel-shading-gadget ] }
+ { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-cel-shading-gadget ] }
+ { T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-cel-shading-gadget ] }
+ { T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-cel-shading-gadget ] }
+ { T{ key-down f f "=" } [ KEY-DISTANCE-STEP neg swap zoom-cel-shading-gadget ] }
+ { T{ key-down f f "-" } [ KEY-DISTANCE-STEP swap zoom-cel-shading-gadget ] }
+
+ { T{ button-down f f 1 } [ drop reset-last-drag-rel ] }
+ { T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-cel-shading-gadget ] keep yaw-cel-shading-gadget ] }
+ { T{ mouse-scroll } [ scroll-direction get second MOUSE-DISTANCE-SCALE * swap zoom-cel-shading-gadget ] }
+} set-gestures
+
+: cel-shading-window ( -- )
+ [ <cel-shading-gadget> "Cel Shading" open-window ] with-ui ;
+
+MAIN: cel-shading-window
diff --git a/extra/opengl/gl/windows/windows.factor b/extra/opengl/gl/windows/windows.factor
old mode 100644
new mode 100755
index 96fb91793d..186f17206c
--- a/extra/opengl/gl/windows/windows.factor
+++ b/extra/opengl/gl/windows/windows.factor
@@ -1,18 +1,34 @@
-USING: alien alien.syntax kernel libc namespaces parser
- sequences syntax system vectors ;
+USING: alien alien.syntax arrays assocs hashtables init kernel
+ libc math namespaces parser sequences syntax system vectors
+ windows.opengl32 ;
IN: opengl.gl.windows
+<PRIVATE
+
+SYMBOL: gl-function-number-counter
SYMBOL: gl-function-pointers
-LIBRARY: gl
-FUNCTION: void* wglGetProcAddress ( char* name ) ;
+0 gl-function-number-counter set
+[ 100 <hashtable> gl-function-pointers set ] "opengl.gl.windows init hook" add-init-hook
+
+: gl-function-number ( -- n )
+ gl-function-number-counter get
+ dup 1+ gl-function-number-counter set ;
+
+: gl-function-pointer ( name n -- funptr )
+ wglGetCurrentContext 2array dup gl-function-pointers get at
+ [ -rot 2drop ]
+ [ >r wglGetProcAddress dup r> gl-function-pointers get set-at ]
+ if* ;
+
+PRIVATE>
: GL-FUNCTION:
"stdcall"
scan
scan
- dup [ wglGetProcAddress check-ptr ] curry swap
+ dup gl-function-number [ gl-function-pointer ] 2curry swap
";" parse-tokens [ "()" subseq? not ] subset
define-indirect
; parsing
diff --git a/extra/windows/opengl32/opengl32.factor b/extra/windows/opengl32/opengl32.factor
old mode 100644
new mode 100755
index 2d58d34083..a8d8ad8153
--- a/extra/windows/opengl32/opengl32.factor
+++ b/extra/windows/opengl32/opengl32.factor
@@ -1,8 +1,7 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax parser namespaces kernel
-math windows.types windows.types init assocs sequences opengl.gl
-libc ;
+math windows.types windows.types init assocs sequences libc ;
IN: windows.opengl32
! PIXELFORMATDESCRIPTOR flags
@@ -100,4 +99,5 @@ LIBRARY: gl
FUNCTION: HGLRC wglCreateContext ( HDC hDC ) ;
FUNCTION: BOOL wglDeleteContext ( HGLRC hRC ) ;
FUNCTION: BOOL wglMakeCurrent ( HDC hDC, HGLRC hglrc ) ;
+FUNCTION: HGLRC wglGetCurrentContext ( ) ;
FUNCTION: void* wglGetProcAddress ( char* name ) ;
From b42d144336e1e98daf93d1e94a5cb38b5e829f02 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 13 Jan 2008 18:15:37 -0800
Subject: [PATCH 13/65] Documentation for the cel shading demo
---
extra/cel-shading/authors.txt | 1 +
extra/cel-shading/summary.txt | 1 +
extra/cel-shading/tags.txt | 3 +++
3 files changed, 5 insertions(+)
create mode 100644 extra/cel-shading/authors.txt
create mode 100644 extra/cel-shading/summary.txt
create mode 100644 extra/cel-shading/tags.txt
diff --git a/extra/cel-shading/authors.txt b/extra/cel-shading/authors.txt
new file mode 100644
index 0000000000..6a0dc7293a
--- /dev/null
+++ b/extra/cel-shading/authors.txt
@@ -0,0 +1 @@
+Joe Groff
\ No newline at end of file
diff --git a/extra/cel-shading/summary.txt b/extra/cel-shading/summary.txt
new file mode 100644
index 0000000000..60da092f6d
--- /dev/null
+++ b/extra/cel-shading/summary.txt
@@ -0,0 +1 @@
+Stanford Bunny rendered with a cel-shading GLSL program
\ No newline at end of file
diff --git a/extra/cel-shading/tags.txt b/extra/cel-shading/tags.txt
new file mode 100644
index 0000000000..0db7e8e629
--- /dev/null
+++ b/extra/cel-shading/tags.txt
@@ -0,0 +1,3 @@
+demos
+opengl
+glsl
\ No newline at end of file
From d73d8820c13c2305dce0d1c8f190e683cdb6ef75 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 13 Jan 2008 18:17:28 -0800
Subject: [PATCH 14/65] Ensure that the right vocabs are available for textmate
See and Help commands
---
misc/Factor.tmbundle/Commands/Help for Word.tmCommand | 2 +-
misc/Factor.tmbundle/Commands/See Word.tmCommand | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/misc/Factor.tmbundle/Commands/Help for Word.tmCommand b/misc/Factor.tmbundle/Commands/Help for Word.tmCommand
index a3d77d2f0c..350c01d344 100644
--- a/misc/Factor.tmbundle/Commands/Help for Word.tmCommand
+++ b/misc/Factor.tmbundle/Commands/Help for Word.tmCommand
@@ -11,7 +11,7 @@ require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
doc = STDIN.read
word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
-factor_run(%Q(#{doc_using_statements(doc)} \\ #{word} help))</string>
+factor_run(%Q(#{doc_using_statements(doc)} USE: help\n \\ #{word} help))</string>
<key>fallbackInput</key>
<string>word</string>
<key>input</key>
diff --git a/misc/Factor.tmbundle/Commands/See Word.tmCommand b/misc/Factor.tmbundle/Commands/See Word.tmCommand
index b9dd2e5e90..4502e235be 100644
--- a/misc/Factor.tmbundle/Commands/See Word.tmCommand
+++ b/misc/Factor.tmbundle/Commands/See Word.tmCommand
@@ -11,7 +11,7 @@ require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
doc = STDIN.read
word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i)
-puts factor_eval(%Q(#{doc_using_statements(doc)} \\ #{word} see))</string>
+puts factor_eval(%Q(#{doc_using_statements(doc)} USE: prettyprint\n \\ #{word} see))</string>
<key>fallbackInput</key>
<string>word</string>
<key>input</key>
From dc2109e6cbce003b9671b43c465c81fad2d6297f Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 13 Jan 2008 18:46:51 -0800
Subject: [PATCH 15/65] Ensure that the parser vocab is in use for textmate Run
command
---
misc/Factor.tmbundle/Commands/Run File in Listener.tmCommand | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/misc/Factor.tmbundle/Commands/Run File in Listener.tmCommand b/misc/Factor.tmbundle/Commands/Run File in Listener.tmCommand
index bc8c84ec13..f28e062541 100644
--- a/misc/Factor.tmbundle/Commands/Run File in Listener.tmCommand
+++ b/misc/Factor.tmbundle/Commands/Run File in Listener.tmCommand
@@ -8,7 +8,7 @@
<string>#!/usr/bin/env ruby
require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor"
-factor_run(%Q("#{ENV["TM_FILEPATH"]}" run-file))</string>
+factor_run(%Q(USE: parser\n "#{ENV["TM_FILEPATH"]}" run-file))</string>
<key>input</key>
<string>none</string>
<key>keyEquivalent</key>
From 53effc35a68bf304f71f05706bb6484c3c65ced4 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 13 Jan 2008 19:06:16 -0800
Subject: [PATCH 16/65] Get multiline working again and use it in cel-shading
---
extra/cel-shading/cel-shading.factor | 82 +++++++++++++--------------
extra/multiline/multiline-docs.factor | 3 +-
extra/multiline/multiline.factor | 2 +-
3 files changed, 44 insertions(+), 43 deletions(-)
diff --git a/extra/cel-shading/cel-shading.factor b/extra/cel-shading/cel-shading.factor
index e21638b75b..20b392195a 100644
--- a/extra/cel-shading/cel-shading.factor
+++ b/extra/cel-shading/cel-shading.factor
@@ -1,5 +1,5 @@
USING: arrays bunny io io.files kernel
- math math.functions math.vectors
+ math math.functions math.vectors multiline
namespaces
opengl opengl.gl
prettyprint
@@ -47,47 +47,47 @@ M: cel-shading-gadget pref-dim* ( gadget -- dim )
FOV-RATIO NEAR-PLANE FOV / v*n
first2 [ -+ ] 2apply NEAR-PLANE FAR-PLANE ;
-: cel-shading-vertex-shader-source
- {
- "varying vec3 position, normal;"
- ""
- "void"
- "main()"
- "{"
- "gl_Position = ftransform();"
- ""
- "position = gl_Vertex.xyz;"
- "normal = gl_Normal;"
- "}"
- } "\n" join ;
+STRING: cel-shading-vertex-shader-source
+varying vec3 position, normal;
-: cel-shading-fragment-shader-source
- {
- "varying vec3 position, normal;"
- "uniform vec3 light_direction;"
- "uniform vec4 color;"
- "uniform vec4 ambient, diffuse;"
- ""
- "float"
- "smooth_modulate(vec3 direction, vec3 normal)"
- "{"
- "return clamp(dot(direction, normal), 0.0, 1.0);"
- "}"
- ""
- "float"
- "modulate(vec3 direction, vec3 normal)"
- "{"
- "float m = smooth_modulate(direction, normal);"
- "return smoothstep(0.0, 0.01, m) * 0.4 + smoothstep(0.49, 0.5, m) * 0.5;"
- "}"
- ""
- "void"
- "main()"
- "{"
- "vec3 direction = normalize(light_direction - position);"
- "gl_FragColor = ambient + diffuse * color * vec4(vec3(modulate(direction, normal)), 1); "
- "}"
- } "\n" join ;
+void
+main()
+{
+ gl_Position = ftransform();
+
+ position = gl_Vertex.xyz;
+ normal = gl_Normal;
+}
+
+;
+
+STRING: cel-shading-fragment-shader-source
+varying vec3 position, normal;
+uniform vec3 light_direction;
+uniform vec4 color;
+uniform vec4 ambient, diffuse;
+
+float
+smooth_modulate(vec3 direction, vec3 normal)
+{
+ return clamp(dot(direction, normal), 0.0, 1.0);
+}
+
+float
+modulate(vec3 direction, vec3 normal)
+{
+ float m = smooth_modulate(direction, normal);
+ return smoothstep(0.0, 0.01, m) * 0.4 + smoothstep(0.49, 0.5, m) * 0.5;
+}
+
+void
+main()
+{
+ vec3 direction = normalize(light_direction - position);
+ gl_FragColor = ambient + diffuse * color * vec4(vec3(modulate(direction, normal)), 1);
+}
+
+;
: cel-shading-program ( -- program )
cel-shading-vertex-shader-source <vertex-shader> check-gl-shader
diff --git a/extra/multiline/multiline-docs.factor b/extra/multiline/multiline-docs.factor
index 7e7375cfad..0c0eb5e9dd 100644
--- a/extra/multiline/multiline-docs.factor
+++ b/extra/multiline/multiline-docs.factor
@@ -1,4 +1,5 @@
-USING: help.markup help.syntax multiline ;
+USING: help.markup help.syntax ;
+IN: multiline
HELP: STRING:
{ $syntax "STRING: name\nfoo\n;" }
diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor
index 89a6e06053..e8063fc759 100644
--- a/extra/multiline/multiline.factor
+++ b/extra/multiline/multiline.factor
@@ -16,7 +16,7 @@ IN: multiline
: STRING:
CREATE dup reset-generic
- parse-here 1quotation define-compound ; parsing
+ [ parse-here 1quotation define ] keep make-inline ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index )
lexer get line-text 2dup start
From 18451c4675422f7744a88e9ff8daace0564f7a8e Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 13 Jan 2008 19:09:01 -0800
Subject: [PATCH 17/65] TextMate syntax highlighting for multiline strings
---
.../Syntaxes/Factor.tmLanguage | 38 +++++++++++++++++++
1 file changed, 38 insertions(+)
diff --git a/misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage b/misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage
index 304af129ce..8df0179fd1 100644
--- a/misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage
+++ b/misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage
@@ -240,6 +240,44 @@
</dict>
</array>
</dict>
+ <dict>
+ <key>begin</key>
+ <string><"</string>
+ <key>end</key>
+ <string>"></string>
+ <key>name</key>
+ <string>string.quoted.double.multiline.factor</string>
+ <key>patterns</key>
+ <array>
+ <dict>
+ <key>include</key>
+ <string>#escaped_characters</string>
+ </dict>
+ </array>
+ </dict>
+ <dict>
+ <key>begin</key>
+ <string>(^|(?<=\s))(STRING:)\s+(\S+)</string>
+ <key>captures</key>
+ <dict>
+ <key>2</key>
+ <dict>
+ <key>name</key>
+ <string>keyword.colon.factor</string>
+ </dict>
+ <key>3</key>
+ <dict>
+ <key>name</key>
+ <string>entity.name.heredoc.factor</string>
+ </dict>
+ </dict>
+ <key>contentName</key>
+ <string>string.unquoted.heredoc.factor</string>
+ <key>end</key>
+ <string>^;$</string>
+ <key>name</key>
+ <string>definition.word.heredoc.factor</string>
+ </dict>
<dict>
<key>match</key>
<string>inline|foldable</string>
From ce92275c8e50ea4347a17749b196e15ea9f9dd2a Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 13 Jan 2008 22:58:11 -0800
Subject: [PATCH 18/65] Documentation for the GLSL-related utility words in
opengl
---
extra/opengl/opengl-docs.factor | 96 ++++++++++++++++++++++++++++++++-
1 file changed, 95 insertions(+), 1 deletion(-)
diff --git a/extra/opengl/opengl-docs.factor b/extra/opengl/opengl-docs.factor
index f9a491aba6..58b86f09b3 100644
--- a/extra/opengl/opengl-docs.factor
+++ b/extra/opengl/opengl-docs.factor
@@ -92,6 +92,96 @@ HELP: with-translation
{ $values { "loc" "a pair of integers" } { "quot" quotation } }
{ $description "Calls the quotation with a translation by " { $snippet "loc" } " pixels applied to the current " { $link GL_MODELVIEW } " matrix, restoring the matrix when the quotation is done." } ;
+HELP: gl-shader
+{ $class-description { $snippet "gl-shader" } " is a predicate class comprising values returned by OpenGL to represent shader objects. The following words are provided for creating and manipulating these objects:"
+ { $list
+ { { $link <gl-shader> } " - Compile GLSL code into a shader object" }
+ { { $link gl-shader-ok? } " - Check whether a shader object compiled successfully" }
+ { { $link check-gl-shader } " - Throw an error unless a shader object compiled successfully" }
+ { { $link gl-shader-info-log } " - Retrieve the info log of messages generated by the GLSL compiler" }
+ { { $link delete-gl-shader } " - Invalidate a shader object" }
+ }
+ "The derived predicate classes " { $link vertex-shader } " and " { $link fragment-shader } " are also defined for the two standard kinds of shader defined by the OpenGL specification." } ;
+
+HELP: vertex-shader
+{ $class-description { $snippet "vertex-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_VERTEX_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following vertex shader-specific functions are defined:"
+ { $list
+ { { $link <vertex-shader> } " - Compile GLSL code into a vertex shader object "}
+ }
+} ;
+
+HELP: fragment-shader
+{ $class-description { $snippet "fragment-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_FRAGMENT_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following fragment shader-specific functions are defined:"
+ { $list
+ { { $link <fragment-shader> } " - Compile GLSL code into a fragment shader object "}
+ }
+} ;
+
+HELP: <gl-shader>
+{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } }
+{ $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ;
+
+HELP: <vertex-shader>
+{ $values { "source" "The GLSL source code to compile" } }
+{ $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER <gl-shader>" } "." } ;
+
+HELP: <fragment-shader>
+{ $values { "source" "The GLSL source code to compile" } }
+{ $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER <gl-shader>" } "." } ;
+
+HELP: gl-shader-ok?
+{ $values { "shader" "A " { $link gl-shader } " object" } }
+{ $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ;
+
+HELP: check-gl-shader
+{ $values { "shader" "A " { $link gl-shader } " object" } }
+{ $description "Throws an error containing the " { $link gl-shader-info-log } " for the shader object if it failed to compile. Otherwise, the shader object is left on the stack." } ;
+
+HELP: delete-gl-shader
+{ $values { "shader" "A " { $link gl-shader } " object" } }
+{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ;
+
+HELP: gl-shader-info-log
+{ $values { "shader" "A " { $link gl-shader } " object" } }
+{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ;
+
+HELP: gl-program
+{ $class-description { $snippet "gl-program" } " is a predicate class comprising values returned by OpenGL to represent proram objects. The following words are provided for creating and manipulating these objects:"
+ { $list
+ { { $link <gl-program> } " - Link a set of shaders into a GLSL program" }
+ { { $link gl-program-ok? } " - Check whether a program object linked successfully" }
+ { { $link check-gl-program } " - Throw an error unless a program object linked successfully" }
+ { { $link gl-program-info-log } " - Retrieve the info log of messages generated by the GLSL linker" }
+ { { $link gl-program-shaders } " - Retrieve the set of shader objects composing the GLSL linker" }
+ { { $link delete-gl-program } " - Invalidate a program object and all its attached shaders" }
+ { { $link with-gl-program } " - Use a program object" }
+ }
+} ;
+
+HELP: <gl-program>
+{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } }
+{ $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ;
+
+HELP: gl-program-ok?
+{ $values { "program" "A " { $link gl-program } " object" } }
+{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ;
+
+HELP: check-gl-program
+{ $values { "program" "A " { $link gl-program } " object" } }
+{ $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ;
+
+HELP: gl-program-info-log
+{ $values { "program" "A " { $link gl-program } " object" } }
+{ $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ;
+
+HELP: delete-gl-program
+{ $values { "program" "A " { $link gl-program } " object" } }
+{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ;
+
+HELP: with-gl-program
+{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation" } }
+{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ;
+
ARTICLE: "gl-utilities" "OpenGL utility words"
"In addition to the full OpenGL API, the " { $vocab-link "opengl" } " vocabulary includes some utility words to give OpenGL a more Factor-like feel."
$nl
@@ -112,6 +202,10 @@ $nl
{ $subsection gl-rect }
{ $subsection gl-fill-poly }
{ $subsection gl-poly }
-{ $subsection gl-gradient } ;
+{ $subsection gl-gradient }
+"Compiling, linking, and using GLSL programs:"
+{ $subsection gl-shader }
+{ $subsection gl-program }
+;
ABOUT: "gl-utilities"
From 15e9575cb69af8c9213ee5094df8fdebefb33277 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <wayo.cavazos@gmail.com>
Date: Mon, 14 Jan 2008 05:19:00 -0600
Subject: [PATCH 19/65] Mortar defined and used parsing words. Refactor this.
---
extra/factory/factory-menus | 2 +-
extra/factory/factory.factor | 2 +-
extra/mortar/mortar.factor | 15 +++++++++++----
extra/mortar/sugar/sugar.factor | 6 ++++++
extra/x/gc/gc.factor | 3 ++-
extra/x/pen/pen.factor | 2 +-
extra/x/widgets/button/button.factor | 4 ++--
extra/x/widgets/keymenu/keymenu.factor | 2 +-
extra/x/widgets/label/label.factor | 2 +-
extra/x/widgets/wm/frame/drag/move/move.factor | 2 +-
extra/x/widgets/wm/frame/drag/size/size.factor | 2 +-
extra/x/widgets/wm/frame/frame.factor | 2 +-
extra/x/widgets/wm/menu/menu.factor | 2 +-
13 files changed, 30 insertions(+), 16 deletions(-)
create mode 100644 extra/mortar/sugar/sugar.factor
diff --git a/extra/factory/factory-menus b/extra/factory/factory-menus
index dd5dc29378..fa72fa6c9a 100644
--- a/extra/factory/factory-menus
+++ b/extra/factory/factory-menus
@@ -1,6 +1,6 @@
! -*-factor-*-
-USING: kernel unix vars mortar slot-accessors
+USING: kernel unix vars mortar mortar.sugar slot-accessors
x.widgets.wm.menu x.widgets.wm.unmapped-frames-menu
factory.commands factory.load ;
diff --git a/extra/factory/factory.factor b/extra/factory/factory.factor
index a5755c2a67..ca534f12c1 100644
--- a/extra/factory/factory.factor
+++ b/extra/factory/factory.factor
@@ -1,6 +1,6 @@
USING: kernel parser io io.files namespaces sequences editors threads vars
- mortar slot-accessors
+ mortar mortar.sugar slot-accessors
x
x.widgets.wm.root
x.widgets.wm.frame
diff --git a/extra/mortar/mortar.factor b/extra/mortar/mortar.factor
index c7522e1db6..b7862af7ac 100644
--- a/extra/mortar/mortar.factor
+++ b/extra/mortar/mortar.factor
@@ -128,7 +128,7 @@ over object-class class-methods 1 head* assoc-stack call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: new* ( class -- object ) <<- create ;
+! : new* ( class -- object ) <<- create ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -136,13 +136,20 @@ IN: slot-accessors
IN: mortar
+! : generate-slot-getter ( name -- )
+! "$" over append "slot-accessors" create swap [ slot-value ] curry
+! define-compound ;
+
: generate-slot-getter ( name -- )
-"$" over append "slot-accessors" create swap [ slot-value ] curry
-define-compound ;
+"$" over append "slot-accessors" create swap [ slot-value ] curry define ;
+
+! : generate-slot-setter ( name -- )
+! ">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
+! define-compound ;
: generate-slot-setter ( name -- )
">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
-define-compound ;
+define ;
: generate-slot-accessors ( name -- )
dup
diff --git a/extra/mortar/sugar/sugar.factor b/extra/mortar/sugar/sugar.factor
new file mode 100644
index 0000000000..04d2f6f651
--- /dev/null
+++ b/extra/mortar/sugar/sugar.factor
@@ -0,0 +1,6 @@
+
+USING: mortar ;
+
+IN: mortar.sugar
+
+: new* ( class -- object ) <<- create ;
\ No newline at end of file
diff --git a/extra/x/gc/gc.factor b/extra/x/gc/gc.factor
index 77e5313d00..8db610a1ac 100644
--- a/extra/x/gc/gc.factor
+++ b/extra/x/gc/gc.factor
@@ -1,5 +1,6 @@
-USING: kernel namespaces arrays x11.xlib mortar slot-accessors x x.font ;
+USING: kernel namespaces arrays x11.xlib mortar mortar.sugar
+ slot-accessors x x.font ;
IN: x.gc
diff --git a/extra/x/pen/pen.factor b/extra/x/pen/pen.factor
index c4fc6cfa9f..59b8aeea44 100644
--- a/extra/x/pen/pen.factor
+++ b/extra/x/pen/pen.factor
@@ -1,5 +1,5 @@
-USING: kernel arrays math.vectors mortar x.gc slot-accessors geom.pos ;
+USING: kernel arrays math.vectors mortar mortar.sugar x.gc slot-accessors geom.pos ;
IN: x.pen
diff --git a/extra/x/widgets/button/button.factor b/extra/x/widgets/button/button.factor
index b26431c4c2..ea46b62a69 100644
--- a/extra/x/widgets/button/button.factor
+++ b/extra/x/widgets/button/button.factor
@@ -1,6 +1,6 @@
USING: kernel combinators math x11.xlib
- mortar slot-accessors x.gc x.widgets.label ;
+ mortar mortar.sugar slot-accessors x.gc x.widgets.label ;
IN: x.widgets.button
@@ -11,7 +11,7 @@ SYMBOL: <button>
{ "action-1" "action-2" "action-3" } accessors
define-simple-class
-<button> "create" ( <button> -- button ) [
+<button> "create" !( <button> -- button ) [
new-empty
<gc> new* >>gc ExposureMask ButtonPressMask bitor >>mask <- init-widget
] add-class-method
diff --git a/extra/x/widgets/keymenu/keymenu.factor b/extra/x/widgets/keymenu/keymenu.factor
index 6c2fbb1e5c..b10f8f5593 100644
--- a/extra/x/widgets/keymenu/keymenu.factor
+++ b/extra/x/widgets/keymenu/keymenu.factor
@@ -1,6 +1,6 @@
USING: kernel strings arrays sequences sequences.lib math x11.xlib
- mortar slot-accessors x x.pen x.widgets ;
+ mortar mortar.sugar slot-accessors x x.pen x.widgets ;
IN: x.widgets.keymenu
diff --git a/extra/x/widgets/label/label.factor b/extra/x/widgets/label/label.factor
index 11201ae9fc..39eff20221 100644
--- a/extra/x/widgets/label/label.factor
+++ b/extra/x/widgets/label/label.factor
@@ -1,5 +1,5 @@
-USING: kernel x11.xlib mortar slot-accessors x.gc x.widgets ;
+USING: kernel x11.xlib mortar mortar.sugar slot-accessors x.gc x.widgets ;
IN: x.widgets.label
diff --git a/extra/x/widgets/wm/frame/drag/move/move.factor b/extra/x/widgets/wm/frame/drag/move/move.factor
index 2ebb5a7286..2a6d61596e 100644
--- a/extra/x/widgets/wm/frame/drag/move/move.factor
+++ b/extra/x/widgets/wm/frame/drag/move/move.factor
@@ -1,6 +1,6 @@
USING: kernel combinators namespaces math.vectors x11.xlib x11.constants
- mortar slot-accessors x x.gc x.widgets.wm.frame.drag ;
+ mortar mortar.sugar slot-accessors x x.gc x.widgets.wm.frame.drag ;
IN: x.widgets.wm.frame.drag.move
diff --git a/extra/x/widgets/wm/frame/drag/size/size.factor b/extra/x/widgets/wm/frame/drag/size/size.factor
index e98d75259a..5ef28e2a41 100644
--- a/extra/x/widgets/wm/frame/drag/size/size.factor
+++ b/extra/x/widgets/wm/frame/drag/size/size.factor
@@ -1,6 +1,6 @@
USING: kernel combinators namespaces math.vectors x11.xlib x11.constants
- mortar slot-accessors geom.rect x x.gc x.widgets.wm.frame.drag ;
+ mortar mortar.sugar slot-accessors geom.rect x x.gc x.widgets.wm.frame.drag ;
IN: x.widgets.wm.frame.drag.size
diff --git a/extra/x/widgets/wm/frame/frame.factor b/extra/x/widgets/wm/frame/frame.factor
index 0c0075ed3b..d8f08d8772 100644
--- a/extra/x/widgets/wm/frame/frame.factor
+++ b/extra/x/widgets/wm/frame/frame.factor
@@ -2,7 +2,7 @@
USING: kernel io combinators namespaces quotations arrays sequences
math math.vectors
x11.xlib x11.constants
- mortar slot-accessors
+ mortar mortar.sugar slot-accessors
geom.rect
x x.gc x.widgets
x.widgets.button
diff --git a/extra/x/widgets/wm/menu/menu.factor b/extra/x/widgets/wm/menu/menu.factor
index e836b21374..ca79b35136 100644
--- a/extra/x/widgets/wm/menu/menu.factor
+++ b/extra/x/widgets/wm/menu/menu.factor
@@ -1,5 +1,5 @@
-USING: kernel x11.constants mortar slot-accessors x.widgets.keymenu ;
+USING: kernel x11.constants mortar mortar.sugar slot-accessors x.widgets.keymenu ;
IN: x.widgets.wm.menu
From 097dad070ae9000067324fe31889830f87534aeb Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Mon, 14 Jan 2008 11:42:21 -1000
Subject: [PATCH 20/65] minor tweaks to make these modules load with
load-everything
---
extra/channels/channels-docs.factor | 2 +-
extra/channels/remote/remote-docs.factor | 4 ++--
extra/channels/sniffer/backend/backend.factor | 3 +++
extra/channels/sniffer/bsd/bsd.factor | 5 +++--
extra/channels/sniffer/sniffer.factor | 4 +---
extra/coroutines/coroutines-docs.factor | 5 +++--
extra/cryptlib/libcl/libcl.factor | 7 ++-----
extra/crypto/md5/md5-docs.factor | 3 ++-
extra/hardware-info/backend/backend.factor | 14 +++++++++++++
extra/hardware-info/hardware-info.factor | 21 +++++--------------
extra/hardware-info/macosx/macosx.factor | 2 +-
extra/hardware-info/windows/ce/ce.factor | 5 ++---
extra/hardware-info/windows/nt/nt.factor | 2 +-
extra/hardware-info/windows/windows.factor | 9 ++++----
extra/html/parser/utils/utils.factor | 1 -
.../basic-authentication-docs.factor | 5 +++--
extra/id3/id3-docs.factor | 3 ++-
extra/inverse/inverse-docs.factor | 3 ++-
extra/inverse/inverse.factor | 4 +++-
extra/io/sniffer/backend/backend.factor | 6 ++++++
extra/io/sniffer/bsd/bsd.factor | 4 ++--
.../io/sniffer/filter/backend/backend.factor | 17 +++++++++++++++
extra/io/sniffer/filter/bsd/bsd.factor | 5 +++--
extra/io/sniffer/filter/filter.factor | 15 ++-----------
extra/io/sniffer/sniffer.factor | 6 ------
extra/jamshred/game/game.factor | 2 +-
extra/jamshred/player/player.factor | 2 +-
extra/json/reader/reader-docs.factor | 5 +++--
extra/json/writer/writer-docs.factor | 3 ++-
extra/json/writer/writer.factor | 2 +-
extra/lisp/listener/listener.factor | 4 ++--
extra/mad/mad.factor | 7 ++-----
.../simple/simple-docs.factor | 4 ++--
extra/xml-rpc/xml-rpc-docs.factor | 3 ++-
34 files changed, 101 insertions(+), 86 deletions(-)
create mode 100644 extra/channels/sniffer/backend/backend.factor
create mode 100644 extra/hardware-info/backend/backend.factor
create mode 100644 extra/io/sniffer/backend/backend.factor
create mode 100644 extra/io/sniffer/filter/backend/backend.factor
diff --git a/extra/channels/channels-docs.factor b/extra/channels/channels-docs.factor
index 8487d59e7f..521a4a4ae2 100644
--- a/extra/channels/channels-docs.factor
+++ b/extra/channels/channels-docs.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup channels ;
+USING: help.syntax help.markup ;
IN: channels
HELP: <channel>
diff --git a/extra/channels/remote/remote-docs.factor b/extra/channels/remote/remote-docs.factor
index 5400f147f4..862084e1d9 100644
--- a/extra/channels/remote/remote-docs.factor
+++ b/extra/channels/remote/remote-docs.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup channels channels.remote concurrency.distributed ;
+USING: help.syntax help.markup channels concurrency.distributed ;
IN: channels.remote
HELP: <remote-channel>
@@ -59,4 +59,4 @@ $nl
{ $snippet "\"myhost.com\" 9001 <node> \"ID123456\" <remote-channel>\n\"hello\" over to" }
;
-ABOUT: { "remote-channels" "remote-channels" }
\ No newline at end of file
+ABOUT: { "remote-channels" "remote-channels" }
diff --git a/extra/channels/sniffer/backend/backend.factor b/extra/channels/sniffer/backend/backend.factor
new file mode 100644
index 0000000000..c7c2e420cb
--- /dev/null
+++ b/extra/channels/sniffer/backend/backend.factor
@@ -0,0 +1,3 @@
+USING: io.backend ;
+
+HOOK: sniff-channel io-backend ( -- channel )
diff --git a/extra/channels/sniffer/bsd/bsd.factor b/extra/channels/sniffer/bsd/bsd.factor
index ba8e5ceeb9..0ba267bb03 100644
--- a/extra/channels/sniffer/bsd/bsd.factor
+++ b/extra/channels/sniffer/bsd/bsd.factor
@@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
!
! Wrap a sniffer in a channel
-USING: kernel channels channels.sniffer concurrency io
-io.sniffer io.sniffer.bsd io.unix.backend ;
+USING: kernel channels channels.sniffer.backend concurrency io
+io.sniffer.backend io.sniffer.bsd io.unix.backend ;
+IN: channels.sniffer.bsd
M: unix-io sniff-channel ( -- channel )
"/dev/bpf0" "en1" <sniffer-spec> <sniffer> <channel> [
diff --git a/extra/channels/sniffer/sniffer.factor b/extra/channels/sniffer/sniffer.factor
index 8edd035cca..1502201225 100755
--- a/extra/channels/sniffer/sniffer.factor
+++ b/extra/channels/sniffer/sniffer.factor
@@ -3,11 +3,9 @@
!
! Wrap a sniffer in a channel
USING: kernel channels concurrency io io.backend
-io.sniffer system vocabs.loader ;
+io.sniffer io.sniffer.backend system vocabs.loader ;
: (sniff-channel) ( stream channel -- )
4096 pick stream-read-partial over to (sniff-channel) ;
-HOOK: sniff-channel io-backend ( -- channel )
-
bsd? [ "channels.sniffer.bsd" require ] when
diff --git a/extra/coroutines/coroutines-docs.factor b/extra/coroutines/coroutines-docs.factor
index ed3788db48..327c60e017 100644
--- a/extra/coroutines/coroutines-docs.factor
+++ b/extra/coroutines/coroutines-docs.factor
@@ -1,5 +1,6 @@
! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
-USING: help.markup help.syntax coroutines ;
+USING: help.markup help.syntax ;
+IN: coroutines
HELP: cocreate
{ $values { "quot" "a quotation with stack effect ( value -- )" } { "co" "a coroutine" } }
@@ -51,4 +52,4 @@ HELP: coterminate
HELP: current-coro
{ $description "Variable which contains the currently executing coroutine, or " { $link f } " if none is executing. User code should treat this variable as read-only." }
{ $see-also cocreate coresume coyield }
-;
\ No newline at end of file
+;
diff --git a/extra/cryptlib/libcl/libcl.factor b/extra/cryptlib/libcl/libcl.factor
index 3cc0d50095..38e6817f6c 100644
--- a/extra/cryptlib/libcl/libcl.factor
+++ b/extra/cryptlib/libcl/libcl.factor
@@ -12,14 +12,11 @@ USING: alien kernel system combinators alien.syntax ;
IN: cryptlib.libcl
-: load-libcl ( -- )
- "libcl" {
+<< "libcl" {
{ [ win32? ] [ "cl32.dll" "stdcall" ] }
{ [ macosx? ] [ "libcl.dylib" "cdecl" ] }
{ [ unix? ] [ "libcl.so" "cdecl" ] }
- } cond add-library ; parsing
-
-load-libcl
+ } cond add-library >>
! ===============================================
! Machine-dependant types
diff --git a/extra/crypto/md5/md5-docs.factor b/extra/crypto/md5/md5-docs.factor
index 53c737554b..fd8bf3f74d 100644
--- a/extra/crypto/md5/md5-docs.factor
+++ b/extra/crypto/md5/md5-docs.factor
@@ -1,5 +1,6 @@
USING: help.markup help.syntax kernel math sequences quotations
-crypto.common crypto.md5 ;
+crypto.common ;
+IN: crypto.md5
HELP: stream>md5
{ $values { "stream" "a stream" } { "byte-array" "md5 hash" } }
diff --git a/extra/hardware-info/backend/backend.factor b/extra/hardware-info/backend/backend.factor
new file mode 100644
index 0000000000..d79678de0c
--- /dev/null
+++ b/extra/hardware-info/backend/backend.factor
@@ -0,0 +1,14 @@
+IN: hardware-info.backend
+
+SYMBOL: os
+HOOK: cpus os ( -- n )
+
+HOOK: memory-load os ( -- n )
+HOOK: physical-mem os ( -- n )
+HOOK: available-mem os ( -- n )
+HOOK: total-page-file os ( -- n )
+HOOK: available-page-file os ( -- n )
+HOOK: total-virtual-mem os ( -- n )
+HOOK: available-virtual-mem os ( -- n )
+HOOK: available-virtual-extended-mem os ( -- n )
+
diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor
index 9b3c969dc3..0515646a5f 100755
--- a/extra/hardware-info/hardware-info.factor
+++ b/extra/hardware-info/hardware-info.factor
@@ -1,26 +1,15 @@
-USING: alien.syntax math prettyprint system combinators
-vocabs.loader ;
+USING: alien.syntax kernel math prettyprint system
+combinators vocabs.loader hardware-info.backend ;
IN: hardware-info
-SYMBOL: os
-HOOK: cpus os ( -- n )
-
-HOOK: memory-load os ( -- n )
-HOOK: physical-mem os ( -- n )
-HOOK: available-mem os ( -- n )
-HOOK: total-page-file os ( -- n )
-HOOK: available-page-file os ( -- n )
-HOOK: total-virtual-mem os ( -- n )
-HOOK: available-virtual-mem os ( -- n )
-HOOK: available-virtual-extended-mem os ( -- n )
-
: kb. ( x -- ) 10 2^ /f . ;
: megs. ( x -- ) 20 2^ /f . ;
: gigs. ( x -- ) 30 2^ /f . ;
-{
+<< {
{ [ windows? ] [ "hardware-info.windows" ] }
{ [ linux? ] [ "hardware-info.linux" ] }
{ [ macosx? ] [ "hardware-info.macosx" ] }
-} cond require
+ { [ t ] [ f ] }
+} cond [ require ] when* >>
diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/hardware-info/macosx/macosx.factor
index ad3060944e..c246a95186 100644
--- a/extra/hardware-info/macosx/macosx.factor
+++ b/extra/hardware-info/macosx/macosx.factor
@@ -1,5 +1,5 @@
USING: alien alien.c-types alien.syntax byte-arrays kernel
-namespaces sequences unix hardware-info ;
+namespaces sequences unix hardware-info.backend ;
IN: hardware-info.macosx
TUPLE: macosx ;
diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor
index 42fd9e5343..9fb15ef823 100644
--- a/extra/hardware-info/windows/ce/ce.factor
+++ b/extra/hardware-info/windows/ce/ce.factor
@@ -1,5 +1,6 @@
USING: alien.c-types hardware-info hardware-info.windows
-kernel math namespaces windows windows.kernel32 ;
+kernel math namespaces windows windows.kernel32
+hardware-info.backend ;
IN: hardware-info.windows.ce
T{ wince } os set-global
@@ -29,5 +30,3 @@ M: wince total-virtual-mem ( -- n )
M: wince available-virtual-mem ( -- n )
memory-status MEMORYSTATUS-dwAvailVirtual ;
-
-
diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor
index 2b2522e6ee..f412754cdf 100644
--- a/extra/hardware-info/windows/nt/nt.factor
+++ b/extra/hardware-info/windows/nt/nt.factor
@@ -1,5 +1,5 @@
USING: alien alien.c-types hardware-info hardware-info.windows
-kernel libc math namespaces
+kernel libc math namespaces hardware-info.backend
windows windows.advapi32 windows.kernel32 ;
IN: hardware-info.windows.nt
diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor
index 5352d64698..a49e4f254a 100755
--- a/extra/hardware-info/windows/windows.factor
+++ b/extra/hardware-info/windows/windows.factor
@@ -1,6 +1,6 @@
USING: alien alien.c-types kernel libc math namespaces
-windows windows.kernel32 windows.advapi32 hardware-info
-words combinators vocabs.loader ;
+windows windows.kernel32 windows.advapi32
+words combinators vocabs.loader hardware-info.backend ;
IN: hardware-info.windows
TUPLE: wince ;
@@ -70,7 +70,8 @@ M: windows cpus ( -- n )
: system-windows-directory ( -- str )
\ GetSystemWindowsDirectory get-directory ;
-{
+<< {
{ [ wince? ] [ "hardware-info.windows.ce" ] }
{ [ winnt? ] [ "hardware-info.windows.nt" ] }
-} cond require
+ { [ t ] [ f ] }
+} cond [ require ] when* >>
diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor
index febd1716ed..b574799b38 100644
--- a/extra/html/parser/utils/utils.factor
+++ b/extra/html/parser/utils/utils.factor
@@ -2,7 +2,6 @@ USING: assocs circular combinators continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
state-parser strings ;
-USING: html.parser ;
IN: html.parser.utils
: string-parse-end?
diff --git a/extra/http/basic-authentication/basic-authentication-docs.factor b/extra/http/basic-authentication/basic-authentication-docs.factor
index 9add842db6..68d6e6bf1d 100644
--- a/extra/http/basic-authentication/basic-authentication-docs.factor
+++ b/extra/http/basic-authentication/basic-authentication-docs.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax http.basic-authentication crypto.sha2 ;
+USING: help.markup help.syntax crypto.sha2 ;
+IN: http.basic-authentication
HELP: realms
{ $description
@@ -65,4 +66,4 @@ $nl
"it is best to use Basic Authentication with SSL." ;
IN: http.basic-authentication
-ABOUT: { "http-authentication" "basic-authentication" }
\ No newline at end of file
+ABOUT: { "http-authentication" "basic-authentication" }
diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor
index 47edee7437..8083514c0d 100644
--- a/extra/id3/id3-docs.factor
+++ b/extra/id3/id3-docs.factor
@@ -1,6 +1,7 @@
! Coyright (C) 2007 Adam Wendt
! See http://factorcode.org/license.txt for BSD license.
-USING: id3 help.syntax help.markup ;
+USING: help.syntax help.markup ;
+IN: id3
ARTICLE: "id3-tags" "ID3 Tags"
"The " { $vocab-link "id3" } " vocabulary is used to read ID3 tags from MP3 audio streams."
diff --git a/extra/inverse/inverse-docs.factor b/extra/inverse/inverse-docs.factor
index f8ae3bfbdb..8204f7174c 100644
--- a/extra/inverse/inverse-docs.factor
+++ b/extra/inverse/inverse-docs.factor
@@ -1,4 +1,5 @@
-USING: inverse help.syntax help.markup ;
+USING: help.syntax help.markup ;
+IN: inverse
HELP: [undo]
{ $values { "quot" "a quotation" } { "undo" "the inverse of the quotation" } }
diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor
index cade645dde..b97748514c 100644
--- a/extra/inverse/inverse.factor
+++ b/extra/inverse/inverse.factor
@@ -63,7 +63,9 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
{
{ [ dup word? not over symbol? or ] [ , ] }
{ [ dup explicit-inverse? ] [ , ] }
- { [ dup compound? over { if dispatch } member? not and ]
+ ! { [ dup compound? over { if dispatch } member? not and ]
+ ! [ word-def [ inline-word ] each ] }
+ { [ dup word? over { if dispatch } member? not and ]
[ word-def [ inline-word ] each ] }
{ [ drop t ] [ "Quotation is not invertible" throw ] }
} cond ;
diff --git a/extra/io/sniffer/backend/backend.factor b/extra/io/sniffer/backend/backend.factor
new file mode 100644
index 0000000000..53bf37a290
--- /dev/null
+++ b/extra/io/sniffer/backend/backend.factor
@@ -0,0 +1,6 @@
+USING: io.backend kernel system vocabs.loader ;
+IN: io.sniffer.backend
+
+SYMBOL: sniffer-type
+TUPLE: sniffer ;
+HOOK: <sniffer> io-backend ( obj -- sniffer )
diff --git a/extra/io/sniffer/bsd/bsd.factor b/extra/io/sniffer/bsd/bsd.factor
index 91266b7be3..6a0d092807 100644
--- a/extra/io/sniffer/bsd/bsd.factor
+++ b/extra/io/sniffer/bsd/bsd.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2007 Elie Chaftari, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax destructors hexdump io
-io.buffers io.nonblocking io.sniffer io.sockets io.streams.lines
+io.buffers io.nonblocking io.sockets io.streams.lines
io.unix.backend io.unix.files kernel libc locals math qualified
-sequences ;
+sequences io.sniffer.backend ;
QUALIFIED: unix
IN: io.sniffer.bsd
diff --git a/extra/io/sniffer/filter/backend/backend.factor b/extra/io/sniffer/filter/backend/backend.factor
new file mode 100644
index 0000000000..dade8bdebf
--- /dev/null
+++ b/extra/io/sniffer/filter/backend/backend.factor
@@ -0,0 +1,17 @@
+USING: byte-arrays combinators io io.backend
+io.sockets.headers io.sniffer.backend kernel
+prettyprint sequences ;
+IN: io.sniffer.filter.backend
+
+HOOK: sniffer-loop io-backend ( stream -- )
+HOOK: packet. io-backend ( string -- )
+
+: (packet.) ( string -- )
+ dup 14 head >byte-array
+ "--Ethernet Header--" print
+ dup etherneth.
+ dup etherneth-type {
+ ! HEX: 800 [ ] ! IP
+ ! HEX: 806 [ ] ! ARP
+ [ "Unknown type: " write .h ]
+ } case 2drop ;
diff --git a/extra/io/sniffer/filter/bsd/bsd.factor b/extra/io/sniffer/filter/bsd/bsd.factor
index c6882352d0..c18cae41e5 100644
--- a/extra/io/sniffer/filter/bsd/bsd.factor
+++ b/extra/io/sniffer/filter/bsd/bsd.factor
@@ -1,7 +1,8 @@
USING: alien.c-types hexdump io io.backend io.sockets.headers
io.sockets.headers.bsd kernel io.sniffer io.sniffer.bsd
-io.sniffer.filter io.streams.string io.unix.backend math
-sequences system byte-arrays ;
+io.streams.string io.unix.backend math
+sequences system byte-arrays io.sniffer.filter.backend
+io.sniffer.filter.backend io.sniffer.backend ;
IN: io.sniffer.filter.bsd
! http://www.iana.org/assignments/ethernet-numbers
diff --git a/extra/io/sniffer/filter/filter.factor b/extra/io/sniffer/filter/filter.factor
index 3240810e7f..91c0ab5a5c 100755
--- a/extra/io/sniffer/filter/filter.factor
+++ b/extra/io/sniffer/filter/filter.factor
@@ -1,19 +1,8 @@
USING: alien.c-types byte-arrays combinators hexdump io
io.backend io.streams.string io.sockets.headers kernel math
-prettyprint io.sniffer sequences system vocabs.loader ;
+prettyprint io.sniffer sequences system vocabs.loader
+io.sniffer.filter.backend ;
IN: io.sniffer.filter
-HOOK: sniffer-loop io-backend ( stream -- )
-HOOK: packet. io-backend ( string -- )
-
-: (packet.) ( string -- )
- dup 14 head >byte-array
- "--Ethernet Header--" print
- dup etherneth.
- dup etherneth-type {
- ! HEX: 800 [ ] ! IP
- ! HEX: 806 [ ] ! ARP
- [ "Unknown type: " write .h ]
- } case 2drop ;
bsd? [ "io.sniffer.filter.bsd" require ] when
diff --git a/extra/io/sniffer/sniffer.factor b/extra/io/sniffer/sniffer.factor
index 04491ca709..6fd74f9e1c 100755
--- a/extra/io/sniffer/sniffer.factor
+++ b/extra/io/sniffer/sniffer.factor
@@ -1,10 +1,4 @@
USING: io.backend kernel system vocabs.loader ;
IN: io.sniffer
-SYMBOL: sniffer-type
-
-TUPLE: sniffer ;
-
-HOOK: <sniffer> io-backend ( obj -- sniffer )
-
bsd? [ "io.sniffer.bsd" require ] when
diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor
index 667d81aeb4..fe517d68fd 100644
--- a/extra/jamshred/game/game.factor
+++ b/extra/jamshred/game/game.factor
@@ -1,4 +1,4 @@
-USING: kernel opengl arrays sequences jamshred jamshred.tunnel
+USING: kernel opengl arrays sequences jamshred.tunnel
jamshred.player math.vectors ;
IN: jamshred.game
diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor
index ddbd03eeb9..4daecf29a2 100644
--- a/extra/jamshred/player/player.factor
+++ b/extra/jamshred/player/player.factor
@@ -1,4 +1,4 @@
-USING: colors jamshred.game jamshred.oint jamshred.tunnel kernel
+USING: colors jamshred.oint jamshred.tunnel kernel
math math.constants sequences ;
IN: jamshred.player
diff --git a/extra/json/reader/reader-docs.factor b/extra/json/reader/reader-docs.factor
index 43edb6c43d..ea4dcbf954 100644
--- a/extra/json/reader/reader-docs.factor
+++ b/extra/json/reader/reader-docs.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax json.reader ;
+USING: help.markup help.syntax ;
+IN: json.reader
HELP: json> "( string -- object )"
{ $values { "string" "a string in JSON format" } { "object" "yhe object deserialized from the JSON string" } }
-{ $description "Deserializes the JSON formatted string into a Factor object. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ;
\ No newline at end of file
+{ $description "Deserializes the JSON formatted string into a Factor object. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ;
diff --git a/extra/json/writer/writer-docs.factor b/extra/json/writer/writer-docs.factor
index cc26f74843..21aa8b2cb5 100644
--- a/extra/json/writer/writer-docs.factor
+++ b/extra/json/writer/writer-docs.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax json.writer ;
+USING: help.markup help.syntax ;
+IN: json.writer
HELP: >json "( obj -- string )"
{ $values { "obj" "an object" } { "string" "the object converted to JSON format" } }
diff --git a/extra/json/writer/writer.factor b/extra/json/writer/writer.factor
index 4370a38411..6c7d6cebb2 100644
--- a/extra/json/writer/writer.factor
+++ b/extra/json/writer/writer.factor
@@ -13,7 +13,7 @@ GENERIC: json-print ( obj -- )
[ json-print ] string-out ;
M: f json-print ( f -- )
- "false" write ;
+ drop "false" write ;
M: string json-print ( obj -- )
CHAR: " write1 "\"" split "\\\"" join CHAR: \r swap remove "\n" split "\\r\\n" join write CHAR: " write1 ;
diff --git a/extra/lisp/listener/listener.factor b/extra/lisp/listener/listener.factor
index 5af44ba362..91f0bb2a8d 100644
--- a/extra/lisp/listener/listener.factor
+++ b/extra/lisp/listener/listener.factor
@@ -5,7 +5,7 @@ USING: kernel parser namespaces io prettyprint math arrays sequences
IN: lisp.listener
-: parse-stdio ( -- quot/f ) stdio get parse-interactive ;
+: parse-stdio ( -- quot/f ) stdio get read-quot ;
: stuff? ( -- ? ) datastack length 0 > ;
@@ -25,4 +25,4 @@ use [ clone ] change
{ "lisp" "lisp.syntax" } add-use
! [ listener-hook get call prompt. lisp-listen ] until-quit
until-quit
-] with-scope ;
\ No newline at end of file
+] with-scope ;
diff --git a/extra/mad/mad.factor b/extra/mad/mad.factor
index 27b053352b..ce65c066b4 100644
--- a/extra/mad/mad.factor
+++ b/extra/mad/mad.factor
@@ -4,14 +4,11 @@
USING: alien alien.c-types alien.syntax combinators kernel math system ;
IN: mad
-: load-mad-library ( -- )
- "mad" {
+<< "mad" {
{ [ macosx? ] [ "libmad.0.dylib" ] }
{ [ unix? ] [ "libmad.so" ] }
{ [ windows? ] [ "mad.dll" ] }
- } cond "cdecl" add-library ; parsing
-
-load-mad-library
+ } cond "cdecl" add-library >>
LIBRARY: mad
diff --git a/extra/parser-combinators/simple/simple-docs.factor b/extra/parser-combinators/simple/simple-docs.factor
index c2cca6e4a0..bba37ca4ca 100755
--- a/extra/parser-combinators/simple/simple-docs.factor
+++ b/extra/parser-combinators/simple/simple-docs.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup parser-combinators
-parser-combinators.simple ;
+USING: help.syntax help.markup parser-combinators ;
+IN: parser-combinators.simple
HELP: 'digit'
{ $values
diff --git a/extra/xml-rpc/xml-rpc-docs.factor b/extra/xml-rpc/xml-rpc-docs.factor
index 323e103d4c..8c20df1fd0 100644
--- a/extra/xml-rpc/xml-rpc-docs.factor
+++ b/extra/xml-rpc/xml-rpc-docs.factor
@@ -1,4 +1,5 @@
-USING: xml-rpc help.syntax help.markup ;
+USING: help.syntax help.markup ;
+IN: xml-rpc
HELP: send-rpc
{ $values { "rpc" "an RPC data type" } { "xml" "an XML document" } }
From e54b7b10a5cc291aabe68860dcb9871598da797c Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Mon, 14 Jan 2008 11:43:33 -1000
Subject: [PATCH 21/65] add a sha1 benchmark
---
extra/benchmark/sha1/sha1.factor | 7 +++++++
1 file changed, 7 insertions(+)
create mode 100644 extra/benchmark/sha1/sha1.factor
diff --git a/extra/benchmark/sha1/sha1.factor b/extra/benchmark/sha1/sha1.factor
new file mode 100644
index 0000000000..614077c673
--- /dev/null
+++ b/extra/benchmark/sha1/sha1.factor
@@ -0,0 +1,7 @@
+USING: crypto.sha1 io.files kernel ;
+IN: benchmark.sha1
+
+: sha1-primes-list ( -- seq )
+ "extra/math/primes/list/list.factor" resource-path file>sha1 ;
+
+MAIN: sha1-primes-list
From 81cd51ae8590efb9da3905a3f5101e41f78b55cc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 14 Jan 2008 19:11:32 -0500
Subject: [PATCH 22/65] multi-methods load fix
---
extra/multi-methods/multi-methods.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor
index 1f260d94eb..827d64b95f 100755
--- a/extra/multi-methods/multi-methods.factor
+++ b/extra/multi-methods/multi-methods.factor
@@ -3,7 +3,7 @@
USING: kernel math sequences vectors classes combinators
arrays words assocs parser namespaces definitions
prettyprint prettyprint.backend quotations arrays.lib
-debugger io ;
+debugger io compiler.units ;
IN: multi-methods
TUPLE: method loc def ;
@@ -217,5 +217,5 @@ syntax:M: method-spec synopsis*
dup definer.
unclip pprint* pprint* ;
-syntax:M: method-spec forget
+syntax:M: method-spec forget*
unclip [ delete-at ] with-methods ;
From 6a4062bf3875e749ca9ac08acb9500be0148a6fd Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Mon, 14 Jan 2008 15:06:12 -1000
Subject: [PATCH 23/65] minor cleanups
---
extra/crypto/sha1/sha1.factor | 2 +-
extra/io/sniffer/bsd/bsd.factor | 2 +-
extra/io/sniffer/filter/bsd/bsd.factor | 2 +-
extra/math/polynomials/polynomials.factor | 4 ++--
extra/ori/ori.factor | 9 +--------
5 files changed, 6 insertions(+), 13 deletions(-)
diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor
index 6906ce2b9a..94a51288bb 100644
--- a/extra/crypto/sha1/sha1.factor
+++ b/extra/crypto/sha1/sha1.factor
@@ -78,7 +78,7 @@ SYMBOL: K
K get nth ,
A get 5 bitroll-32 ,
E get ,
- ] { } make sum 4294967295 bitand ; inline
+ ] { } make sum >32-bit ; inline
: set-vars ( temp -- )
! E = D; D = C; C = S^30(B); B = A; A = TEMP;
diff --git a/extra/io/sniffer/bsd/bsd.factor b/extra/io/sniffer/bsd/bsd.factor
index 6a0d092807..5c32bd78d2 100644
--- a/extra/io/sniffer/bsd/bsd.factor
+++ b/extra/io/sniffer/bsd/bsd.factor
@@ -17,7 +17,7 @@ TUPLE: sniffer-spec path ifname ;
C: <sniffer-spec> sniffer-spec
: IOCPARM_MASK HEX: 1fff ; inline
-: IOCPARM_MAX IOCPARM_MASK 1 + ; inline
+: IOCPARM_MAX IOCPARM_MASK 1+ ; inline
: IOC_VOID HEX: 20000000 ; inline
: IOC_OUT HEX: 40000000 ; inline
: IOC_IN HEX: 80000000 ; inline
diff --git a/extra/io/sniffer/filter/bsd/bsd.factor b/extra/io/sniffer/filter/bsd/bsd.factor
index c18cae41e5..4f6d8b2420 100644
--- a/extra/io/sniffer/filter/bsd/bsd.factor
+++ b/extra/io/sniffer/filter/bsd/bsd.factor
@@ -9,7 +9,7 @@ IN: io.sniffer.filter.bsd
: bpf-align ( n -- n' )
#! Align to next higher word size
- "long" heap-size 1- [ + ] keep bitnot bitand ;
+ "long" heap-size align ;
M: unix-io packet. ( string -- )
18 cut swap >byte-array bpfh.
diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor
index f805df8249..000d97f2a6 100644
--- a/extra/math/polynomials/polynomials.factor
+++ b/extra/math/polynomials/polynomials.factor
@@ -1,5 +1,5 @@
USING: arrays kernel sequences vectors math math.vectors namespaces
-shuffle splitting ;
+shuffle splitting sequences.lib ;
IN: math.polynomials
! Polynomials are vectors with the highest powers on the right:
@@ -22,7 +22,7 @@ PRIVATE>
: p= ( p p -- ? ) pextend = ;
: ptrim ( p -- p )
- dup length 1 = [ [ zero? ] right-trim ] unless ;
+ dup singleton? [ [ zero? ] right-trim ] unless ;
: 2ptrim ( p p -- p p ) [ ptrim ] 2apply ;
: p+ ( p p -- p ) pextend v+ ;
diff --git a/extra/ori/ori.factor b/extra/ori/ori.factor
index 3ada07b53f..db60f95183 100644
--- a/extra/ori/ori.factor
+++ b/extra/ori/ori.factor
@@ -1,7 +1,7 @@
USING: kernel namespaces
math math.constants math.functions math.matrices math.vectors
- sequences splitting self ;
+ sequences splitting self math.trig ;
IN: ori
@@ -11,13 +11,6 @@ C: <ori> ori
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Temporarily defined here until math-contrib gets moved to extra/
-
-: deg>rad pi * 180 / ; inline
-: rad>deg 180 * pi / ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: ori> ( -- val ) self> ori-val ;
: >ori ( val -- ) self> set-ori-val ;
From c9b2af745b57bbd73d72d852a377dca9afd2fd85 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <wayo.cavazos@gmail.com>
Date: Mon, 14 Jan 2008 20:26:03 -0600
Subject: [PATCH 24/65] Fix typo. Hooks weren't running.
---
misc/factor.el | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/misc/factor.el b/misc/factor.el
index 985e10e285..a5ba44357f 100644
--- a/misc/factor.el
+++ b/misc/factor.el
@@ -102,7 +102,7 @@
(setq font-lock-defaults
'(factor-font-lock-keywords nil nil nil nil))
(set-syntax-table factor-mode-syntax-table)
- (run-hooks 'factor-mode-hooks))
+ (run-hooks 'factor-mode-hook))
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
From b10ab726a372b9f147f933e9161d235d2c83b1d2 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 15 Jan 2008 18:16:38 -0800
Subject: [PATCH 25/65] Fix typo in TYPEDEF: documentation
---
core/alien/syntax/syntax-docs.factor | 10 ++++++----
1 file changed, 6 insertions(+), 4 deletions(-)
diff --git a/core/alien/syntax/syntax-docs.factor b/core/alien/syntax/syntax-docs.factor
index 00ee6345dc..858c3f145e 100755
--- a/core/alien/syntax/syntax-docs.factor
+++ b/core/alien/syntax/syntax-docs.factor
@@ -49,14 +49,14 @@ $nl
HELP: TYPEDEF:
{ $syntax "TYPEDEF: old new" }
-{ $values { "word" "a word with stack effect " { $snippet "( -- ? )" } } { "old" "a C type" } { "new" "a C type" } }
-{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
+{ $values { "old" "a C type" } { "new" "a C type" } }
+{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
HELP: TYPEDEF-IF:
{ $syntax "TYPEDEF-IF: word old new" }
{ $values { "word" "a word with stack effect " { $snippet "( -- ? )" } } { "old" "a C type" } { "new" "a C type" } }
-{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } " if " { $snippet "word" } " evaluates to a true value." }
+{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if " { $snippet "word" } " evaluates to a true value." }
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
HELP: C-STRUCT:
@@ -87,7 +87,9 @@ HELP: typedef
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
{ $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ;
-{ typedef POSTPONE: TYPEDEF: } related-words
+{ typedef POSTPONE: TYPEDEF: POSTPONE: TYPEDEF-IF: } related-words
+{ POSTPONE: TYPEDEF: typedef POSTPONE: TYPEDEF-IF: } related-words
+{ POSTPONE: TYPEDEF-IF: POSTPONE: TYPEDEF: typedef } related-words
HELP: c-struct?
{ $values { "type" "a string" } { "?" "a boolean" } }
From 9e70e6ed3552f09b349c2cdea3e09e648518bbea Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 15 Jan 2008 23:32:21 -0400
Subject: [PATCH 26/65] Fix x86 backend for dispatch change, clean up assembler
---
core/cpu/x86/architecture/architecture.factor | 47 +++++----
core/cpu/x86/assembler/assembler.factor | 98 ++++++-------------
2 files changed, 59 insertions(+), 86 deletions(-)
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 733d756157..96b2dcf1ec 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -70,6 +70,14 @@ M: x86-backend %prepare-alien-invoke
temp-reg v>operand 2 cells [+] ds-reg MOV
temp-reg v>operand 3 cells [+] rs-reg MOV ;
+M: x86-backend %call-primitive ( word -- )
+ stack-save-reg stack-reg cell neg [+] LEA
+ address-operand CALL ;
+
+M: x86-backend %jump-primitive ( word -- )
+ stack-save-reg stack-reg MOV
+ address-operand JMP ;
+
M: x86-backend %call-label ( label -- ) CALL ;
M: x86-backend %jump-label ( label -- ) JMP ;
@@ -77,30 +85,31 @@ M: x86-backend %jump-label ( label -- ) JMP ;
M: x86-backend %jump-t ( label -- )
"flag" operand f v>operand CMP JNE ;
-: (%dispatch) ( word-table# -- )
- ! Untag and multiply to get a jump table offset
- "n" operand fixnum>slot@
- ! Add to jump table base. We use a temporary register
+: (%dispatch) ( -- operand )
+ ! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
- "scratch" operand HEX: ffffffff MOV rc-absolute-cell rel-dispatch
- "n" operand "n" operand "scratch" operand [+] MOV
- "n" operand dup word-xt-offset [+] MOV ;
-
-: dispatch-template ( word-table# quot -- )
- [
- >r (%dispatch) "n" operand r> call
- ] H{
- { +input+ { { f "n" } } }
- { +scratch+ { { f "scratch" } } }
- { +clobber+ { "n" } }
- } with-template ; inline
+ ! Untag and multiply to get a jump table offset
+ "n" operand fixnum>slot@
+ ! Add jump table base
+ "offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
+ "n" operand "offset" operand ADD
+ "n" operand bootstrap-cell 8 = 14 9 ? [+] ;
M: x86-backend %call-dispatch ( word-table# -- )
- [ CALL ] dispatch-template ;
+ [ (%dispatch) CALL <label> dup JMP ] H{
+ { +input+ { { f "n" } } }
+ { +scratch+ { { f "offset" } } }
+ } with-template ;
-M: x86-backend %jump-dispatch ( word-table# -- )
- [ %epilogue-later JMP ] dispatch-template ;
+M: x86-backend %jump-dispatch ( -- )
+ [ %epilogue-later (%dispatch) JMP ] H{
+ { +input+ { { f "n" } } }
+ { +scratch+ { { f "offset" } } }
+ } with-template ;
+
+M: x86-backend %dispatch-label ( word -- )
+ 0 cell, rc-absolute-cell rel-word ;
M: x86-backend %unbox-float ( dst src -- )
[ v>operand ] 2apply float-offset [+] MOVSD ;
diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor
index 17aa6bbb54..2d7ffb762d 100755
--- a/core/cpu/x86/assembler/assembler.factor
+++ b/core/cpu/x86/assembler/assembler.factor
@@ -11,78 +11,42 @@ IN: cpu.x86.assembler
! In 64-bit mode, { 1234 } is RIP-relative.
! Beware!
-! Register operands -- eg, ECX
-: define-register ( symbol num size -- )
- >r dupd "register" set-word-prop r>
- "register-size" set-word-prop ;
-
-! x86 registers
-SYMBOL: AL \ AL 0 8 define-register
-SYMBOL: CL \ CL 1 8 define-register
-SYMBOL: DL \ DL 2 8 define-register
-SYMBOL: BL \ BL 3 8 define-register
-
-SYMBOL: AX \ AX 0 16 define-register
-SYMBOL: CX \ CX 1 16 define-register
-SYMBOL: DX \ DX 2 16 define-register
-SYMBOL: BX \ BX 3 16 define-register
-SYMBOL: SP \ SP 4 16 define-register
-SYMBOL: BP \ BP 5 16 define-register
-SYMBOL: SI \ SI 6 16 define-register
-SYMBOL: DI \ DI 7 16 define-register
-
-SYMBOL: EAX \ EAX 0 32 define-register
-SYMBOL: ECX \ ECX 1 32 define-register
-SYMBOL: EDX \ EDX 2 32 define-register
-SYMBOL: EBX \ EBX 3 32 define-register
-SYMBOL: ESP \ ESP 4 32 define-register
-SYMBOL: EBP \ EBP 5 32 define-register
-SYMBOL: ESI \ ESI 6 32 define-register
-SYMBOL: EDI \ EDI 7 32 define-register
-
-SYMBOL: XMM0 \ XMM0 0 128 define-register
-SYMBOL: XMM1 \ XMM1 1 128 define-register
-SYMBOL: XMM2 \ XMM2 2 128 define-register
-SYMBOL: XMM3 \ XMM3 3 128 define-register
-SYMBOL: XMM4 \ XMM4 4 128 define-register
-SYMBOL: XMM5 \ XMM5 5 128 define-register
-SYMBOL: XMM6 \ XMM6 6 128 define-register
-SYMBOL: XMM7 \ XMM7 7 128 define-register
-
-! AMD64 registers
-SYMBOL: RAX \ RAX 0 64 define-register
-SYMBOL: RCX \ RCX 1 64 define-register
-SYMBOL: RDX \ RDX 2 64 define-register
-SYMBOL: RBX \ RBX 3 64 define-register
-SYMBOL: RSP \ RSP 4 64 define-register
-SYMBOL: RBP \ RBP 5 64 define-register
-SYMBOL: RSI \ RSI 6 64 define-register
-SYMBOL: RDI \ RDI 7 64 define-register
-SYMBOL: R8 \ R8 8 64 define-register
-SYMBOL: R9 \ R9 9 64 define-register
-SYMBOL: R10 \ R10 10 64 define-register
-SYMBOL: R11 \ R11 11 64 define-register
-SYMBOL: R12 \ R12 12 64 define-register
-SYMBOL: R13 \ R13 13 64 define-register
-SYMBOL: R14 \ R14 14 64 define-register
-SYMBOL: R15 \ R15 15 64 define-register
-
-SYMBOL: XMM8 \ XMM8 8 128 define-register
-SYMBOL: XMM9 \ XMM9 9 128 define-register
-SYMBOL: XMM10 \ XMM10 10 128 define-register
-SYMBOL: XMM11 \ XMM11 11 128 define-register
-SYMBOL: XMM12 \ XMM12 12 128 define-register
-SYMBOL: XMM13 \ XMM13 13 128 define-register
-SYMBOL: XMM14 \ XMM14 14 128 define-register
-SYMBOL: XMM15 \ XMM15 15 128 define-register
-
-<PRIVATE
-
: n, >le % ; inline
: 4, 4 n, ; inline
: 2, 2 n, ; inline
: cell, bootstrap-cell n, ; inline
+! Register operands -- eg, ECX
+<<
+
+: define-register ( name num size -- )
+ >r >r "cpu.x86.assembler" create dup define-symbol r> r>
+ >r dupd "register" set-word-prop r>
+ "register-size" set-word-prop ;
+
+: define-registers ( names size -- )
+ >r dup length r> [ define-register ] curry 2each ;
+
+: REGISTERS:
+ scan-word ";" parse-tokens swap define-registers ; parsing
+
+>>
+
+REGISTERS: 8 AL CL DL BL ;
+
+REGISTERS: 16 AX CX DX BX SP BP SI DI ;
+
+REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI ;
+
+REGISTERS: 64
+RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
+
+REGISTERS: 128
+XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
+XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
+
+<PRIVATE
+
#! Extended AMD64 registers (R8-R15) return true.
GENERIC: extended? ( op -- ? )
From 123b3da7bfe484502ddfb4b17abb12052b994b51 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 15 Jan 2008 23:35:03 -0400
Subject: [PATCH 27/65] More versatile << >>
---
core/syntax/syntax.factor | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index b0a7ea19bd..7616f6e64b 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -170,5 +170,8 @@ IN: bootstrap.syntax
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
- "<<" [ \ >> parse-until >quotation call ] define-syntax
+ "<<" [
+ [ \ >> parse-until >quotation ] with-compilation-unit
+ call
+ ] define-syntax
] with-compilation-unit
From 0fb511f668dbdeb0fba3012971083ae0af7ca495 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 16 Jan 2008 01:04:28 -0500
Subject: [PATCH 28/65] Simplify
---
core/optimizer/known-words/known-words.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor
index 1d8395d667..6828a0948c 100755
--- a/core/optimizer/known-words/known-words.factor
+++ b/core/optimizer/known-words/known-words.factor
@@ -14,8 +14,8 @@ float-arrays combinators.private combinators ;
! its second-to-last input
{ <tuple> <tuple-boa> } [
[
- node-in-d dup length 2 - swap nth dup value?
- [ value-literal ] [ drop tuple ] if 1array f
+ dup node-in-d dup length 2 - swap nth node-literal
+ dup class? [ drop tuple ] unless 1array f
] "output-classes" set-word-prop
] each
From 1e1561fc2535737533fc44d98eeb97b636a69752 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 16 Jan 2008 01:04:42 -0500
Subject: [PATCH 29/65] XMode loads now
---
extra/xmode/loader/loader.factor | 103 +-----------------------
extra/xmode/loader/syntax/syntax.factor | 101 +++++++++++++++++++++++
extra/xmode/tokens/tokens.factor | 16 ++--
extra/xmode/utilities/utilities.factor | 2 +-
4 files changed, 113 insertions(+), 109 deletions(-)
create mode 100644 extra/xmode/loader/syntax/syntax.factor
diff --git a/extra/xmode/loader/loader.factor b/extra/xmode/loader/loader.factor
index e631a920be..096b83e22e 100755
--- a/extra/xmode/loader/loader.factor
+++ b/extra/xmode/loader/loader.factor
@@ -1,59 +1,11 @@
-USING: xmode.tokens xmode.rules xmode.keyword-map xml.data
-xml.utilities xml assocs kernel combinators sequences
-math.parser namespaces parser xmode.utilities regexp io.files ;
+USING: xmode.loader.syntax xmode.tokens xmode.rules
+xmode.keyword-map xml.data xml.utilities xml assocs kernel
+combinators sequences math.parser namespaces parser
+xmode.utilities regexp io.files ;
IN: xmode.loader
! Based on org.gjt.sp.jedit.XModeHandler
-SYMBOL: ignore-case?
-
-! Attribute utilities
-: string>boolean ( string -- ? ) "TRUE" = ;
-
-: string>match-type ( string -- obj )
- {
- { "RULE" [ f ] }
- { "CONTEXT" [ t ] }
- [ string>token ]
- } case ;
-
-: string>rule-set-name "MAIN" or ;
-
-! PROP, PROPS
-: parse-prop-tag ( tag -- key value )
- "NAME" over at "VALUE" rot at ;
-
-: parse-props-tag ( tag -- assoc )
- child-tags
- [ parse-prop-tag ] H{ } map>assoc ;
-
-: position-attrs ( tag -- at-line-start? at-whitespace-end? at-word-start? )
- ! XXX Wrong logic!
- { "AT_LINE_START" "AT_WHITESPACE_END" "AT_WORD_START" }
- swap [ at string>boolean ] curry map first3 ;
-
-: parse-literal-matcher ( tag -- matcher )
- dup children>string
- ignore-case? get <string-matcher>
- swap position-attrs <matcher> ;
-
-: parse-regexp-matcher ( tag -- matcher )
- dup children>string ignore-case? get <regexp>
- swap position-attrs <matcher> ;
-
-! SPAN's children
-<TAGS: parse-begin/end-tag
-
-TAG: BEGIN
- ! XXX
- parse-literal-matcher swap set-rule-start ;
-
-TAG: END
- ! XXX
- parse-literal-matcher swap set-rule-end ;
-
-TAGS>
-
! RULES and its children
<TAGS: parse-rule-tag
@@ -66,56 +18,12 @@ TAG: IMPORT ( rule-set tag -- )
TAG: TERMINATE ( rule-set tag -- )
"AT_CHAR" swap at string>number swap set-rule-set-terminate-char ;
-: (parse-rule-tag) ( rule-set tag specs class -- )
- construct-rule swap init-from-tag swap add-rule ; inline
-
-: RULE:
- scan scan-word
- parse-definition { } make
- swap [ (parse-rule-tag) ] 2curry (TAG:) ; parsing
-
-: shared-tag-attrs
- { "TYPE" string>token set-rule-body-token } , ; inline
-
-: delegate-attr
- { "DELEGATE" f set-rule-delegate } , ;
-
-: regexp-attr
- { "HASH_CHAR" f set-rule-chars } , ;
-
-: match-type-attr
- { "MATCH_TYPE" string>match-type set-rule-match-token } , ;
-
-: span-attrs
- { "NO_LINE_BREAK" string>boolean set-rule-no-line-break? } ,
- { "NO_WORD_BREAK" string>boolean set-rule-no-word-break? } ,
- { "NO_ESCAPE" string>boolean set-rule-no-escape? } , ;
-
-: literal-start
- [ parse-literal-matcher swap set-rule-start ] , ;
-
-: regexp-start
- [ parse-regexp-matcher swap set-rule-start ] , ;
-
-: literal-end
- [ parse-literal-matcher swap set-rule-end ] , ;
-
RULE: SEQ seq-rule
shared-tag-attrs delegate-attr literal-start ;
RULE: SEQ_REGEXP seq-rule
shared-tag-attrs delegate-attr regexp-attr regexp-start ;
-: parse-begin/end-tags
- [
- ! XXX: handle position attrs on span tag itself
- child-tags [ parse-begin/end-tag ] with each
- ] , ;
-
-: init-span-tag [ drop init-span ] , ;
-
-: init-eol-span-tag [ drop init-eol-span ] , ;
-
RULE: SPAN span-rule
shared-tag-attrs delegate-attr match-type-attr span-attrs parse-begin/end-tags init-span-tag ;
@@ -134,9 +42,6 @@ RULE: MARK_FOLLOWING mark-following-rule
RULE: MARK_PREVIOUS mark-previous-rule
shared-tag-attrs match-type-attr literal-start ;
-: parse-keyword-tag ( tag keyword-map -- )
- >r dup name-tag string>token swap children>string r> set-at ;
-
TAG: KEYWORDS ( rule-set tag -- key value )
ignore-case? get <keyword-map>
swap child-tags [ over parse-keyword-tag ] each
diff --git a/extra/xmode/loader/syntax/syntax.factor b/extra/xmode/loader/syntax/syntax.factor
new file mode 100644
index 0000000000..c754db61c8
--- /dev/null
+++ b/extra/xmode/loader/syntax/syntax.factor
@@ -0,0 +1,101 @@
+USING: xmode.tokens xmode.rules xmode.keyword-map xml.data
+xml.utilities xml assocs kernel combinators sequences
+math.parser namespaces parser xmode.utilities regexp io.files ;
+IN: xmode.loader.syntax
+
+SYMBOL: ignore-case?
+
+! Rule tag parsing utilities
+: (parse-rule-tag) ( rule-set tag specs class -- )
+ construct-rule swap init-from-tag swap add-rule ; inline
+
+: RULE:
+ scan scan-word
+ parse-definition { } make
+ swap [ (parse-rule-tag) ] 2curry (TAG:) ; parsing
+
+! Attribute utilities
+: string>boolean ( string -- ? ) "TRUE" = ;
+
+: string>match-type ( string -- obj )
+ {
+ { "RULE" [ f ] }
+ { "CONTEXT" [ t ] }
+ [ string>token ]
+ } case ;
+
+: string>rule-set-name "MAIN" or ;
+
+! PROP, PROPS
+: parse-prop-tag ( tag -- key value )
+ "NAME" over at "VALUE" rot at ;
+
+: parse-props-tag ( tag -- assoc )
+ child-tags
+ [ parse-prop-tag ] H{ } map>assoc ;
+
+: position-attrs ( tag -- at-line-start? at-whitespace-end? at-word-start? )
+ ! XXX Wrong logic!
+ { "AT_LINE_START" "AT_WHITESPACE_END" "AT_WORD_START" }
+ swap [ at string>boolean ] curry map first3 ;
+
+: parse-literal-matcher ( tag -- matcher )
+ dup children>string
+ ignore-case? get <string-matcher>
+ swap position-attrs <matcher> ;
+
+: parse-regexp-matcher ( tag -- matcher )
+ dup children>string ignore-case? get <regexp>
+ swap position-attrs <matcher> ;
+
+: shared-tag-attrs
+ { "TYPE" string>token set-rule-body-token } , ; inline
+
+: delegate-attr
+ { "DELEGATE" f set-rule-delegate } , ;
+
+: regexp-attr
+ { "HASH_CHAR" f set-rule-chars } , ;
+
+: match-type-attr
+ { "MATCH_TYPE" string>match-type set-rule-match-token } , ;
+
+: span-attrs
+ { "NO_LINE_BREAK" string>boolean set-rule-no-line-break? } ,
+ { "NO_WORD_BREAK" string>boolean set-rule-no-word-break? } ,
+ { "NO_ESCAPE" string>boolean set-rule-no-escape? } , ;
+
+: literal-start
+ [ parse-literal-matcher swap set-rule-start ] , ;
+
+: regexp-start
+ [ parse-regexp-matcher swap set-rule-start ] , ;
+
+: literal-end
+ [ parse-literal-matcher swap set-rule-end ] , ;
+
+! SPAN's children
+<TAGS: parse-begin/end-tag
+
+TAG: BEGIN
+ ! XXX
+ parse-literal-matcher swap set-rule-start ;
+
+TAG: END
+ ! XXX
+ parse-literal-matcher swap set-rule-end ;
+
+TAGS>
+
+: parse-begin/end-tags
+ [
+ ! XXX: handle position attrs on span tag itself
+ child-tags [ parse-begin/end-tag ] with each
+ ] , ;
+
+: init-span-tag [ drop init-span ] , ;
+
+: init-eol-span-tag [ drop init-eol-span ] , ;
+
+: parse-keyword-tag ( tag keyword-map -- )
+ >r dup name-tag string>token swap children>string r> set-at ;
diff --git a/extra/xmode/tokens/tokens.factor b/extra/xmode/tokens/tokens.factor
index 14a48582ec..e1fa2dd04f 100644
--- a/extra/xmode/tokens/tokens.factor
+++ b/extra/xmode/tokens/tokens.factor
@@ -1,20 +1,18 @@
-USING: parser words sequences namespaces kernel assocs ;
+USING: parser words sequences namespaces kernel assocs
+compiler.units ;
IN: xmode.tokens
! Based on org.gjt.sp.jedit.syntax.Token
SYMBOL: tokens
-: string>token ( string -- id ) tokens get at ;
-
-: TOKENS:
- ";" parse-tokens [
+[
+ { "COMMENT1" "COMMENT2" "COMMENT3" "COMMENT4" "DIGIT" "FUNCTION" "INVALID" "KEYWORD1" "KEYWORD2" "KEYWORD3" "KEYWORD4" "LABEL" "LITERAL1" "LITERAL2" "LITERAL3" "LITERAL4" "MARKUP" "OPERATOR" "END" "NULL" } [
create-in dup define-symbol
dup word-name swap
- ] H{ } map>assoc tokens set-global ; parsing
+ ] H{ } map>assoc tokens set-global
+] with-compilation-unit
-TOKENS: COMMENT1 COMMENT2 COMMENT3 COMMENT4 DIGIT FUNCTION
-INVALID KEYWORD1 KEYWORD2 KEYWORD3 KEYWORD4 LABEL LITERAL1
-LITERAL2 LITERAL3 LITERAL4 MARKUP OPERATOR END NULL ;
+: string>token ( string -- id ) tokens get at ;
TUPLE: token str id ;
diff --git a/extra/xmode/utilities/utilities.factor b/extra/xmode/utilities/utilities.factor
index d4096b17e0..f7c8606420 100644
--- a/extra/xmode/utilities/utilities.factor
+++ b/extra/xmode/utilities/utilities.factor
@@ -55,4 +55,4 @@ SYMBOL: tag-handler-word
: TAGS>
tag-handler-word get
tag-handlers get >alist [ >r dup name-tag r> case ] curry
- define-compound ; parsing
+ define ; parsing
From 112c37b990bde2c97070546e801c07f20b9b5345 Mon Sep 17 00:00:00 2001
From: Slava <slava@emu.(none)>
Date: Wed, 16 Jan 2008 01:16:53 -0500
Subject: [PATCH 30/65] Fix Linux and FreeBSD signal handling on x86
---
vm/os-freebsd-x86.32.h | 8 ++++++++
vm/os-linux-x86-32.h | 8 ++++++++
vm/os-unix.c | 7 ++++++-
vm/platform.h | 2 --
4 files changed, 22 insertions(+), 3 deletions(-)
diff --git a/vm/os-freebsd-x86.32.h b/vm/os-freebsd-x86.32.h
index 34299691bc..a04755e9dd 100644
--- a/vm/os-freebsd-x86.32.h
+++ b/vm/os-freebsd-x86.32.h
@@ -1 +1,9 @@
+#include <ucontext.h>
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.mc_esp;
+}
+
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip)
diff --git a/vm/os-linux-x86-32.h b/vm/os-linux-x86-32.h
index e12133966d..b458fcbe21 100644
--- a/vm/os-linux-x86-32.h
+++ b/vm/os-linux-x86-32.h
@@ -1,2 +1,10 @@
+#include <ucontext.h>
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[7];
+}
+
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.gregs[14])
diff --git a/vm/os-unix.c b/vm/os-unix.c
index 55d55f312b..41dbe9cabf 100755
--- a/vm/os-unix.c
+++ b/vm/os-unix.c
@@ -192,7 +192,12 @@ INLINE F_STACK_FRAME *uap_stack_pointer(void *uap)
from Factor to C is a sign of things seriously gone wrong, not just
a divide by zero or stack underflow in the listener */
if(in_code_heap_p(UAP_PROGRAM_COUNTER(uap)))
- return ucontext_stack_pointer(uap);
+ {
+ F_STACK_FRAME *ptr = ucontext_stack_pointer(uap);
+ if(!ptr)
+ critical_error("Invalid uap",(CELL)uap);
+ return ptr;
+ }
else
return NULL;
}
diff --git a/vm/platform.h b/vm/platform.h
index d5687b849d..40324cc330 100644
--- a/vm/platform.h
+++ b/vm/platform.h
@@ -41,7 +41,6 @@
#ifdef __FreeBSD__
#define FACTOR_OS_STRING "freebsd"
#include "os-freebsd.h"
- #include "os-unix-ucontext.h"
#if defined(FACTOR_X86)
#include "os-freebsd-x86.32.h"
@@ -64,7 +63,6 @@
#include "os-linux.h"
#if defined(FACTOR_X86)
- #include "os-unix-ucontext.h"
#include "os-linux-x86-32.h"
#elif defined(FACTOR_PPC)
#include "os-unix-ucontext.h"
From 6a4e98435706b50daa4ab4440e6707df7d4e98a6 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <wayo.cavazos@gmail.com>
Date: Wed, 16 Jan 2008 08:12:14 -0600
Subject: [PATCH 31/65] Fix multiline: define-compound -> define Fix docs
for new circularity requirements
---
extra/multiline/multiline-docs.factor | 4 +++-
extra/multiline/multiline.factor | 2 +-
2 files changed, 4 insertions(+), 2 deletions(-)
diff --git a/extra/multiline/multiline-docs.factor b/extra/multiline/multiline-docs.factor
index 7e7375cfad..c48ee16490 100644
--- a/extra/multiline/multiline-docs.factor
+++ b/extra/multiline/multiline-docs.factor
@@ -1,4 +1,6 @@
-USING: help.markup help.syntax multiline ;
+USING: help.markup help.syntax ;
+
+IN: multiline
HELP: STRING:
{ $syntax "STRING: name\nfoo\n;" }
diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor
index 89a6e06053..7f831e5351 100644
--- a/extra/multiline/multiline.factor
+++ b/extra/multiline/multiline.factor
@@ -16,7 +16,7 @@ IN: multiline
: STRING:
CREATE dup reset-generic
- parse-here 1quotation define-compound ; parsing
+ parse-here 1quotation define ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index )
lexer get line-text 2dup start
From d9ff84c4c6d4d46ddebead181418dc0bd0e07c23 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <wayo.cavazos@gmail.com>
Date: Wed, 16 Jan 2008 09:02:32 -0600
Subject: [PATCH 32/65] Fix odbc docs error
---
extra/odbc/odbc-docs.factor | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/extra/odbc/odbc-docs.factor b/extra/odbc/odbc-docs.factor
index b6915a01fb..57bc35d930 100644
--- a/extra/odbc/odbc-docs.factor
+++ b/extra/odbc/odbc-docs.factor
@@ -1,6 +1,8 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup odbc threads ;
+USING: help.syntax help.markup threads ;
+
+IN: odbc
HELP: odbc-init
{ $values { "env" "an ODBC environment handle" } }
From c6bc0744723217badabdbb64131a70c0aae1ff6b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Wed, 16 Jan 2008 15:45:04 -0500
Subject: [PATCH 33/65] Simplify code heap layout
---
core/compiler/constants/constants.factor | 2 +-
core/compiler/test/templates-early.factor | 2 +-
core/cpu/architecture/architecture.factor | 2 --
core/cpu/ppc/architecture/architecture.factor | 3 --
core/generator/fixup/fixup-docs.factor | 7 ----
core/generator/fixup/fixup.factor | 10 ++----
core/generator/generator.factor | 24 ++++++-------
vm/code_gc.c | 6 +---
vm/code_gc.h | 6 ++--
vm/code_heap.c | 34 +++++--------------
vm/code_heap.h | 3 +-
vm/image.c | 12 ++-----
vm/layouts.h | 2 --
vm/profiler.c | 1 -
vm/quotations.c | 12 ++-----
15 files changed, 33 insertions(+), 93 deletions(-)
diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor
index 3de32ab7fa..66fc8d5789 100755
--- a/core/compiler/constants/constants.factor
+++ b/core/compiler/constants/constants.factor
@@ -19,4 +19,4 @@ IN: compiler.constants
: class-hash-offset bootstrap-cell object tag-number - ;
: word-xt-offset 8 bootstrap-cells object tag-number - ;
: word-code-offset 9 bootstrap-cells object tag-number - ;
-: compiled-header-size 8 bootstrap-cells ;
+: compiled-header-size 4 bootstrap-cells ;
diff --git a/core/compiler/test/templates-early.factor b/core/compiler/test/templates-early.factor
index 795d331c00..e518d2de8a 100755
--- a/core/compiler/test/templates-early.factor
+++ b/core/compiler/test/templates-early.factor
@@ -44,7 +44,7 @@ words kernel math effects definitions compiler.units ;
[
[ ] [ init-templates ] unit-test
- [ ] [ \ + init-generator ] unit-test
+ [ ] [ init-generator ] unit-test
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor
index 2409eafaf0..e48ba97f33 100755
--- a/core/cpu/architecture/architecture.factor
+++ b/core/cpu/architecture/architecture.factor
@@ -72,8 +72,6 @@ HOOK: %jump-dispatch compiler-backend ( -- )
HOOK: %dispatch-label compiler-backend ( word -- )
-HOOK: %end-dispatch compiler-backend ( label -- )
-
! Return to caller
HOOK: %return compiler-backend ( -- )
diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor
index a156c173a1..edbed571e1 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/core/cpu/ppc/architecture/architecture.factor
@@ -144,9 +144,6 @@ M: ppc-backend %jump-dispatch ( -- )
M: ppc-backend %dispatch-label ( word -- )
0 , rc-absolute-cell rel-word ;
-M: ppc-backend %end-dispatch ( label -- )
- resolve-label ;
-
M: ppc-backend %return ( -- ) %epilogue-later BLR ;
M: ppc-backend %unwind drop %return ;
diff --git a/core/generator/fixup/fixup-docs.factor b/core/generator/fixup/fixup-docs.factor
index 284af26a9b..7f4b5026da 100644
--- a/core/generator/fixup/fixup-docs.factor
+++ b/core/generator/fixup/fixup-docs.factor
@@ -13,13 +13,6 @@ HELP: add-literal
{ $values { "obj" object } { "n" integer } }
{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
-HELP: word-table
-{ $var-description "Holds a vector of words called from the currently compiling word." } ;
-
-HELP: add-word
-{ $values { "word" word } { "n" integer } }
-{ $description "Adds a word to the " { $link word-table } ", if it is not already there, and outputs the index of the word in the table. This literal can then be used as an argument for a " { $link rt-xt } " relocation with " { $link rel-fixup } "." } ;
-
HELP: string>symbol
{ $values { "str" string } { "alien" alien } }
{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor
index 3a30a51d09..17c0c64bf1 100755
--- a/core/generator/fixup/fixup.factor
+++ b/core/generator/fixup/fixup.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables
kernel kernel.private math namespaces sequences words
@@ -110,10 +110,6 @@ SYMBOL: literal-table
: add-literal ( obj -- n ) literal-table get push-new* ;
-SYMBOL: word-table
-
-: add-word ( word -- n ) word-table get push-new* ;
-
: string>symbol ( str -- alien )
wince? [ string>u16-alien ] [ string>char-alien ] if ;
@@ -125,10 +121,8 @@ SYMBOL: word-table
add-dlsym-literals
r> r> rt-dlsym rel-fixup ;
-: rel-dispatch ( word-table# class -- ) rt-dispatch rel-fixup ;
-
: rel-word ( word class -- )
- >r add-word r> rt-xt rel-fixup ;
+ >r add-literal r> rt-xt rel-fixup ;
: rel-primitive ( word class -- )
>r word-def first r> rt-primitive rel-fixup ;
diff --git a/core/generator/generator.factor b/core/generator/generator.factor
index 1c23e51e12..df01f9e490 100755
--- a/core/generator/generator.factor
+++ b/core/generator/generator.factor
@@ -1,22 +1,20 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes combinators cpu.architecture
effects generator.fixup generator.registers generic hashtables
inference inference.backend inference.dataflow io kernel
kernel.private layouts math namespaces optimizer prettyprint
-quotations sequences system threads words ;
+quotations sequences system threads words vectors ;
IN: generator
SYMBOL: compile-queue
SYMBOL: compiled
-: 5array 3array >r 2array r> append ;
-
: begin-compiling ( word -- )
f swap compiled get set-at ;
-: finish-compiling ( word literals words relocation labels code -- )
- 5array swap compiled get set-at ;
+: finish-compiling ( word literals relocation labels code -- )
+ 4array swap compiled get set-at ;
: queue-compile ( word -- )
{
@@ -38,20 +36,18 @@ SYMBOL: current-label-start
: compiled-stack-traces? ( -- ? ) 36 getenv ;
-: init-generator ( compiling -- )
- V{ } clone literal-table set
- V{ } clone word-table set
- compiled-stack-traces? swap f ?
- literal-table get push ;
+: init-generator ( -- )
+ compiled-stack-traces?
+ compiling-word get f ?
+ 1vector literal-table set ;
: generate-1 ( word label node quot -- )
pick begin-compiling [
roll compiling-word set
pick compiling-label set
- compiling-word get init-generator
+ init-generator
call
literal-table get >array
- word-table get >array
] { } make fixup finish-compiling ;
GENERIC: generate-node ( node -- next )
@@ -182,7 +178,7 @@ M: #dispatch generate-node
%jump-dispatch dispatch-branches
] [
0 frame-required
- %call-dispatch >r dispatch-branches r> %end-dispatch
+ %call-dispatch >r dispatch-branches r> resolve-label
] if
init-templates iterate-next ;
diff --git a/vm/code_gc.c b/vm/code_gc.c
index 4c5e3c436f..5c51fe7e8b 100755
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -245,17 +245,13 @@ void iterate_code_heap(CODE_HEAP_ITERATOR iter)
/* Copy all literals referenced from a code block to newspace */
void collect_literals_step(F_COMPILED *compiled, CELL code_start,
- CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end)
+ CELL reloc_start, CELL literals_start)
{
CELL scan;
-
CELL literal_end = literals_start + compiled->literals_length;
for(scan = literals_start; scan < literal_end; scan += CELLS)
copy_handle((CELL*)scan);
-
- for(scan = words_start; scan < words_end; scan += CELLS)
- copy_handle((CELL*)scan);
}
/* Copy literals referenced from all code blocks to newspace */
diff --git a/vm/code_gc.h b/vm/code_gc.h
index b91f16e5b0..4341d8ce64 100644
--- a/vm/code_gc.h
+++ b/vm/code_gc.h
@@ -48,17 +48,15 @@ INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
F_HEAP code_heap;
typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start,
- CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end);
+ CELL reloc_start, CELL literals_start);
INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter)
{
CELL code_start = (CELL)(compiled + 1);
CELL reloc_start = code_start + compiled->code_length;
CELL literals_start = reloc_start + compiled->reloc_length;
- CELL words_start = literals_start + compiled->literals_length;
- CELL words_end = words_start + compiled->words_length;
- iter(compiled,code_start,reloc_start,literals_start,words_start,words_end);
+ iter(compiled,code_start,reloc_start,literals_start);
}
INLINE F_BLOCK *compiled_to_block(F_COMPILED *compiled)
diff --git a/vm/code_heap.c b/vm/code_heap.c
index ddd7efb4a0..5771725f9d 100755
--- a/vm/code_heap.c
+++ b/vm/code_heap.c
@@ -38,7 +38,7 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start)
/* Compute an address to store at a relocation */
INLINE CELL compute_code_rel(F_REL *rel,
- CELL code_start, CELL literals_start, CELL words_start)
+ CELL code_start, CELL literals_start)
{
switch(REL_TYPE(rel))
{
@@ -48,10 +48,8 @@ INLINE CELL compute_code_rel(F_REL *rel,
return (CELL)get_rel_symbol(rel,literals_start);
case RT_LITERAL:
return CREF(literals_start,REL_ARGUMENT(rel));
- case RT_DISPATCH:
- return CREF(words_start,REL_ARGUMENT(rel));
case RT_XT:
- return (CELL)untag_word(get(CREF(words_start,REL_ARGUMENT(rel))))->xt;
+ return (CELL)untag_word(get(CREF(literals_start,REL_ARGUMENT(rel))))->xt;
case RT_HERE:
return rel->offset + code_start;
case RT_LABEL:
@@ -127,7 +125,7 @@ void apply_relocation(CELL class, CELL offset, F_FIXNUM absolute_value)
/* Perform all fixups on a code block */
void relocate_code_block(F_COMPILED *relocating, CELL code_start,
- CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end)
+ CELL reloc_start, CELL literals_start)
{
if(reloc_start != literals_start)
{
@@ -138,8 +136,8 @@ void relocate_code_block(F_COMPILED *relocating, CELL code_start,
{
CELL offset = rel->offset + code_start;
- F_FIXNUM absolute_value = compute_code_rel(rel,
- code_start,literals_start,words_start);
+ F_FIXNUM absolute_value = compute_code_rel(
+ rel,code_start,literals_start);
apply_relocation(REL_CLASS(rel),offset,absolute_value);
@@ -228,27 +226,23 @@ F_COMPILED *add_compiled_block(
F_ARRAY *code,
F_ARRAY *labels,
F_ARRAY *relocation,
- F_ARRAY *words,
F_ARRAY *literals)
{
CELL code_format = compiled_code_format();
CELL code_length = align8(array_capacity(code) * code_format);
CELL rel_length = array_capacity(relocation) * sizeof(unsigned int);
- CELL words_length = (words ? array_capacity(words) * CELLS : 0);
CELL literals_length = array_capacity(literals) * CELLS;
REGISTER_UNTAGGED(code);
REGISTER_UNTAGGED(labels);
REGISTER_UNTAGGED(relocation);
- REGISTER_UNTAGGED(words);
REGISTER_UNTAGGED(literals);
CELL here = allot_code_block(sizeof(F_COMPILED) + code_length
- + rel_length + literals_length + words_length);
+ + rel_length + literals_length);
UNREGISTER_UNTAGGED(literals);
- UNREGISTER_UNTAGGED(words);
UNREGISTER_UNTAGGED(relocation);
UNREGISTER_UNTAGGED(labels);
UNREGISTER_UNTAGGED(code);
@@ -259,7 +253,6 @@ F_COMPILED *add_compiled_block(
header->code_length = code_length;
header->reloc_length = rel_length;
header->literals_length = literals_length;
- header->words_length = words_length;
here += sizeof(F_COMPILED);
@@ -277,13 +270,6 @@ F_COMPILED *add_compiled_block(
deposit_objects(here,literals);
here += literals_length;
- /* words */
- if(words)
- {
- deposit_objects(here,words);
- here += words_length;
- }
-
/* fixup labels */
if(labels)
fixup_labels(labels,code_format,code_start);
@@ -347,10 +333,9 @@ DEFINE_PRIMITIVE(modify_code_heap)
F_ARRAY *compiled_code = untag_array(data);
F_ARRAY *literals = untag_array(array_nth(compiled_code,0));
- F_ARRAY *words = untag_array(array_nth(compiled_code,1));
- F_ARRAY *relocation = untag_array(array_nth(compiled_code,2));
- F_ARRAY *labels = untag_array(array_nth(compiled_code,3));
- F_ARRAY *code = untag_array(array_nth(compiled_code,4));
+ F_ARRAY *relocation = untag_array(array_nth(compiled_code,1));
+ F_ARRAY *labels = untag_array(array_nth(compiled_code,2));
+ F_ARRAY *code = untag_array(array_nth(compiled_code,3));
REGISTER_UNTAGGED(alist);
REGISTER_UNTAGGED(word);
@@ -360,7 +345,6 @@ DEFINE_PRIMITIVE(modify_code_heap)
code,
labels,
relocation,
- words,
literals);
UNREGISTER_UNTAGGED(word);
diff --git a/vm/code_heap.h b/vm/code_heap.h
index d5b361e693..4e65313d3b 100755
--- a/vm/code_heap.h
+++ b/vm/code_heap.h
@@ -54,7 +54,7 @@ typedef struct {
} F_REL;
void relocate_code_block(F_COMPILED *relocating, CELL code_start,
- CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end);
+ CELL reloc_start, CELL literals_start);
void default_word_code(F_WORD *word, bool relocate);
@@ -65,7 +65,6 @@ F_COMPILED *add_compiled_block(
F_ARRAY *code,
F_ARRAY *labels,
F_ARRAY *rel,
- F_ARRAY *words,
F_ARRAY *literals);
CELL compiled_code_format(void);
diff --git a/vm/image.c b/vm/image.c
index 0f80303749..3d3c352093 100755
--- a/vm/image.c
+++ b/vm/image.c
@@ -179,7 +179,7 @@ void fixup_word(F_WORD *word)
{
code_fixup((CELL)&word->code);
if(word->profiling) code_fixup((CELL)&word->profiling);
- update_word_xt(word);
+ code_fixup((CELL)&word->xt);
}
}
@@ -262,7 +262,7 @@ void relocate_data()
}
void fixup_code_block(F_COMPILED *relocating, CELL code_start,
- CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end)
+ CELL reloc_start, CELL literals_start)
{
/* relocate literal table data */
CELL scan;
@@ -271,14 +271,8 @@ void fixup_code_block(F_COMPILED *relocating, CELL code_start,
for(scan = literals_start; scan < literal_end; scan += CELLS)
data_fixup((CELL*)scan);
- for(scan = words_start; scan < words_end; scan += CELLS)
- data_fixup((CELL*)scan);
-
if(reloc_start != literals_start)
- {
- relocate_code_block(relocating,code_start,reloc_start,
- literals_start,words_start,words_end);
- }
+ relocate_code_block(relocating,code_start,reloc_start,literals_start);
}
void relocate_code()
diff --git a/vm/layouts.h b/vm/layouts.h
index 7c6d775209..302a4497b4 100755
--- a/vm/layouts.h
+++ b/vm/layouts.h
@@ -151,8 +151,6 @@ typedef struct
CELL code_length; /* # bytes */
CELL reloc_length; /* # bytes */
CELL literals_length; /* # bytes */
- CELL words_length; /* # bytes */
- CELL padding[3];
} F_COMPILED;
/* Assembly code makes assumptions about the layout of this struct */
diff --git a/vm/profiler.c b/vm/profiler.c
index f9dbda860a..72c9046eab 100755
--- a/vm/profiler.c
+++ b/vm/profiler.c
@@ -25,7 +25,6 @@ F_COMPILED *compile_profiling_stub(F_WORD *word)
untag_object(code),
NULL, /* no labels */
untag_object(relocation),
- NULL, /* no words */
untag_object(literals));
}
diff --git a/vm/quotations.c b/vm/quotations.c
index 1e3fa8a47a..536d5d7d5a 100755
--- a/vm/quotations.c
+++ b/vm/quotations.c
@@ -116,9 +116,6 @@ void jit_compile(CELL quot, bool relocate)
GROWABLE_ARRAY(literals);
REGISTER_ROOT(literals);
- GROWABLE_ARRAY(words);
- REGISTER_ROOT(words);
-
GROWABLE_ADD(literals,stack_traces_p() ? quot : F);
bool stack_frame = jit_stack_frame_p(untag_object(array));
@@ -144,19 +141,19 @@ void jit_compile(CELL quot, bool relocate)
current stack frame. */
word = untag_object(obj);
- GROWABLE_ADD(words,array_nth(untag_object(array),i));
+ GROWABLE_ADD(literals,array_nth(untag_object(array),i));
if(i == length - 1)
{
if(stack_frame)
EMIT(JIT_EPILOG,0);
- EMIT(JIT_WORD_JUMP,words_count - 1);
+ EMIT(JIT_WORD_JUMP,literals_count - 1);
tail_call = true;
}
else
- EMIT(JIT_WORD_CALL,words_count - 1);
+ EMIT(JIT_WORD_CALL,literals_count - 1);
break;
case WRAPPER_TYPE:
wrapper = untag_object(obj);
@@ -220,14 +217,12 @@ void jit_compile(CELL quot, bool relocate)
GROWABLE_TRIM(code);
GROWABLE_TRIM(relocation);
GROWABLE_TRIM(literals);
- GROWABLE_TRIM(words);
F_COMPILED *compiled = add_compiled_block(
QUOTATION_TYPE,
untag_object(code),
NULL,
untag_object(relocation),
- untag_object(words),
untag_object(literals));
set_quot_xt(untag_object(quot),compiled);
@@ -235,7 +230,6 @@ void jit_compile(CELL quot, bool relocate)
if(relocate)
iterate_code_heap_step(compiled,relocate_code_block);
- UNREGISTER_ROOT(words);
UNREGISTER_ROOT(literals);
UNREGISTER_ROOT(relocation);
UNREGISTER_ROOT(code);
From eb07fbdc7c31739881057b7a5e67fcb3536fe536 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Thu, 17 Jan 2008 11:04:09 +1300
Subject: [PATCH 34/65] Fix ogg libraries for recent factor changes
---
extra/ogg/ogg.factor | 15 +++++++--------
extra/ogg/theora/theora.factor | 15 +++++++--------
extra/ogg/vorbis/vorbis.factor | 15 +++++++--------
3 files changed, 21 insertions(+), 24 deletions(-)
diff --git a/extra/ogg/ogg.factor b/extra/ogg/ogg.factor
index 9d6647858f..b0a78e1490 100644
--- a/extra/ogg/ogg.factor
+++ b/extra/ogg/ogg.factor
@@ -4,14 +4,13 @@
USING: kernel system combinators alien alien.syntax ;
IN: ogg
-: load-ogg-library ( -- )
- "ogg" {
- { [ win32? ] [ "ogg.dll" ] }
- { [ macosx? ] [ "libogg.0.dylib" ] }
- { [ unix? ] [ "libogg.so" ] }
- } cond "cdecl" add-library ; parsing
-
-load-ogg-library
+<<
+"ogg" {
+ { [ win32? ] [ "ogg.dll" ] }
+ { [ macosx? ] [ "libogg.0.dylib" ] }
+ { [ unix? ] [ "libogg.so" ] }
+} cond "cdecl" add-library
+>>
LIBRARY: ogg
diff --git a/extra/ogg/theora/theora.factor b/extra/ogg/theora/theora.factor
index 325fb91dad..0d9748a6f3 100644
--- a/extra/ogg/theora/theora.factor
+++ b/extra/ogg/theora/theora.factor
@@ -4,14 +4,13 @@
USING: kernel system combinators alien alien.syntax ;
IN: ogg.theora
-: load-theora-library ( -- )
- "theora" {
- { [ win32? ] [ "libtheora.dll" ] }
- { [ macosx? ] [ "libtheora.0.dylib" ] }
- { [ unix? ] [ "libtheora.so" ] }
- } cond "cdecl" add-library ; parsing
-
-load-theora-library
+<<
+"theora" {
+ { [ win32? ] [ "libtheora.dll" ] }
+ { [ macosx? ] [ "libtheora.0.dylib" ] }
+ { [ unix? ] [ "libtheora.so" ] }
+} cond "cdecl" add-library
+>>
LIBRARY: theora
diff --git a/extra/ogg/vorbis/vorbis.factor b/extra/ogg/vorbis/vorbis.factor
index e6e08efb0a..eff28b69ca 100644
--- a/extra/ogg/vorbis/vorbis.factor
+++ b/extra/ogg/vorbis/vorbis.factor
@@ -4,14 +4,13 @@
USING: kernel system combinators alien alien.syntax ;
IN: ogg.vorbis
-: load-vorbis-library ( -- )
- "vorbis" {
- { [ win32? ] [ "vorbis.dll" ] }
- { [ macosx? ] [ "libvorbis.0.dylib" ] }
- { [ unix? ] [ "libvorbis.so" ] }
- } cond "cdecl" add-library ; parsing
-
-load-vorbis-library
+<<
+"vorbis" {
+ { [ win32? ] [ "vorbis.dll" ] }
+ { [ macosx? ] [ "libvorbis.0.dylib" ] }
+ { [ unix? ] [ "libvorbis.so" ] }
+} cond "cdecl" add-library
+>>
LIBRARY: vorbis
From 2d79bdb09a0bb273d873eaf2a82261b7fe465dcf Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Thu, 17 Jan 2008 11:08:13 +1300
Subject: [PATCH 35/65] Fix peg.search for recent factor changes
---
extra/peg/search/search-docs.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/peg/search/search-docs.factor b/extra/peg/search/search-docs.factor
index 244dc7f838..fc1e618b9b 100755
--- a/extra/peg/search/search-docs.factor
+++ b/extra/peg/search/search-docs.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup peg peg.search ;
+USING: help.syntax help.markup peg ;
+IN: peg.search
HELP: tree-write
{ $values
From cd64a7bbee006657b20fd0a501cb8594013f574c Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Thu, 17 Jan 2008 11:17:20 +1300
Subject: [PATCH 36/65] Fix postgresql.libpq for recent factor changes
---
extra/postgresql/libpq/libpq.factor | 15 +++++++--------
1 file changed, 7 insertions(+), 8 deletions(-)
diff --git a/extra/postgresql/libpq/libpq.factor b/extra/postgresql/libpq/libpq.factor
index a7f4261055..3b21fd8203 100644
--- a/extra/postgresql/libpq/libpq.factor
+++ b/extra/postgresql/libpq/libpq.factor
@@ -8,14 +8,13 @@
USING: alien alien.syntax combinators system ;
IN: postgresql.libpq
-: load-postgresql-library ( -- )
- "postgresql" {
- { [ win32? ] [ "libpq.dll" ] }
- { [ macosx? ] [ "/opt/local/lib/postgresql81/libpq.dylib" ] }
- { [ unix? ] [ "libpq.so" ] }
- } cond "cdecl" add-library ; parsing
-
-load-postgresql-library
+<<
+"postgresql" {
+ { [ win32? ] [ "libpq.dll" ] }
+ { [ macosx? ] [ "/opt/local/lib/postgresql81/libpq.dylib" ] }
+ { [ unix? ] [ "libpq.so" ] }
+} cond "cdecl" add-library
+>>
! ConnSatusType
: CONNECTION_OK HEX: 0 ; inline
From f0f309b4b48c73b7aba30d54b568b4a3d63b1a94 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Thu, 17 Jan 2008 11:26:33 +1300
Subject: [PATCH 37/65] Fix sqlite and sqlite.tuple-db for factor changes
---
extra/sqlite/lib/lib.factor | 15 +++++++--------
extra/sqlite/sqlite-docs.factor | 2 +-
extra/sqlite/tuple-db/tuple-db-docs.factor | 2 +-
3 files changed, 9 insertions(+), 10 deletions(-)
diff --git a/extra/sqlite/lib/lib.factor b/extra/sqlite/lib/lib.factor
index d544b8f888..438f22a80f 100644
--- a/extra/sqlite/lib/lib.factor
+++ b/extra/sqlite/lib/lib.factor
@@ -12,14 +12,13 @@ IN: sqlite.lib
USING: alien compiler kernel math namespaces sequences strings alien.syntax
system combinators ;
-: load-sqlite-library ( -- )
- "sqlite" {
- { [ win32? ] [ "sqlite3.dll" ] }
- { [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
- { [ unix? ] [ "libsqlite3.so" ] }
- } cond "cdecl" add-library ; parsing
-
-load-sqlite-library
+<<
+"sqlite" {
+ { [ win32? ] [ "sqlite3.dll" ] }
+ { [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
+ { [ unix? ] [ "libsqlite3.so" ] }
+} cond "cdecl" add-library
+>>
! Return values from sqlite functions
: SQLITE_OK 0 ; inline ! Successful result
diff --git a/extra/sqlite/sqlite-docs.factor b/extra/sqlite/sqlite-docs.factor
index 7bdec6efa4..d58b553f11 100644
--- a/extra/sqlite/sqlite-docs.factor
+++ b/extra/sqlite/sqlite-docs.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help sqlite help.syntax help.markup ;
+USING: help help.syntax help.markup ;
IN: sqlite
HELP: sqlite-open
diff --git a/extra/sqlite/tuple-db/tuple-db-docs.factor b/extra/sqlite/tuple-db/tuple-db-docs.factor
index 795836fa56..3c6df0eaa6 100644
--- a/extra/sqlite/tuple-db/tuple-db-docs.factor
+++ b/extra/sqlite/tuple-db/tuple-db-docs.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help sqlite sqlite.tuple-db help.syntax help.markup ;
+USING: help sqlite help.syntax help.markup ;
IN: sqlite.tuple-db
ARTICLE: { "sqlite" "tuple-db-loading" } "Loading"
From 3df671407f83f5bcd51f466ef88b5b91109b42f6 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Thu, 17 Jan 2008 11:37:46 +1300
Subject: [PATCH 38/65] Update trees for factor changes
---
extra/trees/trees-docs.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/trees/trees-docs.factor b/extra/trees/trees-docs.factor
index 12bae4bac5..df04f1cb40 100644
--- a/extra/trees/trees-docs.factor
+++ b/extra/trees/trees-docs.factor
@@ -1,4 +1,5 @@
-USING: help.syntax help.markup trees assocs ;
+USING: help.syntax help.markup assocs ;
+IN: trees
HELP: TREE{
{ $syntax "TREE{ { key value }... }" }
From 7adea410e412cf53e45a2bc4cbe8fdf2f03264ed Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Thu, 17 Jan 2008 11:55:23 +1300
Subject: [PATCH 39/65] trees.avl trees.splay tuple-syntax doc fixes
---
extra/trees/avl/avl-docs.factor | 4 ++--
extra/trees/splay/splay-docs.factor | 4 ++--
extra/tuple-syntax/tuple-syntax-docs.factor | 3 ++-
3 files changed, 6 insertions(+), 5 deletions(-)
diff --git a/extra/trees/avl/avl-docs.factor b/extra/trees/avl/avl-docs.factor
index 12465eec98..46f647470a 100644
--- a/extra/trees/avl/avl-docs.factor
+++ b/extra/trees/avl/avl-docs.factor
@@ -1,4 +1,5 @@
-USING: help.syntax help.markup trees.avl assocs ;
+USING: help.syntax help.markup assocs ;
+IN: trees.avl
HELP: AVL{
{ $syntax "AVL{ { key value }... }" }
@@ -23,5 +24,4 @@ ARTICLE: { "avl" "intro" } "AVL trees"
{ $subsection >avl }
{ $subsection POSTPONE: AVL{ } ;
-IN: trees.avl
ABOUT: { "avl" "intro" }
diff --git a/extra/trees/splay/splay-docs.factor b/extra/trees/splay/splay-docs.factor
index b621155e73..1c49febe01 100644
--- a/extra/trees/splay/splay-docs.factor
+++ b/extra/trees/splay/splay-docs.factor
@@ -1,4 +1,5 @@
-USING: help.syntax help.markup trees.splay assocs ;
+USING: help.syntax help.markup assocs ;
+IN: trees.splay
HELP: SPLAY{
{ $syntax "SPLAY{ { key value }... }" }
@@ -23,5 +24,4 @@ ARTICLE: { "splay" "intro" } "Splay trees"
{ $subsection >splay }
{ $subsection POSTPONE: SPLAY{ } ;
-IN: trees.splay
ABOUT: { "splay" "intro" }
diff --git a/extra/tuple-syntax/tuple-syntax-docs.factor b/extra/tuple-syntax/tuple-syntax-docs.factor
index 7d4c12c0e9..aacc48f9e5 100644
--- a/extra/tuple-syntax/tuple-syntax-docs.factor
+++ b/extra/tuple-syntax/tuple-syntax-docs.factor
@@ -1,4 +1,5 @@
-USING: help.markup help.syntax tuple-syntax ;
+USING: help.markup help.syntax ;
+IN: tuple-syntax
HELP: TUPLE{
{ $syntax "TUPLE{ class slot-name: value... }" }
From c3d1ba6ce675afada95426e537c266fe3748045c Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Thu, 17 Jan 2008 11:59:23 +1300
Subject: [PATCH 40/65] Fix yahoo for factor changes
---
extra/yahoo/yahoo-docs.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/yahoo/yahoo-docs.factor b/extra/yahoo/yahoo-docs.factor
index abc80c4ea6..b5603103e1 100644
--- a/extra/yahoo/yahoo-docs.factor
+++ b/extra/yahoo/yahoo-docs.factor
@@ -1,4 +1,5 @@
-USING: yahoo help.syntax help.markup ;
+USING: help.syntax help.markup ;
+IN: yahoo
HELP: search-yahoo
{ $values { "search" "a string" } { "num" "a positive integer" } { "seq" "sequence of arrays of length 3" } }
From 2ba88e297005c577aaf76b0e41b4eebc645cb1b8 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Thu, 17 Jan 2008 12:38:12 +1300
Subject: [PATCH 41/65] Fix cpu.8080 and space invaders (Instructions weren't
loading)
---
extra/cpu/8080/8080-docs.factor | 33 +-
extra/cpu/8080/8080.factor | 1596 +++--------------
extra/cpu/8080/emulator/emulator-docs.factor | 36 +
extra/cpu/8080/emulator/emulator.factor | 1356 ++++++++++++++
.../cpu/8080/instructions/instructions.factor | 250 ---
.../space-invaders/space-invaders-docs.factor | 2 +-
extra/space-invaders/space-invaders.factor | 2 +-
7 files changed, 1641 insertions(+), 1634 deletions(-)
create mode 100644 extra/cpu/8080/emulator/emulator-docs.factor
create mode 100644 extra/cpu/8080/emulator/emulator.factor
delete mode 100644 extra/cpu/8080/instructions/instructions.factor
diff --git a/extra/cpu/8080/8080-docs.factor b/extra/cpu/8080/8080-docs.factor
index c92d26ec3a..48b68360cb 100644
--- a/extra/cpu/8080/8080-docs.factor
+++ b/extra/cpu/8080/8080-docs.factor
@@ -1,39 +1,8 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax sequences strings ;
+USING: help.markup help.syntax sequences strings cpu.8080.emulator ;
IN: cpu.8080
-HELP: load-rom
-{ $values { "filename" string } { "cpu" cpu } }
-{ $description
-"Read the ROM file into the cpu's memory starting at address 0000. "
-"The filename is relative to the path stored in the " { $link rom-root }
-" variable. An exception is thrown if this variable is not set."
-}
-{ $see-also load-rom* } ;
-
-HELP: load-rom*
-{ $values { "seq" sequence } { "cpu" cpu } }
-{ $description
-"Loads one or more ROM files into the cpu's memory. Each file is "
-"loaded at a particular starting address. 'seq' is a sequence of "
-"2 element arrays. The first element is the address and the second "
-"element is the file to load at that address." $nl
-"The filenames are relative to the path stored in the " { $link rom-root }
-" variable. An exception is thrown if this variable is not set."
-}
-{ $examples
- { $code "{ { HEX: 0000 \"invaders.rom\" } } <cpu> load-rom*" }
-}
-{ $see-also load-rom } ;
-
-HELP: rom-root
-{ $description
-"Holds the path where the ROM files are stored. Used for expanding "
-"the relative filenames passed to " { $link load-rom } " and "
-{ $link load-rom* } "."
-}
-{ $see-also load-rom load-rom* } ;
ARTICLE: { "cpu-8080" "cpu-8080" } "Intel 8080 CPU Emulator"
"The cpu-8080 library provides an emulator for the Intel 8080 CPU"
diff --git a/extra/cpu/8080/8080.factor b/extra/cpu/8080/8080.factor
index d05c3ab634..fa88cf6c6a 100644
--- a/extra/cpu/8080/8080.factor
+++ b/extra/cpu/8080/8080.factor
@@ -1,1358 +1,254 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel math sequences words arrays io
- io.files namespaces math.parser kernel.private
- assocs quotations parser parser-combinators tools.time
- combinators.private compiler.units ;
+USING: cpu.8080.emulator tools.time ;
IN: cpu.8080
-TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
-
-GENERIC: reset ( cpu -- )
-GENERIC: update-video ( value addr cpu -- )
-GENERIC: read-port ( port cpu -- byte )
-GENERIC: write-port ( value port cpu -- )
-
-M: cpu update-video ( value addr cpu -- )
- 3drop ;
-
-M: cpu read-port ( port cpu -- byte )
- #! Read a byte from the hardware port. 'port' should
- #! be an 8-bit value.
- 2drop 0 ;
-
-M: cpu write-port ( value port cpu -- )
- #! Write a byte to the hardware port, where 'port' is
- #! an 8-bit value.
- 3drop ;
-
-: carry-flag HEX: 01 ; inline
-: parity-flag HEX: 04 ; inline
-: half-carry-flag HEX: 10 ; inline
-: interrupt-flag HEX: 20 ; inline
-: zero-flag HEX: 40 ; inline
-: sign-flag HEX: 80 ; inline
-
-: >word< ( word -- byte byte )
- #! Explode a word into its two 8 bit values.
- dup HEX: FF bitand swap -8 shift HEX: FF bitand swap ;
-
-: cpu-af ( cpu -- word )
- #! Return the 16-bit pseudo register AF.
- [ cpu-a 8 shift ] keep cpu-f bitor ;
-
-: set-cpu-af ( value cpu -- )
- #! Set the value of the 16-bit pseudo register AF
- >r >word< r> tuck set-cpu-f set-cpu-a ;
-
-: cpu-bc ( cpu -- word )
- #! Return the 16-bit pseudo register BC.
- [ cpu-b 8 shift ] keep cpu-c bitor ;
-
-: set-cpu-bc ( value cpu -- )
- #! Set the value of the 16-bit pseudo register BC
- >r >word< r> tuck set-cpu-c set-cpu-b ;
-
-: cpu-de ( cpu -- word )
- #! Return the 16-bit pseudo register DE.
- [ cpu-d 8 shift ] keep cpu-e bitor ;
-
-: set-cpu-de ( value cpu -- )
- #! Set the value of the 16-bit pseudo register DE
- >r >word< r> tuck set-cpu-e set-cpu-d ;
-
-: cpu-hl ( cpu -- word )
- #! Return the 16-bit pseudo register HL.
- [ cpu-h 8 shift ] keep cpu-l bitor ;
-
-: set-cpu-hl ( value cpu -- )
- #! Set the value of the 16-bit pseudo register HL
- >r >word< r> tuck set-cpu-l set-cpu-h ;
-
-: flag-set? ( flag cpu -- bool )
- cpu-f bitand 0 = not ;
-
-: flag-clear? ( flag cpu -- bool )
- cpu-f bitand 0 = ;
-
-: flag-nz? ( cpu -- bool )
- #! Test flag status
- cpu-f zero-flag bitand 0 = ;
-
-: flag-z? ( cpu -- bool )
- #! Test flag status
- cpu-f zero-flag bitand 0 = not ;
-
-: flag-nc? ( cpu -- bool )
- #! Test flag status
- cpu-f carry-flag bitand 0 = ;
-
-: flag-c? ( cpu -- bool )
- #! Test flag status
- cpu-f carry-flag bitand 0 = not ;
-
-: flag-po? ( cpu -- bool )
- #! Test flag status
- cpu-f parity-flag bitand 0 = ;
-
-: flag-pe? ( cpu -- bool )
- #! Test flag status
- cpu-f parity-flag bitand 0 = not ;
-
-: flag-p? ( cpu -- bool )
- #! Test flag status
- cpu-f sign-flag bitand 0 = ;
-
-: flag-m? ( cpu -- bool )
- #! Test flag status
- cpu-f sign-flag bitand 0 = not ;
-
-: read-byte ( addr cpu -- byte )
- #! Read one byte from memory at the specified address.
- #! The address is 16-bit, but if a value greater than
- #! 0xFFFF is provided then return a default value.
- over HEX: FFFF <= [
- cpu-ram nth
- ] [
- 2drop HEX: FF
- ] if ;
-
-: read-word ( addr cpu -- word )
- #! Read a 16-bit word from memory at the specified address.
- #! The address is 16-bit, but if a value greater than
- #! 0xFFFF is provided then return a default value.
- [ read-byte ] 2keep >r 1 + r> read-byte 8 shift bitor ;
-
-: next-byte ( cpu -- byte )
- #! Return the value of the byte at PC, and increment PC.
- [ cpu-pc ] keep
- [ read-byte ] keep
- [ cpu-pc 1 + ] keep
- set-cpu-pc ;
-
-: next-word ( cpu -- word )
- #! Return the value of the word at PC, and increment PC.
- [ cpu-pc ] keep
- [ read-word ] keep
- [ cpu-pc 2 + ] keep
- set-cpu-pc ;
-
-
-: write-byte ( value addr cpu -- )
- #! Write a byte to the specified memory address.
- over dup HEX: 2000 < swap HEX: FFFF > or [
- 3drop
- ] [
- 3dup cpu-ram set-nth
- update-video
- ] if ;
-
-
-: write-word ( value addr cpu -- )
- #! Write a 16-bit word to the specified memory address.
- >r >r >word< r> r> [ write-byte ] 2keep >r 1 + r> write-byte ;
-
-: cpu-a-bitand ( quot cpu -- )
- #! A &= quot call
- [ cpu-a swap call bitand ] keep set-cpu-a ; inline
-
-: cpu-a-bitor ( quot cpu -- )
- #! A |= quot call
- [ cpu-a swap call bitor ] keep set-cpu-a ; inline
-
-: cpu-a-bitxor ( quot cpu -- )
- #! A ^= quot call
- [ cpu-a swap call bitxor ] keep set-cpu-a ; inline
-
-: cpu-a-bitxor= ( value cpu -- )
- #! cpu-a ^= value
- [ cpu-a bitxor ] keep set-cpu-a ;
-
-: cpu-f-bitand ( quot cpu -- )
- #! F &= quot call
- [ cpu-f swap call bitand ] keep set-cpu-f ; inline
-
-: cpu-f-bitor ( quot cpu -- )
- #! F |= quot call
- [ cpu-f swap call bitor ] keep set-cpu-f ; inline
-
-: cpu-f-bitxor ( quot cpu -- )
- #! F |= quot call
- [ cpu-f swap call bitxor ] keep set-cpu-f ; inline
-
-: cpu-f-bitor= ( value cpu -- )
- #! cpu-f |= value
- [ cpu-f bitor ] keep set-cpu-f ;
-
-: cpu-f-bitand= ( value cpu -- )
- #! cpu-f &= value
- [ cpu-f bitand ] keep set-cpu-f ;
-
-: cpu-f-bitxor= ( value cpu -- )
- #! cpu-f ^= value
- [ cpu-f bitxor ] keep set-cpu-f ;
-
-: set-flag ( cpu flag -- )
- swap cpu-f-bitor= ;
-
-: clear-flag ( cpu flag -- )
- bitnot HEX: FF bitand swap cpu-f-bitand= ;
-
-: update-zero-flag ( result cpu -- )
- #! If the result of an instruction has the value 0, this
- #! flag is set, otherwise it is reset.
- swap HEX: FF bitand 0 = [ zero-flag set-flag ] [ zero-flag clear-flag ] if ;
-
-: update-sign-flag ( result cpu -- )
- #! If the most significant bit of the result
- #! has the value 1 then the flag is set, otherwise
- #! it is reset.
- swap HEX: 80 bitand 0 = [ sign-flag clear-flag ] [ sign-flag set-flag ] if ;
-
-: update-parity-flag ( result cpu -- )
- #! If the modulo 2 sum of the bits of the result
- #! is 0, (ie. if the result has even parity) this flag
- #! is set, otherwise it is reset.
- swap HEX: FF bitand 2 mod 0 = [ parity-flag set-flag ] [ parity-flag clear-flag ] if ;
-
-: update-carry-flag ( result cpu -- )
- #! If the instruction resulted in a carry (from addition)
- #! or a borrow (from subtraction or a comparison) out of the
- #! higher order bit, this flag is set, otherwise it is reset.
- swap dup HEX: 100 >= swap 0 < or [ carry-flag set-flag ] [ carry-flag clear-flag ] if ;
-
-: update-half-carry-flag ( original change-by result cpu -- )
- #! If the instruction caused a carry out of bit 3 and into bit 4 of the
- #! resulting value, the half carry flag is set, otherwise it is reset.
- #! The 'original' is the original value of the register being changed.
- #! 'change-by' is the amount it is being added or decremented by.
- #! 'result' is the result of that change.
- >r bitxor bitxor HEX: 10 bitand 0 = not r>
- swap [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if ;
-
-: update-flags ( result cpu -- )
- 2dup update-carry-flag
- 2dup update-parity-flag
- 2dup update-sign-flag
- update-zero-flag ;
-
-: update-flags-no-carry ( result cpu -- )
- 2dup update-parity-flag
- 2dup update-sign-flag
- update-zero-flag ;
-
-: add-byte ( lhs rhs cpu -- result )
- #! Add rhs to lhs
- >r 2dup + r> ! lhs rhs result cpu
- [ update-flags ] 2keep
- [ update-half-carry-flag ] 2keep
- drop HEX: FF bitand ;
-
-: add-carry ( change-by result cpu -- change-by result )
- #! Add the effect of the carry flag to the result
- flag-c? [ 1 + >r 1 + r> ] when ;
-
-: add-byte-with-carry ( lhs rhs cpu -- result )
- #! Add rhs to lhs plus carry.
- >r 2dup + r> ! lhs rhs result cpu
- [ add-carry ] keep
- [ update-flags ] 2keep
- [ update-half-carry-flag ] 2keep
- drop HEX: FF bitand ;
-
-: sub-carry ( change-by result cpu -- change-by result )
- #! Subtract the effect of the carry flag from the result
- flag-c? [ 1 - >r 1 - r> ] when ;
-
-: sub-byte ( lhs rhs cpu -- result )
- #! Subtract rhs from lhs
- >r 2dup - r>
- [ update-flags ] 2keep
- [ update-half-carry-flag ] 2keep
- drop HEX: FF bitand ;
-
-: sub-byte-with-carry ( lhs rhs cpu -- result )
- #! Subtract rhs from lhs and take carry into account
- >r 2dup - r>
- [ sub-carry ] keep
- [ update-flags ] 2keep
- [ update-half-carry-flag ] 2keep
- drop HEX: FF bitand ;
-
-: inc-byte ( byte cpu -- result )
- #! Increment byte by one. Note that carry flag is not affected
- #! by this operation.
- >r 1 2dup + r> ! lhs rhs result cpu
- [ update-flags-no-carry ] 2keep
- [ update-half-carry-flag ] 2keep
- drop HEX: FF bitand ;
-
-: dec-byte ( byte cpu -- result )
- #! Decrement byte by one. Note that carry flag is not affected
- #! by this operation.
- >r 1 2dup - r> ! lhs rhs result cpu
- [ update-flags-no-carry ] 2keep
- [ update-half-carry-flag ] 2keep
- drop HEX: FF bitand ;
-
-: inc-word ( w cpu -- w )
- #! Increment word by one. Note that no flags are modified.
- drop 1 + HEX: FFFF bitand ;
-
-: dec-word ( w cpu -- w )
- #! Decrement word by one. Note that no flags are modified.
- drop 1 - HEX: FFFF bitand ;
-
-: add-word ( lhs rhs cpu -- result )
- #! Add rhs to lhs. Note that only the carry flag is modified
- #! and only if there is a carry out of the double precision add.
- >r + r> over HEX: FFFF > [ carry-flag set-flag ] [ drop ] if HEX: FFFF bitand ;
-
-: bit3or ( lhs rhs -- 0|1 )
- #! bitor bit 3 of the two numbers on the stack
- BIN: 00001000 bitand -3 shift >r
- BIN: 00001000 bitand -3 shift r>
- bitor ;
-
-: and-byte ( lhs rhs cpu -- result )
- #! Logically and rhs to lhs. The carry flag is cleared and
- #! the half carry is set to the ORing of bits 3 of the operands.
- [ drop bit3or ] 3keep ! bit3or lhs rhs cpu
- >r bitand r> [ update-flags ] 2keep
- [ carry-flag clear-flag ] keep
- rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if
- HEX: FF bitand ;
-
-: xor-byte ( lhs rhs cpu -- result )
- #! Logically xor rhs to lhs. The carry and half-carry flags are cleared.
- >r bitxor r> [ update-flags ] 2keep
- [ half-carry-flag carry-flag bitor clear-flag ] keep
- drop HEX: FF bitand ;
-
-: or-byte ( lhs rhs cpu -- result )
- #! Logically or rhs to lhs. The carry and half-carry flags are cleared.
- >r bitor r> [ update-flags ] 2keep
- [ half-carry-flag carry-flag bitor clear-flag ] keep
- drop HEX: FF bitand ;
-
-: flags ( seq -- seq )
- [ 0 [ execute bitor ] reduce ] map ;
-
-: decrement-sp ( n cpu -- )
- #! Decrement the stackpointer by n.
- [ cpu-sp ] keep
- >r swap - r> set-cpu-sp ;
-
-: save-pc ( cpu -- )
- #! Save the value of the PC on the stack.
- [ cpu-pc ] keep ! pc cpu
- [ cpu-sp ] keep ! pc sp cpu
- write-word ;
-
-: push-pc ( cpu -- )
- #! Push the value of the PC on the stack.
- 2 over decrement-sp
- save-pc ;
-
-: pop-pc ( cpu -- pc )
- #! Pop the value of the PC off the stack.
- [ cpu-sp ] keep
- [ read-word ] keep
- -2 swap decrement-sp ;
-
-: push-sp ( value cpu -- )
- [ 2 swap decrement-sp ] keep
- [ cpu-sp ] keep
- write-word ;
-
-: pop-sp ( cpu -- value )
- [ cpu-sp ] keep
- [ read-word ] keep
- -2 swap decrement-sp ;
-
-: call-sub ( addr cpu -- )
- #! Call the address as a subroutine.
- dup push-pc
- >r HEX: FFFF bitand r> set-cpu-pc ;
-
-: ret-from-sub ( cpu -- )
- [ pop-pc ] keep set-cpu-pc ;
-
-: interrupt ( number cpu -- )
- #! Perform a hardware interrupt
-! "***Interrupt: " write over 16 >base print
- dup cpu-f interrupt-flag bitand 0 = not [
- dup push-pc
- set-cpu-pc
- ] [
- 2drop
- ] if ;
-
-: inc-cycles ( n cpu -- )
- #! Increment the number of cpu cycles
- [ cpu-cycles + ] keep set-cpu-cycles ;
-
-: instruction-cycles ( -- vector )
- #! Return a 256 element vector containing the cycles for
- #! each opcode in the 8080 instruction set.
- {
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ;
-
-: instructions ( -- vector )
- #! Return a 256 element vector containing the emulation words for
- #! each opcode in the 8080 instruction set.
- {
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
- f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ;
-
-: not-implemented ( <cpu> -- )
- drop ;
-
-instructions length [
- dup instructions nth [
- drop
- ] [
- [ not-implemented ] swap instructions set-nth
- ] if
-] each
-
-M: cpu reset ( cpu -- )
- #! Reset the CPU to its poweron state
- [ 0 swap set-cpu-b ] keep
- [ 0 swap set-cpu-c ] keep
- [ 0 swap set-cpu-d ] keep
- [ 0 swap set-cpu-e ] keep
- [ 0 swap set-cpu-h ] keep
- [ 0 swap set-cpu-l ] keep
- [ 0 swap set-cpu-a ] keep
- [ 0 swap set-cpu-f ] keep
- [ 0 swap set-cpu-pc ] keep
- [ HEX: F000 swap set-cpu-sp ] keep
- [ HEX: FFFF 0 <array> swap set-cpu-ram ] keep
- [ f swap set-cpu-halted? ] keep
- [ HEX: 10 swap set-cpu-last-interrupt ] keep
- 0 swap set-cpu-cycles ;
-
-: <cpu> ( -- cpu ) cpu construct-empty dup reset ;
-
-: (load-rom) ( n ram -- )
- read1 [ ! n ram ch
- -rot [ set-nth ] 2keep >r 1 + r> (load-rom)
- ] [
- 2drop
- ] if* ;
-
- #! Reads the ROM from stdin and stores it in ROM from
- #! offset n.
-: load-rom ( filename cpu -- )
- #! Load the contents of the file into ROM.
- #! (address 0x0000-0x1FFF).
- cpu-ram swap <file-reader> [
- 0 swap (load-rom)
- ] with-stream ;
-
-SYMBOL: rom-root
-
-: rom-dir ( -- string )
- rom-root get [ home "roms" path+ dup exists? [ drop f ] unless ] unless* ;
-
-: load-rom* ( seq cpu -- )
- #! 'seq' is an array of arrays. Each array contains
- #! an address and filename of a ROM file. The ROM
- #! file will be loaded at the specified address. This
- #! file path shoul dbe relative to the '/roms' resource path.
- rom-dir [
- cpu-ram [
- swap first2 rom-dir swap path+ <file-reader> [
- swap (load-rom)
- ] with-stream
- ] curry each
- ] [
- !
- ! the ROM files.
- "Set 'rom-root' to the path containing the root of the 8080 ROM files." throw
- ] if ;
-
-: read-instruction ( cpu -- word )
- #! Read the next instruction from the cpu's program
- #! counter, and increment the program counter.
- [ cpu-pc ] keep ! pc cpu
- [ over 1 + swap set-cpu-pc ] keep
- read-byte ;
-
-: get-cycles ( n -- opcode )
- #! Returns the cycles for the given instruction value.
- #! If the opcode is not defined throw an error.
- dup instruction-cycles nth [
- nip
- ] [
- [ "Undefined 8080 opcode: " % number>string % ] "" make throw
- ] if* ;
-
-: process-interrupts ( cpu -- )
- #! Process any hardware interrupts
- [ cpu-cycles ] keep
- over 16667 < [
- 2drop
- ] [
- [ >r 16667 - r> set-cpu-cycles ] keep
- dup cpu-last-interrupt HEX: 10 = [
- HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt
- ] [
- HEX: 10 over set-cpu-last-interrupt HEX: 10 swap interrupt
- ] if
- ] if ;
-
-: step ( cpu -- )
- #! Run a single 8080 instruction
- [ read-instruction ] keep ! n cpu
- over get-cycles over inc-cycles
- [ swap instructions dispatch ] keep
- [ cpu-pc HEX: FFFF bitand ] keep
- [ set-cpu-pc ] keep
- process-interrupts ;
-
-: peek-instruction ( cpu -- word )
- #! Return the next instruction from the cpu's program
- #! counter, but don't increment the counter.
- [ cpu-pc ] keep read-byte instructions nth first ;
-
-: cpu. ( cpu -- )
- [ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
- [ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
- [ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
- [ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
- [ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
- [ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
- [ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
- [ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
- [ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
- [ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
- [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
- [ " " write peek-instruction word-name write " " write ] keep
- nl drop ;
-
-: cpu*. ( cpu -- )
- [ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
- [ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
- [ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
- [ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
- [ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
- [ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
- [ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
- [ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
- [ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
- [ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
- [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
- nl drop ;
-
-: test-step ( cpu -- cpu )
- [ step ] keep dup cpu. ;
-
-: test-cpu ( -- cpu )
- <cpu> "invaders.rom" over load-rom dup cpu. ;
-
-: test-n ( n -- )
- test-cpu swap [ test-step ] times ;
-
-: run-n ( cpu n -- cpu )
- [ dup step ] times ;
-
-: register-lookup ( string -- vector )
- #! Given a string containing a register name, return a vector
- #! where the 1st item is the getter and the 2nd is the setter
- #! for that register.
- H{
- { "A" { cpu-a set-cpu-a } }
- { "B" { cpu-b set-cpu-b } }
- { "C" { cpu-c set-cpu-c } }
- { "D" { cpu-d set-cpu-d } }
- { "E" { cpu-e set-cpu-e } }
- { "H" { cpu-h set-cpu-h } }
- { "L" { cpu-l set-cpu-l } }
- { "AF" { cpu-af set-cpu-af } }
- { "BC" { cpu-bc set-cpu-bc } }
- { "DE" { cpu-de set-cpu-de } }
- { "HL" { cpu-hl set-cpu-hl } }
- { "SP" { cpu-sp set-cpu-sp } }
- } at ;
-
-
-: flag-lookup ( string -- vector )
- #! Given a string containing a flag name, return a vector
- #! where the 1st item is a word that tests that flag.
- H{
- { "NZ" { flag-nz? } }
- { "NC" { flag-nc? } }
- { "PO" { flag-po? } }
- { "PE" { flag-pe? } }
- { "Z" { flag-z? } }
- { "C" { flag-c? } }
- { "P" { flag-p? } }
- { "M" { flag-m? } }
- } at ;
-
-SYMBOL: $1
-SYMBOL: $2
-SYMBOL: $3
-SYMBOL: $4
-
-: replace-patterns ( vector tree -- tree )
- #! Copy the tree, replacing each occurence of
- #! $1, $2, etc with the relevant item from the
- #! given index.
- dup quotation? over [ ] = not and [ ! vector tree
- dup first swap 1 tail ! vector car cdr
- >r dupd replace-patterns ! vector v R: cdr
- swap r> replace-patterns >r 1quotation r> append
- ] [ ! vector value
- dup $1 = [ drop 0 over nth ] when
- dup $2 = [ drop 1 over nth ] when
- dup $3 = [ drop 2 over nth ] when
- dup $4 = [ drop 3 over nth ] when
- nip
- ] if ;
-
-: test-rp
- { 4 5 3 } [ 1 $2 [ $1 4 ] ] replace-patterns ;
-
-: (emulate-RST) ( n cpu -- )
- #! RST nn
- [ cpu-sp 2 - dup ] keep ! sp sp cpu
- [ set-cpu-sp ] keep ! sp cpu
- [ cpu-pc ] keep ! sp pc cpu
- swapd [ write-word ] keep ! cpu
- >r 8 * r> set-cpu-pc ;
-
-: (emulate-CALL) ( cpu -- )
- #! 205 - CALL nn
- [ next-word HEX: FFFF bitand ] keep ! addr cpu
- [ cpu-sp 2 - dup ] keep ! addr sp sp cpu
- [ set-cpu-sp ] keep ! addr sp cpu
- [ cpu-pc ] keep ! addr sp pc cpu
- swapd [ write-word ] keep ! addr cpu
- set-cpu-pc ;
-
-: (emulate-RLCA) ( cpu -- )
- #! The content of the accumulator is rotated left
- #! one position. The low order bit and the carry flag
- #! are both set to the value shifd out of the high
- #! order bit position. Only the carry flag is affected.
- [ cpu-a -7 shift ] keep
- over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
- [ cpu-a 1 shift HEX: FF bitand ] keep
- >r bitor r> set-cpu-a ;
-
-: (emulate-RRCA) ( cpu -- )
- #! The content of the accumulator is rotated right
- #! one position. The high order bit and the carry flag
- #! are both set to the value shifd out of the low
- #! order bit position. Only the carry flag is affected.
- [ cpu-a 1 bitand 7 shift ] keep
- over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
- [ cpu-a 254 bitand -1 shift ] keep
- >r bitor r> set-cpu-a ;
-
-: (emulate-RLA) ( cpu -- )
- #! The content of the accumulator is rotated left
- #! one position through the carry flag. The low
- #! order bit is set equal to the carry flag and
- #! the carry flag is set to the value shifd out
- #! of the high order bit. Only the carry flag is
- #! affected.
- [ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep
- [ cpu-a 127 bitand 7 shift ] keep
- dup cpu-a 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
- >r bitor r> set-cpu-a ;
-
-: (emulate-RRA) ( cpu -- )
- #! The content of the accumulator is rotated right
- #! one position through the carry flag. The high order
- #! bit is set to the carry flag and the carry flag is
- #! set to the value shifd out of the low order bit.
- #! Only the carry flag is affected.
- [ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] if ] keep
- [ cpu-a 254 bitand -1 shift ] keep
- dup cpu-a 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
- >r bitor r> set-cpu-a ;
-
-: (emulate-CPL) ( cpu -- )
- #! The contents of the accumulator are complemented
- #! (zero bits become one, one bits becomes zero).
- #! No flags are affected.
- HEX: FF swap cpu-a-bitxor= ;
-
-: (emulate-DAA) ( cpu -- )
- #! The eight bit number in the accumulator is
- #! adjusted to form two four-bit binary-coded-decimal
- #! digits.
- [
- dup half-carry-flag swap flag-set? swap
- cpu-a BIN: 1111 bitand 9 > or [ 6 ] [ 0 ] if
- ] keep
- [ cpu-a + ] keep
- [ update-flags ] 2keep
- [ swap HEX: FF bitand swap set-cpu-a ] keep
- [
- dup carry-flag swap flag-set? swap
- cpu-a -4 shift BIN: 1111 bitand 9 > or [ 96 ] [ 0 ] if
- ] keep
- [ cpu-a + ] keep
- [ update-flags ] 2keep
- swap HEX: FF bitand swap set-cpu-a ;
-
-: patterns ( -- hashtable )
- #! table of code quotation patterns for each type of instruction.
- H{
- { "NOP" [ drop ] }
- { "RET-NN" [ ret-from-sub ] }
- { "RST-0" [ 0 swap (emulate-RST) ] }
- { "RST-8" [ 8 swap (emulate-RST) ] }
- { "RST-10H" [ HEX: 10 swap (emulate-RST) ] }
- { "RST-18H" [ HEX: 18 swap (emulate-RST) ] }
- { "RST-20H" [ HEX: 20 swap (emulate-RST) ] }
- { "RST-28H" [ HEX: 28 swap (emulate-RST) ] }
- { "RST-30H" [ HEX: 30 swap (emulate-RST) ] }
- { "RST-38H" [ HEX: 38 swap (emulate-RST) ] }
- { "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] }
- { "CP-N" [ [ cpu-a ] keep [ next-byte ] keep sub-byte drop ] }
- { "CP-R" [ [ cpu-a ] keep [ $1 ] keep sub-byte drop ] }
- { "CP-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] }
- { "OR-N" [ [ cpu-a ] keep [ next-byte ] keep [ or-byte ] keep set-cpu-a ] }
- { "OR-R" [ [ cpu-a ] keep [ $1 ] keep [ or-byte ] keep set-cpu-a ] }
- { "OR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep set-cpu-a ] }
- { "XOR-N" [ [ cpu-a ] keep [ next-byte ] keep [ xor-byte ] keep set-cpu-a ] }
- { "XOR-R" [ [ cpu-a ] keep [ $1 ] keep [ xor-byte ] keep set-cpu-a ] }
- { "XOR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep set-cpu-a ] }
- { "AND-N" [ [ cpu-a ] keep [ next-byte ] keep [ and-byte ] keep set-cpu-a ] }
- { "AND-R" [ [ cpu-a ] keep [ $1 ] keep [ and-byte ] keep set-cpu-a ] }
- { "AND-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep set-cpu-a ] }
- { "ADC-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] }
- { "ADC-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] }
- { "ADC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] }
- { "ADD-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] }
- { "ADD-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] }
- { "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] }
- { "ADD-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2 ] }
- { "SBC-R,N" [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
- { "SBC-R,R" [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] }
- { "SBC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
- { "SUB-R" [ [ cpu-a ] keep [ $1 ] keep [ sub-byte ] keep set-cpu-a ] }
- { "SUB-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep set-cpu-a ] }
- { "SUB-N" [ [ cpu-a ] keep [ next-byte ] keep [ sub-byte ] keep set-cpu-a ] }
- { "CPL" [ (emulate-CPL) ] }
- { "DAA" [ (emulate-DAA) ] }
- { "RLA" [ (emulate-RLA) ] }
- { "RRA" [ (emulate-RRA) ] }
- { "CCF" [ carry-flag swap cpu-f-bitxor= ] }
- { "SCF" [ carry-flag swap cpu-f-bitor= ] }
- { "RLCA" [ (emulate-RLCA) ] }
- { "RRCA" [ (emulate-RRCA) ] }
- { "HALT" [ drop ] }
- { "DI" [ [ 255 interrupt-flag - ] swap cpu-f-bitand ] }
- { "EI" [ [ interrupt-flag ] swap cpu-f-bitor ] }
- { "POP-RR" [ [ pop-sp ] keep $2 ] }
- { "PUSH-RR" [ [ $1 ] keep push-sp ] }
- { "INC-R" [ [ $1 ] keep [ inc-byte ] keep $2 ] }
- { "DEC-R" [ [ $1 ] keep [ dec-byte ] keep $2 ] }
- { "INC-RR" [ [ $1 ] keep [ inc-word ] keep $2 ] }
- { "DEC-RR" [ [ $1 ] keep [ dec-word ] keep $2 ] }
- { "DEC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] }
- { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] }
- { "JP-NN" [ [ cpu-pc ] keep [ read-word ] keep set-cpu-pc ] }
- { "JP-F|FF,NN" [ [ $1 ] keep swap [ [ next-word ] keep [ set-cpu-pc ] keep [ cpu-cycles ] keep swap 5 + swap set-cpu-cycles ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] }
- { "JP-(RR)" [ [ $1 ] keep set-cpu-pc ] }
- { "CALL-NN" [ (emulate-CALL) ] }
- { "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] }
- { "LD-RR,NN" [ [ next-word ] keep $2 ] }
- { "LD-RR,RR" [ [ $3 ] keep $2 ] }
- { "LD-R,N" [ [ next-byte ] keep $2 ] }
- { "LD-(RR),N" [ [ next-byte ] keep [ $1 ] keep write-byte ] }
- { "LD-(RR),R" [ [ $3 ] keep [ $1 ] keep write-byte ] }
- { "LD-R,R" [ [ $3 ] keep $2 ] }
- { "LD-R,(RR)" [ [ $3 ] keep [ read-byte ] keep $2 ] }
- { "LD-(NN),RR" [ [ $1 ] keep [ next-word ] keep write-word ] }
- { "LD-(NN),R" [ [ $1 ] keep [ next-word ] keep write-byte ] }
- { "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] }
- { "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] }
- { "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] }
- { "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep set-cpu-a ] }
- { "EX-(RR),RR" [ [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] }
- { "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] }
- } ;
-
-: 8-bit-registers ( -- parser )
- #! A parser for 8-bit registers. On a successfull parse the
- #! parse tree contains a vector. The first item in the vector
- #! is the getter word for that register with stack effect
- #! ( cpu -- value ). The second item is the setter word with
- #! stack effect ( value cpu -- ).
- "A" token
- "B" token <|>
- "C" token <|>
- "D" token <|>
- "E" token <|>
- "H" token <|>
- "L" token <|> [ register-lookup ] <@ ;
-
-: all-flags
- #! A parser for 16-bit flags.
- "NZ" token
- "NC" token <|>
- "PO" token <|>
- "PE" token <|>
- "Z" token <|>
- "C" token <|>
- "P" token <|>
- "M" token <|> [ flag-lookup ] <@ ;
-
-: 16-bit-registers
- #! A parser for 16-bit registers. On a successfull parse the
- #! parse tree contains a vector. The first item in the vector
- #! is the getter word for that register with stack effect
- #! ( cpu -- value ). The second item is the setter word with
- #! stack effect ( value cpu -- ).
- "AF" token
- "BC" token <|>
- "DE" token <|>
- "HL" token <|>
- "SP" token <|> [ register-lookup ] <@ ;
-
-: all-registers ( -- parser )
- #! Return a parser that can parse the format
- #! for 8 bit or 16 bit registers.
- 8-bit-registers 16-bit-registers <|> ;
-
-: indirect ( parser -- parser )
- #! Given a parser, return a parser which parses the original
- #! wrapped in brackets, representing an indirect reference.
- #! eg. BC -> (BC). The value of the original parser is left in
- #! the parse tree.
- "(" token swap &> ")" token <& ;
-
-: generate-instruction ( vector string -- quot )
- #! Generate the quotation for an instruction, given the instruction in
- #! the 'string' and a vector containing the arguments for that instruction.
- patterns at replace-patterns ;
-
-: simple-instruction ( token -- parser )
- #! Return a parser for then instruction identified by the token.
- #! The parser return parses the token only and expects no additional
- #! arguments to the instruction.
- token [ [ { } clone , , \ generate-instruction , ] [ ] make ] <@ ;
-
-: complex-instruction ( type token -- parser )
- #! Return a parser for an instruction identified by the token.
- #! The instruction is expected to take additional arguments by
- #! being combined with other parsers. Then 'type' is used for a lookup
- #! in a pattern hashtable to return the instruction quotation pattern.
- token swap [ nip [ , \ generate-instruction , ] [ ] make ] curry <@ ;
-
-: NOP-instruction ( -- parser )
- "NOP" simple-instruction ;
-
-: RET-NN-instruction ( -- parser )
- "RET-NN" "RET" complex-instruction
- "nn" token sp <&
- just [ { } clone swap curry ] <@ ;
-
-: RST-0-instruction ( -- parser )
- "RST-0" "RST" complex-instruction
- "0" token sp <&
- just [ { } clone swap curry ] <@ ;
-
-: RST-8-instruction ( -- parser )
- "RST-8" "RST" complex-instruction
- "8" token sp <&
- just [ { } clone swap curry ] <@ ;
-
-: RST-10H-instruction ( -- parser )
- "RST-10H" "RST" complex-instruction
- "10H" token sp <&
- just [ { } clone swap curry ] <@ ;
-
-: RST-18H-instruction ( -- parser )
- "RST-18H" "RST" complex-instruction
- "18H" token sp <&
- just [ { } clone swap curry ] <@ ;
-
-: RST-20H-instruction ( -- parser )
- "RST-20H" "RST" complex-instruction
- "20H" token sp <&
- just [ { } clone swap curry ] <@ ;
-
-: RST-28H-instruction ( -- parser )
- "RST-28H" "RST" complex-instruction
- "28H" token sp <&
- just [ { } clone swap curry ] <@ ;
-
-: RST-30H-instruction ( -- parser )
- "RST-30H" "RST" complex-instruction
- "30H" token sp <&
- just [ { } clone swap curry ] <@ ;
-
-: RST-38H-instruction ( -- parser )
- "RST-38H" "RST" complex-instruction
- "38H" token sp <&
- just [ { } clone swap curry ] <@ ;
-
-: JP-NN-instruction ( -- parser )
- "JP-NN" "JP" complex-instruction
- "nn" token sp <&
- just [ { } clone swap curry ] <@ ;
-
-: JP-F|FF,NN-instruction ( -- parser )
- "JP-F|FF,NN" "JP" complex-instruction
- all-flags sp <&>
- ",nn" token <&
- just [ first2 swap curry ] <@ ;
-
-: JP-(RR)-instruction ( -- parser )
- "JP-(RR)" "JP" complex-instruction
- 16-bit-registers indirect sp <&>
- just [ first2 swap curry ] <@ ;
-
-: CALL-NN-instruction ( -- parser )
- "CALL-NN" "CALL" complex-instruction
- "nn" token sp <&
- just [ { } clone swap curry ] <@ ;
-
-: CALL-F|FF,NN-instruction ( -- parser )
- "CALL-F|FF,NN" "CALL" complex-instruction
- all-flags sp <&>
- ",nn" token <&
- just [ first2 swap curry ] <@ ;
-
-: RLCA-instruction ( -- parser )
- "RLCA" simple-instruction ;
-
-: RRCA-instruction ( -- parser )
- "RRCA" simple-instruction ;
-
-: HALT-instruction ( -- parser )
- "HALT" simple-instruction ;
-
-: DI-instruction ( -- parser )
- "DI" simple-instruction ;
-
-: EI-instruction ( -- parser )
- "EI" simple-instruction ;
-
-: CPL-instruction ( -- parser )
- "CPL" simple-instruction ;
-
-: CCF-instruction ( -- parser )
- "CCF" simple-instruction ;
-
-: SCF-instruction ( -- parser )
- "SCF" simple-instruction ;
-
-: DAA-instruction ( -- parser )
- "DAA" simple-instruction ;
-
-: RLA-instruction ( -- parser )
- "RLA" simple-instruction ;
-
-: RRA-instruction ( -- parser )
- "RRA" simple-instruction ;
-
-: DEC-R-instruction ( -- parser )
- "DEC-R" "DEC" complex-instruction 8-bit-registers sp <&>
- just [ first2 swap curry ] <@ ;
-
-: DEC-RR-instruction ( -- parser )
- "DEC-RR" "DEC" complex-instruction 16-bit-registers sp <&>
- just [ first2 swap curry ] <@ ;
-
-: DEC-(RR)-instruction ( -- parser )
- "DEC-(RR)" "DEC" complex-instruction
- 16-bit-registers indirect sp <&>
- just [ first2 swap curry ] <@ ;
-
-: POP-RR-instruction ( -- parser )
- "POP-RR" "POP" complex-instruction all-registers sp <&>
- just [ first2 swap curry ] <@ ;
-
-: PUSH-RR-instruction ( -- parser )
- "PUSH-RR" "PUSH" complex-instruction all-registers sp <&>
- just [ first2 swap curry ] <@ ;
-
-: INC-R-instruction ( -- parser )
- "INC-R" "INC" complex-instruction 8-bit-registers sp <&>
- just [ first2 swap curry ] <@ ;
-
-: INC-RR-instruction ( -- parser )
- "INC-RR" "INC" complex-instruction 16-bit-registers sp <&>
- just [ first2 swap curry ] <@ ;
-
-: INC-(RR)-instruction ( -- parser )
- "INC-(RR)" "INC" complex-instruction
- all-registers indirect sp <&> just [ first2 swap curry ] <@ ;
-
-: RET-F|FF-instruction ( -- parser )
- "RET-F|FF" "RET" complex-instruction all-flags sp <&>
- just [ first2 swap curry ] <@ ;
-
-: AND-N-instruction ( -- parser )
- "AND-N" "AND" complex-instruction
- "n" token sp <&
- just [ { } clone swap curry ] <@ ;
-
-: AND-R-instruction ( -- parser )
- "AND-R" "AND" complex-instruction
- 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
-
-: AND-(RR)-instruction ( -- parser )
- "AND-(RR)" "AND" complex-instruction
- 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
-
-: XOR-N-instruction ( -- parser )
- "XOR-N" "XOR" complex-instruction
- "n" token sp <&
- just [ { } clone swap curry ] <@ ;
-
-: XOR-R-instruction ( -- parser )
- "XOR-R" "XOR" complex-instruction
- 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
-
-: XOR-(RR)-instruction ( -- parser )
- "XOR-(RR)" "XOR" complex-instruction
- 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
-
-: OR-N-instruction ( -- parser )
- "OR-N" "OR" complex-instruction
- "n" token sp <&
- just [ { } clone swap curry ] <@ ;
-
-: OR-R-instruction ( -- parser )
- "OR-R" "OR" complex-instruction
- 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
-
-: OR-(RR)-instruction ( -- parser )
- "OR-(RR)" "OR" complex-instruction
- 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
-
-: CP-N-instruction ( -- parser )
- "CP-N" "CP" complex-instruction
- "n" token sp <&
- just [ { } clone swap curry ] <@ ;
-
-: CP-R-instruction ( -- parser )
- "CP-R" "CP" complex-instruction
- 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
-
-: CP-(RR)-instruction ( -- parser )
- "CP-(RR)" "CP" complex-instruction
- 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
-
-: ADC-R,N-instruction ( -- parser )
- "ADC-R,N" "ADC" complex-instruction
- 8-bit-registers sp <&>
- ",n" token <&
- just [ first2 swap curry ] <@ ;
-
-: ADC-R,R-instruction ( -- parser )
- "ADC-R,R" "ADC" complex-instruction
- 8-bit-registers sp <&>
- "," token <&
- 8-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
-
-: ADC-R,(RR)-instruction ( -- parser )
- "ADC-R,(RR)" "ADC" complex-instruction
- 8-bit-registers sp <&>
- "," token <&
- 16-bit-registers indirect <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
-
-: SBC-R,N-instruction ( -- parser )
- "SBC-R,N" "SBC" complex-instruction
- 8-bit-registers sp <&>
- ",n" token <&
- just [ first2 swap curry ] <@ ;
-
-: SBC-R,R-instruction ( -- parser )
- "SBC-R,R" "SBC" complex-instruction
- 8-bit-registers sp <&>
- "," token <&
- 8-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
-
-: SBC-R,(RR)-instruction ( -- parser )
- "SBC-R,(RR)" "SBC" complex-instruction
- 8-bit-registers sp <&>
- "," token <&
- 16-bit-registers indirect <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
-
-: SUB-R-instruction ( -- parser )
- "SUB-R" "SUB" complex-instruction
- 8-bit-registers sp <&>
- just [ first2 swap curry ] <@ ;
-
-: SUB-(RR)-instruction ( -- parser )
- "SUB-(RR)" "SUB" complex-instruction
- 16-bit-registers indirect sp <&>
- just [ first2 swap curry ] <@ ;
-
-: SUB-N-instruction ( -- parser )
- "SUB-N" "SUB" complex-instruction
- "n" token sp <&
- just [ { } clone swap curry ] <@ ;
-
-: ADD-R,N-instruction ( -- parser )
- "ADD-R,N" "ADD" complex-instruction
- 8-bit-registers sp <&>
- ",n" token <&
- just [ first2 swap curry ] <@ ;
-
-: ADD-R,R-instruction ( -- parser )
- "ADD-R,R" "ADD" complex-instruction
- 8-bit-registers sp <&>
- "," token <&
- 8-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
-
-: ADD-RR,RR-instruction ( -- parser )
- "ADD-RR,RR" "ADD" complex-instruction
- 16-bit-registers sp <&>
- "," token <&
- 16-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
-
-: ADD-R,(RR)-instruction ( -- parser )
- "ADD-R,(RR)" "ADD" complex-instruction
- 8-bit-registers sp <&>
- "," token <&
- 16-bit-registers indirect <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
-
-: LD-RR,NN-instruction
- #! LD BC,nn
- "LD-RR,NN" "LD" complex-instruction
- 16-bit-registers sp <&>
- ",nn" token <&
- just [ first2 swap curry ] <@ ;
-
-: LD-R,N-instruction
- #! LD B,n
- "LD-R,N" "LD" complex-instruction
- 8-bit-registers sp <&>
- ",n" token <&
- just [ first2 swap curry ] <@ ;
-
-: LD-(RR),N-instruction
- "LD-(RR),N" "LD" complex-instruction
- 16-bit-registers indirect sp <&>
- ",n" token <&
- just [ first2 swap curry ] <@ ;
-
-: LD-(RR),R-instruction
- #! LD (BC),A
- "LD-(RR),R" "LD" complex-instruction
- 16-bit-registers indirect sp <&>
- "," token <&
- 8-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
-
-: LD-R,R-instruction
- "LD-R,R" "LD" complex-instruction
- 8-bit-registers sp <&>
- "," token <&
- 8-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
-
-: LD-RR,RR-instruction
- "LD-RR,RR" "LD" complex-instruction
- 16-bit-registers sp <&>
- "," token <&
- 16-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
-
-: LD-R,(RR)-instruction
- "LD-R,(RR)" "LD" complex-instruction
- 8-bit-registers sp <&>
- "," token <&
- 16-bit-registers indirect <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
-
-: LD-(NN),RR-instruction
- "LD-(NN),RR" "LD" complex-instruction
- "nn" token indirect sp <&
- "," token <&
- 16-bit-registers <&>
- just [ first2 swap curry ] <@ ;
-
-: LD-(NN),R-instruction
- "LD-(NN),R" "LD" complex-instruction
- "nn" token indirect sp <&
- "," token <&
- 8-bit-registers <&>
- just [ first2 swap curry ] <@ ;
-
-: LD-RR,(NN)-instruction
- "LD-RR,(NN)" "LD" complex-instruction
- 16-bit-registers sp <&>
- "," token <&
- "nn" token indirect <&
- just [ first2 swap curry ] <@ ;
-
-: LD-R,(NN)-instruction
- "LD-R,(NN)" "LD" complex-instruction
- 8-bit-registers sp <&>
- "," token <&
- "nn" token indirect <&
- just [ first2 swap curry ] <@ ;
-
-: OUT-(N),R-instruction
- "OUT-(N),R" "OUT" complex-instruction
- "n" token indirect sp <&
- "," token <&
- 8-bit-registers <&>
- just [ first2 swap curry ] <@ ;
-
-: IN-R,(N)-instruction
- "IN-R,(N)" "IN" complex-instruction
- 8-bit-registers sp <&>
- "," token <&
- "n" token indirect <&
- just [ first2 swap curry ] <@ ;
-
-: EX-(RR),RR-instruction
- "EX-(RR),RR" "EX" complex-instruction
- 16-bit-registers indirect sp <&>
- "," token <&
- 16-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
-
-: EX-RR,RR-instruction
- "EX-RR,RR" "EX" complex-instruction
- 16-bit-registers sp <&>
- "," token <&
- 16-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
-
-: 8080-generator-parser
- NOP-instruction
- RST-0-instruction <|>
- RST-8-instruction <|>
- RST-10H-instruction <|>
- RST-18H-instruction <|>
- RST-20H-instruction <|>
- RST-28H-instruction <|>
- RST-30H-instruction <|>
- RST-38H-instruction <|>
- JP-F|FF,NN-instruction <|>
- JP-NN-instruction <|>
- JP-(RR)-instruction <|>
- CALL-F|FF,NN-instruction <|>
- CALL-NN-instruction <|>
- CPL-instruction <|>
- CCF-instruction <|>
- SCF-instruction <|>
- DAA-instruction <|>
- RLA-instruction <|>
- RRA-instruction <|>
- RLCA-instruction <|>
- RRCA-instruction <|>
- HALT-instruction <|>
- DI-instruction <|>
- EI-instruction <|>
- AND-N-instruction <|>
- AND-R-instruction <|>
- AND-(RR)-instruction <|>
- XOR-N-instruction <|>
- XOR-R-instruction <|>
- XOR-(RR)-instruction <|>
- OR-N-instruction <|>
- OR-R-instruction <|>
- OR-(RR)-instruction <|>
- CP-N-instruction <|>
- CP-R-instruction <|>
- CP-(RR)-instruction <|>
- DEC-RR-instruction <|>
- DEC-R-instruction <|>
- DEC-(RR)-instruction <|>
- POP-RR-instruction <|>
- PUSH-RR-instruction <|>
- INC-RR-instruction <|>
- INC-R-instruction <|>
- INC-(RR)-instruction <|>
- LD-RR,NN-instruction <|>
- LD-R,N-instruction <|>
- LD-R,R-instruction <|>
- LD-RR,RR-instruction <|>
- LD-(RR),N-instruction <|>
- LD-(RR),R-instruction <|>
- LD-R,(RR)-instruction <|>
- LD-(NN),RR-instruction <|>
- LD-(NN),R-instruction <|>
- LD-RR,(NN)-instruction <|>
- LD-R,(NN)-instruction <|>
- ADC-R,N-instruction <|>
- ADC-R,R-instruction <|>
- ADC-R,(RR)-instruction <|>
- ADD-R,N-instruction <|>
- ADD-R,R-instruction <|>
- ADD-RR,RR-instruction <|>
- ADD-R,(RR)-instruction <|>
- SBC-R,N-instruction <|>
- SBC-R,R-instruction <|>
- SBC-R,(RR)-instruction <|>
- SUB-R-instruction <|>
- SUB-(RR)-instruction <|>
- SUB-N-instruction <|>
- RET-F|FF-instruction <|>
- RET-NN-instruction <|>
- OUT-(N),R-instruction <|>
- IN-R,(N)-instruction <|>
- EX-(RR),RR-instruction <|>
- EX-RR,RR-instruction <|>
- just ;
-
-: instruction-quotations ( string -- emulate-quot )
- #! Given an instruction string, return the emulation quotation for
- #! it. This will later be expanded to produce the disassembly and
- #! assembly quotations.
- 8080-generator-parser some parse call ;
-
-SYMBOL: last-instruction
-SYMBOL: last-opcode
-
-: parse-instructions ( list -- emulate-quot )
- #! Process the list of strings, which should make
- #! up an 8080 instruction, and output a quotation
- #! that would implement that instruction.
- [
- dup " " join instruction-quotations
- >r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at
- r> define
- ] with-compilation-unit ;
-
-: INSTRUCTION: ";" parse-tokens parse-instructions ; parsing
-
-: cycles ( -- )
- #! Set the number of cycles for the last instruction that was defined.
- scan string>number last-opcode global at instruction-cycles set-nth ; parsing
-
-: opcode ( -- )
- #! Set the opcode number for the last instruction that was defined.
- last-instruction global at 1quotation scan 16 base>
- dup last-opcode global set-at instructions set-nth ; parsing
+INSTRUCTION: NOP ; opcode 00 cycles 04
+INSTRUCTION: LD BC,nn ; opcode 01 cycles 10
+INSTRUCTION: LD (BC),A ; opcode 02 cycles 07
+INSTRUCTION: INC BC ; opcode 03 cycles 06
+INSTRUCTION: INC B ; opcode 04 cycles 05
+INSTRUCTION: DEC B ; opcode 05 cycles 05
+INSTRUCTION: LD B,n ; opcode 06 cycles 07
+INSTRUCTION: RLCA ; opcode 07 cycles 04
+! INSTRUCTION: NOP ; opcode 08 cycles 04
+INSTRUCTION: ADD HL,BC ; opcode 09 cycles 11
+INSTRUCTION: LD A,(BC) ; opcode 0A cycles 07
+INSTRUCTION: DEC BC ; opcode 0B cycles 06
+INSTRUCTION: INC C ; opcode 0C cycles 05
+INSTRUCTION: DEC C ; opcode 0D cycles 05
+INSTRUCTION: LD C,n ; opcode 0E cycles 07
+INSTRUCTION: RRCA ; opcode 0F cycles 04
+INSTRUCTION: LD DE,nn ; opcode 11 cycles 10
+INSTRUCTION: LD (DE),A ; opcode 12 cycles 07
+INSTRUCTION: INC DE ; opcode 13 cycles 06
+INSTRUCTION: INC D ; opcode 14 cycles 05
+INSTRUCTION: DEC D ; opcode 15 cycles 05
+INSTRUCTION: LD D,n ; opcode 16 cycles 07
+INSTRUCTION: RLA ; opcode 17 cycles 04
+INSTRUCTION: ADD HL,DE ; opcode 19 cycles 11
+INSTRUCTION: LD A,(DE) ; opcode 1A cycles 07
+INSTRUCTION: DEC DE ; opcode 1B cycles 06
+INSTRUCTION: INC E ; opcode 1C cycles 05
+INSTRUCTION: DEC E ; opcode 1D cycles 05
+INSTRUCTION: LD E,n ; opcode 1E cycles 07
+INSTRUCTION: RRA ; opcode 1F cycles 04
+INSTRUCTION: LD HL,nn ; opcode 21 cycles 10
+INSTRUCTION: LD (nn),HL ; opcode 22 cycles 16
+INSTRUCTION: INC HL ; opcode 23 cycles 06
+INSTRUCTION: INC H ; opcode 24 cycles 05
+INSTRUCTION: DEC H ; opcode 25 cycles 05
+INSTRUCTION: LD H,n ; opcode 26 cycles 07
+INSTRUCTION: DAA ; opcode 27 cycles 04
+INSTRUCTION: ADD HL,HL ; opcode 29 cycles 11
+INSTRUCTION: LD HL,(nn) ; opcode 2A cycles 16
+INSTRUCTION: DEC HL ; opcode 2B cycles 06
+INSTRUCTION: INC L ; opcode 2C cycles 05
+INSTRUCTION: DEC L ; opcode 2D cycles 05
+INSTRUCTION: LD L,n ; opcode 2E cycles 07
+INSTRUCTION: CPL ; opcode 2F cycles 04
+INSTRUCTION: LD SP,nn ; opcode 31 cycles 10
+INSTRUCTION: LD (nn),A ; opcode 32 cycles 13
+INSTRUCTION: INC SP ; opcode 33 cycles 06
+INSTRUCTION: INC (HL) ; opcode 34 cycles 10
+INSTRUCTION: DEC (HL) ; opcode 35 cycles 10
+INSTRUCTION: LD (HL),n ; opcode 36 cycles 10
+INSTRUCTION: SCF ; opcode 37 cycles 04
+INSTRUCTION: ADD HL,SP ; opcode 39 cycles 11
+INSTRUCTION: LD A,(nn) ; opcode 3A cycles 13
+INSTRUCTION: DEC SP ; opcode 3B cycles 06
+INSTRUCTION: INC A ; opcode 3C cycles 05
+INSTRUCTION: DEC A ; opcode 3D cycles 05
+INSTRUCTION: LD A,n ; opcode 3E cycles 07
+INSTRUCTION: CCF ; opcode 3F cycles 04
+INSTRUCTION: LD B,B ; opcode 40 cycles 05
+INSTRUCTION: LD B,C ; opcode 41 cycles 05
+INSTRUCTION: LD B,D ; opcode 42 cycles 05
+INSTRUCTION: LD B,E ; opcode 43 cycles 05
+INSTRUCTION: LD B,H ; opcode 44 cycles 05
+INSTRUCTION: LD B,L ; opcode 45 cycles 05
+INSTRUCTION: LD B,(HL) ; opcode 46 cycles 07
+INSTRUCTION: LD B,A ; opcode 47 cycles 05
+INSTRUCTION: LD C,B ; opcode 48 cycles 05
+INSTRUCTION: LD C,C ; opcode 49 cycles 05
+INSTRUCTION: LD C,D ; opcode 4A cycles 05
+INSTRUCTION: LD C,E ; opcode 4B cycles 05
+INSTRUCTION: LD C,H ; opcode 4C cycles 05
+INSTRUCTION: LD C,L ; opcode 4D cycles 05
+INSTRUCTION: LD C,(HL) ; opcode 4E cycles 07
+INSTRUCTION: LD C,A ; opcode 4F cycles 05
+INSTRUCTION: LD D,B ; opcode 50 cycles 05
+INSTRUCTION: LD D,C ; opcode 51 cycles 05
+INSTRUCTION: LD D,D ; opcode 52 cycles 05
+INSTRUCTION: LD D,E ; opcode 53 cycles 05
+INSTRUCTION: LD D,H ; opcode 54 cycles 05
+INSTRUCTION: LD D,L ; opcode 55 cycles 05
+INSTRUCTION: LD D,(HL) ; opcode 56 cycles 07
+INSTRUCTION: LD D,A ; opcode 57 cycles 05
+INSTRUCTION: LD E,B ; opcode 58 cycles 05
+INSTRUCTION: LD E,C ; opcode 59 cycles 05
+INSTRUCTION: LD E,D ; opcode 5A cycles 05
+INSTRUCTION: LD E,E ; opcode 5B cycles 05
+INSTRUCTION: LD E,H ; opcode 5C cycles 05
+INSTRUCTION: LD E,L ; opcode 5D cycles 05
+INSTRUCTION: LD E,(HL) ; opcode 5E cycles 07
+INSTRUCTION: LD E,A ; opcode 5F cycles 05
+INSTRUCTION: LD H,B ; opcode 60 cycles 05
+INSTRUCTION: LD H,C ; opcode 61 cycles 05
+INSTRUCTION: LD H,D ; opcode 62 cycles 05
+INSTRUCTION: LD H,E ; opcode 63 cycles 05
+INSTRUCTION: LD H,H ; opcode 64 cycles 05
+INSTRUCTION: LD H,L ; opcode 65 cycles 05
+INSTRUCTION: LD H,(HL) ; opcode 66 cycles 07
+INSTRUCTION: LD H,A ; opcode 67 cycles 05
+INSTRUCTION: LD L,B ; opcode 68 cycles 05
+INSTRUCTION: LD L,C ; opcode 69 cycles 05
+INSTRUCTION: LD L,D ; opcode 6A cycles 05
+INSTRUCTION: LD L,E ; opcode 6B cycles 05
+INSTRUCTION: LD L,H ; opcode 6C cycles 05
+INSTRUCTION: LD L,L ; opcode 6D cycles 05
+INSTRUCTION: LD L,(HL) ; opcode 6E cycles 07
+INSTRUCTION: LD L,A ; opcode 6F cycles 05
+INSTRUCTION: LD (HL),B ; opcode 70 cycles 07
+INSTRUCTION: LD (HL),C ; opcode 71 cycles 07
+INSTRUCTION: LD (HL),D ; opcode 72 cycles 07
+INSTRUCTION: LD (HL),E ; opcode 73 cycles 07
+INSTRUCTION: LD (HL),H ; opcode 74 cycles 07
+INSTRUCTION: LD (HL),L ; opcode 75 cycles 07
+INSTRUCTION: HALT ; opcode 76 cycles 07
+INSTRUCTION: LD (HL),A ; opcode 77 cycles 07
+INSTRUCTION: LD A,B ; opcode 78 cycles 05
+INSTRUCTION: LD A,C ; opcode 79 cycles 05
+INSTRUCTION: LD A,D ; opcode 7A cycles 05
+INSTRUCTION: LD A,E ; opcode 7B cycles 05
+INSTRUCTION: LD A,H ; opcode 7C cycles 05
+INSTRUCTION: LD A,L ; opcode 7D cycles 05
+INSTRUCTION: LD A,(HL) ; opcode 7E cycles 07
+INSTRUCTION: LD A,A ; opcode 7F cycles 05
+INSTRUCTION: ADD A,B ; opcode 80 cycles 04
+INSTRUCTION: ADD A,C ; opcode 81 cycles 04
+INSTRUCTION: ADD A,D ; opcode 82 cycles 04
+INSTRUCTION: ADD A,E ; opcode 83 cycles 04
+INSTRUCTION: ADD A,H ; opcode 84 cycles 04
+INSTRUCTION: ADD A,L ; opcode 85 cycles 04
+INSTRUCTION: ADD A,(HL) ; opcode 86 cycles 07
+INSTRUCTION: ADD A,A ; opcode 87 cycles 04
+INSTRUCTION: ADC A,B ; opcode 88 cycles 04
+INSTRUCTION: ADC A,C ; opcode 89 cycles 04
+INSTRUCTION: ADC A,D ; opcode 8A cycles 04
+INSTRUCTION: ADC A,E ; opcode 8B cycles 04
+INSTRUCTION: ADC A,H ; opcode 8C cycles 04
+INSTRUCTION: ADC A,L ; opcode 8D cycles 04
+INSTRUCTION: ADC A,(HL) ; opcode 8E cycles 07
+INSTRUCTION: ADC A,A ; opcode 8F cycles 04
+INSTRUCTION: SUB B ; opcode 90 cycles 04
+INSTRUCTION: SUB C ; opcode 91 cycles 04
+INSTRUCTION: SUB D ; opcode 92 cycles 04
+INSTRUCTION: SUB E ; opcode 93 cycles 04
+INSTRUCTION: SUB H ; opcode 94 cycles 04
+INSTRUCTION: SUB L ; opcode 95 cycles 04
+INSTRUCTION: SUB (HL) ; opcode 96 cycles 07
+INSTRUCTION: SUB A ; opcode 97 cycles 04
+INSTRUCTION: SBC A,B ; opcode 98 cycles 04
+INSTRUCTION: SBC A,C ; opcode 99 cycles 04
+INSTRUCTION: SBC A,D ; opcode 9A cycles 04
+INSTRUCTION: SBC A,E ; opcode 9B cycles 04
+INSTRUCTION: SBC A,H ; opcode 9C cycles 04
+INSTRUCTION: SBC A,L ; opcode 9D cycles 04
+INSTRUCTION: SBC A,(HL) ; opcode 9E cycles 07
+INSTRUCTION: SBC A,A ; opcode 9F cycles 04
+INSTRUCTION: AND B ; opcode A0 cycles 04
+INSTRUCTION: AND C ; opcode A1 cycles 04
+INSTRUCTION: AND D ; opcode A2 cycles 04
+INSTRUCTION: AND E ; opcode A3 cycles 04
+INSTRUCTION: AND H ; opcode A4 cycles 04
+INSTRUCTION: AND L ; opcode A5 cycles 04
+INSTRUCTION: AND (HL) ; opcode A6 cycles 07
+INSTRUCTION: AND A ; opcode A7 cycles 04
+INSTRUCTION: XOR B ; opcode A8 cycles 04
+INSTRUCTION: XOR C ; opcode A9 cycles 04
+INSTRUCTION: XOR D ; opcode AA cycles 04
+INSTRUCTION: XOR E ; opcode AB cycles 04
+INSTRUCTION: XOR H ; opcode AC cycles 04
+INSTRUCTION: XOR L ; opcode AD cycles 04
+INSTRUCTION: XOR (HL) ; opcode AE cycles 07
+INSTRUCTION: XOR A ; opcode AF cycles 04
+INSTRUCTION: OR B ; opcode B0 cycles 04
+INSTRUCTION: OR C ; opcode B1 cycles 04
+INSTRUCTION: OR D ; opcode B2 cycles 04
+INSTRUCTION: OR E ; opcode B3 cycles 04
+INSTRUCTION: OR H ; opcode B4 cycles 04
+INSTRUCTION: OR L ; opcode B5 cycles 04
+INSTRUCTION: OR (HL) ; opcode B6 cycles 07
+INSTRUCTION: OR A ; opcode B7 cycles 04
+INSTRUCTION: CP B ; opcode B8 cycles 04
+INSTRUCTION: CP C ; opcode B9 cycles 04
+INSTRUCTION: CP D ; opcode BA cycles 04
+INSTRUCTION: CP E ; opcode BB cycles 04
+INSTRUCTION: CP H ; opcode BC cycles 04
+INSTRUCTION: CP L ; opcode BD cycles 04
+INSTRUCTION: CP (HL) ; opcode BE cycles 07
+INSTRUCTION: CP A ; opcode BF cycles 04
+INSTRUCTION: RET NZ ; opcode C0 cycles 05
+INSTRUCTION: POP BC ; opcode C1 cycles 10
+INSTRUCTION: JP NZ,nn ; opcode C2 cycles 10
+INSTRUCTION: JP nn ; opcode C3 cycles 10
+INSTRUCTION: CALL NZ,nn ; opcode C4 cycles 11
+INSTRUCTION: PUSH BC ; opcode C5 cycles 11
+INSTRUCTION: ADD A,n ; opcode C6 cycles 07
+INSTRUCTION: RST 0 ; opcode C7 cycles 11
+INSTRUCTION: RET Z ; opcode C8 cycles 05
+INSTRUCTION: RET nn ; opcode C9 cycles 10
+INSTRUCTION: JP Z,nn ; opcode CA cycles 10
+INSTRUCTION: CALL Z,nn ; opcode CC cycles 11
+INSTRUCTION: CALL nn ; opcode CD cycles 17
+INSTRUCTION: ADC A,n ; opcode CE cycles 07
+INSTRUCTION: RST 8 ; opcode CF cycles 11
+INSTRUCTION: RET NC ; opcode D0 cycles 05
+INSTRUCTION: POP DE ; opcode D1 cycles 10
+INSTRUCTION: JP NC,nn ; opcode D2 cycles 10
+INSTRUCTION: OUT (n),A ; opcode D3 cycles 10
+INSTRUCTION: CALL NC,nn ; opcode D4 cycles 11
+INSTRUCTION: PUSH DE ; opcode D5 cycles 11
+INSTRUCTION: SUB n ; opcode D6 cycles 07
+INSTRUCTION: RST 10H ; opcode D7 cycles 11
+INSTRUCTION: RET C ; opcode D8 cycles 05
+INSTRUCTION: JP C,nn ; opcode DA cycles 10
+INSTRUCTION: IN A,(n) ; opcode DB cycles 10
+INSTRUCTION: CALL C,nn ; opcode DC cycles 11
+INSTRUCTION: SBC A,n ; opcode DE cycles 07
+INSTRUCTION: RST 18H ; opcode DF cycles 11
+INSTRUCTION: RET PO ; opcode E0 cycles 05
+INSTRUCTION: POP HL ; opcode E1 cycles 10
+INSTRUCTION: JP PO,nn ; opcode E2 cycles 10
+INSTRUCTION: EX (SP),HL ; opcode E3 cycles 04
+INSTRUCTION: CALL PO,nn ; opcode E4 cycles 11
+INSTRUCTION: PUSH HL ; opcode E5 cycles 11
+INSTRUCTION: AND n ; opcode E6 cycles 07
+INSTRUCTION: RST 20H ; opcode E7 cycles 11
+INSTRUCTION: RET PE ; opcode E8 cycles 05
+INSTRUCTION: JP (HL) ; opcode E9 cycles 04
+INSTRUCTION: JP PE,nn ; opcode EA cycles 10
+INSTRUCTION: EX DE,HL ; opcode EB cycles 04
+INSTRUCTION: CALL PE,nn ; opcode EC cycles 11
+INSTRUCTION: XOR n ; opcode EE cycles 07
+INSTRUCTION: RST 28H ; opcode EF cycles 11
+INSTRUCTION: RET P ; opcode F0 cycles 05
+INSTRUCTION: POP AF ; opcode F1 cycles 10
+INSTRUCTION: JP P,nn ; opcode F2 cycles 10
+INSTRUCTION: DI ; opcode F3 cycles 04
+INSTRUCTION: CALL P,nn ; opcode F4 cycles 11
+INSTRUCTION: PUSH AF ; opcode F5 cycles 11
+INSTRUCTION: OR n ; opcode F6 cycles 07
+INSTRUCTION: RST 30H ; opcode F7 cycles 11
+INSTRUCTION: RET M ; opcode F8 cycles 05
+INSTRUCTION: LD SP,HL ; opcode F9 cycles 06
+INSTRUCTION: JP M,nn ; opcode FA cycles 10
+INSTRUCTION: EI ; opcode FB cycles 04
+INSTRUCTION: CALL M,nn ; opcode FC cycles 11
+INSTRUCTION: CP n ; opcode FE cycles 07
+INSTRUCTION: RST 38H ; opcode FF cycles 11
! : each-8bit ( n quot -- )
! 8 [ ! n quot bit
diff --git a/extra/cpu/8080/emulator/emulator-docs.factor b/extra/cpu/8080/emulator/emulator-docs.factor
new file mode 100644
index 0000000000..438b5cf268
--- /dev/null
+++ b/extra/cpu/8080/emulator/emulator-docs.factor
@@ -0,0 +1,36 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax sequences strings ;
+IN: cpu.8080.emulator
+
+HELP: load-rom
+{ $values { "filename" string } { "cpu" cpu } }
+{ $description
+"Read the ROM file into the cpu's memory starting at address 0000. "
+"The filename is relative to the path stored in the " { $link rom-root }
+" variable. An exception is thrown if this variable is not set."
+}
+{ $see-also load-rom* } ;
+
+HELP: load-rom*
+{ $values { "seq" sequence } { "cpu" cpu } }
+{ $description
+"Loads one or more ROM files into the cpu's memory. Each file is "
+"loaded at a particular starting address. 'seq' is a sequence of "
+"2 element arrays. The first element is the address and the second "
+"element is the file to load at that address." $nl
+"The filenames are relative to the path stored in the " { $link rom-root }
+" variable. An exception is thrown if this variable is not set."
+}
+{ $examples
+ { $code "{ { HEX: 0000 \"invaders.rom\" } } <cpu> load-rom*" }
+}
+{ $see-also load-rom } ;
+
+HELP: rom-root
+{ $description
+"Holds the path where the ROM files are stored. Used for expanding "
+"the relative filenames passed to " { $link load-rom } " and "
+{ $link load-rom* } "."
+}
+{ $see-also load-rom load-rom* } ;
diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor
new file mode 100644
index 0000000000..0eca7bdc47
--- /dev/null
+++ b/extra/cpu/8080/emulator/emulator.factor
@@ -0,0 +1,1356 @@
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: kernel math sequences words arrays io
+ io.files namespaces math.parser kernel.private
+ assocs quotations parser parser-combinators tools.time
+ combinators.private compiler.units ;
+IN: cpu.8080.emulator
+
+TUPLE: cpu b c d e f h l a pc sp halted? last-interrupt cycles ram ;
+
+GENERIC: reset ( cpu -- )
+GENERIC: update-video ( value addr cpu -- )
+GENERIC: read-port ( port cpu -- byte )
+GENERIC: write-port ( value port cpu -- )
+
+M: cpu update-video ( value addr cpu -- )
+ 3drop ;
+
+M: cpu read-port ( port cpu -- byte )
+ #! Read a byte from the hardware port. 'port' should
+ #! be an 8-bit value.
+ 2drop 0 ;
+
+M: cpu write-port ( value port cpu -- )
+ #! Write a byte to the hardware port, where 'port' is
+ #! an 8-bit value.
+ 3drop ;
+
+: carry-flag HEX: 01 ; inline
+: parity-flag HEX: 04 ; inline
+: half-carry-flag HEX: 10 ; inline
+: interrupt-flag HEX: 20 ; inline
+: zero-flag HEX: 40 ; inline
+: sign-flag HEX: 80 ; inline
+
+: >word< ( word -- byte byte )
+ #! Explode a word into its two 8 bit values.
+ dup HEX: FF bitand swap -8 shift HEX: FF bitand swap ;
+
+: cpu-af ( cpu -- word )
+ #! Return the 16-bit pseudo register AF.
+ [ cpu-a 8 shift ] keep cpu-f bitor ;
+
+: set-cpu-af ( value cpu -- )
+ #! Set the value of the 16-bit pseudo register AF
+ >r >word< r> tuck set-cpu-f set-cpu-a ;
+
+: cpu-bc ( cpu -- word )
+ #! Return the 16-bit pseudo register BC.
+ [ cpu-b 8 shift ] keep cpu-c bitor ;
+
+: set-cpu-bc ( value cpu -- )
+ #! Set the value of the 16-bit pseudo register BC
+ >r >word< r> tuck set-cpu-c set-cpu-b ;
+
+: cpu-de ( cpu -- word )
+ #! Return the 16-bit pseudo register DE.
+ [ cpu-d 8 shift ] keep cpu-e bitor ;
+
+: set-cpu-de ( value cpu -- )
+ #! Set the value of the 16-bit pseudo register DE
+ >r >word< r> tuck set-cpu-e set-cpu-d ;
+
+: cpu-hl ( cpu -- word )
+ #! Return the 16-bit pseudo register HL.
+ [ cpu-h 8 shift ] keep cpu-l bitor ;
+
+: set-cpu-hl ( value cpu -- )
+ #! Set the value of the 16-bit pseudo register HL
+ >r >word< r> tuck set-cpu-l set-cpu-h ;
+
+: flag-set? ( flag cpu -- bool )
+ cpu-f bitand 0 = not ;
+
+: flag-clear? ( flag cpu -- bool )
+ cpu-f bitand 0 = ;
+
+: flag-nz? ( cpu -- bool )
+ #! Test flag status
+ cpu-f zero-flag bitand 0 = ;
+
+: flag-z? ( cpu -- bool )
+ #! Test flag status
+ cpu-f zero-flag bitand 0 = not ;
+
+: flag-nc? ( cpu -- bool )
+ #! Test flag status
+ cpu-f carry-flag bitand 0 = ;
+
+: flag-c? ( cpu -- bool )
+ #! Test flag status
+ cpu-f carry-flag bitand 0 = not ;
+
+: flag-po? ( cpu -- bool )
+ #! Test flag status
+ cpu-f parity-flag bitand 0 = ;
+
+: flag-pe? ( cpu -- bool )
+ #! Test flag status
+ cpu-f parity-flag bitand 0 = not ;
+
+: flag-p? ( cpu -- bool )
+ #! Test flag status
+ cpu-f sign-flag bitand 0 = ;
+
+: flag-m? ( cpu -- bool )
+ #! Test flag status
+ cpu-f sign-flag bitand 0 = not ;
+
+: read-byte ( addr cpu -- byte )
+ #! Read one byte from memory at the specified address.
+ #! The address is 16-bit, but if a value greater than
+ #! 0xFFFF is provided then return a default value.
+ over HEX: FFFF <= [
+ cpu-ram nth
+ ] [
+ 2drop HEX: FF
+ ] if ;
+
+: read-word ( addr cpu -- word )
+ #! Read a 16-bit word from memory at the specified address.
+ #! The address is 16-bit, but if a value greater than
+ #! 0xFFFF is provided then return a default value.
+ [ read-byte ] 2keep >r 1 + r> read-byte 8 shift bitor ;
+
+: next-byte ( cpu -- byte )
+ #! Return the value of the byte at PC, and increment PC.
+ [ cpu-pc ] keep
+ [ read-byte ] keep
+ [ cpu-pc 1 + ] keep
+ set-cpu-pc ;
+
+: next-word ( cpu -- word )
+ #! Return the value of the word at PC, and increment PC.
+ [ cpu-pc ] keep
+ [ read-word ] keep
+ [ cpu-pc 2 + ] keep
+ set-cpu-pc ;
+
+
+: write-byte ( value addr cpu -- )
+ #! Write a byte to the specified memory address.
+ over dup HEX: 2000 < swap HEX: FFFF > or [
+ 3drop
+ ] [
+ 3dup cpu-ram set-nth
+ update-video
+ ] if ;
+
+
+: write-word ( value addr cpu -- )
+ #! Write a 16-bit word to the specified memory address.
+ >r >r >word< r> r> [ write-byte ] 2keep >r 1 + r> write-byte ;
+
+: cpu-a-bitand ( quot cpu -- )
+ #! A &= quot call
+ [ cpu-a swap call bitand ] keep set-cpu-a ; inline
+
+: cpu-a-bitor ( quot cpu -- )
+ #! A |= quot call
+ [ cpu-a swap call bitor ] keep set-cpu-a ; inline
+
+: cpu-a-bitxor ( quot cpu -- )
+ #! A ^= quot call
+ [ cpu-a swap call bitxor ] keep set-cpu-a ; inline
+
+: cpu-a-bitxor= ( value cpu -- )
+ #! cpu-a ^= value
+ [ cpu-a bitxor ] keep set-cpu-a ;
+
+: cpu-f-bitand ( quot cpu -- )
+ #! F &= quot call
+ [ cpu-f swap call bitand ] keep set-cpu-f ; inline
+
+: cpu-f-bitor ( quot cpu -- )
+ #! F |= quot call
+ [ cpu-f swap call bitor ] keep set-cpu-f ; inline
+
+: cpu-f-bitxor ( quot cpu -- )
+ #! F |= quot call
+ [ cpu-f swap call bitxor ] keep set-cpu-f ; inline
+
+: cpu-f-bitor= ( value cpu -- )
+ #! cpu-f |= value
+ [ cpu-f bitor ] keep set-cpu-f ;
+
+: cpu-f-bitand= ( value cpu -- )
+ #! cpu-f &= value
+ [ cpu-f bitand ] keep set-cpu-f ;
+
+: cpu-f-bitxor= ( value cpu -- )
+ #! cpu-f ^= value
+ [ cpu-f bitxor ] keep set-cpu-f ;
+
+: set-flag ( cpu flag -- )
+ swap cpu-f-bitor= ;
+
+: clear-flag ( cpu flag -- )
+ bitnot HEX: FF bitand swap cpu-f-bitand= ;
+
+: update-zero-flag ( result cpu -- )
+ #! If the result of an instruction has the value 0, this
+ #! flag is set, otherwise it is reset.
+ swap HEX: FF bitand 0 = [ zero-flag set-flag ] [ zero-flag clear-flag ] if ;
+
+: update-sign-flag ( result cpu -- )
+ #! If the most significant bit of the result
+ #! has the value 1 then the flag is set, otherwise
+ #! it is reset.
+ swap HEX: 80 bitand 0 = [ sign-flag clear-flag ] [ sign-flag set-flag ] if ;
+
+: update-parity-flag ( result cpu -- )
+ #! If the modulo 2 sum of the bits of the result
+ #! is 0, (ie. if the result has even parity) this flag
+ #! is set, otherwise it is reset.
+ swap HEX: FF bitand 2 mod 0 = [ parity-flag set-flag ] [ parity-flag clear-flag ] if ;
+
+: update-carry-flag ( result cpu -- )
+ #! If the instruction resulted in a carry (from addition)
+ #! or a borrow (from subtraction or a comparison) out of the
+ #! higher order bit, this flag is set, otherwise it is reset.
+ swap dup HEX: 100 >= swap 0 < or [ carry-flag set-flag ] [ carry-flag clear-flag ] if ;
+
+: update-half-carry-flag ( original change-by result cpu -- )
+ #! If the instruction caused a carry out of bit 3 and into bit 4 of the
+ #! resulting value, the half carry flag is set, otherwise it is reset.
+ #! The 'original' is the original value of the register being changed.
+ #! 'change-by' is the amount it is being added or decremented by.
+ #! 'result' is the result of that change.
+ >r bitxor bitxor HEX: 10 bitand 0 = not r>
+ swap [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if ;
+
+: update-flags ( result cpu -- )
+ 2dup update-carry-flag
+ 2dup update-parity-flag
+ 2dup update-sign-flag
+ update-zero-flag ;
+
+: update-flags-no-carry ( result cpu -- )
+ 2dup update-parity-flag
+ 2dup update-sign-flag
+ update-zero-flag ;
+
+: add-byte ( lhs rhs cpu -- result )
+ #! Add rhs to lhs
+ >r 2dup + r> ! lhs rhs result cpu
+ [ update-flags ] 2keep
+ [ update-half-carry-flag ] 2keep
+ drop HEX: FF bitand ;
+
+: add-carry ( change-by result cpu -- change-by result )
+ #! Add the effect of the carry flag to the result
+ flag-c? [ 1 + >r 1 + r> ] when ;
+
+: add-byte-with-carry ( lhs rhs cpu -- result )
+ #! Add rhs to lhs plus carry.
+ >r 2dup + r> ! lhs rhs result cpu
+ [ add-carry ] keep
+ [ update-flags ] 2keep
+ [ update-half-carry-flag ] 2keep
+ drop HEX: FF bitand ;
+
+: sub-carry ( change-by result cpu -- change-by result )
+ #! Subtract the effect of the carry flag from the result
+ flag-c? [ 1 - >r 1 - r> ] when ;
+
+: sub-byte ( lhs rhs cpu -- result )
+ #! Subtract rhs from lhs
+ >r 2dup - r>
+ [ update-flags ] 2keep
+ [ update-half-carry-flag ] 2keep
+ drop HEX: FF bitand ;
+
+: sub-byte-with-carry ( lhs rhs cpu -- result )
+ #! Subtract rhs from lhs and take carry into account
+ >r 2dup - r>
+ [ sub-carry ] keep
+ [ update-flags ] 2keep
+ [ update-half-carry-flag ] 2keep
+ drop HEX: FF bitand ;
+
+: inc-byte ( byte cpu -- result )
+ #! Increment byte by one. Note that carry flag is not affected
+ #! by this operation.
+ >r 1 2dup + r> ! lhs rhs result cpu
+ [ update-flags-no-carry ] 2keep
+ [ update-half-carry-flag ] 2keep
+ drop HEX: FF bitand ;
+
+: dec-byte ( byte cpu -- result )
+ #! Decrement byte by one. Note that carry flag is not affected
+ #! by this operation.
+ >r 1 2dup - r> ! lhs rhs result cpu
+ [ update-flags-no-carry ] 2keep
+ [ update-half-carry-flag ] 2keep
+ drop HEX: FF bitand ;
+
+: inc-word ( w cpu -- w )
+ #! Increment word by one. Note that no flags are modified.
+ drop 1 + HEX: FFFF bitand ;
+
+: dec-word ( w cpu -- w )
+ #! Decrement word by one. Note that no flags are modified.
+ drop 1 - HEX: FFFF bitand ;
+
+: add-word ( lhs rhs cpu -- result )
+ #! Add rhs to lhs. Note that only the carry flag is modified
+ #! and only if there is a carry out of the double precision add.
+ >r + r> over HEX: FFFF > [ carry-flag set-flag ] [ drop ] if HEX: FFFF bitand ;
+
+: bit3or ( lhs rhs -- 0|1 )
+ #! bitor bit 3 of the two numbers on the stack
+ BIN: 00001000 bitand -3 shift >r
+ BIN: 00001000 bitand -3 shift r>
+ bitor ;
+
+: and-byte ( lhs rhs cpu -- result )
+ #! Logically and rhs to lhs. The carry flag is cleared and
+ #! the half carry is set to the ORing of bits 3 of the operands.
+ [ drop bit3or ] 3keep ! bit3or lhs rhs cpu
+ >r bitand r> [ update-flags ] 2keep
+ [ carry-flag clear-flag ] keep
+ rot 0 = [ half-carry-flag set-flag ] [ half-carry-flag clear-flag ] if
+ HEX: FF bitand ;
+
+: xor-byte ( lhs rhs cpu -- result )
+ #! Logically xor rhs to lhs. The carry and half-carry flags are cleared.
+ >r bitxor r> [ update-flags ] 2keep
+ [ half-carry-flag carry-flag bitor clear-flag ] keep
+ drop HEX: FF bitand ;
+
+: or-byte ( lhs rhs cpu -- result )
+ #! Logically or rhs to lhs. The carry and half-carry flags are cleared.
+ >r bitor r> [ update-flags ] 2keep
+ [ half-carry-flag carry-flag bitor clear-flag ] keep
+ drop HEX: FF bitand ;
+
+: flags ( seq -- seq )
+ [ 0 [ execute bitor ] reduce ] map ;
+
+: decrement-sp ( n cpu -- )
+ #! Decrement the stackpointer by n.
+ [ cpu-sp ] keep
+ >r swap - r> set-cpu-sp ;
+
+: save-pc ( cpu -- )
+ #! Save the value of the PC on the stack.
+ [ cpu-pc ] keep ! pc cpu
+ [ cpu-sp ] keep ! pc sp cpu
+ write-word ;
+
+: push-pc ( cpu -- )
+ #! Push the value of the PC on the stack.
+ 2 over decrement-sp
+ save-pc ;
+
+: pop-pc ( cpu -- pc )
+ #! Pop the value of the PC off the stack.
+ [ cpu-sp ] keep
+ [ read-word ] keep
+ -2 swap decrement-sp ;
+
+: push-sp ( value cpu -- )
+ [ 2 swap decrement-sp ] keep
+ [ cpu-sp ] keep
+ write-word ;
+
+: pop-sp ( cpu -- value )
+ [ cpu-sp ] keep
+ [ read-word ] keep
+ -2 swap decrement-sp ;
+
+: call-sub ( addr cpu -- )
+ #! Call the address as a subroutine.
+ dup push-pc
+ >r HEX: FFFF bitand r> set-cpu-pc ;
+
+: ret-from-sub ( cpu -- )
+ [ pop-pc ] keep set-cpu-pc ;
+
+: interrupt ( number cpu -- )
+ #! Perform a hardware interrupt
+! "***Interrupt: " write over 16 >base print
+ dup cpu-f interrupt-flag bitand 0 = not [
+ dup push-pc
+ set-cpu-pc
+ ] [
+ 2drop
+ ] if ;
+
+: inc-cycles ( n cpu -- )
+ #! Increment the number of cpu cycles
+ [ cpu-cycles + ] keep set-cpu-cycles ;
+
+: instruction-cycles ( -- vector )
+ #! Return a 256 element vector containing the cycles for
+ #! each opcode in the 8080 instruction set.
+ {
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ;
+
+: instructions ( -- vector )
+ #! Return a 256 element vector containing the emulation words for
+ #! each opcode in the 8080 instruction set.
+ {
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f
+ f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f f } ;
+
+: not-implemented ( <cpu> -- )
+ drop ;
+
+instructions length [
+ dup instructions nth [
+ drop
+ ] [
+ [ not-implemented ] swap instructions set-nth
+ ] if
+] each
+
+M: cpu reset ( cpu -- )
+ #! Reset the CPU to its poweron state
+ [ 0 swap set-cpu-b ] keep
+ [ 0 swap set-cpu-c ] keep
+ [ 0 swap set-cpu-d ] keep
+ [ 0 swap set-cpu-e ] keep
+ [ 0 swap set-cpu-h ] keep
+ [ 0 swap set-cpu-l ] keep
+ [ 0 swap set-cpu-a ] keep
+ [ 0 swap set-cpu-f ] keep
+ [ 0 swap set-cpu-pc ] keep
+ [ HEX: F000 swap set-cpu-sp ] keep
+ [ HEX: FFFF 0 <array> swap set-cpu-ram ] keep
+ [ f swap set-cpu-halted? ] keep
+ [ HEX: 10 swap set-cpu-last-interrupt ] keep
+ 0 swap set-cpu-cycles ;
+
+: <cpu> ( -- cpu ) cpu construct-empty dup reset ;
+
+: (load-rom) ( n ram -- )
+ read1 [ ! n ram ch
+ -rot [ set-nth ] 2keep >r 1 + r> (load-rom)
+ ] [
+ 2drop
+ ] if* ;
+
+ #! Reads the ROM from stdin and stores it in ROM from
+ #! offset n.
+: load-rom ( filename cpu -- )
+ #! Load the contents of the file into ROM.
+ #! (address 0x0000-0x1FFF).
+ cpu-ram swap <file-reader> [
+ 0 swap (load-rom)
+ ] with-stream ;
+
+SYMBOL: rom-root
+
+: rom-dir ( -- string )
+ rom-root get [ home "roms" path+ dup exists? [ drop f ] unless ] unless* ;
+
+: load-rom* ( seq cpu -- )
+ #! 'seq' is an array of arrays. Each array contains
+ #! an address and filename of a ROM file. The ROM
+ #! file will be loaded at the specified address. This
+ #! file path shoul dbe relative to the '/roms' resource path.
+ rom-dir [
+ cpu-ram [
+ swap first2 rom-dir swap path+ <file-reader> [
+ swap (load-rom)
+ ] with-stream
+ ] curry each
+ ] [
+ !
+ ! the ROM files.
+ "Set 'rom-root' to the path containing the root of the 8080 ROM files." throw
+ ] if ;
+
+: read-instruction ( cpu -- word )
+ #! Read the next instruction from the cpu's program
+ #! counter, and increment the program counter.
+ [ cpu-pc ] keep ! pc cpu
+ [ over 1 + swap set-cpu-pc ] keep
+ read-byte ;
+
+: get-cycles ( n -- opcode )
+ #! Returns the cycles for the given instruction value.
+ #! If the opcode is not defined throw an error.
+ dup instruction-cycles nth [
+ nip
+ ] [
+ [ "Undefined 8080 opcode: " % number>string % ] "" make throw
+ ] if* ;
+
+: process-interrupts ( cpu -- )
+ #! Process any hardware interrupts
+ [ cpu-cycles ] keep
+ over 16667 < [
+ 2drop
+ ] [
+ [ >r 16667 - r> set-cpu-cycles ] keep
+ dup cpu-last-interrupt HEX: 10 = [
+ HEX: 08 over set-cpu-last-interrupt HEX: 08 swap interrupt
+ ] [
+ HEX: 10 over set-cpu-last-interrupt HEX: 10 swap interrupt
+ ] if
+ ] if ;
+
+: step ( cpu -- )
+ #! Run a single 8080 instruction
+ [ read-instruction ] keep ! n cpu
+ over get-cycles over inc-cycles
+ [ swap instructions dispatch ] keep
+ [ cpu-pc HEX: FFFF bitand ] keep
+ [ set-cpu-pc ] keep
+ process-interrupts ;
+
+: peek-instruction ( cpu -- word )
+ #! Return the next instruction from the cpu's program
+ #! counter, but don't increment the counter.
+ [ cpu-pc ] keep read-byte instructions nth first ;
+
+: cpu. ( cpu -- )
+ [ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
+ [ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
+ [ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
+ [ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
+ [ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
+ [ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
+ [ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
+ [ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
+ [ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
+ [ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
+ [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
+ [ " " write peek-instruction word-name write " " write ] keep
+ nl drop ;
+
+: cpu*. ( cpu -- )
+ [ " PC: " write cpu-pc 16 >base 4 CHAR: \s pad-left write ] keep
+ [ " B: " write cpu-b 16 >base 2 CHAR: \s pad-left write ] keep
+ [ " C: " write cpu-c 16 >base 2 CHAR: \s pad-left write ] keep
+ [ " D: " write cpu-d 16 >base 2 CHAR: \s pad-left write ] keep
+ [ " E: " write cpu-e 16 >base 2 CHAR: \s pad-left write ] keep
+ [ " F: " write cpu-f 16 >base 2 CHAR: \s pad-left write ] keep
+ [ " H: " write cpu-h 16 >base 2 CHAR: \s pad-left write ] keep
+ [ " L: " write cpu-l 16 >base 2 CHAR: \s pad-left write ] keep
+ [ " A: " write cpu-a 16 >base 2 CHAR: \s pad-left write ] keep
+ [ " SP: " write cpu-sp 16 >base 4 CHAR: \s pad-left write ] keep
+ [ " cycles: " write cpu-cycles number>string 5 CHAR: \s pad-left write ] keep
+ nl drop ;
+
+: test-step ( cpu -- cpu )
+ [ step ] keep dup cpu. ;
+
+: test-cpu ( -- cpu )
+ <cpu> "invaders.rom" over load-rom dup cpu. ;
+
+: test-n ( n -- )
+ test-cpu swap [ test-step ] times ;
+
+: run-n ( cpu n -- cpu )
+ [ dup step ] times ;
+
+: register-lookup ( string -- vector )
+ #! Given a string containing a register name, return a vector
+ #! where the 1st item is the getter and the 2nd is the setter
+ #! for that register.
+ H{
+ { "A" { cpu-a set-cpu-a } }
+ { "B" { cpu-b set-cpu-b } }
+ { "C" { cpu-c set-cpu-c } }
+ { "D" { cpu-d set-cpu-d } }
+ { "E" { cpu-e set-cpu-e } }
+ { "H" { cpu-h set-cpu-h } }
+ { "L" { cpu-l set-cpu-l } }
+ { "AF" { cpu-af set-cpu-af } }
+ { "BC" { cpu-bc set-cpu-bc } }
+ { "DE" { cpu-de set-cpu-de } }
+ { "HL" { cpu-hl set-cpu-hl } }
+ { "SP" { cpu-sp set-cpu-sp } }
+ } at ;
+
+
+: flag-lookup ( string -- vector )
+ #! Given a string containing a flag name, return a vector
+ #! where the 1st item is a word that tests that flag.
+ H{
+ { "NZ" { flag-nz? } }
+ { "NC" { flag-nc? } }
+ { "PO" { flag-po? } }
+ { "PE" { flag-pe? } }
+ { "Z" { flag-z? } }
+ { "C" { flag-c? } }
+ { "P" { flag-p? } }
+ { "M" { flag-m? } }
+ } at ;
+
+SYMBOL: $1
+SYMBOL: $2
+SYMBOL: $3
+SYMBOL: $4
+
+: replace-patterns ( vector tree -- tree )
+ #! Copy the tree, replacing each occurence of
+ #! $1, $2, etc with the relevant item from the
+ #! given index.
+ dup quotation? over [ ] = not and [ ! vector tree
+ dup first swap 1 tail ! vector car cdr
+ >r dupd replace-patterns ! vector v R: cdr
+ swap r> replace-patterns >r 1quotation r> append
+ ] [ ! vector value
+ dup $1 = [ drop 0 over nth ] when
+ dup $2 = [ drop 1 over nth ] when
+ dup $3 = [ drop 2 over nth ] when
+ dup $4 = [ drop 3 over nth ] when
+ nip
+ ] if ;
+
+: test-rp
+ { 4 5 3 } [ 1 $2 [ $1 4 ] ] replace-patterns ;
+
+: (emulate-RST) ( n cpu -- )
+ #! RST nn
+ [ cpu-sp 2 - dup ] keep ! sp sp cpu
+ [ set-cpu-sp ] keep ! sp cpu
+ [ cpu-pc ] keep ! sp pc cpu
+ swapd [ write-word ] keep ! cpu
+ >r 8 * r> set-cpu-pc ;
+
+: (emulate-CALL) ( cpu -- )
+ #! 205 - CALL nn
+ [ next-word HEX: FFFF bitand ] keep ! addr cpu
+ [ cpu-sp 2 - dup ] keep ! addr sp sp cpu
+ [ set-cpu-sp ] keep ! addr sp cpu
+ [ cpu-pc ] keep ! addr sp pc cpu
+ swapd [ write-word ] keep ! addr cpu
+ set-cpu-pc ;
+
+: (emulate-RLCA) ( cpu -- )
+ #! The content of the accumulator is rotated left
+ #! one position. The low order bit and the carry flag
+ #! are both set to the value shifd out of the high
+ #! order bit position. Only the carry flag is affected.
+ [ cpu-a -7 shift ] keep
+ over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
+ [ cpu-a 1 shift HEX: FF bitand ] keep
+ >r bitor r> set-cpu-a ;
+
+: (emulate-RRCA) ( cpu -- )
+ #! The content of the accumulator is rotated right
+ #! one position. The high order bit and the carry flag
+ #! are both set to the value shifd out of the low
+ #! order bit position. Only the carry flag is affected.
+ [ cpu-a 1 bitand 7 shift ] keep
+ over 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
+ [ cpu-a 254 bitand -1 shift ] keep
+ >r bitor r> set-cpu-a ;
+
+: (emulate-RLA) ( cpu -- )
+ #! The content of the accumulator is rotated left
+ #! one position through the carry flag. The low
+ #! order bit is set equal to the carry flag and
+ #! the carry flag is set to the value shifd out
+ #! of the high order bit. Only the carry flag is
+ #! affected.
+ [ carry-flag swap flag-set? [ 1 ] [ 0 ] if ] keep
+ [ cpu-a 127 bitand 7 shift ] keep
+ dup cpu-a 128 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
+ >r bitor r> set-cpu-a ;
+
+: (emulate-RRA) ( cpu -- )
+ #! The content of the accumulator is rotated right
+ #! one position through the carry flag. The high order
+ #! bit is set to the carry flag and the carry flag is
+ #! set to the value shifd out of the low order bit.
+ #! Only the carry flag is affected.
+ [ carry-flag swap flag-set? [ BIN: 10000000 ] [ 0 ] if ] keep
+ [ cpu-a 254 bitand -1 shift ] keep
+ dup cpu-a 1 bitand 0 = [ dup carry-flag clear-flag ] [ dup carry-flag set-flag ] if
+ >r bitor r> set-cpu-a ;
+
+: (emulate-CPL) ( cpu -- )
+ #! The contents of the accumulator are complemented
+ #! (zero bits become one, one bits becomes zero).
+ #! No flags are affected.
+ HEX: FF swap cpu-a-bitxor= ;
+
+: (emulate-DAA) ( cpu -- )
+ #! The eight bit number in the accumulator is
+ #! adjusted to form two four-bit binary-coded-decimal
+ #! digits.
+ [
+ dup half-carry-flag swap flag-set? swap
+ cpu-a BIN: 1111 bitand 9 > or [ 6 ] [ 0 ] if
+ ] keep
+ [ cpu-a + ] keep
+ [ update-flags ] 2keep
+ [ swap HEX: FF bitand swap set-cpu-a ] keep
+ [
+ dup carry-flag swap flag-set? swap
+ cpu-a -4 shift BIN: 1111 bitand 9 > or [ 96 ] [ 0 ] if
+ ] keep
+ [ cpu-a + ] keep
+ [ update-flags ] 2keep
+ swap HEX: FF bitand swap set-cpu-a ;
+
+: patterns ( -- hashtable )
+ #! table of code quotation patterns for each type of instruction.
+ H{
+ { "NOP" [ drop ] }
+ { "RET-NN" [ ret-from-sub ] }
+ { "RST-0" [ 0 swap (emulate-RST) ] }
+ { "RST-8" [ 8 swap (emulate-RST) ] }
+ { "RST-10H" [ HEX: 10 swap (emulate-RST) ] }
+ { "RST-18H" [ HEX: 18 swap (emulate-RST) ] }
+ { "RST-20H" [ HEX: 20 swap (emulate-RST) ] }
+ { "RST-28H" [ HEX: 28 swap (emulate-RST) ] }
+ { "RST-30H" [ HEX: 30 swap (emulate-RST) ] }
+ { "RST-38H" [ HEX: 38 swap (emulate-RST) ] }
+ { "RET-F|FF" [ dup $1 [ 6 over inc-cycles ret-from-sub ] [ drop ] if ] }
+ { "CP-N" [ [ cpu-a ] keep [ next-byte ] keep sub-byte drop ] }
+ { "CP-R" [ [ cpu-a ] keep [ $1 ] keep sub-byte drop ] }
+ { "CP-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep sub-byte drop ] }
+ { "OR-N" [ [ cpu-a ] keep [ next-byte ] keep [ or-byte ] keep set-cpu-a ] }
+ { "OR-R" [ [ cpu-a ] keep [ $1 ] keep [ or-byte ] keep set-cpu-a ] }
+ { "OR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ or-byte ] keep set-cpu-a ] }
+ { "XOR-N" [ [ cpu-a ] keep [ next-byte ] keep [ xor-byte ] keep set-cpu-a ] }
+ { "XOR-R" [ [ cpu-a ] keep [ $1 ] keep [ xor-byte ] keep set-cpu-a ] }
+ { "XOR-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ xor-byte ] keep set-cpu-a ] }
+ { "AND-N" [ [ cpu-a ] keep [ next-byte ] keep [ and-byte ] keep set-cpu-a ] }
+ { "AND-R" [ [ cpu-a ] keep [ $1 ] keep [ and-byte ] keep set-cpu-a ] }
+ { "AND-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ and-byte ] keep set-cpu-a ] }
+ { "ADC-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte-with-carry ] keep $2 ] }
+ { "ADC-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte-with-carry ] keep $2 ] }
+ { "ADC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte-with-carry ] keep $2 ] }
+ { "ADD-R,N" [ [ $1 ] keep [ next-byte ] keep [ add-byte ] keep $2 ] }
+ { "ADD-R,R" [ [ $1 ] keep [ $3 ] keep [ add-byte ] keep $2 ] }
+ { "ADD-RR,RR" [ [ $1 ] keep [ $3 ] keep [ add-word ] keep $2 ] }
+ { "ADD-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ add-byte ] keep $2 ] }
+ { "SBC-R,N" [ [ $1 ] keep [ next-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
+ { "SBC-R,R" [ [ $1 ] keep [ $3 ] keep [ sub-byte-with-carry ] keep $2 ] }
+ { "SBC-R,(RR)" [ [ $1 ] keep [ $3 ] keep [ read-byte ] keep [ sub-byte-with-carry ] keep $2 ] }
+ { "SUB-R" [ [ cpu-a ] keep [ $1 ] keep [ sub-byte ] keep set-cpu-a ] }
+ { "SUB-(RR)" [ [ cpu-a ] keep [ $1 ] keep [ read-byte ] keep [ sub-byte ] keep set-cpu-a ] }
+ { "SUB-N" [ [ cpu-a ] keep [ next-byte ] keep [ sub-byte ] keep set-cpu-a ] }
+ { "CPL" [ (emulate-CPL) ] }
+ { "DAA" [ (emulate-DAA) ] }
+ { "RLA" [ (emulate-RLA) ] }
+ { "RRA" [ (emulate-RRA) ] }
+ { "CCF" [ carry-flag swap cpu-f-bitxor= ] }
+ { "SCF" [ carry-flag swap cpu-f-bitor= ] }
+ { "RLCA" [ (emulate-RLCA) ] }
+ { "RRCA" [ (emulate-RRCA) ] }
+ { "HALT" [ drop ] }
+ { "DI" [ [ 255 interrupt-flag - ] swap cpu-f-bitand ] }
+ { "EI" [ [ interrupt-flag ] swap cpu-f-bitor ] }
+ { "POP-RR" [ [ pop-sp ] keep $2 ] }
+ { "PUSH-RR" [ [ $1 ] keep push-sp ] }
+ { "INC-R" [ [ $1 ] keep [ inc-byte ] keep $2 ] }
+ { "DEC-R" [ [ $1 ] keep [ dec-byte ] keep $2 ] }
+ { "INC-RR" [ [ $1 ] keep [ inc-word ] keep $2 ] }
+ { "DEC-RR" [ [ $1 ] keep [ dec-word ] keep $2 ] }
+ { "DEC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ dec-byte ] keep [ $1 ] keep write-byte ] }
+ { "INC-(RR)" [ [ $1 ] keep [ read-byte ] keep [ inc-byte ] keep [ $1 ] keep write-byte ] }
+ { "JP-NN" [ [ cpu-pc ] keep [ read-word ] keep set-cpu-pc ] }
+ { "JP-F|FF,NN" [ [ $1 ] keep swap [ [ next-word ] keep [ set-cpu-pc ] keep [ cpu-cycles ] keep swap 5 + swap set-cpu-cycles ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] }
+ { "JP-(RR)" [ [ $1 ] keep set-cpu-pc ] }
+ { "CALL-NN" [ (emulate-CALL) ] }
+ { "CALL-F|FF,NN" [ [ $1 ] keep swap [ 7 over inc-cycles (emulate-CALL) ] [ [ cpu-pc 2 + ] keep set-cpu-pc ] if ] }
+ { "LD-RR,NN" [ [ next-word ] keep $2 ] }
+ { "LD-RR,RR" [ [ $3 ] keep $2 ] }
+ { "LD-R,N" [ [ next-byte ] keep $2 ] }
+ { "LD-(RR),N" [ [ next-byte ] keep [ $1 ] keep write-byte ] }
+ { "LD-(RR),R" [ [ $3 ] keep [ $1 ] keep write-byte ] }
+ { "LD-R,R" [ [ $3 ] keep $2 ] }
+ { "LD-R,(RR)" [ [ $3 ] keep [ read-byte ] keep $2 ] }
+ { "LD-(NN),RR" [ [ $1 ] keep [ next-word ] keep write-word ] }
+ { "LD-(NN),R" [ [ $1 ] keep [ next-word ] keep write-byte ] }
+ { "LD-RR,(NN)" [ [ next-word ] keep [ read-word ] keep $2 ] }
+ { "LD-R,(NN)" [ [ next-word ] keep [ read-byte ] keep $2 ] }
+ { "OUT-(N),R" [ [ $1 ] keep [ next-byte ] keep write-port ] }
+ { "IN-R,(N)" [ [ next-byte ] keep [ read-port ] keep set-cpu-a ] }
+ { "EX-(RR),RR" [ [ $1 ] keep [ read-word ] keep [ $3 ] keep [ $1 ] keep [ write-word ] keep $4 ] }
+ { "EX-RR,RR" [ [ $1 ] keep [ $3 ] keep [ $2 ] keep $4 ] }
+ } ;
+
+: 8-bit-registers ( -- parser )
+ #! A parser for 8-bit registers. On a successfull parse the
+ #! parse tree contains a vector. The first item in the vector
+ #! is the getter word for that register with stack effect
+ #! ( cpu -- value ). The second item is the setter word with
+ #! stack effect ( value cpu -- ).
+ "A" token
+ "B" token <|>
+ "C" token <|>
+ "D" token <|>
+ "E" token <|>
+ "H" token <|>
+ "L" token <|> [ register-lookup ] <@ ;
+
+: all-flags
+ #! A parser for 16-bit flags.
+ "NZ" token
+ "NC" token <|>
+ "PO" token <|>
+ "PE" token <|>
+ "Z" token <|>
+ "C" token <|>
+ "P" token <|>
+ "M" token <|> [ flag-lookup ] <@ ;
+
+: 16-bit-registers
+ #! A parser for 16-bit registers. On a successfull parse the
+ #! parse tree contains a vector. The first item in the vector
+ #! is the getter word for that register with stack effect
+ #! ( cpu -- value ). The second item is the setter word with
+ #! stack effect ( value cpu -- ).
+ "AF" token
+ "BC" token <|>
+ "DE" token <|>
+ "HL" token <|>
+ "SP" token <|> [ register-lookup ] <@ ;
+
+: all-registers ( -- parser )
+ #! Return a parser that can parse the format
+ #! for 8 bit or 16 bit registers.
+ 8-bit-registers 16-bit-registers <|> ;
+
+: indirect ( parser -- parser )
+ #! Given a parser, return a parser which parses the original
+ #! wrapped in brackets, representing an indirect reference.
+ #! eg. BC -> (BC). The value of the original parser is left in
+ #! the parse tree.
+ "(" token swap &> ")" token <& ;
+
+: generate-instruction ( vector string -- quot )
+ #! Generate the quotation for an instruction, given the instruction in
+ #! the 'string' and a vector containing the arguments for that instruction.
+ patterns at replace-patterns ;
+
+: simple-instruction ( token -- parser )
+ #! Return a parser for then instruction identified by the token.
+ #! The parser return parses the token only and expects no additional
+ #! arguments to the instruction.
+ token [ [ { } clone , , \ generate-instruction , ] [ ] make ] <@ ;
+
+: complex-instruction ( type token -- parser )
+ #! Return a parser for an instruction identified by the token.
+ #! The instruction is expected to take additional arguments by
+ #! being combined with other parsers. Then 'type' is used for a lookup
+ #! in a pattern hashtable to return the instruction quotation pattern.
+ token swap [ nip [ , \ generate-instruction , ] [ ] make ] curry <@ ;
+
+: NOP-instruction ( -- parser )
+ "NOP" simple-instruction ;
+
+: RET-NN-instruction ( -- parser )
+ "RET-NN" "RET" complex-instruction
+ "nn" token sp <&
+ just [ { } clone swap curry ] <@ ;
+
+: RST-0-instruction ( -- parser )
+ "RST-0" "RST" complex-instruction
+ "0" token sp <&
+ just [ { } clone swap curry ] <@ ;
+
+: RST-8-instruction ( -- parser )
+ "RST-8" "RST" complex-instruction
+ "8" token sp <&
+ just [ { } clone swap curry ] <@ ;
+
+: RST-10H-instruction ( -- parser )
+ "RST-10H" "RST" complex-instruction
+ "10H" token sp <&
+ just [ { } clone swap curry ] <@ ;
+
+: RST-18H-instruction ( -- parser )
+ "RST-18H" "RST" complex-instruction
+ "18H" token sp <&
+ just [ { } clone swap curry ] <@ ;
+
+: RST-20H-instruction ( -- parser )
+ "RST-20H" "RST" complex-instruction
+ "20H" token sp <&
+ just [ { } clone swap curry ] <@ ;
+
+: RST-28H-instruction ( -- parser )
+ "RST-28H" "RST" complex-instruction
+ "28H" token sp <&
+ just [ { } clone swap curry ] <@ ;
+
+: RST-30H-instruction ( -- parser )
+ "RST-30H" "RST" complex-instruction
+ "30H" token sp <&
+ just [ { } clone swap curry ] <@ ;
+
+: RST-38H-instruction ( -- parser )
+ "RST-38H" "RST" complex-instruction
+ "38H" token sp <&
+ just [ { } clone swap curry ] <@ ;
+
+: JP-NN-instruction ( -- parser )
+ "JP-NN" "JP" complex-instruction
+ "nn" token sp <&
+ just [ { } clone swap curry ] <@ ;
+
+: JP-F|FF,NN-instruction ( -- parser )
+ "JP-F|FF,NN" "JP" complex-instruction
+ all-flags sp <&>
+ ",nn" token <&
+ just [ first2 swap curry ] <@ ;
+
+: JP-(RR)-instruction ( -- parser )
+ "JP-(RR)" "JP" complex-instruction
+ 16-bit-registers indirect sp <&>
+ just [ first2 swap curry ] <@ ;
+
+: CALL-NN-instruction ( -- parser )
+ "CALL-NN" "CALL" complex-instruction
+ "nn" token sp <&
+ just [ { } clone swap curry ] <@ ;
+
+: CALL-F|FF,NN-instruction ( -- parser )
+ "CALL-F|FF,NN" "CALL" complex-instruction
+ all-flags sp <&>
+ ",nn" token <&
+ just [ first2 swap curry ] <@ ;
+
+: RLCA-instruction ( -- parser )
+ "RLCA" simple-instruction ;
+
+: RRCA-instruction ( -- parser )
+ "RRCA" simple-instruction ;
+
+: HALT-instruction ( -- parser )
+ "HALT" simple-instruction ;
+
+: DI-instruction ( -- parser )
+ "DI" simple-instruction ;
+
+: EI-instruction ( -- parser )
+ "EI" simple-instruction ;
+
+: CPL-instruction ( -- parser )
+ "CPL" simple-instruction ;
+
+: CCF-instruction ( -- parser )
+ "CCF" simple-instruction ;
+
+: SCF-instruction ( -- parser )
+ "SCF" simple-instruction ;
+
+: DAA-instruction ( -- parser )
+ "DAA" simple-instruction ;
+
+: RLA-instruction ( -- parser )
+ "RLA" simple-instruction ;
+
+: RRA-instruction ( -- parser )
+ "RRA" simple-instruction ;
+
+: DEC-R-instruction ( -- parser )
+ "DEC-R" "DEC" complex-instruction 8-bit-registers sp <&>
+ just [ first2 swap curry ] <@ ;
+
+: DEC-RR-instruction ( -- parser )
+ "DEC-RR" "DEC" complex-instruction 16-bit-registers sp <&>
+ just [ first2 swap curry ] <@ ;
+
+: DEC-(RR)-instruction ( -- parser )
+ "DEC-(RR)" "DEC" complex-instruction
+ 16-bit-registers indirect sp <&>
+ just [ first2 swap curry ] <@ ;
+
+: POP-RR-instruction ( -- parser )
+ "POP-RR" "POP" complex-instruction all-registers sp <&>
+ just [ first2 swap curry ] <@ ;
+
+: PUSH-RR-instruction ( -- parser )
+ "PUSH-RR" "PUSH" complex-instruction all-registers sp <&>
+ just [ first2 swap curry ] <@ ;
+
+: INC-R-instruction ( -- parser )
+ "INC-R" "INC" complex-instruction 8-bit-registers sp <&>
+ just [ first2 swap curry ] <@ ;
+
+: INC-RR-instruction ( -- parser )
+ "INC-RR" "INC" complex-instruction 16-bit-registers sp <&>
+ just [ first2 swap curry ] <@ ;
+
+: INC-(RR)-instruction ( -- parser )
+ "INC-(RR)" "INC" complex-instruction
+ all-registers indirect sp <&> just [ first2 swap curry ] <@ ;
+
+: RET-F|FF-instruction ( -- parser )
+ "RET-F|FF" "RET" complex-instruction all-flags sp <&>
+ just [ first2 swap curry ] <@ ;
+
+: AND-N-instruction ( -- parser )
+ "AND-N" "AND" complex-instruction
+ "n" token sp <&
+ just [ { } clone swap curry ] <@ ;
+
+: AND-R-instruction ( -- parser )
+ "AND-R" "AND" complex-instruction
+ 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
+
+: AND-(RR)-instruction ( -- parser )
+ "AND-(RR)" "AND" complex-instruction
+ 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
+
+: XOR-N-instruction ( -- parser )
+ "XOR-N" "XOR" complex-instruction
+ "n" token sp <&
+ just [ { } clone swap curry ] <@ ;
+
+: XOR-R-instruction ( -- parser )
+ "XOR-R" "XOR" complex-instruction
+ 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
+
+: XOR-(RR)-instruction ( -- parser )
+ "XOR-(RR)" "XOR" complex-instruction
+ 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
+
+: OR-N-instruction ( -- parser )
+ "OR-N" "OR" complex-instruction
+ "n" token sp <&
+ just [ { } clone swap curry ] <@ ;
+
+: OR-R-instruction ( -- parser )
+ "OR-R" "OR" complex-instruction
+ 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
+
+: OR-(RR)-instruction ( -- parser )
+ "OR-(RR)" "OR" complex-instruction
+ 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
+
+: CP-N-instruction ( -- parser )
+ "CP-N" "CP" complex-instruction
+ "n" token sp <&
+ just [ { } clone swap curry ] <@ ;
+
+: CP-R-instruction ( -- parser )
+ "CP-R" "CP" complex-instruction
+ 8-bit-registers sp <&> just [ first2 swap curry ] <@ ;
+
+: CP-(RR)-instruction ( -- parser )
+ "CP-(RR)" "CP" complex-instruction
+ 16-bit-registers indirect sp <&> just [ first2 swap curry ] <@ ;
+
+: ADC-R,N-instruction ( -- parser )
+ "ADC-R,N" "ADC" complex-instruction
+ 8-bit-registers sp <&>
+ ",n" token <&
+ just [ first2 swap curry ] <@ ;
+
+: ADC-R,R-instruction ( -- parser )
+ "ADC-R,R" "ADC" complex-instruction
+ 8-bit-registers sp <&>
+ "," token <&
+ 8-bit-registers <&>
+ just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+
+: ADC-R,(RR)-instruction ( -- parser )
+ "ADC-R,(RR)" "ADC" complex-instruction
+ 8-bit-registers sp <&>
+ "," token <&
+ 16-bit-registers indirect <&>
+ just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+
+: SBC-R,N-instruction ( -- parser )
+ "SBC-R,N" "SBC" complex-instruction
+ 8-bit-registers sp <&>
+ ",n" token <&
+ just [ first2 swap curry ] <@ ;
+
+: SBC-R,R-instruction ( -- parser )
+ "SBC-R,R" "SBC" complex-instruction
+ 8-bit-registers sp <&>
+ "," token <&
+ 8-bit-registers <&>
+ just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+
+: SBC-R,(RR)-instruction ( -- parser )
+ "SBC-R,(RR)" "SBC" complex-instruction
+ 8-bit-registers sp <&>
+ "," token <&
+ 16-bit-registers indirect <&>
+ just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+
+: SUB-R-instruction ( -- parser )
+ "SUB-R" "SUB" complex-instruction
+ 8-bit-registers sp <&>
+ just [ first2 swap curry ] <@ ;
+
+: SUB-(RR)-instruction ( -- parser )
+ "SUB-(RR)" "SUB" complex-instruction
+ 16-bit-registers indirect sp <&>
+ just [ first2 swap curry ] <@ ;
+
+: SUB-N-instruction ( -- parser )
+ "SUB-N" "SUB" complex-instruction
+ "n" token sp <&
+ just [ { } clone swap curry ] <@ ;
+
+: ADD-R,N-instruction ( -- parser )
+ "ADD-R,N" "ADD" complex-instruction
+ 8-bit-registers sp <&>
+ ",n" token <&
+ just [ first2 swap curry ] <@ ;
+
+: ADD-R,R-instruction ( -- parser )
+ "ADD-R,R" "ADD" complex-instruction
+ 8-bit-registers sp <&>
+ "," token <&
+ 8-bit-registers <&>
+ just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+
+: ADD-RR,RR-instruction ( -- parser )
+ "ADD-RR,RR" "ADD" complex-instruction
+ 16-bit-registers sp <&>
+ "," token <&
+ 16-bit-registers <&>
+ just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+
+: ADD-R,(RR)-instruction ( -- parser )
+ "ADD-R,(RR)" "ADD" complex-instruction
+ 8-bit-registers sp <&>
+ "," token <&
+ 16-bit-registers indirect <&>
+ just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+
+: LD-RR,NN-instruction
+ #! LD BC,nn
+ "LD-RR,NN" "LD" complex-instruction
+ 16-bit-registers sp <&>
+ ",nn" token <&
+ just [ first2 swap curry ] <@ ;
+
+: LD-R,N-instruction
+ #! LD B,n
+ "LD-R,N" "LD" complex-instruction
+ 8-bit-registers sp <&>
+ ",n" token <&
+ just [ first2 swap curry ] <@ ;
+
+: LD-(RR),N-instruction
+ "LD-(RR),N" "LD" complex-instruction
+ 16-bit-registers indirect sp <&>
+ ",n" token <&
+ just [ first2 swap curry ] <@ ;
+
+: LD-(RR),R-instruction
+ #! LD (BC),A
+ "LD-(RR),R" "LD" complex-instruction
+ 16-bit-registers indirect sp <&>
+ "," token <&
+ 8-bit-registers <&>
+ just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+
+: LD-R,R-instruction
+ "LD-R,R" "LD" complex-instruction
+ 8-bit-registers sp <&>
+ "," token <&
+ 8-bit-registers <&>
+ just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+
+: LD-RR,RR-instruction
+ "LD-RR,RR" "LD" complex-instruction
+ 16-bit-registers sp <&>
+ "," token <&
+ 16-bit-registers <&>
+ just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+
+: LD-R,(RR)-instruction
+ "LD-R,(RR)" "LD" complex-instruction
+ 8-bit-registers sp <&>
+ "," token <&
+ 16-bit-registers indirect <&>
+ just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+
+: LD-(NN),RR-instruction
+ "LD-(NN),RR" "LD" complex-instruction
+ "nn" token indirect sp <&
+ "," token <&
+ 16-bit-registers <&>
+ just [ first2 swap curry ] <@ ;
+
+: LD-(NN),R-instruction
+ "LD-(NN),R" "LD" complex-instruction
+ "nn" token indirect sp <&
+ "," token <&
+ 8-bit-registers <&>
+ just [ first2 swap curry ] <@ ;
+
+: LD-RR,(NN)-instruction
+ "LD-RR,(NN)" "LD" complex-instruction
+ 16-bit-registers sp <&>
+ "," token <&
+ "nn" token indirect <&
+ just [ first2 swap curry ] <@ ;
+
+: LD-R,(NN)-instruction
+ "LD-R,(NN)" "LD" complex-instruction
+ 8-bit-registers sp <&>
+ "," token <&
+ "nn" token indirect <&
+ just [ first2 swap curry ] <@ ;
+
+: OUT-(N),R-instruction
+ "OUT-(N),R" "OUT" complex-instruction
+ "n" token indirect sp <&
+ "," token <&
+ 8-bit-registers <&>
+ just [ first2 swap curry ] <@ ;
+
+: IN-R,(N)-instruction
+ "IN-R,(N)" "IN" complex-instruction
+ 8-bit-registers sp <&>
+ "," token <&
+ "n" token indirect <&
+ just [ first2 swap curry ] <@ ;
+
+: EX-(RR),RR-instruction
+ "EX-(RR),RR" "EX" complex-instruction
+ 16-bit-registers indirect sp <&>
+ "," token <&
+ 16-bit-registers <&>
+ just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+
+: EX-RR,RR-instruction
+ "EX-RR,RR" "EX" complex-instruction
+ 16-bit-registers sp <&>
+ "," token <&
+ 16-bit-registers <&>
+ just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+
+: 8080-generator-parser
+ NOP-instruction
+ RST-0-instruction <|>
+ RST-8-instruction <|>
+ RST-10H-instruction <|>
+ RST-18H-instruction <|>
+ RST-20H-instruction <|>
+ RST-28H-instruction <|>
+ RST-30H-instruction <|>
+ RST-38H-instruction <|>
+ JP-F|FF,NN-instruction <|>
+ JP-NN-instruction <|>
+ JP-(RR)-instruction <|>
+ CALL-F|FF,NN-instruction <|>
+ CALL-NN-instruction <|>
+ CPL-instruction <|>
+ CCF-instruction <|>
+ SCF-instruction <|>
+ DAA-instruction <|>
+ RLA-instruction <|>
+ RRA-instruction <|>
+ RLCA-instruction <|>
+ RRCA-instruction <|>
+ HALT-instruction <|>
+ DI-instruction <|>
+ EI-instruction <|>
+ AND-N-instruction <|>
+ AND-R-instruction <|>
+ AND-(RR)-instruction <|>
+ XOR-N-instruction <|>
+ XOR-R-instruction <|>
+ XOR-(RR)-instruction <|>
+ OR-N-instruction <|>
+ OR-R-instruction <|>
+ OR-(RR)-instruction <|>
+ CP-N-instruction <|>
+ CP-R-instruction <|>
+ CP-(RR)-instruction <|>
+ DEC-RR-instruction <|>
+ DEC-R-instruction <|>
+ DEC-(RR)-instruction <|>
+ POP-RR-instruction <|>
+ PUSH-RR-instruction <|>
+ INC-RR-instruction <|>
+ INC-R-instruction <|>
+ INC-(RR)-instruction <|>
+ LD-RR,NN-instruction <|>
+ LD-R,N-instruction <|>
+ LD-R,R-instruction <|>
+ LD-RR,RR-instruction <|>
+ LD-(RR),N-instruction <|>
+ LD-(RR),R-instruction <|>
+ LD-R,(RR)-instruction <|>
+ LD-(NN),RR-instruction <|>
+ LD-(NN),R-instruction <|>
+ LD-RR,(NN)-instruction <|>
+ LD-R,(NN)-instruction <|>
+ ADC-R,N-instruction <|>
+ ADC-R,R-instruction <|>
+ ADC-R,(RR)-instruction <|>
+ ADD-R,N-instruction <|>
+ ADD-R,R-instruction <|>
+ ADD-RR,RR-instruction <|>
+ ADD-R,(RR)-instruction <|>
+ SBC-R,N-instruction <|>
+ SBC-R,R-instruction <|>
+ SBC-R,(RR)-instruction <|>
+ SUB-R-instruction <|>
+ SUB-(RR)-instruction <|>
+ SUB-N-instruction <|>
+ RET-F|FF-instruction <|>
+ RET-NN-instruction <|>
+ OUT-(N),R-instruction <|>
+ IN-R,(N)-instruction <|>
+ EX-(RR),RR-instruction <|>
+ EX-RR,RR-instruction <|>
+ just ;
+
+: instruction-quotations ( string -- emulate-quot )
+ #! Given an instruction string, return the emulation quotation for
+ #! it. This will later be expanded to produce the disassembly and
+ #! assembly quotations.
+ 8080-generator-parser some parse call ;
+
+SYMBOL: last-instruction
+SYMBOL: last-opcode
+
+: parse-instructions ( list -- emulate-quot )
+ #! Process the list of strings, which should make
+ #! up an 8080 instruction, and output a quotation
+ #! that would implement that instruction.
+ [
+ dup " " join instruction-quotations
+ >r "_" join [ "emulate-" % % ] "" make create-in dup last-instruction global set-at
+ r> define
+ ] with-compilation-unit ;
+
+: INSTRUCTION: ";" parse-tokens parse-instructions ; parsing
+
+: cycles ( -- )
+ #! Set the number of cycles for the last instruction that was defined.
+ scan string>number last-opcode global at instruction-cycles set-nth ; parsing
+
+: opcode ( -- )
+ #! Set the opcode number for the last instruction that was defined.
+ last-instruction global at 1quotation scan 16 base>
+ dup last-opcode global set-at instructions set-nth ; parsing
+
diff --git a/extra/cpu/8080/instructions/instructions.factor b/extra/cpu/8080/instructions/instructions.factor
deleted file mode 100644
index a1c3240d81..0000000000
--- a/extra/cpu/8080/instructions/instructions.factor
+++ /dev/null
@@ -1,250 +0,0 @@
-! Copyright (C) 2006 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: cpu.8080 ;
-IN: cpu.8080.instructions
-
-INSTRUCTION: NOP ; opcode 00 cycles 04
-INSTRUCTION: LD BC,nn ; opcode 01 cycles 10
-INSTRUCTION: LD (BC),A ; opcode 02 cycles 07
-INSTRUCTION: INC BC ; opcode 03 cycles 06
-INSTRUCTION: INC B ; opcode 04 cycles 05
-INSTRUCTION: DEC B ; opcode 05 cycles 05
-INSTRUCTION: LD B,n ; opcode 06 cycles 07
-INSTRUCTION: RLCA ; opcode 07 cycles 04
-! INSTRUCTION: NOP ; opcode 08 cycles 04
-INSTRUCTION: ADD HL,BC ; opcode 09 cycles 11
-INSTRUCTION: LD A,(BC) ; opcode 0A cycles 07
-INSTRUCTION: DEC BC ; opcode 0B cycles 06
-INSTRUCTION: INC C ; opcode 0C cycles 05
-INSTRUCTION: DEC C ; opcode 0D cycles 05
-INSTRUCTION: LD C,n ; opcode 0E cycles 07
-INSTRUCTION: RRCA ; opcode 0F cycles 04
-INSTRUCTION: LD DE,nn ; opcode 11 cycles 10
-INSTRUCTION: LD (DE),A ; opcode 12 cycles 07
-INSTRUCTION: INC DE ; opcode 13 cycles 06
-INSTRUCTION: INC D ; opcode 14 cycles 05
-INSTRUCTION: DEC D ; opcode 15 cycles 05
-INSTRUCTION: LD D,n ; opcode 16 cycles 07
-INSTRUCTION: RLA ; opcode 17 cycles 04
-INSTRUCTION: ADD HL,DE ; opcode 19 cycles 11
-INSTRUCTION: LD A,(DE) ; opcode 1A cycles 07
-INSTRUCTION: DEC DE ; opcode 1B cycles 06
-INSTRUCTION: INC E ; opcode 1C cycles 05
-INSTRUCTION: DEC E ; opcode 1D cycles 05
-INSTRUCTION: LD E,n ; opcode 1E cycles 07
-INSTRUCTION: RRA ; opcode 1F cycles 04
-INSTRUCTION: LD HL,nn ; opcode 21 cycles 10
-INSTRUCTION: LD (nn),HL ; opcode 22 cycles 16
-INSTRUCTION: INC HL ; opcode 23 cycles 06
-INSTRUCTION: INC H ; opcode 24 cycles 05
-INSTRUCTION: DEC H ; opcode 25 cycles 05
-INSTRUCTION: LD H,n ; opcode 26 cycles 07
-INSTRUCTION: DAA ; opcode 27 cycles 04
-INSTRUCTION: ADD HL,HL ; opcode 29 cycles 11
-INSTRUCTION: LD HL,(nn) ; opcode 2A cycles 16
-INSTRUCTION: DEC HL ; opcode 2B cycles 06
-INSTRUCTION: INC L ; opcode 2C cycles 05
-INSTRUCTION: DEC L ; opcode 2D cycles 05
-INSTRUCTION: LD L,n ; opcode 2E cycles 07
-INSTRUCTION: CPL ; opcode 2F cycles 04
-INSTRUCTION: LD SP,nn ; opcode 31 cycles 10
-INSTRUCTION: LD (nn),A ; opcode 32 cycles 13
-INSTRUCTION: INC SP ; opcode 33 cycles 06
-INSTRUCTION: INC (HL) ; opcode 34 cycles 10
-INSTRUCTION: DEC (HL) ; opcode 35 cycles 10
-INSTRUCTION: LD (HL),n ; opcode 36 cycles 10
-INSTRUCTION: SCF ; opcode 37 cycles 04
-INSTRUCTION: ADD HL,SP ; opcode 39 cycles 11
-INSTRUCTION: LD A,(nn) ; opcode 3A cycles 13
-INSTRUCTION: DEC SP ; opcode 3B cycles 06
-INSTRUCTION: INC A ; opcode 3C cycles 05
-INSTRUCTION: DEC A ; opcode 3D cycles 05
-INSTRUCTION: LD A,n ; opcode 3E cycles 07
-INSTRUCTION: CCF ; opcode 3F cycles 04
-INSTRUCTION: LD B,B ; opcode 40 cycles 05
-INSTRUCTION: LD B,C ; opcode 41 cycles 05
-INSTRUCTION: LD B,D ; opcode 42 cycles 05
-INSTRUCTION: LD B,E ; opcode 43 cycles 05
-INSTRUCTION: LD B,H ; opcode 44 cycles 05
-INSTRUCTION: LD B,L ; opcode 45 cycles 05
-INSTRUCTION: LD B,(HL) ; opcode 46 cycles 07
-INSTRUCTION: LD B,A ; opcode 47 cycles 05
-INSTRUCTION: LD C,B ; opcode 48 cycles 05
-INSTRUCTION: LD C,C ; opcode 49 cycles 05
-INSTRUCTION: LD C,D ; opcode 4A cycles 05
-INSTRUCTION: LD C,E ; opcode 4B cycles 05
-INSTRUCTION: LD C,H ; opcode 4C cycles 05
-INSTRUCTION: LD C,L ; opcode 4D cycles 05
-INSTRUCTION: LD C,(HL) ; opcode 4E cycles 07
-INSTRUCTION: LD C,A ; opcode 4F cycles 05
-INSTRUCTION: LD D,B ; opcode 50 cycles 05
-INSTRUCTION: LD D,C ; opcode 51 cycles 05
-INSTRUCTION: LD D,D ; opcode 52 cycles 05
-INSTRUCTION: LD D,E ; opcode 53 cycles 05
-INSTRUCTION: LD D,H ; opcode 54 cycles 05
-INSTRUCTION: LD D,L ; opcode 55 cycles 05
-INSTRUCTION: LD D,(HL) ; opcode 56 cycles 07
-INSTRUCTION: LD D,A ; opcode 57 cycles 05
-INSTRUCTION: LD E,B ; opcode 58 cycles 05
-INSTRUCTION: LD E,C ; opcode 59 cycles 05
-INSTRUCTION: LD E,D ; opcode 5A cycles 05
-INSTRUCTION: LD E,E ; opcode 5B cycles 05
-INSTRUCTION: LD E,H ; opcode 5C cycles 05
-INSTRUCTION: LD E,L ; opcode 5D cycles 05
-INSTRUCTION: LD E,(HL) ; opcode 5E cycles 07
-INSTRUCTION: LD E,A ; opcode 5F cycles 05
-INSTRUCTION: LD H,B ; opcode 60 cycles 05
-INSTRUCTION: LD H,C ; opcode 61 cycles 05
-INSTRUCTION: LD H,D ; opcode 62 cycles 05
-INSTRUCTION: LD H,E ; opcode 63 cycles 05
-INSTRUCTION: LD H,H ; opcode 64 cycles 05
-INSTRUCTION: LD H,L ; opcode 65 cycles 05
-INSTRUCTION: LD H,(HL) ; opcode 66 cycles 07
-INSTRUCTION: LD H,A ; opcode 67 cycles 05
-INSTRUCTION: LD L,B ; opcode 68 cycles 05
-INSTRUCTION: LD L,C ; opcode 69 cycles 05
-INSTRUCTION: LD L,D ; opcode 6A cycles 05
-INSTRUCTION: LD L,E ; opcode 6B cycles 05
-INSTRUCTION: LD L,H ; opcode 6C cycles 05
-INSTRUCTION: LD L,L ; opcode 6D cycles 05
-INSTRUCTION: LD L,(HL) ; opcode 6E cycles 07
-INSTRUCTION: LD L,A ; opcode 6F cycles 05
-INSTRUCTION: LD (HL),B ; opcode 70 cycles 07
-INSTRUCTION: LD (HL),C ; opcode 71 cycles 07
-INSTRUCTION: LD (HL),D ; opcode 72 cycles 07
-INSTRUCTION: LD (HL),E ; opcode 73 cycles 07
-INSTRUCTION: LD (HL),H ; opcode 74 cycles 07
-INSTRUCTION: LD (HL),L ; opcode 75 cycles 07
-INSTRUCTION: HALT ; opcode 76 cycles 07
-INSTRUCTION: LD (HL),A ; opcode 77 cycles 07
-INSTRUCTION: LD A,B ; opcode 78 cycles 05
-INSTRUCTION: LD A,C ; opcode 79 cycles 05
-INSTRUCTION: LD A,D ; opcode 7A cycles 05
-INSTRUCTION: LD A,E ; opcode 7B cycles 05
-INSTRUCTION: LD A,H ; opcode 7C cycles 05
-INSTRUCTION: LD A,L ; opcode 7D cycles 05
-INSTRUCTION: LD A,(HL) ; opcode 7E cycles 07
-INSTRUCTION: LD A,A ; opcode 7F cycles 05
-INSTRUCTION: ADD A,B ; opcode 80 cycles 04
-INSTRUCTION: ADD A,C ; opcode 81 cycles 04
-INSTRUCTION: ADD A,D ; opcode 82 cycles 04
-INSTRUCTION: ADD A,E ; opcode 83 cycles 04
-INSTRUCTION: ADD A,H ; opcode 84 cycles 04
-INSTRUCTION: ADD A,L ; opcode 85 cycles 04
-INSTRUCTION: ADD A,(HL) ; opcode 86 cycles 07
-INSTRUCTION: ADD A,A ; opcode 87 cycles 04
-INSTRUCTION: ADC A,B ; opcode 88 cycles 04
-INSTRUCTION: ADC A,C ; opcode 89 cycles 04
-INSTRUCTION: ADC A,D ; opcode 8A cycles 04
-INSTRUCTION: ADC A,E ; opcode 8B cycles 04
-INSTRUCTION: ADC A,H ; opcode 8C cycles 04
-INSTRUCTION: ADC A,L ; opcode 8D cycles 04
-INSTRUCTION: ADC A,(HL) ; opcode 8E cycles 07
-INSTRUCTION: ADC A,A ; opcode 8F cycles 04
-INSTRUCTION: SUB B ; opcode 90 cycles 04
-INSTRUCTION: SUB C ; opcode 91 cycles 04
-INSTRUCTION: SUB D ; opcode 92 cycles 04
-INSTRUCTION: SUB E ; opcode 93 cycles 04
-INSTRUCTION: SUB H ; opcode 94 cycles 04
-INSTRUCTION: SUB L ; opcode 95 cycles 04
-INSTRUCTION: SUB (HL) ; opcode 96 cycles 07
-INSTRUCTION: SUB A ; opcode 97 cycles 04
-INSTRUCTION: SBC A,B ; opcode 98 cycles 04
-INSTRUCTION: SBC A,C ; opcode 99 cycles 04
-INSTRUCTION: SBC A,D ; opcode 9A cycles 04
-INSTRUCTION: SBC A,E ; opcode 9B cycles 04
-INSTRUCTION: SBC A,H ; opcode 9C cycles 04
-INSTRUCTION: SBC A,L ; opcode 9D cycles 04
-INSTRUCTION: SBC A,(HL) ; opcode 9E cycles 07
-INSTRUCTION: SBC A,A ; opcode 9F cycles 04
-INSTRUCTION: AND B ; opcode A0 cycles 04
-INSTRUCTION: AND C ; opcode A1 cycles 04
-INSTRUCTION: AND D ; opcode A2 cycles 04
-INSTRUCTION: AND E ; opcode A3 cycles 04
-INSTRUCTION: AND H ; opcode A4 cycles 04
-INSTRUCTION: AND L ; opcode A5 cycles 04
-INSTRUCTION: AND (HL) ; opcode A6 cycles 07
-INSTRUCTION: AND A ; opcode A7 cycles 04
-INSTRUCTION: XOR B ; opcode A8 cycles 04
-INSTRUCTION: XOR C ; opcode A9 cycles 04
-INSTRUCTION: XOR D ; opcode AA cycles 04
-INSTRUCTION: XOR E ; opcode AB cycles 04
-INSTRUCTION: XOR H ; opcode AC cycles 04
-INSTRUCTION: XOR L ; opcode AD cycles 04
-INSTRUCTION: XOR (HL) ; opcode AE cycles 07
-INSTRUCTION: XOR A ; opcode AF cycles 04
-INSTRUCTION: OR B ; opcode B0 cycles 04
-INSTRUCTION: OR C ; opcode B1 cycles 04
-INSTRUCTION: OR D ; opcode B2 cycles 04
-INSTRUCTION: OR E ; opcode B3 cycles 04
-INSTRUCTION: OR H ; opcode B4 cycles 04
-INSTRUCTION: OR L ; opcode B5 cycles 04
-INSTRUCTION: OR (HL) ; opcode B6 cycles 07
-INSTRUCTION: OR A ; opcode B7 cycles 04
-INSTRUCTION: CP B ; opcode B8 cycles 04
-INSTRUCTION: CP C ; opcode B9 cycles 04
-INSTRUCTION: CP D ; opcode BA cycles 04
-INSTRUCTION: CP E ; opcode BB cycles 04
-INSTRUCTION: CP H ; opcode BC cycles 04
-INSTRUCTION: CP L ; opcode BD cycles 04
-INSTRUCTION: CP (HL) ; opcode BE cycles 07
-INSTRUCTION: CP A ; opcode BF cycles 04
-INSTRUCTION: RET NZ ; opcode C0 cycles 05
-INSTRUCTION: POP BC ; opcode C1 cycles 10
-INSTRUCTION: JP NZ,nn ; opcode C2 cycles 10
-INSTRUCTION: JP nn ; opcode C3 cycles 10
-INSTRUCTION: CALL NZ,nn ; opcode C4 cycles 11
-INSTRUCTION: PUSH BC ; opcode C5 cycles 11
-INSTRUCTION: ADD A,n ; opcode C6 cycles 07
-INSTRUCTION: RST 0 ; opcode C7 cycles 11
-INSTRUCTION: RET Z ; opcode C8 cycles 05
-INSTRUCTION: RET nn ; opcode C9 cycles 10
-INSTRUCTION: JP Z,nn ; opcode CA cycles 10
-INSTRUCTION: CALL Z,nn ; opcode CC cycles 11
-INSTRUCTION: CALL nn ; opcode CD cycles 17
-INSTRUCTION: ADC A,n ; opcode CE cycles 07
-INSTRUCTION: RST 8 ; opcode CF cycles 11
-INSTRUCTION: RET NC ; opcode D0 cycles 05
-INSTRUCTION: POP DE ; opcode D1 cycles 10
-INSTRUCTION: JP NC,nn ; opcode D2 cycles 10
-INSTRUCTION: OUT (n),A ; opcode D3 cycles 10
-INSTRUCTION: CALL NC,nn ; opcode D4 cycles 11
-INSTRUCTION: PUSH DE ; opcode D5 cycles 11
-INSTRUCTION: SUB n ; opcode D6 cycles 07
-INSTRUCTION: RST 10H ; opcode D7 cycles 11
-INSTRUCTION: RET C ; opcode D8 cycles 05
-INSTRUCTION: JP C,nn ; opcode DA cycles 10
-INSTRUCTION: IN A,(n) ; opcode DB cycles 10
-INSTRUCTION: CALL C,nn ; opcode DC cycles 11
-INSTRUCTION: SBC A,n ; opcode DE cycles 07
-INSTRUCTION: RST 18H ; opcode DF cycles 11
-INSTRUCTION: RET PO ; opcode E0 cycles 05
-INSTRUCTION: POP HL ; opcode E1 cycles 10
-INSTRUCTION: JP PO,nn ; opcode E2 cycles 10
-INSTRUCTION: EX (SP),HL ; opcode E3 cycles 04
-INSTRUCTION: CALL PO,nn ; opcode E4 cycles 11
-INSTRUCTION: PUSH HL ; opcode E5 cycles 11
-INSTRUCTION: AND n ; opcode E6 cycles 07
-INSTRUCTION: RST 20H ; opcode E7 cycles 11
-INSTRUCTION: RET PE ; opcode E8 cycles 05
-INSTRUCTION: JP (HL) ; opcode E9 cycles 04
-INSTRUCTION: JP PE,nn ; opcode EA cycles 10
-INSTRUCTION: EX DE,HL ; opcode EB cycles 04
-INSTRUCTION: CALL PE,nn ; opcode EC cycles 11
-INSTRUCTION: XOR n ; opcode EE cycles 07
-INSTRUCTION: RST 28H ; opcode EF cycles 11
-INSTRUCTION: RET P ; opcode F0 cycles 05
-INSTRUCTION: POP AF ; opcode F1 cycles 10
-INSTRUCTION: JP P,nn ; opcode F2 cycles 10
-INSTRUCTION: DI ; opcode F3 cycles 04
-INSTRUCTION: CALL P,nn ; opcode F4 cycles 11
-INSTRUCTION: PUSH AF ; opcode F5 cycles 11
-INSTRUCTION: OR n ; opcode F6 cycles 07
-INSTRUCTION: RST 30H ; opcode F7 cycles 11
-INSTRUCTION: RET M ; opcode F8 cycles 05
-INSTRUCTION: LD SP,HL ; opcode F9 cycles 06
-INSTRUCTION: JP M,nn ; opcode FA cycles 10
-INSTRUCTION: EI ; opcode FB cycles 04
-INSTRUCTION: CALL M,nn ; opcode FC cycles 11
-INSTRUCTION: CP n ; opcode FE cycles 07
-INSTRUCTION: RST 38H ; opcode FF cycles 11
diff --git a/extra/space-invaders/space-invaders-docs.factor b/extra/space-invaders/space-invaders-docs.factor
index e6f5b123b0..c4e3a35668 100644
--- a/extra/space-invaders/space-invaders-docs.factor
+++ b/extra/space-invaders/space-invaders-docs.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup cpu.8080 ;
+USING: help.syntax help.markup cpu.8080.emulator ;
IN: space-invaders
HELP: run
diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor
index aa76f8ec3f..4d74968c35 100755
--- a/extra/space-invaders/space-invaders.factor
+++ b/extra/space-invaders/space-invaders.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: cpu.8080 openal math alien.c-types sequences kernel
+USING: cpu.8080 cpu.8080.emulator openal math alien.c-types sequences kernel
shuffle arrays io.files combinators kernel.private
ui.gestures ui.gadgets ui.render opengl.gl system
threads concurrency match ui byte-arrays combinators.lib
From e3b89f1f12d46ad635df987d9cc90c9e167f60a7 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Thu, 17 Jan 2008 12:41:44 +1300
Subject: [PATCH 42/65] Fix other CPU 8080 games
---
extra/balloon-bomber/balloon-bomber-docs.factor | 2 +-
extra/cpu/8080/authors.txt | 1 +
extra/cpu/8080/emulator/authors.txt | 1 +
extra/cpu/8080/emulator/summary.txt | 1 +
extra/cpu/8080/emulator/tags.txt | 1 +
extra/cpu/8080/summary.txt | 1 +
extra/cpu/8080/tags.txt | 1 +
extra/lunar-rescue/lunar-rescue-docs.factor | 2 +-
8 files changed, 8 insertions(+), 2 deletions(-)
create mode 100644 extra/cpu/8080/authors.txt
create mode 100644 extra/cpu/8080/emulator/authors.txt
create mode 100644 extra/cpu/8080/emulator/summary.txt
create mode 100644 extra/cpu/8080/emulator/tags.txt
create mode 100644 extra/cpu/8080/summary.txt
create mode 100644 extra/cpu/8080/tags.txt
diff --git a/extra/balloon-bomber/balloon-bomber-docs.factor b/extra/balloon-bomber/balloon-bomber-docs.factor
index ad7464aa64..694ac1882a 100644
--- a/extra/balloon-bomber/balloon-bomber-docs.factor
+++ b/extra/balloon-bomber/balloon-bomber-docs.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup cpu.8080 ;
+USING: help.syntax help.markup cpu.8080.emulator ;
IN: balloon-bomber
HELP: run
diff --git a/extra/cpu/8080/authors.txt b/extra/cpu/8080/authors.txt
new file mode 100644
index 0000000000..44b06f94bc
--- /dev/null
+++ b/extra/cpu/8080/authors.txt
@@ -0,0 +1 @@
+Chris Double
diff --git a/extra/cpu/8080/emulator/authors.txt b/extra/cpu/8080/emulator/authors.txt
new file mode 100644
index 0000000000..44b06f94bc
--- /dev/null
+++ b/extra/cpu/8080/emulator/authors.txt
@@ -0,0 +1 @@
+Chris Double
diff --git a/extra/cpu/8080/emulator/summary.txt b/extra/cpu/8080/emulator/summary.txt
new file mode 100644
index 0000000000..083492dfc4
--- /dev/null
+++ b/extra/cpu/8080/emulator/summary.txt
@@ -0,0 +1 @@
+Intel 8080 CPU Emulator
diff --git a/extra/cpu/8080/emulator/tags.txt b/extra/cpu/8080/emulator/tags.txt
new file mode 100644
index 0000000000..86069f7680
--- /dev/null
+++ b/extra/cpu/8080/emulator/tags.txt
@@ -0,0 +1 @@
+emulator
diff --git a/extra/cpu/8080/summary.txt b/extra/cpu/8080/summary.txt
new file mode 100644
index 0000000000..083492dfc4
--- /dev/null
+++ b/extra/cpu/8080/summary.txt
@@ -0,0 +1 @@
+Intel 8080 CPU Emulator
diff --git a/extra/cpu/8080/tags.txt b/extra/cpu/8080/tags.txt
new file mode 100644
index 0000000000..86069f7680
--- /dev/null
+++ b/extra/cpu/8080/tags.txt
@@ -0,0 +1 @@
+emulator
diff --git a/extra/lunar-rescue/lunar-rescue-docs.factor b/extra/lunar-rescue/lunar-rescue-docs.factor
index 7755415b1a..d54fe7d485 100644
--- a/extra/lunar-rescue/lunar-rescue-docs.factor
+++ b/extra/lunar-rescue/lunar-rescue-docs.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup cpu.8080 ;
+USING: help.syntax help.markup cpu.8080.emulator ;
IN: lunar-rescue
HELP: run
From f694a832d51a5c6c6d1c9a4970927a6e20ee2bdd Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Thu, 17 Jan 2008 16:33:11 +1300
Subject: [PATCH 43/65] Fix environment variables and post support in
webapps.cgi
---
extra/webapps/cgi/cgi.factor | 10 ++++++----
1 file changed, 6 insertions(+), 4 deletions(-)
diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor
index 26b8f31eae..950174a831 100644
--- a/extra/webapps/cgi/cgi.factor
+++ b/extra/webapps/cgi/cgi.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs io.files combinators
arrays io.launcher io http.server.responders webapps.file
-sequences strings ;
+sequences strings math.parser ;
IN: webapps.cgi
SYMBOL: cgi-root
@@ -12,6 +12,8 @@ SYMBOL: cgi-root
: cgi-variables ( name -- assoc )
#! This needs some work.
[
+ cgi-root get over path+ "PATH_TRANSLATED" set
+ cgi-root get over path+ "SCRIPT_FILENAME" set
"SCRIPT_NAME" set
"CGI/1.0" "GATEWAY_INTERFACE" set
@@ -29,13 +31,14 @@ SYMBOL: cgi-root
"method" get >upper "REQUEST_METHOD" set
"raw-query" get "QUERY_STRING" set
+ "Cookie" "header" get at "HTTP_COOKIE" set
"User-Agent" header-param "HTTP_USER_AGENT" set
"Accept" header-param "HTTP_ACCEPT" set
post? [
"Content-Type" header-param "CONTENT_TYPE" set
- "raw-response" get length "CONTENT_LENGTH" set
+ "raw-response" get length number>string "CONTENT_LENGTH" set
] when
] H{ } make-assoc ;
@@ -49,8 +52,7 @@ SYMBOL: cgi-root
"200 CGI output follows" response
stdio get swap cgi-descriptor <process-stream> [
post? [
- "raw-response" get
- stream-write stream-flush
+ "raw-response" get write flush
] when
stdio get swap (stream-copy)
] with-stream ;
From c6ed59bd650ec4fee2ffa821855871082f5fe2fb Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Thu, 17 Jan 2008 16:38:35 +1300
Subject: [PATCH 44/65] Use header-param in last webapps.cgi patch
---
extra/webapps/cgi/cgi.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor
index 950174a831..9dd9dca39c 100644
--- a/extra/webapps/cgi/cgi.factor
+++ b/extra/webapps/cgi/cgi.factor
@@ -31,7 +31,7 @@ SYMBOL: cgi-root
"method" get >upper "REQUEST_METHOD" set
"raw-query" get "QUERY_STRING" set
- "Cookie" "header" get at "HTTP_COOKIE" set
+ "Cookie" header-param "HTTP_COOKIE" set
"User-Agent" header-param "HTTP_USER_AGENT" set
"Accept" header-param "HTTP_ACCEPT" set
From b88d219ff632485aa4e37de2f8172c6ff0bf8b10 Mon Sep 17 00:00:00 2001
From: Slava <slava@emu.(none)>
Date: Thu, 17 Jan 2008 04:03:09 -0500
Subject: [PATCH 45/65] Fix x86
---
core/cpu/x86/architecture/architecture.factor | 8 ++++----
core/kernel/kernel-tests.factor | 2 +-
2 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 96b2dcf1ec..cf2f5ee594 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -85,7 +85,7 @@ M: x86-backend %jump-label ( label -- ) JMP ;
M: x86-backend %jump-t ( label -- )
"flag" operand f v>operand CMP JNE ;
-: (%dispatch) ( -- operand )
+: (%dispatch) ( n -- operand )
! Load jump table base. We use a temporary register
! since on AMD64 we have to load a 64-bit immediate. On
! x86, this is redundant.
@@ -94,16 +94,16 @@ M: x86-backend %jump-t ( label -- )
! Add jump table base
"offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
"n" operand "offset" operand ADD
- "n" operand bootstrap-cell 8 = 14 9 ? [+] ;
+ "n" operand swap bootstrap-cell 8 = 14 9 ? + [+] ;
M: x86-backend %call-dispatch ( word-table# -- )
- [ (%dispatch) CALL <label> dup JMP ] H{
+ [ 5 (%dispatch) CALL <label> dup JMP ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;
M: x86-backend %jump-dispatch ( -- )
- [ %epilogue-later (%dispatch) JMP ] H{
+ [ %epilogue-later 0 (%dispatch) JMP ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
} with-template ;
diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor
index 2cb308b619..c294c23738 100755
--- a/core/kernel/kernel-tests.factor
+++ b/core/kernel/kernel-tests.factor
@@ -1,6 +1,6 @@
USING: arrays byte-arrays kernel kernel.private math memory
namespaces sequences tools.test math.private quotations
-continuations prettyprint io.streams.string debugger ;
+continuations prettyprint io.streams.string debugger assocs ;
IN: temporary
[ 0 ] [ f size ] unit-test
From b0944cb3f85915e2b5dc049f2e848cea9f9128f0 Mon Sep 17 00:00:00 2001
From: Slava <slava@emu.(none)>
Date: Thu, 17 Jan 2008 17:19:10 -0500
Subject: [PATCH 46/65] Another cpu.x86 fix
---
core/cpu/x86/architecture/architecture.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index cf2f5ee594..876c631b81 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -100,12 +100,14 @@ M: x86-backend %call-dispatch ( word-table# -- )
[ 5 (%dispatch) CALL <label> dup JMP ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
+ { +clobber+ { "n" } }
} with-template ;
M: x86-backend %jump-dispatch ( -- )
[ %epilogue-later 0 (%dispatch) JMP ] H{
{ +input+ { { f "n" } } }
{ +scratch+ { { f "offset" } } }
+ { +clobber+ { "n" } }
} with-template ;
M: x86-backend %dispatch-label ( word -- )
From 6755e0f7ca7614f932bc17a06e096a9373e42522 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 17 Jan 2008 16:36:25 -0500
Subject: [PATCH 47/65] Fix unit test
---
core/compiler/test/redefine.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor
index 821daef203..4f0c18dfd2 100755
--- a/core/compiler/test/redefine.factor
+++ b/core/compiler/test/redefine.factor
@@ -17,7 +17,7 @@ DEFER: x-2
{ x-1 } compile
- \ x-2 word-xt eq?
+ \ x-2 word-xt =
] unit-test
] with-variable
From 6499fe8f80548e5b605506bf0372dca1cf1179af Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 17 Jan 2008 17:02:26 -0500
Subject: [PATCH 48/65] Fix unit tests again
---
core/compiler/test/redefine.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor
index 4f0c18dfd2..6e652df877 100755
--- a/core/compiler/test/redefine.factor
+++ b/core/compiler/test/redefine.factor
@@ -115,7 +115,7 @@ DEFER: g-test-3
"IN: temporary USE: math GENERIC: g-test-1 ( x -- y ) M: integer g-test-1 3 + ;" eval
- \ g-test-3 word-xt eq?
+ \ g-test-3 word-xt =
] unit-test
DEFER: g-test-5
From b36ab0b0482c079971621e2acf67037883e29745 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 17 Jan 2008 17:55:51 -0500
Subject: [PATCH 49/65] Optimization
---
core/generic/standard/standard.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 851a58ecd6..6cc7f7f3e8 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -139,7 +139,8 @@ TUPLE: no-method object generic ;
M: standard-combination perform-combination
standard-combination-# (dispatch#) [
- standard-methods single-combination
+ [ standard-methods ] keep "inline" word-prop
+ [ small-generic ] [ single-combination ] if
] with-variable ;
: default-hook-method ( word -- pair )
From 1e265b001c85db75a28d50493320eb70e163d45a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 17 Jan 2008 17:55:59 -0500
Subject: [PATCH 50/65] Clean up trees a bit
---
extra/trees/avl/avl.factor | 12 ++----------
extra/trees/splay/splay.factor | 19 ++++---------------
extra/trees/trees.factor | 31 +++++++++++++++++--------------
3 files changed, 23 insertions(+), 39 deletions(-)
diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor
index 0c4bf5af28..a806dafdec 100644
--- a/extra/trees/avl/avl.factor
+++ b/extra/trees/avl/avl.factor
@@ -6,10 +6,10 @@ IN: trees.avl
TUPLE: avl ;
-INSTANCE: avl assoc
+INSTANCE: avl tree-mixin
: <avl> ( -- tree )
- avl construct-empty <tree> over set-delegate ;
+ avl construct-tree ;
TUPLE: avl-node balance ;
@@ -148,11 +148,3 @@ M: avl assoc-like
\ } [ >avl ] parse-literal ; parsing
M: avl pprint-delims drop \ AVL{ \ } ;
-
-! When tuple inheritance is used, the following lines won't be necessary
-M: avl assoc-size tree-count ;
-M: avl clear-assoc delegate clear-assoc ;
-M: avl assoc-find >r tree-root r> find-node ;
-M: avl clone dup assoc-clone-like ;
-M: avl >pprint-sequence >alist ;
-M: avl pprint-narrow? drop t ;
diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor
index 5f7c50cfb2..4fe6fe79a5 100644
--- a/extra/trees/splay/splay.factor
+++ b/extra/trees/splay/splay.factor
@@ -1,5 +1,5 @@
! Copyright (c) 2005 Mackenzie Straight.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces sequences assocs parser
prettyprint.backend trees generic ;
IN: trees.splay
@@ -7,10 +7,9 @@ IN: trees.splay
TUPLE: splay ;
: <splay> ( -- splay-tree )
- \ splay construct-empty
- <tree> over set-delegate ;
+ splay construct-tree ;
-INSTANCE: splay assoc
+INSTANCE: splay tree-mixin
: rotate-right ( node -- node )
dup node-left
@@ -138,16 +137,6 @@ M: splay new-assoc
\ } [ >splay ] parse-literal ; parsing
M: splay assoc-like
- drop dup splay? [
- dup tree? [ <splay> tuck set-delegate ] [ >splay ] if
- ] unless ;
+ drop dup splay? [ >splay ] unless ;
M: splay pprint-delims drop \ SPLAY{ \ } ;
-
-! When tuple inheritance is used, the following lines won't be necessary
-M: splay assoc-size tree-count ;
-M: splay clear-assoc delegate clear-assoc ;
-M: splay assoc-find >r tree-root r> find-node ;
-M: splay clone dup assoc-clone-like ;
-M: splay >pprint-sequence >alist ;
-M: splay pprint-narrow? drop t ;
diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor
index 971c961cbc..6d53d9e541 100644
--- a/extra/trees/trees.factor
+++ b/extra/trees/trees.factor
@@ -5,11 +5,19 @@ prettyprint.private kernel.private assocs random combinators
parser prettyprint.backend ;
IN: trees
+MIXIN: tree-mixin
+
TUPLE: tree root count ;
+
: <tree> ( -- tree )
f 0 tree construct-boa ;
-INSTANCE: tree assoc
+: construct-tree ( class -- tree )
+ construct-empty <tree> over set-delegate ; inline
+
+INSTANCE: tree tree-mixin
+
+INSTANCE: tree-mixin assoc
TUPLE: node key value left right ;
: <node> ( key value -- node )
@@ -111,16 +119,13 @@ M: tree set-at ( value key tree -- )
{ [ t ] [ >r node-right r> find-node ] }
} cond ; inline
-M: tree assoc-find ( tree quot -- key value ? )
+M: tree-mixin assoc-find ( tree quot -- key value ? )
>r tree-root r> find-node ;
-M: tree clear-assoc
+M: tree-mixin clear-assoc
0 over set-tree-count
f swap set-tree-root ;
-M: tree assoc-size
- tree-count ;
-
: copy-node-contents ( new old -- )
dup node-key pick set-node-key node-value swap set-node-value ;
@@ -189,16 +194,14 @@ M: tree clone dup assoc-clone-like ;
: >tree ( assoc -- tree )
T{ tree f f 0 } assoc-clone-like ;
-GENERIC: tree-assoc-like ( assoc -- tree )
-M: tuple tree-assoc-like ! will need changes for tuple inheritance
- dup delegate dup tree? [ nip ] [ drop >tree ] if ;
-M: tree tree-assoc-like ;
-M: assoc tree-assoc-like >tree ;
-M: tree assoc-like drop tree-assoc-like ;
+M: tree-mixin assoc-like drop dup tree? [ >tree ] unless ;
: TREE{
\ } [ >tree ] parse-literal ; parsing
M: tree pprint-delims drop \ TREE{ \ } ;
-M: tree >pprint-sequence >alist ;
-M: tree pprint-narrow? drop t ;
+
+M: tree-mixin assoc-size tree-count ;
+M: tree-mixin clone dup assoc-clone-like ;
+M: tree-mixin >pprint-sequence >alist ;
+M: tree-mixin pprint-narrow? drop t ;
From 22955945263684fb85446c6ec91d707352553cee Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 17 Jan 2008 23:06:32 -0800
Subject: [PATCH 51/65] Remove USE-IF: again
---
core/syntax/syntax-docs.factor | 6 ------
core/syntax/syntax.factor | 1 -
extra/opengl/gl/gl.factor | 5 ++---
3 files changed, 2 insertions(+), 10 deletions(-)
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index f4efc3b6bb..9cf9647e41 100755
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -363,12 +363,6 @@ HELP: USE:
{ $description "Adds a new vocabulary at the front of the search path. Subsequent word lookups by the parser will search this vocabulary first." }
{ $errors "Throws an error if the vocabulary does not exist." } ;
-HELP: USE-IF:
-{ $syntax "USE-IF: word vocabulary" }
-{ $values { "word" "a word with stack effect " { $snippet "( -- ? )" } } { "vocabulary" "a vocabulary name" } }
-{ $description "Adds " { $snippet "vocabulary" } " at the front of the search path if " { $snippet "word" } " evaluates to a true value." }
-{ $errors "Throws an error if the vocabulary does not exist." } ;
-
HELP: USING:
{ $syntax "USING: vocabularies... ;" }
{ $values { "vocabularies" "a list of vocabulary names" } }
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index de627358e4..7616f6e64b 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -46,7 +46,6 @@ IN: bootstrap.syntax
] define-syntax
"USE:" [ scan use+ ] define-syntax
- "USE-IF:" [ scan-word execute scan swap [ use+ ] [ drop ] if ] define-syntax
"USING:" [ ";" parse-tokens add-use ] define-syntax
diff --git a/extra/opengl/gl/gl.factor b/extra/opengl/gl/gl.factor
index 4a9d9c84d5..071fbc45e7 100644
--- a/extra/opengl/gl/gl.factor
+++ b/extra/opengl/gl/gl.factor
@@ -3,9 +3,8 @@
! This file is based on the gl.h that comes with xorg-x11 6.8.2
-USING: alien alien.syntax kernel sequences system words ;
-USE-IF: windows? opengl.gl.windows
-USE-IF: unix? opengl.gl.unix
+USING: alien alien.syntax kernel parser sequences system words ;
+<< windows? "opengl.gl.windows" "opengl.gl.unix" ? use+ >>
IN: opengl.gl
From 08e9503f842a2b89570cfe7476d935d247a1fb74 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 18 Jan 2008 02:39:09 -0500
Subject: [PATCH 52/65] XMode fixes
---
extra/xmode/README.txt | 3 +++
extra/xmode/catalog/catalog.factor | 22 +++++++++++-----------
extra/xmode/marker/context/context.factor | 1 +
extra/xmode/marker/marker-tests.factor | 8 ++++++++
extra/xmode/modes/bcel.xml | 2 +-
extra/xmode/modes/clips.xml | 2 +-
extra/xmode/modes/objective-c.xml | 2 +-
extra/xmode/modes/powerdynamo.xml | 16 ++++++++--------
extra/xmode/modes/rview.xml | 2 +-
extra/xmode/modes/tthtml.xml | 2 +-
10 files changed, 36 insertions(+), 24 deletions(-)
diff --git a/extra/xmode/README.txt b/extra/xmode/README.txt
index 57d9f42b22..07d56dd877 100755
--- a/extra/xmode/README.txt
+++ b/extra/xmode/README.txt
@@ -36,6 +36,9 @@ to depend on:
find a mode file which depends on this flaw, please fix it and submit
the changes to the jEdit project.
+- References to non-existent rule sets in IMPORT tags and DELEGATE
+ attributes were ignored in jEdit. They raise an error in Factor.
+
If you wish to contribute a new or improved mode file, please contact
the jEdit project. Updated mode files in jEdit will be periodically
imported into the Factor source tree.
diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor
index 6a0efa072e..9c7e6a1ee7 100644
--- a/extra/xmode/catalog/catalog.factor
+++ b/extra/xmode/catalog/catalog.factor
@@ -42,9 +42,12 @@ MEMO: (load-mode) ( name -- rule-sets )
SYMBOL: rule-sets
+: no-such-rule-set ( name -- * )
+ "No such rule set: " swap append throw ;
+
: get-rule-set ( name -- rule-sets rules )
- "::" split1 [ swap (load-mode) ] [ rule-sets get ] if*
- tuck at ;
+ dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if*
+ dup -roll at* [ nip ] [ drop no-such-rule-set ] if ;
: resolve-delegate ( rule -- )
dup rule-delegate dup string?
@@ -68,14 +71,11 @@ SYMBOL: rule-sets
: resolve-imports ( ruleset -- )
dup rule-set-imports [
- get-rule-set dup [
- swap rule-sets [
- 2dup import-keywords
- import-rules
- ] with-variable
- ] [
- 3drop
- ] if
+ get-rule-set swap rule-sets [
+ dup resolve-delegates
+ 2dup import-keywords
+ import-rules
+ ] with-variable
] with each ;
: finalize-rule-set ( ruleset -- )
@@ -99,7 +99,7 @@ SYMBOL: rule-sets
(load-mode) dup finalize-mode ;
: reset-modes ( -- )
- \ load-mode "memoize" word-prop clear-assoc ;
+ \ (load-mode) "memoize" word-prop clear-assoc ;
: ?glob-matches ( string glob/f -- ? )
dup [ glob-matches? ] [ 2drop f ] if ;
diff --git a/extra/xmode/marker/context/context.factor b/extra/xmode/marker/context/context.factor
index 8023e1d321..72ac3f2a3f 100644
--- a/extra/xmode/marker/context/context.factor
+++ b/extra/xmode/marker/context/context.factor
@@ -10,6 +10,7 @@ end
;
: <line-context> ( ruleset parent -- line-context )
+ over [ "no context" throw ] unless
{ set-line-context-in-rule-set set-line-context-parent }
line-context construct ;
diff --git a/extra/xmode/marker/marker-tests.factor b/extra/xmode/marker/marker-tests.factor
index b9621a112a..6bcba91c84 100755
--- a/extra/xmode/marker/marker-tests.factor
+++ b/extra/xmode/marker/marker-tests.factor
@@ -133,3 +133,11 @@ IN: temporary
] [
f "font:75%/1.6em \"Lucida Grande\", \"Lucida Sans Unicode\", verdana, geneva, sans-serif;" "css" load-mode tokenize-line 2drop
] unit-test
+
+[
+ {
+ T{ token f "<" MARKUP }
+ T{ token f "aaa" MARKUP }
+ T{ token f ">" MARKUP }
+ }
+] [ f "<aaa>" "html" load-mode tokenize-line nip ] unit-test
diff --git a/extra/xmode/modes/bcel.xml b/extra/xmode/modes/bcel.xml
index 19ab3cfd67..628911f431 100644
--- a/extra/xmode/modes/bcel.xml
+++ b/extra/xmode/modes/bcel.xml
@@ -19,7 +19,7 @@
<SEQ TYPE="COMMENT1">/**/</SEQ>
<!-- Javadoc comment -->
- <SPAN TYPE="COMMENT3" DELEGATE="JAVADOC">
+ <SPAN TYPE="COMMENT3">
<BEGIN>/**</BEGIN>
<END>*/</END>
</SPAN>
diff --git a/extra/xmode/modes/clips.xml b/extra/xmode/modes/clips.xml
index ce2efcabab..51d89d05eb 100644
--- a/extra/xmode/modes/clips.xml
+++ b/extra/xmode/modes/clips.xml
@@ -33,7 +33,7 @@
</SPAN>
<!-- List literals -->
- <SPAN TYPE="LITERAL2" NO_LINE_BREAK="TRUE" DELEGATE="LIST">
+ <SPAN TYPE="LITERAL2" NO_LINE_BREAK="TRUE">
<BEGIN>[</BEGIN>
<END>]</END>
</SPAN>
diff --git a/extra/xmode/modes/objective-c.xml b/extra/xmode/modes/objective-c.xml
index c6c52c8211..7496838938 100644
--- a/extra/xmode/modes/objective-c.xml
+++ b/extra/xmode/modes/objective-c.xml
@@ -89,7 +89,7 @@
<EOL_SPAN_REGEXP HASH_CHAR="elif" TYPE="MARKUP" DELEGATE="c::CONDITION">elif\b</EOL_SPAN_REGEXP>
<EOL_SPAN_REGEXP HASH_CHAR="if" TYPE="MARKUP" DELEGATE="c::CONDITION">if\b</EOL_SPAN_REGEXP>
- <IMPORT DELEGATE="LEX"/>
+ <IMPORT DELEGATE="c::LEX"/>
<!-- Directives -->
<KEYWORDS>
diff --git a/extra/xmode/modes/powerdynamo.xml b/extra/xmode/modes/powerdynamo.xml
index 7babf3dc74..f5eb29e49c 100644
--- a/extra/xmode/modes/powerdynamo.xml
+++ b/extra/xmode/modes/powerdynamo.xml
@@ -200,11 +200,11 @@ for the other tags (data, document, etc). more support planned for future.
<END>*/</END>
</SPAN>
- <SPAN TYPE="LITERAL1" DELEGATE="powerdynamo_LITERAL">
+ <SPAN TYPE="LITERAL1">
<BEGIN>"</BEGIN>
<END>"</END>
</SPAN>
- <SPAN TYPE="LITERAL1" DELEGATE="powerdynamo_LITERAL">
+ <SPAN TYPE="LITERAL1">
<BEGIN>'</BEGIN>
<END>'</END>
</SPAN>
@@ -413,11 +413,11 @@ for the other tags (data, document, etc). more support planned for future.
</RULES>
<RULES IGNORE_CASE="TRUE" SET="powerdynamo-tag-general">
- <SPAN TYPE="LITERAL1" DELEGATE="powerdynamo_LITERAL">
+ <SPAN TYPE="LITERAL1">
<BEGIN>"</BEGIN>
<END>"</END>
</SPAN>
- <SPAN TYPE="LITERAL1" DELEGATE="powerdynamo_LITERAL">
+ <SPAN TYPE="LITERAL1">
<BEGIN>'</BEGIN>
<END>'</END>
</SPAN>
@@ -428,11 +428,11 @@ for the other tags (data, document, etc). more support planned for future.
</RULES>
<RULES IGNORE_CASE="TRUE" SET="powerdynamo-tag-data">
- <SPAN TYPE="LITERAL1" DELEGATE="powerdynamo_LITERAL">
+ <SPAN TYPE="LITERAL1">
<BEGIN>"</BEGIN>
<END>"</END>
</SPAN>
- <SPAN TYPE="LITERAL1" DELEGATE="powerdynamo_LITERAL">
+ <SPAN TYPE="LITERAL1">
<BEGIN>'</BEGIN>
<END>'</END>
</SPAN>
@@ -444,11 +444,11 @@ for the other tags (data, document, etc). more support planned for future.
</RULES>
<RULES IGNORE_CASE="TRUE" SET="powerdynamo-tag-document">
- <SPAN TYPE="LITERAL1" DELEGATE="powerdynamo_LITERAL">
+ <SPAN TYPE="LITERAL1">
<BEGIN>"</BEGIN>
<END>"</END>
</SPAN>
- <SPAN TYPE="LITERAL1" DELEGATE="powerdynamo_LITERAL">
+ <SPAN TYPE="LITERAL1">
<BEGIN>'</BEGIN>
<END>'</END>
</SPAN>
diff --git a/extra/xmode/modes/rview.xml b/extra/xmode/modes/rview.xml
index 9747465814..2ca2fdf36a 100644
--- a/extra/xmode/modes/rview.xml
+++ b/extra/xmode/modes/rview.xml
@@ -23,7 +23,7 @@
<SEQ TYPE="COMMENT1">/**/</SEQ>
<!-- Javadoc comment -->
- <SPAN TYPE="COMMENT2" DELEGATE="JAVADOC">
+ <SPAN TYPE="COMMENT2">
<BEGIN>/**</BEGIN>
<END>*/</END>
</SPAN>
diff --git a/extra/xmode/modes/tthtml.xml b/extra/xmode/modes/tthtml.xml
index 24d9667c6c..37bfa2fb17 100644
--- a/extra/xmode/modes/tthtml.xml
+++ b/extra/xmode/modes/tthtml.xml
@@ -101,7 +101,7 @@
HIGHLIGHT_DIGITS="TRUE"
DIGIT_RE="(0x[\p{XDigit}]+[lL]?|[\p{Digit}]+(e[\p{Digit}]*)?[lLdDfF]?)">
- <SPAN TYPE="KEYWORD2" NO_LINE_BREAK="TRUE" DELEGATE="VARIABLE">
+ <SPAN TYPE="KEYWORD2" NO_LINE_BREAK="TRUE">
<BEGIN>${</BEGIN>
<END>}</END>
</SPAN>
From 15fa72da9c3c3e1e12f0fa3a2112300c93393c7b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 18 Jan 2008 02:39:24 -0500
Subject: [PATCH 53/65] No point having get/set-global inline
---
core/namespaces/namespaces.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor
index bac6895b62..3d3d3c554b 100644
--- a/core/namespaces/namespaces.factor
+++ b/core/namespaces/namespaces.factor
@@ -15,16 +15,16 @@ IN: namespaces
PRIVATE>
: namespace ( -- namespace ) namestack* peek ;
-: namestack ( -- namestack ) namestack* clone ; inline
-: set-namestack ( namestack -- ) >vector 0 setenv ; inline
+: namestack ( -- namestack ) namestack* clone ;
+: set-namestack ( namestack -- ) >vector 0 setenv ;
: global ( -- g ) 21 getenv { hashtable } declare ; inline
: init-namespaces ( -- ) global 1array set-namestack ;
: get ( variable -- value ) namestack* assoc-stack ; flushable
: set ( value variable -- ) namespace set-at ;
: on ( variable -- ) t swap set ; inline
: off ( variable -- ) f swap set ; inline
-: get-global ( variable -- value ) global at ; inline
-: set-global ( value variable -- ) global set-at ; inline
+: get-global ( variable -- value ) global at ;
+: set-global ( value variable -- ) global set-at ;
: change ( variable quot -- )
>r dup get r> rot slip set ; inline
From 423b0c469745f88c6641b75ac995261cc5e11eba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 18 Jan 2008 17:09:30 -0500
Subject: [PATCH 54/65] Remove useless optimization
---
core/cpu/architecture/architecture.factor | 10 ++--------
core/cpu/ppc/architecture/architecture.factor | 14 +-------------
core/cpu/x86/architecture/architecture.factor | 10 +---------
core/generator/generator.factor | 17 +++--------------
4 files changed, 7 insertions(+), 44 deletions(-)
diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor
index e48ba97f33..4da22ff38a 100755
--- a/core/cpu/architecture/architecture.factor
+++ b/core/cpu/architecture/architecture.factor
@@ -51,14 +51,8 @@ HOOK: %save-dispatch-xt compiler-backend ( -- )
M: object %save-dispatch-xt %save-word-xt ;
-! Call C primitive
-HOOK: %call-primitive compiler-backend ( label -- )
-
-! Call another label
-HOOK: %call-label compiler-backend ( label -- )
-
-! Far jump to C primitive
-HOOK: %jump-primitive compiler-backend ( label -- )
+! Call another word
+HOOK: %call compiler-backend ( word -- )
! Local jump for branches
HOOK: %jump-label compiler-backend ( label -- )
diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor
index edbed571e1..7444c21a8c 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/core/cpu/ppc/architecture/architecture.factor
@@ -97,26 +97,14 @@ M: ppc-backend %epilogue ( n -- )
1 1 rot ADDI
0 MTLR ;
-: %prepare-primitive ( word -- )
- #! Save stack pointer to stack_chain->callstack_top, load XT
- 4 1 MR
- 0 11 LOAD32
- rc-absolute-ppc-2/2 rel-primitive ;
-
: (%call) 11 MTLR BLRL ;
-M: ppc-backend %call-primitive ( word -- )
- %prepare-primitive (%call) ;
-
: (%jump) 11 MTCTR BCTR ;
-M: ppc-backend %jump-primitive ( word -- )
- %prepare-primitive (%jump) ;
-
: %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
-M: ppc-backend %call-label ( label -- ) BL ;
+M: ppc-backend %call ( label -- ) BL ;
M: ppc-backend %jump-label ( label -- ) B ;
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 876c631b81..8c5d5c1dc0 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/core/cpu/x86/architecture/architecture.factor
@@ -70,15 +70,7 @@ M: x86-backend %prepare-alien-invoke
temp-reg v>operand 2 cells [+] ds-reg MOV
temp-reg v>operand 3 cells [+] rs-reg MOV ;
-M: x86-backend %call-primitive ( word -- )
- stack-save-reg stack-reg cell neg [+] LEA
- address-operand CALL ;
-
-M: x86-backend %jump-primitive ( word -- )
- stack-save-reg stack-reg MOV
- address-operand JMP ;
-
-M: x86-backend %call-label ( label -- ) CALL ;
+M: x86-backend %call ( label -- ) CALL ;
M: x86-backend %jump-label ( label -- ) JMP ;
diff --git a/core/generator/generator.factor b/core/generator/generator.factor
index df01f9e490..0e499cf90f 100755
--- a/core/generator/generator.factor
+++ b/core/generator/generator.factor
@@ -100,21 +100,10 @@ UNION: #terminal
! node
M: node generate-node drop iterate-next ;
-: %call ( word -- )
- dup primitive? [ %call-primitive ] [ %call-label ] if ;
-
: %jump ( word -- )
- {
- { [ dup compiling-label get eq? ] [
- drop current-label-start get %jump-label
- ] }
- { [ dup primitive? ] [
- %epilogue-later %jump-primitive
- ] }
- { [ t ] [
- %epilogue-later %jump-label
- ] }
- } cond ;
+ dup compiling-label get eq?
+ [ drop current-label-start get ] [ %epilogue-later ] if
+ %jump-label ;
: generate-call ( label -- next )
dup maybe-compile
From 011681f07ab08c0425e398bda93000f6fca3aef2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 18 Jan 2008 17:09:45 -0500
Subject: [PATCH 55/65] Fix construct-empty transform
---
.../transforms/transforms-tests.factor | 4 ++-
core/inference/transforms/transforms.factor | 26 +++++++++++++------
2 files changed, 21 insertions(+), 9 deletions(-)
diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor
index 6dc5bcabcd..9a62a1faca 100644
--- a/core/inference/transforms/transforms-tests.factor
+++ b/core/inference/transforms/transforms-tests.factor
@@ -1,6 +1,6 @@
IN: temporary
USING: sequences inference.transforms tools.test math kernel
-quotations ;
+quotations tools.test.inference ;
: compose-n-quot <repetition> >quotation ;
: compose-n compose-n-quot call ;
@@ -18,3 +18,5 @@ quotations ;
[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
+
+\ construct-empty must-infer
diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor
index 62c3129f3a..eabe4b8c2a 100755
--- a/core/inference/transforms/transforms.factor
+++ b/core/inference/transforms/transforms.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
-inference.dataflow inference.state tuples.private ;
+inference.dataflow inference.state tuples.private effects ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )
@@ -61,11 +61,21 @@ M: pair (bitfield-quot) ( spec -- quot )
\ set-slots [ <reversed> [get-slots] ] 1 define-transform
-: [construct] ( word quot -- newquot )
- >r dup +inlined+ depends-on dup tuple-size r> 2curry ;
+\ construct-boa [
+ dup +inlined+ depends-on
+ dup tuple-size [ <tuple-boa> ] 2curry
+] 1 define-transform
-\ construct-boa
-[ [ <tuple-boa> ] [construct] ] 1 define-transform
+\ construct-empty [
+ 1 ensure-values
+ peek-d value? [
+ pop-literal
+ dup +inlined+ depends-on
+ dup tuple-size [ <tuple> ] 2curry
+ swap infer-quot
+ ] [
+ \ construct-empty declared-infer
+ ] if
+] "infer" set-word-prop
-\ construct-empty
-[ [ <tuple> ] [construct] ] 1 define-transform
+\ construct-empty 1 1 <effect> "inferred-effect" set-word-prop
From 30dec8b0a886eea7e9f833d3eda019ec3750f3e3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 18 Jan 2008 17:09:55 -0500
Subject: [PATCH 56/65] Fix documentation typos
---
core/kernel/kernel-docs.factor | 2 +-
extra/io/launcher/launcher-docs.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 8f0e4efbd9..2301216394 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -557,7 +557,7 @@ HELP: dip
HELP: while
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
-{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
+{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "body" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
{ $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used."
$nl
"Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:"
diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor
index 99f318eaf4..7ad5e064bf 100755
--- a/extra/io/launcher/launcher-docs.factor
+++ b/extra/io/launcher/launcher-docs.factor
@@ -85,7 +85,7 @@ HELP: run-detached
HELP: <process-stream>
{ $values { "obj" object } { "stream" "a bidirectional stream" } }
-{ $description "Launches a process and redirects its input and output via a paper of pipes which may be read and written as a stream." }
+{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream." }
{ $notes "Closing the stream will block until the process exits." } ;
{ run-process run-detached <process-stream> } related-words
From 5c388404d6e061a1d6b4894e12560b010fe5b2f1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 18 Jan 2008 17:10:08 -0500
Subject: [PATCH 57/65] Fix sha1
---
extra/benchmark/sha1/sha1.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/benchmark/sha1/sha1.factor b/extra/benchmark/sha1/sha1.factor
index 614077c673..897d83ea0e 100644
--- a/extra/benchmark/sha1/sha1.factor
+++ b/extra/benchmark/sha1/sha1.factor
@@ -1,7 +1,7 @@
USING: crypto.sha1 io.files kernel ;
IN: benchmark.sha1
-: sha1-primes-list ( -- seq )
- "extra/math/primes/list/list.factor" resource-path file>sha1 ;
+: sha1-primes-list ( -- )
+ "extra/math/primes/list/list.factor" resource-path file>sha1 drop ;
MAIN: sha1-primes-list
From 588253dfe3f9c042c1522b2b8174236b63f6ad97 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 18 Jan 2008 18:18:54 -0500
Subject: [PATCH 58/65] Cleaning up Unix I/O
---
extra/io/unix/backend/backend.factor | 127 +++++++++------------
extra/io/unix/backend/select/select.factor | 53 +++++++++
extra/io/unix/sockets/sockets.factor | 20 ++--
extra/unix/kqueue/kqueue.factor | 73 ++++++++++++
4 files changed, 188 insertions(+), 85 deletions(-)
create mode 100644 extra/io/unix/backend/select/select.factor
create mode 100644 extra/unix/kqueue/kqueue.factor
diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor
index 3522a2218b..ec73a5395e 100755
--- a/extra/io/unix/backend/backend.factor
+++ b/extra/io/unix/backend/backend.factor
@@ -1,21 +1,24 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien bit-arrays generic assocs io kernel
-kernel.private math io.nonblocking sequences strings structs
-sbufs threads unix vectors io.buffers io.backend
-io.streams.duplex math.parser continuations system libc ;
+USING: alien generic assocs kernel kernel.private math
+io.nonblocking sequences strings structs sbufs threads unix
+vectors io.buffers io.backend io.streams.duplex math.parser
+continuations system libc qualified namespaces ;
+QUALIFIED: io
IN: io.unix.backend
+! Multiplexer protocol
+SYMBOL: unix-io-backend
+
+HOOK: init-unix-io unix-io-backend ( -- )
+HOOK: register-io-task unix-io-backend ( task -- )
+HOOK: unregister-io-task unix-io-backend ( task -- )
+HOOK: unix-io-multiplex unix-io-backend ( timeval -- )
+
TUPLE: unix-io ;
-! We want namespaces::bind to shadow the bind system call from
-! unix
-USING: namespaces ;
-
! Global variables
-SYMBOL: read-fdset
SYMBOL: read-tasks
-SYMBOL: write-fdset
SYMBOL: write-tasks
! Some general stuff
@@ -53,9 +56,9 @@ M: integer close-handle ( fd -- )
! port to finish I/O
TUPLE: io-task port callbacks ;
-: <io-task> ( port class -- task )
- >r V{ } clone io-task construct-boa
- { set-delegate } r> construct ; inline
+: <io-task> ( port continuation class -- task )
+ >r 1vector io-task construct-boa r> construct-delegate ;
+ inline
! Multiplexer
GENERIC: do-io-task ( task -- ? )
@@ -63,58 +66,30 @@ GENERIC: task-container ( task -- vector )
: io-task-fd io-task-port port-handle ;
-: add-io-task ( callback task -- )
- [ io-task-callbacks push ] keep
- dup io-task-fd over task-container 2dup at [
+: check-io-task ( task -- )
+ dup io-task-fd swap task-container at [
"Cannot perform multiple reads from the same port" throw
- ] when set-at ;
+ ] when ;
+
+: add-io-task ( task -- )
+ dup check-io-task
+ dup register-io-task
+ dup io-task-fd over task-container set-at ;
: remove-io-task ( task -- )
- dup io-task-fd swap task-container delete-at ;
+ dup io-task-fd over task-container delete-at
+ unregister-io-task ;
: pop-callbacks ( task -- )
- dup io-task-callbacks swap remove-io-task
- [ schedule-thread ] each ;
+ dup remove-io-task
+ io-task-callbacks [ schedule-thread ] each ;
: handle-fd ( task -- )
dup io-task-port touch-port
dup do-io-task [ pop-callbacks ] [ drop ] if ;
-: handle-fdset ( fdset tasks -- )
- swap [
- swap dup io-task-port timeout? [
- dup io-task-port "Timeout" swap report-error
- nip pop-callbacks
- ] [
- tuck io-task-fd swap nth
- [ handle-fd ] [ drop ] if
- ] if drop
- ] curry assoc-each ;
-
-: init-fdset ( fdset tasks -- )
- swap dup clear-bits
- [ >r drop t swap r> set-nth ] curry assoc-each ;
-
-: read-fdset/tasks
- read-fdset get-global read-tasks get-global ;
-
-: write-fdset/tasks
- write-fdset get-global write-tasks get-global ;
-
-: init-fdsets ( -- read write except )
- read-fdset/tasks dupd init-fdset
- write-fdset/tasks dupd init-fdset
- f ;
-
-: (io-multiplex) ( ms -- )
- >r FD_SETSIZE init-fdsets r> make-timeval select 0 < [
- err_no ignorable-error? [ (io-error) ] unless
- ] when ;
-
-M: unix-io io-multiplex ( ms -- )
- (io-multiplex)
- read-fdset/tasks handle-fdset
- write-fdset/tasks handle-fdset ;
+: handle-timeout ( task -- )
+ "Timeout" over io-task-port report-error pop-callbacks ;
! Readers
: reader-eof ( reader -- )
@@ -137,17 +112,18 @@ M: unix-io io-multiplex ( ms -- )
TUPLE: read-task ;
-: <read-task> ( port -- task ) read-task <io-task> ;
+: <read-task> ( port continuation -- task )
+ read-task <io-task> ;
M: read-task do-io-task
io-task-port dup refill
[ [ reader-eof ] [ drop ] if ] keep ;
-M: read-task task-container drop read-tasks get-global ;
+M: read-task task-container
+ drop read-tasks get-global ;
M: input-port (wait-to-read)
- [ swap <read-task> add-io-task stop ] callcc0
- pending-error ;
+ [ <read-task> add-io-task stop ] callcc0 pending-error ;
! Writers
: write-step ( port -- ? )
@@ -156,35 +132,34 @@ M: input-port (wait-to-read)
TUPLE: write-task ;
-: <write-task> ( port -- task ) write-task <io-task> ;
+: <write-task> ( port continuation -- task )
+ write-task <io-task> ;
M: write-task do-io-task
io-task-port dup buffer-empty? over port-error or
[ 0 swap buffer-reset t ] [ write-step ] if ;
-M: write-task task-container drop write-tasks get-global ;
+M: write-task task-container
+ drop write-tasks get-global ;
-: add-write-io-task ( callback task -- )
- dup io-task-fd write-tasks get-global at
- [ io-task-callbacks push ] [ add-io-task ] ?if ;
+: add-write-io-task ( port continuation -- )
+ over port-handle write-tasks get-global at
+ [ io-task-callbacks push drop ]
+ [ <write-task> add-io-task ] if* ;
: (wait-to-write) ( port -- )
- [ swap <write-task> add-write-io-task stop ] callcc0 drop ;
+ [ add-write-io-task stop ] callcc0 drop ;
M: port port-flush ( port -- )
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
-USE: io
+M: unix-io io-multiplex ( ms -- )
+ make-timeval unix-io-multiplex ;
M: unix-io init-io ( -- )
- #! Should only be called on startup. Calling this at any
- #! other time can have unintended consequences.
- global [
- H{ } clone read-tasks set
- FD_SETSIZE 8 * <bit-array> read-fdset set
- H{ } clone write-tasks set
- FD_SETSIZE 8 * <bit-array> write-fdset set
- ] bind ;
+ H{ } clone read-tasks set-global
+ H{ } clone write-tasks set-global
+ init-unix-io ;
M: unix-io init-stdio ( -- )
- 0 1 handle>duplex-stream stdio set-global ;
+ 0 1 handle>duplex-stream io:stdio set-global ;
diff --git a/extra/io/unix/backend/select/select.factor b/extra/io/unix/backend/select/select.factor
new file mode 100644
index 0000000000..255010bff6
--- /dev/null
+++ b/extra/io/unix/backend/select/select.factor
@@ -0,0 +1,53 @@
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel io.nonblocking io.unix.backend
+bit-arrays sequences assocs unix math namespaces ;
+IN: io.unix.backend.select
+
+TUPLE: unix-select-io ;
+
+! Global variables
+SYMBOL: read-fdset
+SYMBOL: write-fdset
+
+M: unix-select-io init-unix-io ( -- )
+ FD_SETSIZE 8 * <bit-array> read-fdset set-global
+ FD_SETSIZE 8 * <bit-array> write-fdset set-global ;
+
+: handle-fdset ( fdset tasks -- )
+ swap [
+ swap dup io-task-port timeout? [
+ nip handle-timeout
+ ] [
+ tuck io-task-fd swap nth
+ [ handle-fd ] [ drop ] if
+ ] if drop
+ ] curry assoc-each ;
+
+: init-fdset ( fdset tasks -- )
+ swap dup clear-bits
+ [ >r drop t swap r> set-nth ] curry assoc-each ;
+
+: read-fdset/tasks
+ read-fdset get-global read-tasks get-global ;
+
+: write-fdset/tasks
+ write-fdset get-global write-tasks get-global ;
+
+: init-fdsets ( -- read write except )
+ read-fdset/tasks dupd init-fdset
+ write-fdset/tasks dupd init-fdset
+ f ;
+
+M: unix-select-io register-io-task ( task -- ) drop ;
+
+M: unix-select-io unregister-io-task ( task -- ) drop ;
+
+M: unix-select-io unix-io-multiplex ( timeval -- )
+ >r FD_SETSIZE init-fdsets r> select 0 < [
+ err_no ignorable-error? [ (io-error) ] unless
+ ] when
+ read-fdset/tasks handle-fdset
+ write-fdset/tasks handle-fdset ;
+
+T{ unix-select-io } unix-io-backend set-global
diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor
index 0787a1afde..30d3bbd94c 100644
--- a/extra/io/unix/sockets/sockets.factor
+++ b/extra/io/unix/sockets/sockets.factor
@@ -33,7 +33,8 @@ M: unix-io addrinfo-error ( n -- )
TUPLE: connect-task ;
-: <connect-task> ( port -- task ) connect-task <io-task> ;
+: <connect-task> ( port continuation -- task )
+ connect-task <io-task> ;
M: connect-task do-io-task
io-task-port dup port-handle f 0 write
@@ -42,7 +43,7 @@ M: connect-task do-io-task
M: connect-task task-container drop write-tasks get-global ;
: wait-to-connect ( port -- )
- [ swap <connect-task> add-io-task stop ] callcc0 drop ;
+ [ <connect-task> add-io-task stop ] callcc0 drop ;
M: unix-io (client) ( addrspec -- stream )
dup make-sockaddr/size >r >r
@@ -66,7 +67,8 @@ USE: unix
TUPLE: accept-task ;
-: <accept-task> ( port -- task ) accept-task <io-task> ;
+: <accept-task> ( port continuation -- task )
+ accept-task <io-task> ;
M: accept-task task-container drop read-tasks get ;
@@ -85,7 +87,7 @@ M: accept-task do-io-task
over 0 >= [ do-accept t ] [ 2drop defer-error ] if ;
: wait-to-accept ( server -- )
- [ swap <accept-task> add-io-task stop ] callcc0 drop ;
+ [ <accept-task> add-io-task stop ] callcc0 drop ;
USE: io.sockets
@@ -136,7 +138,8 @@ packet-size <byte-array> receive-buffer set-global
TUPLE: receive-task ;
-: <receive-task> ( stream -- task ) receive-task <io-task> ;
+: <receive-task> ( stream continuation -- task )
+ receive-task <io-task> ;
M: receive-task do-io-task
io-task-port
@@ -152,7 +155,7 @@ M: receive-task do-io-task
M: receive-task task-container drop read-tasks get ;
: wait-receive ( stream -- )
- [ swap <receive-task> add-io-task stop ] callcc0 drop ;
+ [ <receive-task> add-io-task stop ] callcc0 drop ;
M: unix-io receive ( datagram -- packet addrspec )
dup check-datagram-port
@@ -166,7 +169,7 @@ M: unix-io receive ( datagram -- packet addrspec )
TUPLE: send-task packet sockaddr len ;
-: <send-task> ( packet sockaddr len port -- task )
+: <send-task> ( packet sockaddr len stream continuation -- task )
send-task <io-task> [
{
set-send-task-packet
@@ -185,8 +188,7 @@ M: send-task do-io-task
M: send-task task-container drop write-tasks get ;
: wait-send ( packet sockaddr len stream -- )
- [ >r <send-task> r> swap add-io-task stop ] callcc0
- 2drop 2drop ;
+ [ <send-task> add-io-task stop ] callcc0 2drop 2drop ;
M: unix-io send ( packet addrspec datagram -- )
3dup check-datagram-send
diff --git a/extra/unix/kqueue/kqueue.factor b/extra/unix/kqueue/kqueue.factor
new file mode 100644
index 0000000000..4e6504470d
--- /dev/null
+++ b/extra/unix/kqueue/kqueue.factor
@@ -0,0 +1,73 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax ;
+IN: unix.kqueue
+
+FUNCTION: int kqueue ( ) ;
+
+FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;
+
+C-STRUCT: kevent
+ { "ulong" "ident" } ! identifier for this event
+ { "short" "filter" } ! filter for event
+ { "ushort" "flags" } ! action flags for kqueue
+ { "uint" "fflags" } ! filter flag value
+ { "long" "data" } ! filter data value
+ { "void*" "udata" } ! opaque user data identifier
+;
+
+: EVFILT_READ -1 ; inline
+: EVFILT_WRITE -2 ; inline
+: EVFILT_AIO -3 ; inline ! attached to aio requests
+: EVFILT_VNODE -4 ; inline ! attached to vnodes
+: EVFILT_PROC -5 ; inline ! attached to struct proc
+: EVFILT_SIGNAL -6 ; inline ! attached to struct proc
+: EVFILT_TIMER -7 ; inline ! timers
+: EVFILT_MACHPORT -8 ; inline ! Mach ports
+: EVFILT_FS -9 ; inline ! Filesystem events
+
+! actions
+: EV_ADD HEX: 1 ; inline ! add event to kq (implies enable)
+: EV_DELETE HEX: 2 ; inline ! delete event from kq
+: EV_ENABLE HEX: 4 ; inline ! enable event
+: EV_DISABLE HEX: 8 ; inline ! disable event (not reported)
+
+! flags
+: EV_ONESHOT HEX: 10 ; inline ! only report one occurrence
+: EV_CLEAR HEX: 20 ; inline ! clear event state after reporting
+
+: EV_SYSFLAGS HEX: f000 ; inline ! reserved by system
+: EV_FLAG0 HEX: 1000 ; inline ! filter-specific flag
+: EV_FLAG1 HEX: 2000 ; inline ! filter-specific flag
+
+! returned values
+: EV_EOF HEX: 8000 ; inline ! EOF detected
+: EV_ERROR HEX: 4000 ; inline ! error, data contains errno
+
+: EV_POLL EV_FLAG0 ; inline
+: EV_OOBAND EV_FLAG1 ; inline
+
+: NOTE_LOWAT HEX: 00000001 ; inline ! low water mark
+
+: NOTE_DELETE HEX: 00000001 ; inline ! vnode was removed
+: NOTE_WRITE HEX: 00000002 ; inline ! data contents changed
+: NOTE_EXTEND HEX: 00000004 ; inline ! size increased
+: NOTE_ATTRIB HEX: 00000008 ; inline ! attributes changed
+: NOTE_LINK HEX: 00000010 ; inline ! link count changed
+: NOTE_RENAME HEX: 00000020 ; inline ! vnode was renamed
+: NOTE_REVOKE HEX: 00000040 ; inline ! vnode access was revoked
+
+: NOTE_EXIT HEX: 80000000 ; inline ! process exited
+: NOTE_FORK HEX: 40000000 ; inline ! process forked
+: NOTE_EXEC HEX: 20000000 ; inline ! process exec'd
+: NOTE_PCTRLMASK HEX: f0000000 ; inline ! mask for hint bits
+: NOTE_PDATAMASK HEX: 000fffff ; inline ! mask for pid
+
+: NOTE_SECONDS HEX: 00000001 ; inline ! data is seconds
+: NOTE_USECONDS HEX: 00000002 ; inline ! data is microseconds
+: NOTE_NSECONDS HEX: 00000004 ; inline ! data is nanoseconds
+: NOTE_ABSOLUTE HEX: 00000008 ; inline ! absolute timeout
+
+: NOTE_TRACK HEX: 00000001 ; inline ! follow across forks
+: NOTE_TRACKERR HEX: 00000002 ; inline ! could not track child
+: NOTE_CHILD HEX: 00000004 ; inline ! am a child process
From 309a1c179c6fb745210eb7f92dce8c0a872abcf3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 18 Jan 2008 19:43:14 -0500
Subject: [PATCH 59/65] Add stderr stream; more Unix I/O work
---
core/io/io.factor | 3 +
core/io/streams/c/c.factor | 5 +-
extra/io/unix/backend/backend.factor | 8 ++-
extra/io/unix/backend/kqueue/kqueue.factor | 83 ++++++++++++++++++++++
extra/io/unix/backend/select/select.factor | 5 +-
extra/io/unix/unix.factor | 16 +++--
extra/structs/structs.factor | 1 -
extra/unix/unix.factor | 6 ++
vm/io.c | 5 +-
vm/run.h | 7 +-
10 files changed, 120 insertions(+), 19 deletions(-)
create mode 100644 extra/io/unix/backend/kqueue/kqueue.factor
diff --git a/core/io/io.factor b/core/io/io.factor
index 0336ffda78..56b284eaaf 100755
--- a/core/io/io.factor
+++ b/core/io/io.factor
@@ -35,6 +35,9 @@ GENERIC: stream-write-table ( table-cells style stream -- )
! Default stream
SYMBOL: stdio
+! Default error stream
+SYMBOL: stderr
+
: close ( -- ) stdio get stream-close ;
: readln ( -- str/f ) stdio get stream-readln ;
diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor
index 61eea4ba7b..1dfb89f9c9 100755
--- a/core/io/streams/c/c.factor
+++ b/core/io/streams/c/c.factor
@@ -57,11 +57,12 @@ M: c-reader stream-close
M: object init-io ;
: stdin 11 getenv ;
-
: stdout 12 getenv ;
+: stderr 38 getenv ;
M: object init-stdio
- stdin stdout <duplex-c-stream> stdio set-global ;
+ stdin stdout <duplex-c-stream> stdio set-global
+ stderr <c-writer> stderr set-global ;
M: object io-multiplex (sleep) ;
diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor
index ec73a5395e..f29d71dd86 100755
--- a/extra/io/unix/backend/backend.factor
+++ b/extra/io/unix/backend/backend.factor
@@ -154,7 +154,7 @@ M: port port-flush ( port -- )
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
M: unix-io io-multiplex ( ms -- )
- make-timeval unix-io-multiplex ;
+ unix-io-multiplex ;
M: unix-io init-io ( -- )
H{ } clone read-tasks set-global
@@ -162,4 +162,8 @@ M: unix-io init-io ( -- )
init-unix-io ;
M: unix-io init-stdio ( -- )
- 0 1 handle>duplex-stream io:stdio set-global ;
+ 0 1 handle>duplex-stream io:stdio set-global
+ 2 <writer> io:stderr set-global ;
+
+: multiplexer-error ( n -- )
+ 0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;
diff --git a/extra/io/unix/backend/kqueue/kqueue.factor b/extra/io/unix/backend/kqueue/kqueue.factor
new file mode 100644
index 0000000000..35f2641e00
--- /dev/null
+++ b/extra/io/unix/backend/kqueue/kqueue.factor
@@ -0,0 +1,83 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel io.nonblocking io.unix.backend
+sequences assocs unix unix.kqueue math namespaces ;
+IN: io.unix.backend.kqueue
+
+TUPLE: unix-kqueue-io ;
+
+! Global variables
+SYMBOL: kqueue-fd
+SYMBOL: kqueue-changes
+SYMBOL: kqueue-events
+
+: max-events ( -- n )
+ #! We read up to 256 events at a time. This is an arbitrary
+ #! constant...
+ 256 ; inline
+
+M: unix-kqueue-io init-unix-io ( -- )
+ V{ } clone kqueue-changes set-global
+ max-events "kevent" <c-array> kqueue-events set-global
+ kqueue kqueue-fd dup io-error set-global ;
+
+: add-change ( event -- ) kqueue-changes get-global push ;
+
+: io-task-filter ( task -- n )
+ class {
+ { read-task EVFILT_READ }
+ { accept-task EVFILT_READ }
+ { receive-task EVFILT_READ }
+ { write-task EVFILT_WRITE }
+ { connect-task EVFILT_WRITE }
+ { send-task EVFILT_WRITE }
+ } case ;
+
+: make-kevent ( task -- event )
+ "kevent" <c-object>
+ over io-task-fd over set-kevent-ident
+ over io-task-filter over set-kevent-filter ;
+
+: make-add-kevent ( task -- event )
+ make-kevent
+ EV_ADD over set-kevent-flags ;
+
+: make-delete-kevent ( task -- event )
+ make-kevent
+ EV_DELETE over set-kevent-flags ;
+
+M: unix-select-io register-io-task ( task -- )
+ make-add-kevent add-change ;
+
+M: unix-select-io unregister-io-task ( task -- )
+ make-delete-kevent add-change ;
+
+: kqueue-changelist ( -- byte-array n )
+ kqueue-changes get-global
+ dup concat f like over length rot delete-all ;
+
+: kqueue-eventlist ( -- byte-array n )
+ kqueue-events get-global max-events ;
+
+: do-kevent ( timespec -- n )
+ >r
+ kqueue-fd get-global
+ kqueue-changelist
+ kqueue-eventlist
+ r> kevent dup multiplexer-error ;
+
+: kevent-task ( kevent -- task )
+ dup kevent-filter {
+ { [ dup EVFILT_READ = ] [ read-tasks ] }
+ { [ dup EVFILT_WRITE = ] [ write-tasks ] }
+ } cond get at ;
+
+: handle-kevents ( n eventlist -- )
+ [ kevent-nth kevent-task handle-fd ] curry each ;
+
+M: unix-select-io unix-io-multiplex ( ms -- )
+ make-timespec
+ do-kevent
+ kqueue-events get-global handle-kevents ;
+
+T{ unix-kqueue-io } unix-io-backend set-global
diff --git a/extra/io/unix/backend/select/select.factor b/extra/io/unix/backend/select/select.factor
index 255010bff6..b132c8b9e8 100644
--- a/extra/io/unix/backend/select/select.factor
+++ b/extra/io/unix/backend/select/select.factor
@@ -44,9 +44,8 @@ M: unix-select-io register-io-task ( task -- ) drop ;
M: unix-select-io unregister-io-task ( task -- ) drop ;
M: unix-select-io unix-io-multiplex ( timeval -- )
- >r FD_SETSIZE init-fdsets r> select 0 < [
- err_no ignorable-error? [ (io-error) ] unless
- ] when
+ make-timeval >r FD_SETSIZE init-fdsets r>
+ select multiplexer-error
read-fdset/tasks handle-fdset
write-fdset/tasks handle-fdset ;
diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor
index 7114f388e0..1c86224433 100755
--- a/extra/io/unix/unix.factor
+++ b/extra/io/unix/unix.factor
@@ -1,9 +1,11 @@
-USE: io.unix.backend
-USE: io.unix.files
-USE: io.unix.sockets
-USE: io.unix.launcher
-USE: io.unix.mmap
-USE: io.backend
-USE: namespaces
+USING: io.unix.backend io.unix.files io.unix.sockets
+io.unix.launcher io.unix.mmap io.backend combinators namespaces
+system vocabs.loader ;
+
+{
+ { [ macosx? ] [ "io.unix.backend.kqueue" ] }
+ { [ bsd? ] [ "io.unix.backend.kqueue" ] }
+ { [ unix? ] [ "io.unix.backend.select" ] }
+} cond require
T{ unix-io } io-backend set-global
diff --git a/extra/structs/structs.factor b/extra/structs/structs.factor
index c0792ed317..f54917dc47 100644
--- a/extra/structs/structs.factor
+++ b/extra/structs/structs.factor
@@ -10,4 +10,3 @@ C-STRUCT: timeval
"timeval" <c-object>
[ set-timeval-usec ] keep
[ set-timeval-sec ] keep ;
-
diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index 94bb598c25..d87e7f885d 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -41,6 +41,12 @@ C-STRUCT: timespec
{ "time_t" "sec" }
{ "long" "nsec" } ;
+: make-timespec ( ms -- timespec )
+ 1000 /mod 1000000 *
+ "timespec" <c-object>
+ [ set-timespec-nsec ] keep
+ [ set-timespec-usec ] keep ;
+
! ! ! Unix constants
! File type
diff --git a/vm/io.c b/vm/io.c
index bc7d057abf..d3a29abe72 100755
--- a/vm/io.c
+++ b/vm/io.c
@@ -13,8 +13,9 @@ normal operation. */
void init_c_io(void)
{
- userenv[IN_ENV] = allot_alien(F,(CELL)stdin);
- userenv[OUT_ENV] = allot_alien(F,(CELL)stdout);
+ userenv[STDIN_ENV] = allot_alien(F,(CELL)stdin);
+ userenv[STDOUT_ENV] = allot_alien(F,(CELL)stdout);
+ userenv[STDERR_ENV] = allot_alien(F,(CELL)stderr);
}
void io_error(void)
diff --git a/vm/run.h b/vm/run.h
index 6f2caa0c14..976fa36337 100755
--- a/vm/run.h
+++ b/vm/run.h
@@ -16,8 +16,8 @@ typedef enum {
OS_ENV, /* operating system name */
ARGS_ENV = 10, /* command line arguments */
- IN_ENV, /* stdin FILE* handle */
- OUT_ENV, /* stdout FILE* handle */
+ STDIN_ENV, /* stdin FILE* handle */
+ STDOUT_ENV, /* stdout FILE* handle */
IMAGE_ENV = 13, /* image path name */
EXECUTABLE_ENV, /* runtime executable path name */
@@ -51,6 +51,9 @@ typedef enum {
STACK_TRACES_ENV = 36,
UNDEFINED_ENV = 37, /* default quotation for undefined words */
+
+ STDERR_ENV = 38, /* stderr FILE* handle */
+
STAGE2_ENV = 39 /* have we bootstrapped? */
} F_ENVTYPE;
From d5257e47b14cb1bd77a8a748ca5ff53a2c7fd4a6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 18 Jan 2008 19:50:18 -0500
Subject: [PATCH 60/65] Fix circularity
---
core/alien/syntax/syntax-docs.factor | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/core/alien/syntax/syntax-docs.factor b/core/alien/syntax/syntax-docs.factor
index 858c3f145e..09169e63b4 100755
--- a/core/alien/syntax/syntax-docs.factor
+++ b/core/alien/syntax/syntax-docs.factor
@@ -1,5 +1,6 @@
-USING: alien alien.c-types alien.structs alien.syntax
-alien.syntax.private help.markup help.syntax ;
+IN: alien.syntax
+USING: alien alien.c-types alien.structs alien.syntax.private
+help.markup help.syntax ;
HELP: DLL"
{ $syntax "DLL\" path\"" }
From 670a28477286dc633771d1dbcbc6389a942765ad Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 18 Jan 2008 19:50:35 -0500
Subject: [PATCH 61/65] Fix stderr
---
core/io/streams/c/c-docs.factor | 15 ++++++++++-----
core/io/streams/c/c.factor | 10 +++++-----
2 files changed, 15 insertions(+), 10 deletions(-)
diff --git a/core/io/streams/c/c-docs.factor b/core/io/streams/c/c-docs.factor
index af8136262a..de8a756f92 100644
--- a/core/io/streams/c/c-docs.factor
+++ b/core/io/streams/c/c-docs.factor
@@ -14,9 +14,10 @@ ARTICLE: "io.streams.c" "ANSI C streams"
{ $subsection fclose }
{ $subsection fgetc }
{ $subsection fread }
-"Two standard file handles:"
-{ $subsection stdin }
-{ $subsection stdout } ;
+"The three standard file handles:"
+{ $subsection stdin-handle }
+{ $subsection stdout-handle }
+{ $subsection stderr-handle } ;
ABOUT: "io.streams.c"
@@ -64,10 +65,14 @@ HELP: fread ( n alien -- str/f )
{ $description "Reads a sequence of characters from a C FILE* handle, and outputs " { $link f } " on end of file." }
{ $errors "Throws an error if the input operation failed." } ;
-HELP: stdin
+HELP: stdin-handle
{ $values { "in" "a C FILE* handle" } }
{ $description "Outputs the console standard input file handle." } ;
-HELP: stdout
+HELP: stdout-handle
{ $values { "out" "a C FILE* handle" } }
{ $description "Outputs the console standard output file handle." } ;
+
+HELP: stderr-handle
+{ $values { "out" "a C FILE* handle" } }
+{ $description "Outputs the console standard error file handle." } ;
diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor
index 1dfb89f9c9..d816e08443 100755
--- a/core/io/streams/c/c.factor
+++ b/core/io/streams/c/c.factor
@@ -56,13 +56,13 @@ M: c-reader stream-close
M: object init-io ;
-: stdin 11 getenv ;
-: stdout 12 getenv ;
-: stderr 38 getenv ;
+: stdin-handle 11 getenv ;
+: stdout-handle 12 getenv ;
+: stderr-handle 38 getenv ;
M: object init-stdio
- stdin stdout <duplex-c-stream> stdio set-global
- stderr <c-writer> stderr set-global ;
+ stdin-handle stdout-handle <duplex-c-stream> stdio set-global
+ stderr-handle <c-writer> <plain-writer> stderr set-global ;
M: object io-multiplex (sleep) ;
From 3f5342890e92f3b07ff713c1eea02f95e47fe19c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 18 Jan 2008 19:50:48 -0500
Subject: [PATCH 62/65] Fix typo
---
extra/unix/unix.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index d87e7f885d..16b279765f 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -45,7 +45,7 @@ C-STRUCT: timespec
1000 /mod 1000000 *
"timespec" <c-object>
[ set-timespec-nsec ] keep
- [ set-timespec-usec ] keep ;
+ [ set-timespec-sec ] keep ;
! ! ! Unix constants
From f138c3675eb7794a198c63c8991d15c8afef7027 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 18 Jan 2008 19:51:01 -0500
Subject: [PATCH 63/65] Fix typo
---
core/kernel/kernel-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 2301216394..f832742034 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -49,7 +49,7 @@ ARTICLE: "basic-combinators" "Basic combinators"
{ $subsection execute }
"These words are used to implement " { $emphasis "combinators" } ", which are words that take code from the stack. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
{ $code
- ": keep ( x quot -- x | quot: x -- )"
+ ": keep ( x quot -- x )"
" over >r call r> ; inline"
}
"Word inlining is documented in " { $link "declarations" } "."
From 8339cb0b4a01447d095797458a464ad3dee2c248 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 18 Jan 2008 20:28:43 -0500
Subject: [PATCH 64/65] Fix for word renaming
---
extra/tools/deploy/shaker/shaker.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index d157571757..fd6c79e5ba 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -11,7 +11,7 @@ IN: tools.deploy.shaker
: show ( msg -- )
#! Use primitives directly so that we can print stuff even
#! after most of the image has been stripped away
- "\r\n" append stdout fwrite stdout fflush ;
+ "\r\n" append stdout-handle fwrite stdout-handle fflush ;
: strip-init-hooks ( -- )
"Stripping startup hooks" show
From 74329237e6d49522ba0c169ca04039e041d02fff Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 18 Jan 2008 20:29:43 -0500
Subject: [PATCH 65/65] kqueue work in progress
---
extra/io/unix/backend/kqueue/kqueue.factor | 67 +++++++++++++++-------
extra/io/unix/unix.factor | 5 +-
2 files changed, 48 insertions(+), 24 deletions(-)
diff --git a/extra/io/unix/backend/kqueue/kqueue.factor b/extra/io/unix/backend/kqueue/kqueue.factor
index 35f2641e00..287b88c1c3 100644
--- a/extra/io/unix/backend/kqueue/kqueue.factor
+++ b/extra/io/unix/backend/kqueue/kqueue.factor
@@ -1,14 +1,16 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel io.nonblocking io.unix.backend
-sequences assocs unix unix.kqueue math namespaces ;
+USING: alien.c-types kernel io.nonblocking io.unix.backend
+io.unix.sockets sequences assocs unix unix.kqueue math
+namespaces classes combinators ;
IN: io.unix.backend.kqueue
TUPLE: unix-kqueue-io ;
! Global variables
SYMBOL: kqueue-fd
-SYMBOL: kqueue-changes
+SYMBOL: kqueue-added
+SYMBOL: kqueue-deleted
SYMBOL: kqueue-events
: max-events ( -- n )
@@ -17,26 +19,43 @@ SYMBOL: kqueue-events
256 ; inline
M: unix-kqueue-io init-unix-io ( -- )
- V{ } clone kqueue-changes set-global
+ H{ } clone kqueue-added set-global
+ H{ } clone kqueue-deleted set-global
max-events "kevent" <c-array> kqueue-events set-global
- kqueue kqueue-fd dup io-error set-global ;
+ kqueue dup io-error kqueue-fd set-global ;
-: add-change ( event -- ) kqueue-changes get-global push ;
+M: unix-kqueue-io register-io-task ( task -- )
+ dup io-task-fd kqueue-added get-global key? [ drop ] [
+ dup io-task-fd kqueue-deleted get-global key? [
+ io-task-fd kqueue-deleted get-global delete-at
+ ] [
+ dup io-task-fd kqueue-added get-global set-at
+ ] if
+ ] if ;
+
+M: unix-kqueue-io unregister-io-task ( task -- )
+ dup io-task-fd kqueue-deleted get-global key? [ drop ] [
+ dup io-task-fd kqueue-added get-global key? [
+ io-task-fd kqueue-added get-global delete-at
+ ] [
+ dup io-task-fd kqueue-deleted get-global set-at
+ ] if
+ ] if ;
: io-task-filter ( task -- n )
class {
- { read-task EVFILT_READ }
- { accept-task EVFILT_READ }
- { receive-task EVFILT_READ }
- { write-task EVFILT_WRITE }
- { connect-task EVFILT_WRITE }
- { send-task EVFILT_WRITE }
+ { read-task [ EVFILT_READ ] }
+ { accept-task [ EVFILT_READ ] }
+ { receive-task [ EVFILT_READ ] }
+ { write-task [ EVFILT_WRITE ] }
+ { connect-task [ EVFILT_WRITE ] }
+ { send-task [ EVFILT_WRITE ] }
} case ;
: make-kevent ( task -- event )
"kevent" <c-object>
over io-task-fd over set-kevent-ident
- over io-task-filter over set-kevent-filter ;
+ swap io-task-filter over set-kevent-filter ;
: make-add-kevent ( task -- event )
make-kevent
@@ -46,15 +65,19 @@ M: unix-kqueue-io init-unix-io ( -- )
make-kevent
EV_DELETE over set-kevent-flags ;
-M: unix-select-io register-io-task ( task -- )
- make-add-kevent add-change ;
+: kqueue-additions ( -- kevents )
+ kqueue-added get-global
+ dup clear-assoc values
+ [ make-add-kevent ] map ;
-M: unix-select-io unregister-io-task ( task -- )
- make-delete-kevent add-change ;
+: kqueue-deletions ( -- kevents )
+ kqueue-deleted get-global
+ dup clear-assoc values
+ [ make-delete-kevent ] map ;
: kqueue-changelist ( -- byte-array n )
- kqueue-changes get-global
- dup concat f like over length rot delete-all ;
+ kqueue-additions kqueue-deletions append
+ dup concat f like swap length ;
: kqueue-eventlist ( -- byte-array n )
kqueue-events get-global max-events ;
@@ -67,15 +90,15 @@ M: unix-select-io unregister-io-task ( task -- )
r> kevent dup multiplexer-error ;
: kevent-task ( kevent -- task )
- dup kevent-filter {
+ dup kevent-ident swap kevent-filter {
{ [ dup EVFILT_READ = ] [ read-tasks ] }
{ [ dup EVFILT_WRITE = ] [ write-tasks ] }
- } cond get at ;
+ } cond nip get at ;
: handle-kevents ( n eventlist -- )
[ kevent-nth kevent-task handle-fd ] curry each ;
-M: unix-select-io unix-io-multiplex ( ms -- )
+M: unix-kqueue-io unix-io-multiplex ( ms -- )
make-timespec
do-kevent
kqueue-events get-global handle-kevents ;
diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor
index 1c86224433..3800008864 100755
--- a/extra/io/unix/unix.factor
+++ b/extra/io/unix/unix.factor
@@ -3,8 +3,9 @@ io.unix.launcher io.unix.mmap io.backend combinators namespaces
system vocabs.loader ;
{
- { [ macosx? ] [ "io.unix.backend.kqueue" ] }
- { [ bsd? ] [ "io.unix.backend.kqueue" ] }
+ ! kqueue is a work in progress
+ ! { [ macosx? ] [ "io.unix.backend.kqueue" ] }
+ ! { [ bsd? ] [ "io.unix.backend.kqueue" ] }
{ [ unix? ] [ "io.unix.backend.select" ] }
} cond require