home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / OS2XLSP1.ZIP / INIT.LSP < prev    next >
Lisp/Scheme  |  1988-07-19  |  8KB  |  273 lines
  1. ; initialization file for XLISP 2.0
  2. ; for OS2XLISP 1.10
  3. ; revised Andrew Schulman 12-June-1988
  4.  
  5. ;======================================================================
  6. (expand 10)
  7.  
  8. ;======================================================================
  9. ; define some macros
  10. (defmacro defvar (sym &optional val)
  11.   `(if (boundp ',sym) ,sym (setq ,sym ,val)))
  12. (defmacro defparameter (sym val)
  13.   `(setq ,sym ,val))
  14. (defmacro defconstant (sym val)
  15.   `(setq ,sym ,val))
  16.  
  17. ; (makunbound sym) - make a symbol value be unbound
  18. (defun makunbound (sym) (setf (symbol-value sym) '*unbound*) sym)
  19.  
  20. ; (fmakunbound sym) - make a symbol function be unbound
  21. (defun fmakunbound (sym) (setf (symbol-function sym) '*unbound*) sym)
  22.  
  23. ; (mapcan fun list [ list ]...)
  24. (defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))
  25.  
  26. ; (mapcon fun list [ list ]...)
  27. (defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))
  28.  
  29. ; (set-macro-character ch fun [ tflag ])
  30. (defun set-macro-character (ch fun &optional tflag)
  31.     (setf (aref *readtable* (char-int ch))
  32.           (cons (if tflag :tmacro :nmacro) fun))
  33.     t)
  34.  
  35. ; (get-macro-character ch)
  36. (defun get-macro-character (ch)
  37.   (if (consp (aref *readtable* (char-int ch)))
  38.     (cdr (aref *readtable* (char-int ch)))
  39.     nil))
  40.  
  41. ; (savefun fun) - save a function definition to a file
  42. (defmacro savefun (fun)
  43.   `(let* ((fname (strcat (symbol-name ',fun) ".lsp"))
  44.           (fval (get-lambda-expression (symbol-function ',fun)))
  45.           (fp (open fname :direction :output)))
  46.      (cond (fp (print (cons (if (eq (car fval) 'lambda)
  47.                                 'defun
  48.                                 'defmacro)
  49.                             (cons ',fun (cdr fval))) fp)
  50.                (close fp)
  51.                fname)
  52.            (t nil))))
  53.  
  54. ; (debug) - enable debug breaks
  55. (defun debug ()
  56.        (setq *breakenable* t))
  57.  
  58. ; (nodebug) - disable debug breaks
  59. (defun nodebug ()
  60.        (setq *breakenable* nil))
  61.  
  62. ; initialize to enable breaks but no trace back
  63. (setq *breakenable* t)
  64. (setq *tracenable* nil)
  65.  
  66.  
  67. ;======================================================================
  68. ;;; DEFINE -- from the book "T Programming Language", with changes
  69. (defmacro define (name &rest body)
  70.     (cond
  71.         ((atom name)
  72.             `(setq ,name ,@body))
  73.         ((null (cdr (last name)))
  74.             `(defun ,(car name) ,(cdr name) ,@body))))
  75.  
  76. (defmacro while (test &rest body)
  77.     `(do () ((not ,test)) ,@body))
  78.  
  79. (defmacro repeat (n &rest expr)
  80.     `(dotimes (i ,n) ,@expr))
  81.  
  82. (defmacro incr (x) `(setf ,x (1+ ,x)))
  83.  
  84. (defmacro decr (x) `(setf ,x (1- ,x)))
  85.  
  86. (defconstant stdout *standard-output*)
  87.  
  88. (defconstant stdin *standard-input*)
  89.  
  90.  
  91. ;======================================================================
  92. ;;; pointer manipulation macros
  93.  
  94. (defmacro mk-fp (seg off)
  95.     `(makelong ,seg ,off))
  96.         
  97. (defmacro fp-seg (fp) `(lo-word ,fp))
  98.  
  99. (defmacro fp-off (fp) `(hi-word ,fp))
  100.  
  101.  
  102. ;======================================================================
  103. ;;; read macros
  104. ;;; Dave Betz wrote these -- thanks, Dave!
  105.  
  106. (set-macro-character #\^
  107.     #'(lambda (stream ch)
  108.         (list `(addr ,(read stream t)))))
  109.  
  110. (set-macro-character #\~
  111.     #'(lambda (stream ch)
  112.         (list `(word ,(read stream t)))))
  113.  
  114. ;======================================================================
  115. (define doscalls (loadmodule "DOSCALLS"))
  116. (define viocalls (loadmodule "VIOCALLS"))
  117. (define kbdcalls (loadmodule "KBDCALLS"))
  118. (define moucalls (loadmodule "MOUCALLS"))
  119. (define crtlib (loadmodule "CRTLIB"))       ; C 5.1 run-time library DLL
  120.  
  121. ;======================================================================
  122. (define gdt 0)
  123. (define ldt 0)
  124. (call (getprocaddr doscalls "DOSGETINFOSEG") ^gdt ^ldt)
  125. ; gdt and ldt have now been "poked" by OS/2
  126.  
  127. (define (date)
  128.     `(,(peek (mk-fp gdt 17) 'byte)           ; month
  129.     ,(peek (mk-fp gdt 16) 'byte)             ; day
  130.     ,(peek (mk-fp gdt 18) 'int)))            ; year
  131.             
  132. (define (time)
  133.     `(,(peek (mk-fp gdt 8) 'byte)            ; hour
  134.     ,(peek (mk-fp gdt 9) 'byte)              ; minutes
  135.     ,(peek (mk-fp gdt 10) 'byte)))           ; seconds
  136.             
  137. (define (elapsed-time)
  138.     (peek (mk-fp gdt 4) 'long))              ; milliseconds since IPL
  139.         
  140. (define (vers)
  141.     `(,(peek (mk-fp gdt 21) 'byte)           ; major version number
  142.     ,(peek (mk-fp gdt 22) 'byte)             ; minor version number
  143.     ,(peek (mk-fp gdt 23) 'byte)))           ; revision letter
  144.             
  145. (define (foreground-session)
  146.     (peek (mk-fp gdt 24) 'byte))
  147.  
  148. (define (protect-only?)
  149.     (= 1 (peek (mk-fp gdt 27) 'byte)))
  150.         
  151. (define (foreground-pid)
  152.     (peek (mk-fp gdt 28) 'int))
  153.         
  154. (define (boot-drive)
  155.     (peek (mk-fp gdt 36) 'int))
  156.         
  157. (define (getpid)                ; process id
  158.     (peek (mk-fp ldt 0) 'int))
  159.         
  160. (define (getppid)               ; process id of parent
  161.     (peek (mk-fp ldt 2) 'int))
  162.         
  163. (define (getgrp)                ; screen group/session
  164.     (peek (mk-fp ldt 8) 'int))
  165.  
  166. (define (priority)
  167.     (peek (mk-fp ldt 4) 'int))
  168.         
  169. (define (thread-id)
  170.     (peek (mk-fp ldt 6) 'int))
  171.  
  172. (define (subsession)
  173.     (peek (mk-fp ldt 10) 'int))
  174.         
  175. (define (foreground?)
  176.     (not (zerop (peek (mk-fp ldt 12) 'int))))
  177.  
  178.  
  179. ;======================================================================
  180. (define (dos-mem-avail &aux (mem 0))
  181.     (call
  182.         (getprocaddr doscalls "DOSMEMAVAIL")
  183.         ^mem)
  184.     mem)
  185.  
  186. ;;; SEGMENT INFORMATION PREDICATES          
  187. ; is segment present in memory?
  188. (define (present? x)
  189.     (=
  190.         128
  191.         (logand
  192.             (lar x)
  193.             128)))
  194.                 
  195. ; is segment code?
  196. (define (code? x)
  197.     (=
  198.         8
  199.         (logand
  200.             (lar x)
  201.             8)))
  202.  
  203. ;;; MEMORY ALLOCATION
  204.  
  205. (define dosallocseg (getprocaddr doscalls "DOSALLOCSEG"))
  206. (define dosfreeseg (getprocaddr doscalls "DOSFREESEG"))
  207.  
  208. ; convoluted expression sometimes necessary to get unique node
  209. (define (new-node x)
  210.     (1+ (1- x)))
  211.  
  212. (define (dos-alloc-seg size &aux (seg 0))
  213.     (if (zerop (call dosallocseg (word size) (addr seg) (word 0)))
  214.         (new-node seg)))
  215.         
  216. (define (dos-free-seg seg)
  217.      (zerop (call dosfreeseg (word seg))))
  218.  
  219.  
  220. ;======================================================================
  221. (define (cls) (princ "\033[2J"))
  222.  
  223. (define (set-cursor row col)
  224.     (format stdout "\033[~A;~AH" row col))
  225.  
  226.  
  227. ;======================================================================
  228. ;;; structures
  229. (load 'struct)
  230.  
  231. ;======================================================================
  232. ; miscellaneous stuff
  233.  
  234. ;;; convert from XLISP file stream to OS/2 DOS file handle
  235. (define (fileno f)
  236.     (peek (+ 11 ^f) 1))
  237.  
  238. ;;; replacement for old (peek)
  239. ;;; no longer used, but kept in as illustrating of writing front-ends
  240. ;;; for built-ins.  If you don't like a function, write a front-end for it!
  241. ;    (if (not (boundp 'old-peek))
  242. ;        (define old-peek #'peek))               ; same away old function ptr
  243. ;    (define (peek place &optional (arg 1))      ; define new func
  244. ;         (funcall old-peek                      ; call the old func,
  245. ;            (if (listp place)                   ; but rewrite the arguments
  246. ;                (mk-fp (car place) (cadr place))    
  247. ;                place)
  248. ;            (case arg
  249. ;                ((str string)   0)
  250. ;                ((byte)         1)
  251. ;                ((word int)     2)
  252. ;                ((long fixnum)  4)
  253. ;                ((float double) 8)
  254. ;                (t              arg))))
  255.  
  256. ; for compatibility with old versions of OS2XLISP               
  257. (define (register library function)
  258.     (getprocaddr
  259.         (loadmodule library)
  260.         function))
  261.  
  262. ;;; uncomment these next two lines if you want a different prompt
  263. ; (define *promptcount* 0)
  264. ; (define *prompt* '(format stdout "[~A] " (incr *promptcount*)))
  265.  
  266.  
  267. ;======================================================================
  268. ; (format stdout 
  269. ;    "~A/~A/~A   ~A:~A:~A~%"
  270. ;    (first (date)) (second (date)) (third (date))
  271. ;    (first (time)) (second (time)) (third (time)))
  272.  
  273.