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:
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: