implement segmap

diff --git a/layout/layout b/layout/layout
index f50d33d94093a8f3ac499c6d62661ae4d71c6d63..bf006ce563070355eb2d4464e1a9f109a0d939e6 100755 (executable)
--- a/layout/layout
+++ b/layout/layout
@@ -194,6 +194,7 @@ our $allwidthmin= allwidth(undef);
 # Data structures:
 #  $ctx->{CmdLog}= undef                  } not in defobj
 #  $ctx->{CmdLog}[]= [ command args ]     } in defobj
+#  $ctx->{Parent}= $parent_ctx or undef
 #  $ctx->{LocsMade}[]{Id}= $id
 #  $ctx->{LocsMade}[]{Neg}= 1 or 0
 #  $ctx->{Loc}{$id}{X}
@@ -213,6 +214,8 @@ our $allwidthmin= allwidth(undef);
 #  $ctx->{SegName}        # initial segment name (at start of object or file)
 #                         #  or nonexistent if in object in unknown segment
 #                         #  may have leading `-'
+#  $ctx->{SegMapN}{$s}= $o
+#  $ctx->{SegMapNM}{$s}= $o
 #  $ctx->{SavedSegment}   # exists iff segment command used, is a $csss
 #  $ctx->{Layer}{Level}
 #  $ctx->{Layer}{Kind}
@@ -427,18 +430,6 @@ sub cva_idstr ($) {
     die "invalid id" unless $sp =~ m/^[a-z][_0-9A-Za-z]*$/;
     return $&;
 }
-sub cva_subsegspec ($) {
-    my ($sp)=@_;
-    die "invalid subsegment spec" unless
-       $sp =~ m,^(\-?)([0-9A-Za-z_]*)(?:/(?:([A-Za-z_]+)(\d+))?)?$,;
-    my ($sign,$segname,$movfeat,$movconf)=($1,$2,$3,$4);
-    $segname= exists $ctx->{SegName} ?
-       $sign.$ctx->{SegName}.$segname
-           : '';
-    $segname =~ s/^\-(.*)\-/$1/;
-    return $segname.'/'.
-       (defined $movfeat ? sprintf "%s%d", $movfeat, $movconf : '');
-}
 sub cva_idex ($) {
     my ($sp)=@_;
     my ($id,$r,$d,$k,$neg,$na,$obj_id,$vflip,$locs);
@@ -1098,10 +1089,14 @@ sub newctx (;$) {
     $ctx= {
        Trans => { X => 0.0, Y => 0.0, A => 0.0, R => 1.0 },
        InRunObj => "",
-       DrawMap => sub { $_[0]; }
+       DrawMap => sub { $_[0]; },
+       SegMapN => { },
+       SegMapNM => { }
        };
-    %{ $ctx->{Layer} }= %{ $ctx_save->{Layer} }
-        if defined $ctx_save;
+    if (defined $ctx_save) {
+       %{ $ctx->{Layer} }= %{ $ctx_save->{Layer} };
+       $ctx->{Parent}= $ctx_save;
+    }
 }
 
 our $defobj_save;
@@ -1150,6 +1145,42 @@ sub cmd__runobj ($) {
     }
 }
 
+sub cva_subsegspec ($) {
+    my ($sp)=@_;
+    die "invalid subsegment spec" unless
+       $sp =~ m,^(\-?)([0-9A-Za-z_]*)(?:/(?:([A-Za-z_]+)(\d+))?)?$,;
+    my ($sign,$segname,$movfeat,$movconf)=($1,$2,$3,$4);
+
+    if (!exists $ctx->{SegName}) {
+       $segname= '';
+       $sign= '';
+    } else {
+       my ($map_ctx);
+       
+       $ctx->{SegName} =~ m/^\-?/ or die;
+       $sign .= $&;
+       $segname= $'.$segname;
+       
+       for ($map_ctx= $ctx;
+            defined $map_ctx;
+            $map_ctx= $map_ctx->{Parent}) {
+           if (defined $movfeat &&
+               exists $map_ctx->{SegMapNM}{"$segname/$movfeat"}) {
+               $movfeat= $map_ctx->{SegMapNM}{"$segname/$movfeat"};
+           }
+           if (exists $map_ctx->{SegMapN}{$segname}) {
+               $map_ctx->{SegMapN}{$segname} =~ m/^\-?/ or die;
+               $sign .= $&;
+               $segname= $';
+           }
+       }
+       $sign =~ s/\-\-//g;
+    }
+
+    return $sign.$segname.'/'.
+       (defined $movfeat ? sprintf "%s%d", $movfeat, $movconf : '');
+}
+
 sub cmd_segment {
     my ($csss,$length);
     $ctx->{SavedSegment}= pop @segments
@@ -1164,6 +1195,37 @@ sub cmd_segment {
     push @segments, $csss;
 }
 
+sub cva_segmap_s {
+    my ($sp) = @_;
+    $sp =~ m,^\w+(?:/[a-zA-Z_]+)?$,
+        or die "invalid (sub)segment mapping S \`$sp'";
+    return $sp;
+}
+
+sub cva_segmap_n {
+    my ($sp) = @_;
+    $sp =~ m,^\-?\w+$, or die "invalid segment mapping N' \`$sp'";
+    return $sp;
+}
+    
+sub cva_segmap_m {
+    my ($sp) = @_;
+    $sp =~ m,^[a-zA-Z_]+$, or die "invalid segment mapping M' \`$sp'";
+    return $sp;
+}
+    
+sub cmd_segmap {
+    my ($s,$d);
+    while (@al) {
+       $s= can(\&cva_segmap_s);
+       if ($s =~ m,/,) {
+           $ctx->{SegMapNM}{$s}= can(\&cva_segmap_m);
+       } else {
+           $ctx->{SegMapN}{$s}= can(\&cva_segmap_n);
+       }
+    }
+}
+
 sub layer_draw ($$) {
     my ($k,$l) = @_;
     my ($eo,$cc, $r);