5.53. Code fragment inliner

Start ocaml section to src/flx_csubst.mli[1 /1 ]
     1: # 4 "./lpsrc/flx_csubst.ipk"
     2: open Flx_types
     3: open Flx_ast
     4: open Flx_ctypes
     5: 
     6: val csubst:
     7:   range_srcref ->
     8:   range_srcref ->
     9:   string ->
    10:   cexpr_t ->      (* value argument 'as is' use $t *)
    11:   cexpr_t list -> (* value arguments as strings *)
    12:   string list -> (* types of value arguments as strings *)
    13:   string ->      (* argument type as string *)
    14:   string ->      (* return type as string *)
    15:   string list -> (* generic arguments as strings *)
    16:   string ->      (* precedence *)
    17:   string ->      (* shape of argument *)
    18:   string list -> (* shape of arguments *)
    19:   string list -> (* display EXCLUDING thread frame *)
    20:   string list -> (* shape of generic type arguments as strings *)
    21:   cexpr_t
    22: 
End ocaml section to src/flx_csubst.mli[1]
Start ocaml section to src/flx_csubst.ml[1 /1 ]
     1: # 27 "./lpsrc/flx_csubst.ipk"
     2: open Flx_types
     3: open Flx_typing
     4: open List
     5: open Flx_util
     6: open Flx_exceptions
     7: open Flx_ctypes
     8: open Flx_cexpr
     9: 
    10: (* substitution encoding:
    11:    $n: n'th component of argument tuple, 1 origin!
    12:    $a: expands to $1, $2, .. $n
    13:    $b: expands to $2, .. $n
    14:    `n: n'th component of argument tuple, reference kind
    15: 
    16:    #x: expands to #x for all 'x' other than those below
    17: 
    18:    #n: type of n'th component of argument tuple (1 origin)
    19:    #0: return type
    20:    @n: reference to shape object
    21: 
    22:    $t: pass a tuple argument 'as a tuple'
    23:    $Tn: pass argument n expanded into an argument list (varargs)
    24:    #t: the type of the argument tuple
    25:    @t: the shape of the argument tuple
    26:    @dn: expands to first n components of display, excluding thread frame
    27: 
    28:    ??: expands to ?
    29:    ?n: the n'th generic type argument ..
    30:    @?n: the n'th generic type argument shape ..
    31:    ?a: expands to ?1,?2, ...
    32: 
    33: *)
    34: 
    35: (* finite state machine states *)
    36: # 85 "./lpsrc/flx_csubst.ipk"
    37: type mode_t =
    38:  | Normal
    39: # 86 "./lpsrc/flx_csubst.ipk"
    40:  | CString
    41: # 86 "./lpsrc/flx_csubst.ipk"
    42:  | CChar
    43: # 86 "./lpsrc/flx_csubst.ipk"
    44:  | CStringBackslash
    45: # 86 "./lpsrc/flx_csubst.ipk"
    46:  | CCharBackslash
    47: # 86 "./lpsrc/flx_csubst.ipk"
    48:  | Dollar
    49: # 86 "./lpsrc/flx_csubst.ipk"
    50:  | Backquote
    51: # 86 "./lpsrc/flx_csubst.ipk"
    52:  | Hash
    53: # 86 "./lpsrc/flx_csubst.ipk"
    54:  | Earhole
    55: # 86 "./lpsrc/flx_csubst.ipk"
    56:  | Quest
    57: # 86 "./lpsrc/flx_csubst.ipk"
    58:  | DollarDigits
    59: # 86 "./lpsrc/flx_csubst.ipk"
    60:  | BackquoteDigits
    61: # 86 "./lpsrc/flx_csubst.ipk"
    62:  | HashDigits
    63: # 86 "./lpsrc/flx_csubst.ipk"
    64:  | EarholeDigits
    65: # 86 "./lpsrc/flx_csubst.ipk"
    66:  | EarholeDisplayDigits
    67: # 86 "./lpsrc/flx_csubst.ipk"
    68:  | EarholeQuestDigits
    69: # 86 "./lpsrc/flx_csubst.ipk"
    70:  | QuestDigits
    71: # 86 "./lpsrc/flx_csubst.ipk"
    72:  | Varargs
    73: # 86 "./lpsrc/flx_csubst.ipk"
    74:  | VarargsDigits
    75: # 86 "./lpsrc/flx_csubst.ipk"
    76:  | DollarDigitsPrec
    77: # 86 "./lpsrc/flx_csubst.ipk"
    78:  | Escape
    79: 
    80: let pr = function
    81:  | Normal -> "Normal"
    82: # 89 "./lpsrc/flx_csubst.ipk"
    83:  | CString -> "CString"
    84: # 89 "./lpsrc/flx_csubst.ipk"
    85:  | CChar -> "CChar"
    86: # 89 "./lpsrc/flx_csubst.ipk"
    87:  | CStringBackslash -> "CStringBackslash"
    88: # 89 "./lpsrc/flx_csubst.ipk"
    89:  | CCharBackslash -> "CCharBackslash"
    90: # 89 "./lpsrc/flx_csubst.ipk"
    91:  | Dollar -> "Dollar"
    92: # 89 "./lpsrc/flx_csubst.ipk"
    93:  | Backquote -> "Backquote"
    94: # 89 "./lpsrc/flx_csubst.ipk"
    95:  | Hash -> "Hash"
    96: # 89 "./lpsrc/flx_csubst.ipk"
    97:  | Earhole -> "Earhole"
    98: # 89 "./lpsrc/flx_csubst.ipk"
    99:  | Quest -> "Quest"
   100: # 89 "./lpsrc/flx_csubst.ipk"
   101:  | DollarDigits -> "DollarDigits"
   102: # 89 "./lpsrc/flx_csubst.ipk"
   103:  | BackquoteDigits -> "BackquoteDigits"
   104: # 89 "./lpsrc/flx_csubst.ipk"
   105:  | HashDigits -> "HashDigits"
   106: # 89 "./lpsrc/flx_csubst.ipk"
   107:  | EarholeDigits -> "EarholeDigits"
   108: # 89 "./lpsrc/flx_csubst.ipk"
   109:  | EarholeDisplayDigits -> "EarholeDisplayDigits"
   110: # 89 "./lpsrc/flx_csubst.ipk"
   111:  | EarholeQuestDigits -> "EarholeQuestDigits"
   112: # 89 "./lpsrc/flx_csubst.ipk"
   113:  | QuestDigits -> "QuestDigits"
   114: # 89 "./lpsrc/flx_csubst.ipk"
   115:  | Varargs -> "Varargs"
   116: # 89 "./lpsrc/flx_csubst.ipk"
   117:  | VarargsDigits -> "VarargsDigits"
   118: # 89 "./lpsrc/flx_csubst.ipk"
   119:  | DollarDigitsPrec -> "DollarDigitsPrec"
   120: # 89 "./lpsrc/flx_csubst.ipk"
   121:  | Escape -> "Escape"
   122: 
   123: let is_idletter ch =
   124:   ch >= '0' && ch <='9' ||
   125:   ch >= 'A' && ch <='Z' ||
   126:   ch >= 'a' && ch <='z' ||
   127:   ch = '_'
   128: 
   129: (* identifier or integer *)
   130: let is_atomic s =
   131:   try
   132:     for i = 0 to String.length s - 1 do
   133:       if not (is_idletter s.[i]) then raise Not_found
   134:     done;
   135:     true
   136:   with Not_found -> false
   137: 
   138: let islower = function | 'a' .. 'z' -> true | _ -> false
   139: 
   140: let csubst sr sr2 ct arg (args:cexpr_t list) typs argtyp retyp gargs prec argshape argshapes display gargshapes =
   141:   (*
   142:   print_endline ("INPUT ct,prec=" ^ ct ^ " is " ^ prec);
   143:   *)
   144:   let ct,prec = Flx_cexpr.genprec ct prec in
   145:   (*
   146:   print_endline ("OUTPUT ct,prec=" ^ ct ^ " is " ^ prec);
   147:   *)
   148:   let n = length args in
   149:   assert (n = length typs);
   150:   (* print_endline ("CSUBST " ^ ct ^ ", count="^si n^", result prec=" ^ prec); *)
   151:   let len = String.length ct in
   152:   let buf = Buffer.create (n * 2 + 20) in
   153:   let bcat s = Buffer.add_string buf s in
   154:   let chcat c = Buffer.add_char buf c in
   155:   let mode = ref Normal in
   156:   let precname = ref "" in
   157:   let digits = ref 0 in
   158:   let serr i msg =
   159:     let spc k = String.make k ' ' in
   160:     clierr2 sr sr2
   161:     (
   162:       "[csubst] " ^ msg ^ " in code fragment \n\"" ^ ct ^
   163:        "\"\n" ^ spc (i+1) ^ "^" ^ "\n" ^ "Column " ^ string_of_int (i+1)
   164:     )
   165:   in
   166:   let rec trans i ch =
   167:     match !mode with
   168:     | Normal ->
   169:       begin match ch with
   170:       | '$' -> mode := Dollar
   171:       | '`' -> mode := Backquote
   172:       | '#' -> mode := Hash
   173:       | '@' -> mode := Earhole
   174:       | '?' -> mode := Quest
   175:       | '\\' -> mode := Escape
   176:       | '"' -> chcat ch; mode := CString
   177:       | '\'' -> chcat ch; mode := CChar
   178:       | _ -> chcat ch
   179:       end
   180: 
   181:     | Escape ->
   182:       chcat ch; mode := Normal
   183: 
   184:     | CString ->
   185:       begin match ch with
   186:       | '"' -> chcat ch; mode := Normal
   187:       | '\\' -> chcat ch; mode := CStringBackslash
   188:       | _ -> chcat ch
   189:       end
   190: 
   191:     | CChar ->
   192:       begin match ch with
   193:       | '\'' -> chcat ch; mode := Normal
   194:       | '\\' -> chcat ch; mode := CCharBackslash
   195:       | _ -> chcat ch
   196:       end
   197: 
   198:     | CStringBackslash ->
   199:       chcat ch;
   200:       mode := CString
   201: 
   202:     | CCharBackslash ->
   203:       chcat ch;
   204:       mode := CChar
   205: 
   206:     | Dollar ->
   207:       begin match ch with
   208:       | 'a' ->
   209:         bcat (catmap ", " string_of_cexpr args);
   210:         mode := Normal
   211: 
   212:       | 'b' ->
   213:         bcat (catmap ", " string_of_cexpr (List.tl args));
   214:         mode := Normal
   215: 
   216:       | 't' ->
   217:         bcat (string_of_cexpr arg);
   218:         (*
   219:         bcat ( argtyp ^ "(" ^ catmap "," string_of_cexpr args ^ ")");
   220:         *)
   221:         mode := Normal
   222: 
   223:       | 'T' ->
   224:         mode := Varargs
   225: 
   226:       | '0' .. '9' ->
   227:         digits := Char.code ch - Char.code '0';
   228:         mode := DollarDigits
   229: 
   230:       | _ -> serr i "Expected 't' or digit after $"
   231:       end
   232: 
   233:     | Varargs ->
   234:       begin match ch with
   235:       | '0' .. '9' ->
   236:         digits := Char.code ch - Char.code '0';
   237:         mode := VarargsDigits
   238: 
   239:       | _ -> serr i "Expected digits after $T"
   240:       end
   241: 
   242:     | Backquote ->
   243:       begin match ch with
   244:       | '0' .. '9' ->
   245:         digits := Char.code ch - Char.code '0';
   246:         mode := BackquoteDigits
   247: 
   248:       | _ -> serr i "Expected digit after `"
   249:       end
   250: 
   251:     | Quest ->
   252:       begin match ch with
   253:       | '?' ->
   254:         chcat '?';
   255:         mode := Normal
   256: 
   257:       | '0' .. '9' ->
   258:         digits := Char.code ch - Char.code '0';
   259:         mode := QuestDigits
   260: 
   261:       | 'a' ->
   262:         bcat ( cat "," gargs);
   263:         mode := Normal
   264: 
   265:       | _ -> serr i "Expected '?a' or digit after ?"
   266:       end
   267: 
   268:     | Earhole ->
   269:       begin match ch with
   270:       | 't' ->
   271:         bcat ( argshape );
   272:         mode := Normal
   273: 
   274:       | 'd' ->
   275:         digits := 0;
   276:         mode := EarholeDisplayDigits
   277: 
   278:      | '?' ->
   279:         digits := 0;
   280:         mode := EarholeQuestDigits
   281: 
   282:       | '0' .. '9' ->
   283:         digits := Char.code ch - Char.code '0';
   284:         mode := EarholeDigits
   285: 
   286:       | _ -> serr i "Expected 't' or digit after @"
   287:       end
   288: 
   289:     | EarholeDisplayDigits ->
   290:       begin match ch with
   291:       | '0' .. '9' ->
   292:         digits := Char.code ch - Char.code '0'
   293: 
   294:       | _ ->
   295:         let d = String.concat "," (list_prefix display !digits) in
   296:         bcat d;
   297:         mode := Normal;
   298:         trans i ch
   299:       end
   300: 
   301:     | EarholeQuestDigits ->
   302:       begin match ch with
   303:       | '0' .. '9' ->
   304:         digits := Char.code ch - Char.code '0'
   305: 
   306:       | _ ->
   307:         if !digits> List.length gargs
   308:         then serr i ("Generic type parameter ?" ^ string_of_int !digits ^ " too large")
   309:         else if !digits<1 then serr i ("Generic type arg no " ^ string_of_int !digits ^ " too small")
   310:         else
   311:           bcat
   312:           (
   313:             nth gargshapes (!digits-1)
   314:           );
   315:         mode := Normal;
   316:         trans i ch
   317:       end
   318: 
   319:     | Hash ->
   320:       begin match ch with
   321:       | 't' ->
   322:         bcat argtyp;
   323:         mode := Normal
   324: 
   325:       | '0' .. '9' ->
   326:         digits := Char.code ch - Char.code '0';
   327:         mode := HashDigits
   328: 
   329:       | x -> chcat '#'; chcat x; mode:= Normal
   330:       end
   331: 
   332:     | DollarDigits ->
   333:       begin match ch with
   334:       | '0' .. '9' ->
   335:         digits := !digits * 10 + Char.code ch - Char.code '0'
   336: 
   337:       | ':' when i+1<len && islower (ct.[i+1]) ->
   338:         precname := "";
   339:         mode := DollarDigitsPrec
   340: 
   341:       | _ ->
   342:         if !digits> List.length args
   343:         then serr i
   344:           ("Parameter $" ^ string_of_int !digits ^ " > number of arguments, only got " ^ si (length args))
   345:         else if !digits<=0 then serr i ("Negative $" ^ string_of_int !digits)
   346:         else begin
   347:           let s' = nth args (!digits-1) in
   348:           let s' = string_of_cexpr s' in
   349:           if is_atomic s' then bcat s'
   350:           else bcat ("(" ^ s' ^ ")");
   351:           mode := Normal;
   352:           trans i ch
   353:         end
   354:       end
   355: 
   356:     | DollarDigitsPrec ->
   357:       begin match ch with
   358:       | 'a'..'z' -> precname := !precname ^ String.make 1 ch
   359:       | _ ->
   360:         if !digits> List.length args
   361:         then serr i
   362:           ("Parameter $" ^ string_of_int !digits ^ " > number of arguments, only got " ^ si (length args))
   363:         else if !digits<=0 then serr i ("Negative $" ^ string_of_int !digits)
   364:         else
   365:           let s' = nth args (!digits-1) in
   366:           let s' =
   367:             try sc !precname s'
   368:             with Unknown_prec s-> clierr2 sr sr2 ("Unknown precedence " ^ s)
   369:           in
   370:           bcat s';
   371:           mode := Normal;
   372:           trans i ch
   373:       end
   374: 
   375:     | VarargsDigits ->
   376:       begin match ch with
   377:       | '0' .. '9' ->
   378:         digits := !digits * 10 + Char.code ch - Char.code '0'
   379: 
   380:       | _ ->
   381:         if !digits> List.length args
   382:         then serr i ("Parameter no $T" ^ string_of_int !digits ^ " too large")
   383:         else if !digits<=0 then serr i ("Arg no " ^ string_of_int !digits ^ " too small")
   384:         else
   385:           let s' = nth args (!digits-1) in
   386:           let s' = string_of_cexpr s' in
   387:           let n = String.length s' in
   388:           begin
   389:             try
   390:               let start = String.index s' '('
   391:               and fin = String.rindex s' ')'
   392:               in
   393:               let s' = String.sub s' (start+1) (fin-start-1)
   394:               in
   395:                 (* WE SHOULD CHECK THE # of args agrees with
   396:                 the type of the tuple .. but there is no
   397:                 way to do that since we only get a string
   398:                 representation .. this code is unequivocably
   399:                 a HACK
   400:                 *)
   401:                 bcat s';
   402:                 mode := Normal;
   403:                 trans i ch
   404:             with Not_found ->
   405:               (* serr i "Varargs requires  literal tuple" *)
   406:               bcat s';
   407:               mode := Normal;
   408:               trans i ch
   409:           end
   410:        end
   411: 
   412:     | BackquoteDigits ->
   413:       begin match ch with
   414:       | '0' .. '9' ->
   415:         digits := !digits * 10 + Char.code ch - Char.code '0'
   416: 
   417:       | _ ->
   418:         if !digits> List.length args
   419:         then serr i ("Parameter `" ^ string_of_int !digits ^ " too large")
   420:         else if !digits<=0 then serr i ("Arg no " ^ string_of_int !digits ^ " too small")
   421:         else
   422:           let s' = nth args (!digits-1) in
   423:           let s' = string_of_cexpr s' in
   424:           let t' = nth typs (!digits-1) in
   425:           bcat ("("^t'^"*)(" ^ s' ^ ".data)");
   426:           mode := Normal;
   427:           trans i ch
   428:        end
   429: 
   430:     | EarholeDigits ->
   431:         if !digits> List.length args
   432:         then serr i ("Parameter @" ^ string_of_int !digits ^ " too large")
   433:         else if !digits<0 then serr i ("Arg no " ^ string_of_int !digits ^ " too small")
   434:         else
   435:           let t = nth argshapes (!digits-1) in
   436:           bcat (argshape);
   437:           mode := Normal;
   438:           trans i ch
   439: 
   440:     | HashDigits ->
   441:         if !digits> List.length args
   442:         then serr i ("Paramater #" ^ string_of_int !digits ^ " too large")
   443:         else if !digits<0 then serr i ("Arg no " ^ string_of_int !digits ^ " too small")
   444:         else
   445:           bcat
   446:           (
   447:             if !digits = 0
   448:             then retyp
   449:             else nth typs (!digits-1)
   450:           );
   451:           mode := Normal;
   452:           trans i ch
   453: 
   454:     | QuestDigits ->
   455:         if !digits> List.length gargs
   456:         then serr i ("Generic type parameter ?" ^ string_of_int !digits ^ " too large")
   457:         else if !digits<1 then serr i ("Generic type arg no " ^ string_of_int !digits ^ " too small")
   458:         else
   459:           bcat
   460:           (
   461:             nth gargs (!digits-1)
   462:           );
   463:           mode := Normal;
   464:           trans i ch
   465: in
   466:   for i = 0 to len - 1 do trans i ct.[i] done;
   467:   begin match !mode with
   468:   | CChar
   469:   | Normal -> ()
   470:   | HashDigits
   471:   | EarholeDigits
   472:   | DollarDigits
   473:   | DollarDigitsPrec
   474:   | QuestDigits
   475:     -> trans len ' ' (* hack .. space is harmless *)
   476:   | _ -> serr len ("Unexpected end in mode " ^ pr !mode)
   477:   end;
   478:   let prec = if prec = "" then "expr" else prec in
   479:   ce prec (Buffer.contents buf)
   480: 
   481: 
End ocaml section to src/flx_csubst.ml[1]