more parser cleanups; stack inference cleanups

library/compiler/linearizer.factor

@@ -34,6 +34,8 @@ USE: namespaces
 USE: words
 USE: strings
 USE: errors
+USE: prettyprint
+USE: kernel-internals
 
 ! The linear IR is close to assembly language. It also resembles
 ! Forth code in some sense. It exists so that pattern matching
@@ -51,7 +53,7 @@ SYMBOL: #jump ( tail-call )
 SYMBOL: #jump-label ( tail-call )
 SYMBOL: #return-to ( push addr on C stack )
 
-! #dispatch is linearized as #dispatch followed by a #target
+! dispatch is linearized as dispatch followed by a #target
 ! for each dispatch table entry. The linearizer ensures the
 ! correct number of #targets is emitted.
 SYMBOL: #target ( part of jump table )
@@ -127,8 +129,7 @@ SYMBOL: #target ( part of jump table )
 : linearize-ifte ( param -- )
     #! The parameter is a list of two lists, each one a dataflow
     #! IR.
-    uncons car
+    2unlist  <label> [
-    <label> [
         #jump-t swons ,
         (linearize) ( false branch )
         <label> dup #jump-label swons ,
@@ -136,14 +137,14 @@ SYMBOL: #target ( part of jump table )
     swap (linearize) ( true branch )
     label, ( branch target of false branch end ) ;
 
-#ifte [
+\ ifte [
     [ node-param get ] bind linearize-ifte
 ] "linearizer" set-word-property
 
 : dispatch-head ( vtable -- end label/code )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
-    [ #dispatch ] ,
+    [ dispatch ] ,
     <label> ( end label ) swap
     [ <label> dup #target swons ,  cons ] map ;
 
@@ -163,7 +164,7 @@ SYMBOL: #target ( part of jump table )
     #! take in case the top of stack has that type.
     dup check-dispatch dispatch-head dupd dispatch-body label, ;
 
-#dispatch [
+\ dispatch [
     [ node-param get ] bind linearize-dispatch
 ] "linearizer" set-word-property
 

library/compiler/optimizer.factor

@@ -32,6 +32,7 @@ USE: kernel
 USE: inference
 USE: words
 USE: prettyprint
+USE: kernel-internals
 
 ! The optimizer transforms dataflow IR to dataflow IR. Currently
 ! it removes literals that are eventually dropped, and never
@@ -149,11 +150,11 @@ USE: prettyprint
 : branches-call-label? ( label list -- ? )
     [ dupd calls-label? ] some? nip ;
 
-#ifte [
+\ ifte [
     [ node-param get ] bind branches-call-label?
 ] "calls-label" set-word-property
 
-#dispatch [
+\ dispatch [
     [ node-param get ] bind branches-call-label?
 ] "calls-label" set-word-property
 
@@ -169,13 +170,13 @@ USE: prettyprint
     ] extend ,
 ] "kill-node" set-word-property
 
-#ifte [ scan-branches ] "scan-literal" set-word-property
+\ ifte [ scan-branches ] "scan-literal" set-word-property
-#ifte [ can-kill-branches? ] "can-kill" set-word-property
+\ ifte [ can-kill-branches? ] "can-kill" set-word-property
-#ifte [ kill-branches ] "kill-node" set-word-property
+\ ifte [ kill-branches ] "kill-node" set-word-property
 
-#dispatch [ scan-branches ] "scan-literal" set-word-property
+\ dispatch [ scan-branches ] "scan-literal" set-word-property
-#dispatch [ can-kill-branches? ] "can-kill" set-word-property
+\ dispatch [ can-kill-branches? ] "can-kill" set-word-property
-#dispatch [ kill-branches ] "kill-node" set-word-property
+\ dispatch [ kill-branches ] "kill-node" set-word-property
 
 ! Don't care about inputs to recursive combinator calls
 #call-label [ 2drop t ] "can-kill" set-word-property

library/compiler/x86/generator.factor

@@ -84,7 +84,7 @@ USE: words
 
 #return [ drop RET ] "generator" set-word-property
 
-#dispatch [
+\ dispatch [
     #! Compile a piece of code that jumps to an offset in a
     #! jump table indexed by the fixnum at the top of the stack.
     #! The jump table must immediately follow this macro.

library/generic/predicate.factor

@@ -77,7 +77,7 @@ predicate [
     pick "superclass" word-property "predicate" word-property
     [ \ dup , append, , [ drop f ] , \ ifte , ] make-list
     define-compound
-    predicate define-class ;
+    predicate "metaclass" set-word-property ;
 
 : PREDICATE: ( -- class predicate definition )
     #! Followed by a superclass name, then a class name.

library/inference/branches.factor

@@ -222,7 +222,7 @@ SYMBOL: cloned
 : dynamic-ifte ( true false -- )
     #! If branch taken is computed, infer along both paths and
     #! unify.
-    2list >r 1 meta-d get vector-tail* #ifte r>
+    2list >r 1 meta-d get vector-tail* \ ifte r>
     pop-d [
         dup \ general-t cons ,
         \ f cons ,
@@ -246,15 +246,15 @@ SYMBOL: cloned
     dup value-recursion swap literal-value vector>list
     [ over <literal> ] map nip ;
 
+USE: kernel-internals
 : infer-dispatch ( -- )
     #! Infer effects for all branches, unify.
     [ object vector ] ensure-d
     dataflow-drop, pop-d vtable>list
-    >r 1 meta-d get vector-tail* #dispatch r>
+    >r 1 meta-d get vector-tail* \ dispatch r>
     pop-d ( n ) num-types [ dupd cons ] project nip zip
     infer-branches ;
 
-USE: kernel-internals
 \ dispatch [ infer-dispatch ] "infer" set-word-property
 \ dispatch [ [ fixnum vector ] [ ] ]
 "infer-effect" set-word-property

library/inference/dataflow.factor

@@ -49,9 +49,6 @@ SYMBOL: #call ( non-tail call )
 SYMBOL: #call-label
 SYMBOL: #push ( literal )
 
-SYMBOL: #ifte
-SYMBOL: #dispatch
-
 ! This is purely a marker for values we retain after a
 ! conditional. It does not generate code, but merely alerts the
 ! dataflow optimizer to the fact these values must be retained.

library/lists.factor

@@ -172,21 +172,7 @@ M: cons = ( obj cons -- ? )
         ] ifte
     ] ifte ;
 
-: cons-hashcode ( cons count -- hash )
+M: cons hashcode ( cons -- hash ) car hashcode ;
-    dup 0 number= [
-        2drop 0
-    ] [
-        over cons? [
-            1 - >r uncons r> tuck
-            cons-hashcode >r
-            cons-hashcode r>
-            bitxor
-        ] [
-            drop hashcode
-        ] ifte
-    ] ifte ;
-
-M: cons hashcode ( cons -- hash ) 4 cons-hashcode ;
 
 : project ( n quot -- list )
     #! Execute the quotation n times, passing the loop counter

library/syntax/parse-syntax.factor

@@ -2,7 +2,7 @@
 
 ! $Id$
 !
-! Copyright (C) 2004 Slava Pestov.
+! 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:
@@ -117,21 +117,20 @@ USE: unparser
     scan dup "use" cons@ "in" set ; parsing
 
 ! Char literal
-: CHAR: ( -- ) next-word-ch parse-ch swons ; parsing
+: CHAR: ( -- ) 0 scan next-char drop swons ; parsing
 
 ! String literal
-: parse-string ( -- )
+: parse-string ( n str -- n )
-    next-ch dup CHAR: " = [
+    2dup str-nth CHAR: " = [
-        drop
+        drop 1 +
     ] [
-        parse-ch , parse-string
+        [ next-char swap , ] keep parse-string
     ] ifte ;
 
 : "
-    #! Note the ugly hack to carry the new value of 'pos' from
+    "col" [
-    #! the make-string scope up to the original scope.
+        "line" get [ parse-string ] make-string swap
-    [ parse-string "col" get ] make-string
+    ] change swons ; parsing
-    swap "col" set swons ; parsing
 
 ! Comments
 : (

library/syntax/parser.factor

@@ -2,7 +2,7 @@
 
 ! $Id$
 !
-! Copyright (C) 2004 Slava Pestov.
+! 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:
@@ -48,22 +48,6 @@ USE: unparser
 : parsing? ( word -- ? )
     dup word? [ "parsing" word-property ] [ drop f ] ifte ;
 
-: end? ( -- ? )
-    "col" get "line" get str-length >= ;
-
-: (with-parser) ( quot -- )
-    end? [ drop ] [ [ call ] keep (with-parser) ] ifte ;
-
-: with-parser ( text quot -- )
-    #! Keep calling the quotation until we reach the end of the
-    #! input.
-    swap "line" set 0 "col" set
-    (with-parser)
-    "line" off "col" off ;
-
-: ch ( -- ch ) "col" get "line" get str-nth ;
-: advance ( -- ) "col" [ 1 + ] change ;
-
 : skip ( n line quot -- n )
     #! Find the next character that satisfies the quotation,
     #! which should have stack effect ( ch -- ? ).
@@ -80,9 +64,6 @@ USE: unparser
 : skip-blank ( n line -- n )
     [ blank? not ] skip ;
 
-: skip-word ( n line -- n )
-    [ blank? ] skip ;
-
 : denotation? ( ch -- ? )
     #! Hard-coded for now. Make this customizable later.
     #! A 'denotation' is a character that is treated as its
@@ -93,37 +74,35 @@ USE: unparser
     #! Will call the parsing word ".
     "\"" str-contains? ;
 
-: (scan) ( n line -- start end )
+: skip-word ( n line -- n )
-    dup >r skip-blank dup r>
+    2dup str-nth denotation? [
-    2dup str-length < [
+        drop 1 +
-        2dup str-nth denotation? [
-            drop 1 +
-        ] [
-            skip-word
-        ] ifte
     ] [
-        drop
+        [ blank? ] skip
     ] ifte ;
 
+: (scan) ( n line -- start end )
+    [ skip-blank dup ] keep
+    2dup str-length < [ skip-word ] [ drop ] ifte ;
+
 : scan ( -- token )
     "col" get "line" get dup >r (scan) dup "col" set
-    2dup = [
+    2dup = [ r> 3drop f ] [ r> substring ] ifte ;
-        r> 3drop f
-    ] [
-        r> substring
-    ] ifte ;
 
 : scan-word ( -- obj )
     scan dup [
         dup "use" get search [ str>number ] ?unless
     ] when ;
 
+: parse-loop ( -- )
+    scan-word [
+        dup parsing? [ execute ] [ swons ] ifte  parse-loop
+    ] when* ;
+
 : (parse) ( str -- )
-    [
+    "line" set 0 "col" set
-        scan-word [
+    parse-loop
-            dup parsing? [ execute ] [ swons ] ifte
+    "line" off "col" off ;
-        ] when*
-    ] with-parser ;
 
 : parse ( str -- code )
     #! Parse the string into a parse tree that can be executed.
@@ -151,12 +130,6 @@ USE: unparser
     #! the parser is already line-tokenized.
     (until-eol) (until) ;
 
-: next-ch ( -- ch )
-    end? [ "Unexpected EOF" throw ] [ ch advance ] ifte ;
-
-: next-word-ch ( -- ch )
-    "col" get "line" get skip-blank "col" set next-ch ;
-
 : CREATE ( -- word )
     scan "in" get create dup set-word
     dup f "documentation" set-word-property
@@ -165,15 +138,7 @@ USE: unparser
     dup "col"         get "col"  set-word-property
     dup "file"        get "file" set-word-property ;
 
-! \x
+: escape ( ch -- esc )
-: unicode-escape>ch ( -- esc )
-    #! Read \u....
-    next-ch digit> 16 *
-    next-ch digit> + 16 *
-    next-ch digit> + 16 *
-    next-ch digit> + ;
-
-: ascii-escape>ch ( ch -- esc )
     [
         [[ CHAR: e  CHAR: \e ]]
         [[ CHAR: n  CHAR: \n ]]
@@ -184,20 +149,21 @@ USE: unparser
         [[ CHAR: 0  CHAR: \0 ]]
         [[ CHAR: \\ CHAR: \\ ]]
         [[ CHAR: \" CHAR: \" ]]
-    ] assoc ;
+    ] assoc dup [ "Bad escape" throw ] unless ;
 
-: escape ( ch -- esc )
+: next-escape ( n str -- ch n )
-    dup CHAR: u = [
+    2dup str-nth CHAR: u = [
-        drop unicode-escape>ch
+        swap 1 + dup 4 + [ rot substring hex> ] keep
     ] [
-        ascii-escape>ch
+        over 1 + >r str-nth escape r>
     ] ifte ;
 
-: parse-escape ( -- )
+: next-char ( n str -- ch n )
-    next-ch escape dup [ drop "Bad escape" throw ] unless ;
+    2dup str-nth CHAR: \\ = [
-
+        >r 1 + r> next-escape
-: parse-ch ( ch -- ch )
+    ] [
-    dup CHAR: \\ = [ drop parse-escape ] when ;
+        over 1 + >r str-nth r>
+    ] ifte ;
 
 : doc-comment-here? ( parsed -- ? )
     not "in-definition" get and ;

library/test/compiler/linearizer.factor

@@ -0,0 +1,10 @@
+IN: scratchpad
+USE: test
+USE: kernel
+USE: compiler
+USE: inference
+USE: words
+
+: foo [ drop ] each-word ;
+
+[ ] [ \ foo word-parameter dataflow linearize drop ] unit-test

library/test/dataflow.factor

@@ -41,7 +41,7 @@ USE: generic
 ! ] unit-test
 
 [ t ] [
-    #ifte [ [ drop ] [ + ] ifte ] dataflow dataflow-contains-op? >boolean
+    \ ifte [ [ drop ] [ + ] ifte ] dataflow dataflow-contains-op? >boolean
 ] unit-test
 
 : dataflow-consume-d-len ( object -- n )
@@ -55,7 +55,7 @@ USE: generic
 [ t ] [ [ 2 ] dataflow car dataflow-produce-d-len 1 = ] unit-test
 
 : dataflow-ifte-node-consume-d ( list -- node )
-    #ifte swap dataflow-contains-op? car [ node-consume-d get ] bind ;
+    \ ifte swap dataflow-contains-op? car [ node-consume-d get ] bind ;
 
 [ t ] [
     [ [ swap ] [ nip "hi" ] ifte ] dataflow
@@ -64,7 +64,7 @@ USE: generic
 
 ! [ t ] [
 !     [ { [ drop ] [ undefined-method ] [ drop ] [ undefined-method ] } generic ] dataflow
-!     #dispatch swap dataflow-contains-op? car [
+!     \ dispatch swap dataflow-contains-op? car [
 !         node-param get [
 !             [ [ node-param get \ undefined-method = ] bind ] some?
 !         ] some?
@@ -94,6 +94,6 @@ SYMBOL: #test
 ! Somebody (cough) got the order of ifte nodes wrong.
 
 [ t ] [
-    #ifte [ [ 1 ] [ 2 ] ifte ] dataflow dataflow-contains-op? car
+    \ ifte [ [ 1 ] [ 2 ] ifte ] dataflow dataflow-contains-op? car
     [ node-param get ] bind car car [ node-param get ] bind 1 =
 ] unit-test

library/test/parser.factor

@@ -7,52 +7,59 @@ USE: kernel
 USE: generic
 USE: words
 
+[ CHAR: a 1 ]
+[ 0 "abcd" next-char ] unit-test
+
+[ CHAR: \s 6 ]
+[ 1 "\\u0020hello" next-escape ] unit-test
+
+[ CHAR: \n 2 ]
+[ 1 "\\nhello" next-escape ] unit-test
+
+[ CHAR: \s 6 ]
+[ 0 "\\u0020hello" next-char ] unit-test
+
 [ [ 1 [ 2 [ 3 ] 4 ] 5 ] ]
-[ "1\n[\n2\n[\n3\n]\n4\n]\n5" ]
+[ "1\n[\n2\n[\n3\n]\n4\n]\n5" parse ]
-[ parse ]
+unit-test
-test-word
 
 [ [ t t f f ] ]
-[ "t t f f" ]
+[ "t t f f" parse ]
-[ parse ]
+unit-test
-test-word
 
 [ [ "hello world" ] ]
-[ "\"hello world\"" ]
+[ "\"hello world\"" parse ]
-[ parse ]
+unit-test
-test-word
 
 [ [ "\n\r\t\\" ] ]
-[ "\"\\n\\r\\t\\\\\"" ]
+[ "\"\\n\\r\\t\\\\\"" parse ]
-[ parse ]
+unit-test
-test-word
 
 [ "hello world" ]
-[ "IN: scratchpad : hello \"hello world\" ;" ]
+[
-[ parse call "USE: scratchpad hello" eval ]
+    "IN: scratchpad : hello \"hello world\" ;"
-test-word
+    parse call "USE: scratchpad hello" eval
+] unit-test
 
 [ ]
-[ "! This is a comment, people." ]
+[ "! This is a comment, people." parse call ]
-[ parse call ]
+unit-test
-test-word
 
 [ ]
-[ "( This is a comment, people. )" ]
+[ "( This is a comment, people. )" parse call ]
-[ parse call ]
+unit-test
-test-word
 
 ! Test escapes
 
 [ [ " " ] ]
-[ "\"\\u0020\"" ]
+[ "\"\\u0020\"" parse ]
-[ parse ]
+unit-test
-test-word
 
 [ [ "'" ] ]
-[ "\"\\u0027\"" ]
+[ "\"\\u0027\"" parse ]
-[ parse ]
+unit-test
-test-word
+
+[ "\\u123" parse ] unit-test-fails
 
 ! Test improper lists
 

library/test/test.factor

@@ -123,6 +123,7 @@ USE: unparser
             "compiler/ifte"
             "compiler/generic"
             "compiler/bail-out"
+            "compiler/linearizer"
         ] [
             test
         ] each