From f24721a010715490e0c4be0cf2cdd9c11222281d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 10 Feb 2005 03:35:11 +0000 Subject: [PATCH] tuples gracefully handle changing shape --- TODO.FACTOR.txt | 1 - library/compiler/alien-types.factor | 6 +-- library/generic/generic.factor | 2 +- library/generic/tuple.factor | 75 +++++++++++++++++++---------- library/io/ansi.factor | 4 +- library/io/stdio.factor | 4 +- library/syntax/parser.factor | 55 ++++++--------------- library/test/tuple.factor | 26 ++++++++-- library/vocabularies.factor | 8 ++- 9 files changed, 103 insertions(+), 78 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 95089dffba..0ebe2d393a 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,6 +1,5 @@ 72/73: -- tuples: gracefully handle changing shape - keep a list of getter/setter words - default constructor - move tuple to generic vocab diff --git a/library/compiler/alien-types.factor b/library/compiler/alien-types.factor index a978f30d13..8ccdda177e 100644 --- a/library/compiler/alien-types.factor +++ b/library/compiler/alien-types.factor @@ -53,13 +53,13 @@ namespaces parser strings words ; : 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 ) @@ -78,7 +78,7 @@ namespaces parser strings words ; #! Used for C functions that expect you to pass in a struct. [ ] cons [ "<" , "struct-name" get , ">" , ] make-string - "in" get create swap + create-in swap define-compound ; : define-struct-type ( width -- ) diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 4aed76f502..a7f39e2e72 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -7,7 +7,7 @@ namespaces parser strings words vectors math math-internals ; ! 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 diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index a52b6eb806..7e4eb4f041 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -29,15 +29,27 @@ kernel-internals math hashtables errors vectors ; 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 ; +: accessor-word ( name tuple -- word ) + [ word-name , "-" , , ] make-string + create-in ; -: 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-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 ; -: define-field ( word name n -- ) +: 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 @@ -50,43 +62,54 @@ kernel-internals math hashtables errors vectors ; [ 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 diff --git a/library/io/ansi.factor b/library/io/ansi.factor index 3a47e40ae6..865b6a9e1e 100644 --- a/library/io/ansi.factor +++ b/library/io/ansi.factor @@ -48,7 +48,9 @@ presentation generic ; : 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> diff --git a/library/io/stdio.factor b/library/io/stdio.factor index bf63838666..c016f0018e 100644 --- a/library/io/stdio.factor +++ b/library/io/stdio.factor @@ -29,7 +29,9 @@ SYMBOL: stdio 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 ; diff --git a/library/syntax/parser.factor b/library/syntax/parser.factor index 245087faf6..d1223589a3 100644 --- a/library/syntax/parser.factor +++ b/library/syntax/parser.factor @@ -1,39 +1,8 @@ -! :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 @@ -137,13 +106,17 @@ global [ string-mode off ] bind #! 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 ) [ diff --git a/library/test/tuple.factor b/library/test/tuple.factor index cd2e3ebe5e..eea3af872e 100644 --- a/library/test/tuple.factor +++ b/library/test/tuple.factor @@ -1,5 +1,5 @@ IN: scratchpad -USING: generic kernel test math ; +USING: generic kernel test math parser ; TUPLE: rect x y w h ; C: rect @@ -20,7 +20,9 @@ M: object delegation-test drop 3 ; 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 ] [ delegation-test ] unit-test @@ -28,6 +30,24 @@ GENERIC: delegation-test-2 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 ] [ 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 + + ! Use eval to sequence parsing explicitly + "TUPLE: point y x ;" eval + + point-x +] unit-test diff --git a/library/vocabularies.factor b/library/vocabularies.factor index 55c21d280b..595d20d79b 100644 --- a/library/vocabularies.factor +++ b/library/vocabularies.factor @@ -57,7 +57,13 @@ IN: words USING: hashtables kernel lists namespaces strings ; #! 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.