home *** CD-ROM | disk | FTP | other *** search
/ ftp.ee.pdx.edu / 2014.02.ftp.ee.pdx.edu.tar / ftp.ee.pdx.edu / pub / users / Harry / Blitz / OSProject / p1 / System.c < prev    next >
Text File  |  2007-09-19  |  11KB  |  310 lines
  1. code System
  2.  
  3.   type
  4.     -- The following record has a fixed format:
  5.     CATCH_RECORD = record
  6.                      next: ptr to CATCH_RECORD
  7.                      errorID: ptr to char    -- Null terminated string
  8.                      catchCodePtr: int       -- Address of the code
  9.                      oldFP: int
  10.                      oldSP: int
  11.                      fileName: ptr to char   -- Null terminated string
  12.                      lineNumber: int
  13.                    endRecord
  14.  
  15.     -- The following record has a fixed format:
  16.     DISPATCH_TABLE = record
  17.                        classDescriptor: ptr to CLASS_DESCRIPTOR
  18.                        firstMethodPtr: int    -- Address of code
  19.                      endRecord
  20.  
  21.     -- The following record has a fixed format:
  22.     CLASS_DESCRIPTOR = record
  23.                          magic: int                -- Should be 0x434C4153 == 'CLAS'
  24.                          myName: ptr to char       -- Null terminated string
  25.                          fileName: ptr to char     -- Null terminated string
  26.                          lineNumber: int
  27.                          sizeInBytes: int
  28.                          firstSuperPtr: ptr to DISPATCH_TABLE
  29.                        endRecord
  30.  
  31.     -- The following record has a fixed format:
  32.     INTERFACE_DESCRIPTOR = record
  33.                              magic: int                -- Should be 0x494E5446 == 'INTF'
  34.                              myName: ptr to char       -- Null terminated string
  35.                              fileName: ptr to char     -- Null terminated string
  36.                              lineNumber: int
  37.                              firstInterfacePtr: ptr to INTERFACE_DESCRIPTOR
  38.                            endRecord
  39.  
  40.     -- The following record has a fixed format:
  41.     OBJECT_RECORD = record
  42.                       dispatchTable: ptr to DISPATCH_TABLE
  43.                       firstField: int
  44.                     endRecord
  45.  
  46. -----------------------------  nl  ---------------------------------
  47.  
  48.   function nl ()
  49.       printChar ('\n')
  50.     endFunction
  51.  
  52. ---------------------------  printNullTerminatedString  -------------------------------
  53.  
  54.   function printNullTerminatedString (p: ptr to char)
  55.     -- This function is passed a pointer to a sequence of
  56.     -- characters, followed by '\0'.  It prints them.
  57.     var ch: char
  58.       while true
  59.         ch = *p
  60.         if ch == '\0'
  61.           return
  62.         endIf
  63.         printChar (ch)
  64.         p = p + 1
  65.       endWhile
  66.     endFunction
  67.  
  68. -----------------------------  KPLSystemError  ---------------------------------
  69.  
  70.   function KPLSystemError (message: ptr to array of char)
  71.     -- Come here when a fatal error occurs.  Print a message and terminate
  72.     -- the KPL program.  There will be no return from this function.
  73.     -- NOTE: This function is not aware of threads; it is better to use FatalError
  74.     -- (from the Thread package) if possible.
  75.       print ("\n\nFATAL KPL RUNTIME ERROR: ")
  76.       print (message)
  77.       nl ()
  78.       RuntimeExit ()
  79.     endFunction
  80.  
  81. -----------------------------  KPLIsKindOf  ---------------------------------
  82.  
  83.   function KPLIsKindOf (objPtr: ptr to Object, typeDesc: ptr to int) returns int
  84.     -- There will be an upcall from the runtime system to this function, which
  85.     -- will evaluate the "isKindOf" relation.  This routine determines whether
  86.     -- the object pointed to satisfies the "isKindOf" relation, i.e., whether it
  87.     -- is an instance of the given type, or of one of its super-classes or super-
  88.     -- interfaces.  It returns either 0 (for FALSE) or 1 (for TRUE).
  89.       var
  90.         dispTable: ptr to DISPATCH_TABLE
  91.         classDesc: ptr to CLASS_DESCRIPTOR
  92.         next: ptr to ptr to void
  93.    
  94.       -- We should never be passed a NULL pointer, but check anyway.
  95.       if objPtr == null
  96.         KPLSystemError ("WITHIN KPLIsKindOf: objPtr is NULL")
  97.       endIf
  98.  
  99.       -- If the object is uninitialized return false.
  100.       dispTable = (objPtr asPtrTo OBJECT_RECORD).dispatchTable
  101.       if dispTable == null
  102.         return 0
  103.       endIf
  104.  
  105.       classDesc = dispTable.classDescriptor
  106.  
  107.       -- Make sure the magic number is what we expect it to be.
  108.       if classDesc.magic != 0x434C4153   -- 'CLAS'
  109.         KPLSystemError ("WITHIN KPLIsKindOf: Bad Magic Number")
  110.       endIf
  111.  
  112.       -- Run through all supers.  (Each class is a super of itself.)
  113.       next = & classDesc.firstSuperPtr
  114.       while true
  115.         if *next == null
  116.           return 0
  117.         elseIf *next == typeDesc
  118.           return 1
  119.         endIf
  120.         next = next + 4
  121.       endWhile
  122.     endFunction
  123.  
  124. ------------------------------------  THE HEAP  ---------------------------------
  125.  
  126.   -- The following functions (provided below) are used to implement the heap.
  127.   --    KPLMemoryInitialize
  128.   --    KPLMemoryAlloc
  129.   --    KPLMemoryFree
  130.   -- The runtime system will execute calls to these routines whenever:
  131.   --    Whenever a TRY statement is executed
  132.   --    Whenever an ALLOC statement is executed
  133.   --    Whenever a FREE statement is executed
  134.   --
  135.   -- The heap implementation provided here is overly simple: Blocks of memory
  136.   -- are allocated sequentially and any attempt to "free" memory is ignored.
  137.   --
  138.   const
  139.     HEAP_SIZE = 20000
  140.   var
  141.     memoryArea: array [HEAP_SIZE] of char
  142.     nextCharToUse: int = 0
  143.     alreadyInAlloc: bool = false          -- Used to detect re-entrance
  144.  
  145. -----------------------------  KPLMemoryInitialize  ---------------------------------
  146.  
  147.   function KPLMemoryInitialize ()
  148.     -- Initialize the array count without initializing the data.
  149.     var p: ptr to int = (& memoryArea) asPtrTo int
  150.       *p = HEAP_SIZE
  151.     endFunction
  152.  
  153. -----------------------------  KPLMemoryAlloc  ---------------------------------
  154.  
  155.   function KPLMemoryAlloc (byteCount: int) returns ptr to char
  156.     -- This routine is called to allocate memory from the heap.
  157.     -- This heap implementation is trivial: It allocates space
  158.     -- sequentially, until there is no more.  When space is exhausted,
  159.     -- we throw an error.
  160.     --
  161.     -- NOTE: THIS FUNCTION IS ***NOT*** RE-ENTRANT!!!  The caller must
  162.     --       ensure that it will only be called from one thread.  (If it might
  163.     --       be called from different threads, the caller must ensure that it
  164.     --       is protected with semaphores, locks, etc. from be invoked while
  165.     --       it is already active!!!
  166.     --
  167.     var i: int
  168.         p: ptr to char
  169.  
  170.       -- The following test is NOT correct!!!  But it may
  171.       -- detect some cases of re-entrance...
  172.       if alreadyInAlloc
  173.         KPLSystemError ("WITHIN KPLMemoryAlloc: Reentered")
  174.       endIf
  175.       alreadyInAlloc = true
  176.  
  177.       i = nextCharToUse
  178.       if byteCount <= 0
  179.         print ("\n\nBad byteCount = ")
  180.         printInt (byteCount)
  181.         KPLSystemError ("WITHIN KPLMemoryAlloc: byte count is not positive")
  182.       endIf
  183.  
  184.       -- Add 4 bytes to the byte count, for storing a hidden byte count.
  185.       byteCount = byteCount + 4
  186.  
  187.       -- Round up to a multiple of 8.
  188.       if byteCount % 8 > 0
  189.         byteCount = (byteCount / 8 + 1) * 8
  190.       endIf
  191.  
  192.       -- Uncomment the following to see when "HEAP Alloc" occurs
  193.       /*
  194.       print ("\n+++++ KPLMemoryAlloc   byteCount: ")
  195.       printInt (byteCount)
  196.       print (", remaining: ")
  197.       printInt (HEAP_SIZE-(nextCharToUse + byteCount))
  198.       print (", returns: ")
  199.       printHex ((& (memoryArea [i])) asInteger + 4)
  200.       print (" +++++\n")
  201.       */
  202.  
  203.       nextCharToUse = nextCharToUse + byteCount
  204.       if nextCharToUse > HEAP_SIZE
  205.         KPLSystemError ("WITHIN KPLMemoryAlloc: Out of memory")
  206.       endIf
  207.       p = & (memoryArea [i])
  208.       *(p asPtrTo int) = byteCount
  209.  
  210.       alreadyInAlloc = false
  211.  
  212.       return p + 4
  213.  
  214.     endFunction
  215.  
  216. -----------------------------  KPLMemoryFree  ---------------------------------
  217.  
  218.   function KPLMemoryFree (p: ptr to char)
  219.     -- This routine is called to free memory in the heap.  It is passed a
  220.     -- pointer to a block of memory previously allocated in a call to "alloc".
  221.     --
  222.     -- Currently, this routine is a nop.
  223.     --
  224.       --print ("\n+++++ KPLMemoryFree called... ptr: ")
  225.       --printHex (p asInteger)
  226.       --print (" +++++\n")
  227.     endFunction
  228.  
  229. -----------------------------  KPLUncaughtThrow  ---------------------------------
  230.  
  231.   function KPLUncaughtThrow (errorID: ptr to char, line: int, rPtr: int)
  232.     -- Whenever an error is thrown but not caught, there will be an upcall from the
  233.     -- runtime system to this function.  (Exception: if "UncaughtThrowError" is thrown
  234.     -- but not caught, it will cause a fatal runtime error.)  This function will
  235.     -- print some info about the error that was thrown, then it will throw an
  236.     -- error called "UncaughtThrowError".  This error may or may not be caught by
  237.     -- the user's code.  If not, the runtime system will simply print an error and halt.
  238.     --
  239.       var
  240.         charPtr: ptr to char
  241.       print ("\n\n++++++++++ An error has been thrown but not caught ++++++++++\n")
  242.       print ("   Error Name = ")
  243.       printNullTerminatedString (errorID)
  244.       nl ()
  245.       print ("   Location at time of THROW = ")
  246.       charPtr = * (rPtr asPtrTo ptr to char)
  247.       printNullTerminatedString (charPtr)
  248.       print (":")
  249.       printInt (line)
  250.       nl ()
  251.       print ("   Currently active method or function = ")
  252.       rPtr = rPtr + 4
  253.       charPtr = * (rPtr asPtrTo ptr to char)
  254.       printNullTerminatedString (charPtr)
  255.       nl ()
  256.       printCatchStack ()
  257.       print ("+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n\n")
  258.       throw UncaughtThrowError (errorID, line, rPtr)
  259.     endFunction
  260.  
  261. -----------------------------  printCatchStack  ---------------------------------
  262.  
  263.   function printCatchStack ()
  264.     -- Print all CATCH_RECORDs on the CATCH_STACK.
  265.     --
  266.     -- NOTE: Whenever we leave the body statements in a try (i.e., fall-thru,
  267.     --       throw, or return), records from the catch stack will be popped and
  268.     --       freed.  "getCatchStack" returns a pointer to a list of CATCH_RECORDs
  269.     --       as it is when getCatchStack is called.  This routine merely reads data
  270.     --       from these records, so additional pushing and popping is okay and may
  271.     --       occur (e.g., we call "print", which may contain TRY statements).  However,
  272.     --       none of the records on the list returned by getCatchStack will be freed
  273.     --       before this routine is done looking at and printing them.
  274.     --
  275.     var p: ptr to CATCH_RECORD = getCatchStack () asPtrTo CATCH_RECORD
  276.       print ("   Here is the CATCH STACK:\n")
  277.       while p
  278.         print ("     ")
  279.         printNullTerminatedString (p.fileName)
  280.         print (":")
  281.         printInt (p. lineNumber)
  282.         print (":\t")
  283.         printNullTerminatedString (p.errorID)
  284.         --print ("\t\t(CATCH-RECORD addr = 0x")
  285.         --printHex (p asInteger)
  286.         --print (")")
  287.         nl ()
  288. /***
  289.         print ("     ")
  290.         printNullTerminatedString (p.errorID)
  291.         print ("\n        Source Filename:   ")
  292.         printNullTerminatedString (p.fileName)
  293.         print ("\n        Line number:       ")
  294.         printInt (p. lineNumber)
  295.         print ("\n        Catch record addr: ")
  296.         printHex (p asInteger)
  297.         print ("\n        Catch code addr:   ")
  298.         printHex (p.catchCodePtr)
  299.         print ("\n        Old FP:            ")
  300.         printHex (p.oldFP)
  301.         print ("\n        Old SP:            ")
  302.         printHex (p.oldSP)
  303.         nl ()
  304. ***/
  305.         p = p.next
  306.       endWhile
  307.     endFunction
  308.  
  309. endCode
  310.