home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / xeinfo.spt < prev    next >
Text File  |  1996-09-28  |  9KB  |  266 lines
  1. *-----------------------------------------------------------------------------
  2. *-                                                                          --
  3. *-                                 G N A T                                  --
  4. *-                                                                          --
  5. *-                            COMPILER UTILITIES                            --
  6. *-                                                                          --
  7. *-                               X E I N F O                                --
  8. *-                                                                          --
  9. *-                            $Revision: 1.19 $                             --
  10. *-                                                                          --
  11. *-           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
  12. *-                                                                          --
  13. *- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. *- terms of the  GNU General Public License as published  by the Free Soft- --
  15. *- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. *- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. *- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. *- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. *- for  more details.  You should have  received  a copy of the GNU General --
  20. *- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. *- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. *-                                                                          --
  23. *-----------------------------------------------------------------------------
  24.  
  25. * Program to construct C header file a-einfo.h (C version of einfo.ads spec,
  26. * for use by Gigi, contains all definitions and access functions, but does not
  27. * contain set procedures, since Gigi is not allowed to modify the GNAT tree)
  28. *
  29. *   Input files:
  30. *
  31. *      einfo.ads     spec of Einfo package
  32. *      einfo.adb     body of Einfo package
  33. *
  34. *   Output files:
  35. *
  36. *      a-einfo.h     Corresponding c header file
  37. *
  38. * Note: It is assumed that the input files have been compiled without errors
  39. *
  40. * An optional argument allows the specification of an output file name to
  41. * override the default a-einfo.h file name for the generated output file.
  42. *
  43. * Most, but not all of the functions in Einfo can be inlined in the C header.
  44. * Those functions which cannot be inlined are identified in the header and
  45. * in terminal output when this utility program is run.
  46.  
  47.         "$Revision: 1.19 $" "$Rev" "ision: " break(' ') $ xeinforev
  48.  
  49.         arg = trim(host(1))
  50.         arg = ident(arg, "0") trim(host(0))
  51.         ofile = ident(arg) 'a-einfo.h'
  52.         ofile = differ(arg) arg
  53.  
  54.         lineno = 0
  55.         &stlimit = -1
  56.         input(.in,1,'einfo.ads')
  57.         input(.inb,5,'einfo.adb')
  58.         output(.out,2,ofile)
  59.         &anchor = 1
  60.         wsp = span(' ' char(9)) | ''
  61.  
  62. * Get einfo revs and write header to output file
  63.  
  64. slp1    line = inb
  65.         ident(line)   :s(err)
  66.         line breakx('$') '$Rev' 'ision: ' break(' ') $ einfobrev
  67. .                                                     :f(slp1)
  68.  
  69. slp     line = in
  70.         ident(line)    :s(start)
  71.         line breakx('$') '$Rev' 'ision: ' break(' ') $ einforev :s(vsn)
  72.         line '--                                 S p e c       ' =
  73. .            '--                              C Header File    '
  74.  
  75.         line '--' = '/*'
  76.         line rtab(2) $ a '--' = a '*/'
  77.         out = line                :(slp)
  78.  
  79. vsn     out = '/*                 Generated by xeinfo revision ' xeinforev
  80. .             ' using                  */'
  81.         out = '/*                         einfo.ads revision ' einforev
  82. .             '                         */'
  83.         out = '/*                         einfo.adb revision ' einfobrev
  84. .             '                         */'           :(slp)
  85.  
  86. start   lc = 'abcdefghijklmnopqrstuvwxyz'
  87.         uc = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
  88.         out =
  89.  
  90. * status<N> = 'I' for inlined function, null otherwise
  91.  
  92.         status = table(200)
  93.  
  94. *  Get non-comment line (comment lines skipped)
  95.  
  96.         define('getlins()a,b')                  :(fd2)
  97.  
  98. getlins getlins = trim(in)                      :f(freturn)
  99.         lineno = lineno + 1
  100.         ident(getlins)                          :s(getlins)
  101.         getlins wsp $ a '--' =                  :f(return)s(getlins)
  102.  
  103. *  Process function header into C form and output it
  104.  
  105. fd2     define('sethead(line,term)a,args,formal,formaltype,filler,i') :(fd3)
  106.  
  107. sethead line wsp $ a
  108. .       'function' wsp break(' ') $ Name =      :s(sh5)f(err)
  109.  
  110. sh5     args =
  111.         line wsp $ filler '(' =                 :f(sh8)
  112.         args = filler '('
  113.  
  114. sh6     line break(' :') $ formal wsp ':' wsp
  115. .            breakx(' );') $ formaltype =       :f(err)
  116.         args = args formaltype ' ' formal
  117.         line wsp '; ' =                         :f(sh7)
  118.         args = args ','                         :(sh6)
  119.  
  120. sh7     line wsp ')' =
  121.         args = args ')'
  122.  
  123. sh8     line wsp 'return' wsp breakx(' ;') $ rtn :s(sh10)f(err)
  124.  
  125. sh10    i =
  126.         i = ident(status<Name>,'I') "INLINE "
  127.         out = a i rtn ' ' Name args term
  128. .                                               :(return)
  129.  
  130. fd3
  131.  
  132. * find pragma inlines
  133.  
  134. i0      lineno = 0
  135.  
  136. i1      line = getlins()                        :f(n0)
  137.         line wsp 'pragma Inline (' break(')') $ name  :f(i1)
  138.         status<name> = 'I'                      :(i1)
  139.  
  140. * process specification
  141.  
  142. n0      input(.in,4,'einfo.ads')
  143.         lineno = 0
  144.  
  145. n1      line = getlins()
  146.         line wsp 'package '                     :s(n2)f(n1)
  147.  
  148. n2      V = 0
  149.         line = getlins()
  150.         line wsp 'type Entity_Kind'             :f(err)
  151.  
  152. n3      line = getlins()
  153.         line wsp break(',') $ N ','             :f(n4)
  154.         out = '   #define ' rpad(N,32) ' ' V
  155.         V = V + 1                               :(n3)
  156.  
  157. n4      line wsp rem $ N                        :f(err)
  158.         out = '   #define ' rpad(N,32) ' ' V
  159.         getlins() wsp ");"                      :f(err)
  160.  
  161.         out =
  162.  
  163. * Loop through subtype declarations
  164.  
  165. n5      line = getlins()                        :f(err)
  166.         line wsp 'function'                     :s(funcs)
  167.         line wsp $ a 'subtype ' break(' ') $ N  :f(err)
  168.  
  169. *  Processing a subtype declaration, see if it is simply an abbrevation
  170. *  of the form subtype x is y, and if so generate the appropriate typedef
  171.  
  172.         line wsp 'subtype' wsp break(' ') $ new wsp 'is'
  173. .         wsp break(' ;') $ old wsp ';' wsp rtab(0)  :f(n8)
  174.         out = a 'typedef ' old ' ' new ';'      :(n5)
  175.  
  176. *  Otherwise the subtype must be declaring a subrange of Entity_Id
  177.  
  178. n8      line wsp $ a 'subtype ' break(' ') $ N  :f(n5)
  179.         getlins() wsp break(' ') $ N1           :f(err)
  180.  
  181. n8a     line = trim(in)                         :f(err)
  182.         lineno = lineno + 1
  183.         line wsp '-- ' rem $ N2                 :s(n8a)
  184.  
  185.         line wsp break(';') $ N3                :f(err)
  186.         out = a 'SUBTYPE (' N ', Entity_Kind, '
  187.         out = a '   ' N1 ', ' N3 ')'            
  188.         out =                                   :(n5)
  189.  
  190. * process function declarations (note laststatus used to control blank lines)
  191.  
  192. funcs   out =
  193.         laststatus = 'I'
  194.  
  195. * loop through function declarations
  196.  
  197. n9      line wsp $ aa 'function' wsp break(' (') $ FN   :f(rbody)
  198.  
  199.         ident(status<FN>,'I')                           :s(n9a)
  200.  
  201. * case of non-lined function
  202.  
  203.         out =
  204.         out = '   #define ' FN ' einfo__' replace(FN,uc,lc) :s(n9b)
  205.  
  206. * case of inlined function
  207.  
  208. n9a     out = ident(laststatus)
  209.  
  210. * merge here to output spec
  211.  
  212. n9b     sethead(line,';')
  213.         laststatus = status<FN>
  214.         line = getlins()                        :(n9)
  215.  
  216.  
  217. * Read body to find inlined functions
  218.  
  219. rbody   out =
  220.         input(.in,3,'einfo.adb')
  221.         lineno = 1
  222.  
  223. * Loop through input lines to find bodies of inlined functions
  224.  
  225. n10     fline = getlins()                        :f(n13)
  226.         fline wsp $ aa 'function' wsp break(' (') $ FN :f(n10)
  227.         ident(status<FN>,'I')                   :f(n10)
  228.  
  229. * Here we have an inlined function
  230.  
  231.         fline breakx('r') 'return'              :f(badfunc)
  232.         getlins() wsp 'begin'                   :f(badfunc)
  233.  
  234. * Skip past pragma Asserts
  235.  
  236. n10b    line = getlins()
  237.         line wsp "pragma Assert"                :f(n11)
  238.  
  239. * pragma Assert found, get its continuation lines
  240.  
  241. n10c    line breakx(';')                        :s(n10b)
  242.         line = getlins()                        :(n10c)
  243.  
  244. * process return statement
  245.  
  246. n11     line breakx('-') $ a '--' = a
  247.         line wsp 'return ' break(';') $ expr    :f(badfunc)
  248.         getlins() wsp 'end' breakx(';') ';'     :f(badfunc)
  249.  
  250.         expr breakx(' ') $ a " in " rem $ b = "IN (" a ', ' b ")"
  251.         expr breakx(' ') $ a " = " rem $ b = a ' == ' b
  252.         out =
  253.         sethead(fline,'')
  254.  
  255.         out = aa '   { return ' expr '; }'      :(n10)
  256.  
  257. n13     out =
  258.         out =
  259. .         '/* End of einfo.h (C version of Einfo package specification)'
  260. .               ' */'    :(end)
  261.  
  262. badfunc terminal = "Body for function " FN " does not meet requirements"
  263. .                         :(err)
  264.  
  265. end
  266.