72/73:\r
\r
-- tuples: gracefully handle changing shape\r
- keep a list of getter/setter words\r
- default constructor\r
- move tuple to generic vocab\r
: define-getter ( offset type name -- )
#! Define a word with stack effect ( alien -- obj ) in the
#! current 'in' vocabulary.
- "in" get create >r
+ create-in >r
[ "getter" get ] bind cons r> swap define-compound ;
: define-setter ( offset type name -- )
#! Define a word with stack effect ( obj alien -- ) in the
#! current 'in' vocabulary.
- "set-" swap cat2 "in" get create >r
+ "set-" swap cat2 create-in >r
[ "setter" get ] bind cons r> swap define-compound ;
: define-field ( offset type name -- offset )
#! Used for C functions that expect you to pass in a struct.
[ <local-alien> ] cons
[ "<" , "struct-name" get , ">" , ] make-string
- "in" get create swap
+ create-in swap
define-compound ;
: define-struct-type ( width -- )
! A simple single-dispatch generic word system.
: predicate-word ( word -- word )
- word-name "?" cat2 "in" get create ;
+ word-name "?" cat2 create-in ;
! Terminology:
! - type: a datatype built in to the runtime, eg fixnum, word
over >r [ single-combination ] \ GENERIC: r> define-generic
define-method ;
-: define-accessor ( word name n -- )
- >r [ >r dup word-name , "-" , r> , ] make-string
- "in" get create r> [ slot ] cons define-tuple-generic ;
-
-: define-mutator ( word name n -- )
- >r [ "set-" , >r dup word-name , "-" , r> , ] make-string
- "in" get create r> [ set-slot ] cons define-tuple-generic ;
-
-: define-field ( word name n -- )
+: accessor-word ( name tuple -- word )
+ [ word-name , "-" , , ] make-string
+ create-in ;
+
+: define-accessor ( tuple name n -- accessor )
+ #! Generic word with a method specializing on the tuple's
+ #! class that reads the right slot.
+ >r over accessor-word r> [ slot ] cons
+ define-tuple-generic ;
+
+: mutator-word ( name tuple -- word )
+ [ "set-" , word-name , "-" , , ] make-string
+ create-in ;
+
+: define-mutator ( word name n -- mutator )
+ #! Generic word with a method specializing on the tuple's
+ #! class that writes to the right slot.
+ >r over mutator-word r> [ set-slot ] cons
+ define-tuple-generic ;
+
+: define-slot ( word name n -- )
over "delegate" = [
pick over "delegate-field" set-word-property
] when
[ swap dup tuple? [ class eq? ] [ 2drop f ] ifte ] cons
define-compound ;
-: define-tuple ( word fields -- )
- 2dup length 1 + "tuple-size" set-word-property
- dup length [ 3 + ] project zip
- [ uncons define-field ] each-with ;
-
: begin-tuple ( word -- )
dup intern-symbol
dup tuple-predicate
dup define-promise
tuple "metaclass" set-word-property ;
+: check-shape ( word slots -- )
+ #! If the new list of slots is different from the previous,
+ #! forget the old definition.
+ >r "use" get search dup [
+ dup "slots" word-property r> = [
+ drop
+ ] [
+ forget
+ ] ifte
+ ] [
+ r> 2drop
+ ] ifte ;
+
+: define-slots ( tuple slots -- )
+ 2dup "slots" set-word-property
+ 2dup length 1 + "tuple-size" set-word-property
+ dup length [ 3 + ] project zip
+ [ uncons define-slot ] each-with ;
+
+: define-tuple ( tuple slots -- )
+ 2dup check-shape
+ >r
+ create-in dup save-location
+ dup begin-tuple
+ r>
+ define-slots ;
+
: TUPLE:
- #! Followed by a tuple name, then field names, then ;
- CREATE dup begin-tuple
+ #! Followed by a tuple name, then slot names, then ;
+ scan
string-mode on
[ string-mode off define-tuple ]
f ; parsing
: constructor-word ( word -- word )
- word-name "<" swap ">" cat3 "in" get create ;
+ word-name "<" swap ">" cat3 create-in ;
: tuple-constructor ( word def -- )
over constructor-word >r
[ swap literal, \ make-tuple , append, ] make-list
r> swap define-compound ;
-: wrapper-constructor ( word -- quot )
- "delegate-field" word-property [ set-slot ] cons
- [ keep ] cons ;
-
-: WRAPPER:
- #! A wrapper is a tuple whose only slot is a delegate slot.
- CREATE dup begin-tuple
- dup [ "delegate" ] define-tuple
- dup wrapper-constructor
- tuple-constructor ; parsing
-
: C:
#! Followed by a tuple name, then constructor code, then ;
#! Constructor code executes with the empty tuple on the
: ansi-attr-string ( string style -- string )
[ ansi-attrs , reset , ] make-string ;
-WRAPPER: ansi-stream
+TUPLE: ansi-stream delegate ;
+C: ansi-stream ( delegate -- stream )
+ [ set-ansi-stream-delegate ] keep ;
M: ansi-stream fwrite-attr ( string style stream -- )
>r [ default-style ] unless* ansi-attr-string r>
call stdio get stream>str
] with-stream ;
-WRAPPER: stdio-stream
+TUPLE: stdio-stream delegate ;
+C: stdio-stream ( delegate -- stream )
+ [ set-stdio-stream-delegate ] keep ;
M: stdio-stream fauto-flush ( -- )
stdio-stream-delegate fflush ;
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004, 2005 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
IN: parser
-USE: errors
-USE: kernel
-USE: lists
-USE: math
-USE: namespaces
-USE: strings
-USE: words
-USE: unparser
+USING: errors kernel lists math namespaces strings words
+unparser ;
! The parser uses a number of variables:
! line - the line being parsed
#! the parser is already line-tokenized.
(until-eol) (until) ;
-: CREATE ( -- word )
- scan "in" get create dup set-word
- dup f "documentation" set-word-property
- dup f "stack-effect" set-word-property
+: save-location ( word -- )
+ #! Remember where this word was defined.
+ dup set-word
dup "line-number" get "line" set-word-property
- dup "col" get "col" set-word-property
- dup "file" get "file" set-word-property ;
+ dup "col" get "col" set-word-property
+ "file" get "file" set-word-property ;
+
+: create-in "in" get create ;
+
+: CREATE ( -- word )
+ scan create-in dup save-location ;
: escape ( ch -- esc )
[
IN: scratchpad
-USING: generic kernel test math ;
+USING: generic kernel test math parser ;
TUPLE: rect x y w h ;
C: rect
TUPLE: quux-tuple ;
C: quux-tuple ;
M: quux-tuple delegation-test drop 4 ;
-WRAPPER: quuux-tuple
+TUPLE: quuux-tuple delegate ;
+C: quuux-tuple
+ [ set-quuux-tuple-delegate ] keep ;
[ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test
TUPLE: quux-tuple-2 ;
C: quux-tuple-2 ;
M: quux-tuple-2 delegation-test-2 drop 4 ;
-WRAPPER: quuux-tuple-2
+TUPLE: quuux-tuple-2 delegate ;
+C: quuux-tuple-2
+ [ set-quuux-tuple-2-delegate ] keep ;
[ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
+
+! Make sure we handle changing shapes!
+
+[
+ 100
+] [
+ TUPLE: point x y ;
+ C: point [ set-point-y ] keep [ set-point-x ] keep ;
+
+ 100 200 <point>
+
+ ! Use eval to sequence parsing explicitly
+ "TUPLE: point y x ;" eval
+
+ point-x
+] unit-test
#! Create a new word in a vocabulary. If the vocabulary
#! already contains the word, the existing instance is
#! returned.
- 2dup (search) [ nip ] [ (create) dup reveal ] ?ifte ;
+ 2dup (search) [
+ nip
+ dup f "documentation" set-word-property
+ dup f "stack-effect" set-word-property
+ ] [
+ (create) dup reveal
+ ] ?ifte ;
: forget ( word -- )
#! Remove a word definition.
projects / factor.git / commitdiff