home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 254b.lha / AMXLISP_v2.0 / lsp / monitor.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1989-05-10  |  6.7 KB  |  164 lines
  1. ;demo file that shows you the essential ressources in your Amiga
  2.  
  3. (progn
  4.    (defamiga 'FindTask 'exec )
  5.    (load-c-struct "exec/lists")
  6.    (load-c-struct "exec/tasks")
  7.    (load-c-struct "exec/nodes")
  8.    (load-c-struct "exec/libraries" )
  9.    (load-c-struct "exec/execbase" )
  10.    (load-c-struct "exec/ports")
  11.    (load-c-struct "graphics/text" '(textfont))
  12.    (load-c-struct "graphics/gfxbase" )
  13.    (load-c-struct "exec/types" )
  14.    (load-c-struct "exec/memory" ))
  15.  
  16. ; we should use this but I can't get make-symbol to work
  17. ;(defun monitor (name)
  18. ;   (let ((exbase (execbase :new (cassoc 'base exec))))
  19. ;        (funcall (make-symbol (strcat "monitor-" (symbol-name name))))))
  20. ;so instead we fix
  21. (setq exbase (send execbase :new (cassoc 'base exec)))
  22.  
  23. ; how to get an Xlisp list with all the nodes from a c_list
  24. (defun get-list (liststruct)
  25.    (let* ((headnode (send liststruct :-> 'lh_head))
  26.           (thelist (list headnode)))
  27.          (get-list-aux headnode thelist)))
  28. (defun get-list-aux (anode thelist)
  29.    (let ((nextnode (send anode :-> 'ln_succ)))
  30.         (if (equal (send nextnode :ptr) 0)
  31.             thelist
  32.             (append1 (get-list-aux nextnode thelist) nextnode))))
  33.  
  34. (defun monitor-task ()
  35.    (let ((taskreadylist (send exbase :-> 'TaskReady))
  36.          (taskwaitlist (send exbase :-> 'TaskWait)))
  37.         (print "***** TASK READY *******")
  38.         (mapc 'analyse-task (get-list taskreadylist))
  39.         (print "***** TASK WAIT *******")
  40.         (mapc 'analyse-task (get-list taskwaitlist))))
  41.  
  42. (defun analyse-task (nodestruct)
  43.    (let ((tname (c-to-string (send (send nodestruct :-> 'ln_Name) :ptr)))
  44.          (tpri (send nodestruct :-> 'ln_pri)))
  45.         (princ "Task Name: ") (princ tname) (terpri)
  46.         (princ "  with priority:") (princ tpri) (terpri)))
  47.  
  48. (defun monitor-library ()
  49.    (let ((liblist (send exbase :-> 'LibList)))
  50.         (mapc 'analyse-library (get-list liblist))))
  51.  
  52. (defun monitor-device ()
  53.    (let ((devlist (send exbase :-> 'DeviceList)))
  54.         (mapc 'analyse-library (get-list devlist))))
  55.  
  56. (defun analyse-library (nodestruct)
  57.    (princ "Library Name: ")
  58.    (princ  (c-to-string (send (send nodestruct :-> 'ln_Name) :ptr)))
  59.    (terpri)
  60.    (let ((libstruct (send library :new (send nodestruct :ptr))))
  61.         (princ "  version: ") (princ (send libstruct :-> 'lib_version))(terpri)
  62.         (print "  revision:  ") (princ (send libstruct :-> 'lib_revision))(terpri)
  63.         (princ " Current OpenCnt: ") (princ (send libstruct :-> 'lib_OpenCnt))(terpri)
  64.         (print "  IdString:  ")
  65.         (print  (c-to-string (send (send libstruct :->  'lib_IdString) :ptr)))
  66.         ))
  67.  
  68. (defun monitor-port ()
  69.    (let ((portlist (send exbase :-> 'PortList)))
  70.         (mapc 'analyse-port (get-list portlist))))
  71.  
  72. (defun analyse-port (nodestruct)
  73.    (princ "Port Name: ") (princ (c-to-string (send (send nodestruct :-> 'ln_Name) :ptr)))(terpri)
  74.    (let ((portstruct (send msgport :new (send nodestruct :ptr))))
  75.         (princ " adresse: ")(princ (send portstruct :ptr))(terpri)
  76.         (princ " sigbit: ")(princ (send portstruct :-> 'mp_sigbit))(terpri)
  77.         ))
  78.  
  79.  
  80. ; there is in GfxBase a pointer to the list of fonts
  81. (defun monitor-font ()
  82.    (let ((graphicsbase (send gfxbase :ptr (openlibrary 'graphics))))
  83.         (mapc 'analyse-font
  84.               (get-list (send graphicsbase :-> 'TextFonts)))
  85.         (callamiga 'CloseLibrary exec graphicsbase)))
  86.  
  87.  
  88. (defun analyse-font (nodestruct)
  89.    (princ "Font Name: ") (princ (c-to-string (send (send nodestruct :-> 'ln_Name) :ptr)))(terpri)
  90.    (let ((fontstruct (send textfont :new (send nodestruct :ptr))))
  91.         (princ "YSize : ")(princ (send fontstruct :-> 'tf_Ysize))(terpri)
  92.         (princ " Style : ")(princ (send fontstruct :-> 'tf_Style))(terpri)
  93.         (princ " Flags : ")(princ (send fontstruct :-> 'tf_Flags))(terpri)
  94.         (princ " XSize : ")(princ (send fontstruct :-> 'tf_Xsize)))(terpri)
  95.         )
  96.  
  97. (defun monitor-mem ()
  98.    (let ((memorylist (send exbase :-> 'memlist)))
  99.         (mapc 'analyse-mem (get-list memorylist))))
  100.  
  101.  
  102. (defun analyse-mem (nodestruct)
  103.    (princ "Node Name: ")(princ (c-to-string (send (send nodestruct :-> 'ln_Name) :ptr)))(terpri)
  104.    (let ((nodestruct (send memheader :new (send nodestruct :ptr))))
  105.    (princ "  Attributes: ")(princ (send nodestruct :-> 'mh_Attributes))(terpri)
  106.    (unless (equal (send nodestruct :-> 'mh_Attributes) 0)
  107.            (analyse-chunk (send nodestruct :-> 'mh_First)))
  108.    (princ " Lower: ")(princ (send (send nodestruct :-> 'mh_Lower) :ptr ))(terpri)
  109.    (princ " Upper: ")(princ (send (send nodestruct :-> 'mh_Upper) :ptr))(terpri)
  110.    (princ "Free Bytes: ")(princ (send nodestruct :-> 'mh_Free))(terpri)
  111.    ))
  112.  
  113. (defun analyse-chunk (chunk)
  114.    (if (equal (send chunk :ptr) 0)
  115.        (terpri)
  116.        (progn (princ (send chunk :-> 'mc_Bytes))
  117.               (analyse-chunk (send chunk :-> 'mc_Next)))))
  118.  
  119. ;we still have to write lhoblist
  120. ;(defun monitor-? () (lhoblist 'monitor))
  121.  
  122. (defun examine-task (name)
  123.    (let ((taskptr (callamiga 'FindTask exec name)))
  124.         (when (equal taskptr 0)
  125.               (error  "task not found" name))
  126.         (let ((mytask (send node :new taskptr)))
  127.              (princ "Priority: ")(princ (send mytask :-> 'ln_pri))(terpri)
  128.              (let ((mytask (send task :new taskptr)))
  129.              (princ "  Flags: ")(princ (send mytask :-> 'tc_Flags))(terpri)
  130.              (princ "  State: ")(princ (send mytask :-> 'tc_State))
  131.              (princ "Sig: ")
  132.              (princ "Alloc ")(princ (send mytask :-> 'tc_SigAlloc))
  133.              (princ " Wait ")(princ (send mytask :-> 'tc_SigWait))
  134.              (princ " Recvd ")(princ (send mytask :-> 'tc_SigRecvd))
  135.              (princ " Except ")(princ (send mytask :-> 'tc_SigExcept))
  136.              (terpri)
  137.              (princ "Traps: ")
  138.              (princ "Alloc ")(princ (send mytask :-> 'tc_TrapAlloc))
  139.              (princ " Able ")(princ (send mytask :-> 'tc_TrapAble))
  140.              (princ " Data ")(princ (aref (send mytask :-> 'tc_TrapData) 0 ))
  141.              (princ " Code ")(princ (aref (send mytask :-> 'tc_TrapCode) 0 ))
  142.              (terpri)
  143.              (princ "Except: ")
  144.              (princ " Data ")(princ (aref (send mytask :-> 'tc_ExceptData) 0 ))
  145.              (princ " Code ")(princ (aref (send mytask :-> 'tc_ExceptCode) 0 ))
  146.              (terpri)
  147.              (princ "Stack: ")
  148.              (princ " Pointer ")(princ (aref (send mytask :-> 'tc_SPReg) 0 ))
  149.              (princ " Lower ")(princ (aref (send mytask :-> 'tc_SPLower) 0 ))
  150.              (princ " Upper ")(princ (aref (send mytask :-> 'tc_SPUpper) 0 ))
  151.              (terpri)
  152.              (princ "Memory: ")
  153.              (let ((mlist (get-list (send mytask :-> 'tc_MemEntry))))
  154.                   (mapc 'analyse-entry mlist)))))
  155. )
  156. ;(defun analyse-entry (nodestruct)
  157. ;   (typevector nodestruct 'mementry)
  158. ;   (show nodestruct))
  159.  
  160.  
  161.  
  162.  
  163.  
  164.