Add some Huffmanny shorthands for Q:CgOp

sorear · Jul 16, 2010 · 77809fa · 77809fa
1 parent 04a8475
commit 77809fa
Show file tree

Hide file tree

Showing 3 changed files with 38 additions and 20 deletions.
diff --git a/CodeGen.pm b/CodeGen.pm
@@ -255,9 +255,13 @@ use 5.010;
     }
 
     sub lextypes {
-        my ($self, @args) = @_;
+        my ($self, %args) = @_;
         #say STDERR "lextypes: @args";
-        %{ $self->lex2type } = (%{ $self->lex2type }, @args);
+        my $body = $self->body // $self->bodies->[-1];
+        if ($body) {
+            for (keys %args) { $body->lexical->{$_} = 1 }
+        }
+        %{ $self->lex2type } = (%{ $self->lex2type }, %args);
     }
 
     sub rawlexget {

diff --git a/Niecza/Actions.pm b/Niecza/Actions.pm
@@ -550,10 +550,24 @@ sub cgexp__S_quote { my ($cl, $M) = @_;
     $M->{_ast} = $M->{quote}{_ast}->text;
 }
 
+my %opshortcut = (
+    '@',   [ 'fetch' ],
+    'l',   [ 'scopedlex' ],
+    'w',   [ 'wrap' ],
+    'ns',  [ 'newscalar' ],
+    'nsw', [ 'newrwscalar' ],
+    '==',  [ 'compare', '==' ], '!=',  [ 'compare', '!=' ],
+    '>=',  [ 'compare', '>=' ], '<=',  [ 'compare', '<=' ],
+    '<',   [ 'compare', '<' ],  '>',   [ 'compare', '>' ],
+    '+',   [ 'arith', '+' ],    '-',   [ 'arith', '-' ],
+    '*',   [ 'arith', '*' ],    '/',   [ 'arith', '/' ],
+);
+
 sub cgexp__S_op { my ($cl, $M) = @_;
     no strict 'refs';
-    $M->{_ast} = &{'CgOp::' . $M->{cgopname}{_ast}}(
-        map { $_->{_ast} } @{ $M->{cgexp} });
+    my $l = $M->{cgopname}{_ast};
+    my ($op, @p) = @{ $opshortcut{$l} // [ $l ] };
+    $M->{_ast} = &{"CgOp::$op"}(@p, map { $_->{_ast} } @{ $M->{cgexp} });
 }
 
 sub voidmark { my ($cl, $M) = @_;

diff --git a/setting b/setting
@@ -49,35 +49,35 @@ PRE-INIT {
     sub new { Q:CgOp {
         (prog
           (lextypes $pmo DynProtoMetaObject $self DynObject)
-          (lexput 0 $pmo (rawnew DynProtoMetaObject))
-          (lexput 0 $self (rawnew DynObject))
+          (l $pmo  (rawnew DynProtoMetaObject))
+          (l $self (rawnew DynObject))
 
-          (setfield how  (lexget 0 $pmo) (lexget 0 $self))
-          (setfield name (lexget 0 $pmo) (unwrap String (fetch (pos 1))))
+          (setfield how  (l $pmo) (l $self))
+          (setfield name (l $pmo) (unwrap String (@ (pos 1))))
 
-          (setindex meta-object (getfield slots (lexget 0 $self))
-            (newrwscalar (rawnew CLRImportObject (lexget 0 $pmo))))
-          (setfield klass (lexget 0 $self)
-            (getfield klass (cast DynObject (fetch (pos 0)))))
+          (setindex meta-object (getfield slots (l $self))
+            (nsw (rawnew CLRImportObject (l $pmo))))
+          (setfield klass (l $self) (getfield klass
+            (cast DynObject (@ (pos 0)))))
 
-          (newscalar (lexget 0 $self)))
+          (ns (l $self)))
     } }
 
     # $how.push-scope($outer)
     sub push-scope { Q:CgOp {
         (prog (lextypes $df List<Frame>)
-              (lexput 0 $df (getfield def_outers (unwrap DynProtoMetaObject
-                (getattr meta-object (fetch (pos 0))))))
-              (rawcall (lexget 0 $df) Add (unwrap Frame (fetch (pos 1))))
-              (wrap (arith - (int 1) (getfield Count (lexget 0 $df)))))
+              (l $df (getfield def_outers (unwrap DynProtoMetaObject
+                (getattr meta-object (@ (pos 0))))))
+              (rawcall (l $df) Add (unwrap Frame (@ (pos 1))))
+              (w (- (int 1) (getfield Count (l $df)))))
     } }
 
     # $how.add-super($how)
     sub add-super { Q:CgOp { (prog
         (rawcall
           (getfield superclasses (unwrap DynProtoMetaObject
-            (getattr meta-object (fetch (pos 0))))) Add
-          (unwrap DynProtoMetaObject (getattr meta-object (fetch (pos 1)))))
+            (getattr meta-object (@ (pos 0))))) Add
+          (unwrap DynProtoMetaObject (getattr meta-object (@ (pos 1)))))
         (null Variable))
     } }
 
@@ -175,7 +175,7 @@ PRE-INIT {
     sub wrap-dpmo { Q:CgOp {
         (prog
           (lextypes $ch Variable $dp DynProtoMetaObject)
-          (lexput 0 $ch (methodcall (scopedlex ClassHOW) new
+          (lexput 0 $ch (methodcall (l ClassHOW) new
             (wrap (clr_string ""))))
           (lexput 0 $dp (unwrap DynProtoMetaObject (fetch (pos 0))))