home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Professional / OS2PRO194.ISO / os2 / prgramer / xlisp / enumproc.lsp < prev    next >
Encoding:
Text File  |  1992-06-26  |  3.7 KB  |  106 lines
  1. ; enumproc.lsp -- Lisp "callback" functions, etc.
  2. ; Andrew Schulman 2-June-1988
  3. ; revised 13-June-1988
  4.  
  5. ;======================================================================
  6.  
  7. ; general-purpose enumeration function
  8. ; only confusing part:  (if (listp elem) elem (list elem))
  9. ; this takes care of two cases:  if elem is NIL, don't put into list;
  10. ; and if elem is already list, don't put into list.  works because
  11. ; (listp nil) is T.
  12.  
  13. (define (enum func &rest args)
  14.     (do*
  15.         ((elem (apply func args))                           ; init
  16.          (lst (if (listp elem) elem (list elem))))
  17.         ((not elem) lst)                                    ; test, retval
  18.         (setf elem (apply func nil))                        ; body
  19.         (nconc lst (if (listp elem) elem (list elem)))))
  20.             
  21. ;======================================================================
  22.  
  23. ; helper routines
  24.  
  25. (defmacro dos-call (func &rest args)
  26.     `(call (getprocaddr doscalls ,func) ,@args t))
  27.  
  28. (define (get-full-path-name dll)
  29.     (if (eq dll "DOSCALLS")
  30.         dll
  31.         (let
  32.             ((handle (word 0))
  33.              (buf (make-string 32 128)))
  34.             (if (dos-call "DOSGETMODHANDLE" dll ^handle)
  35.                 (if (dos-call "DOSGETMODNAME" handle (word 128) buf)
  36.                     buf)))))
  37.                         
  38. ;======================================================================
  39.                         
  40. ; returns list of all functions exported from DLL            
  41. (define (procs dll)
  42.     (enum #'enum-procs (get-full-path-name dll)))
  43.         
  44. ;======================================================================
  45.  
  46. ; note that nconc-ing up list pretty unnecessary for (install)
  47. ; just included here to show sample use of (procs)
  48. ; see real (install) later
  49.  
  50. (define (old-install dll)
  51.     (let
  52.         ((module (loadmodule dll)))
  53.         (mapcar
  54.             (lambda (p)
  55.                 ;;; (print p) ;;; for debugging
  56.                 (set
  57.                     (read (make-string-input-stream 
  58.                         (if
  59.                             (char= #\_ (char p 0))
  60.                             (subseq p 1)
  61.                             p))) 
  62.                     (getprocaddr module p)))
  63.              (cdr (procs (get-full-path-name dll))))))
  64.              
  65. ;======================================================================
  66.  
  67. (define strtok (getprocaddr crtlib "_strtok"))
  68.  
  69. (define (parse s delim)
  70.     (enum
  71.         (lambda (&rest args)
  72.             (if args (define delims (cadr args)))
  73.             (c-call strtok (if args (car args) 0) delims 'str))
  74.         s delim))
  75.             
  76. ;======================================================================
  77.  
  78. (define (install dll &optional print-flag &aux name addr)
  79.     (do*
  80.         ((module (loadmodule dll))                          ; init
  81.          (fullname (get-full-path-name dll))
  82.          (p (enum-procs fullname))
  83.          (ok (progn
  84.                  (if p
  85.                      (format stdout "Installing ~A\n" fullname)
  86.                      (format stdout "Can't install ~A\n" dll))
  87.                  p)))
  88.         ((not p) (if ok t))                                 ; test, retval
  89.         (setf name
  90.             (read (make-string-input-stream
  91.                 (if
  92.                     (char= #\_ (char p 0))
  93.                     (subseq p 1)            ; maybe strip leading underscore
  94.                     p))))
  95.         (setf addr (getprocaddr module p))
  96.         (if addr
  97.             (progn
  98.                 (if print-flag (format stdout "~A\t" name))
  99.                 (set name addr)))
  100.         (setf p (enum-procs))))
  101.  
  102. ; (install "DOSCALLS")
  103. ; (install "CRTLIB")
  104.  
  105.  
  106.