home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / lib / xt / make-widget < prev    next >
Encoding:
Text File  |  1992-10-02  |  5.5 KB  |  176 lines
  1. ;;; -*-Scheme-*-
  2.  
  3. (define type-name #f)
  4.  
  5. (define classes '())
  6. (define callbacks '())
  7. (define primitives '())
  8. (define converters '())
  9.  
  10. (define f)
  11.  
  12. (define (check-string proc x name)
  13.   (if (not (memq (type x) '(symbol string)))
  14.       (error proc (format #f "~s must be string or symbol" name))))
  15.  
  16. (define (define-widget-type name include)
  17.     (if type-name
  18.     (error 'define-widget-type "must be called once"))
  19.     (check-string 'define-widget-type name 'name)
  20.     (if (pair? include)
  21.     (for-each
  22.       (lambda (i) (check-string 'define-widget-type i 'include)) include)
  23.         (check-string 'define-widget-type include 'include))
  24.     (set! type-name name)
  25.     (format f "#include \"../xt/xt.h\"~%")
  26.     (case widget-set
  27.       (xmotif
  28.     (format f "#include <Xm/Xm.h>~%")))
  29.     (if (and (not (eqv? include "")) (not (null? include)))
  30.     (begin
  31.       (define dir)
  32.       (case widget-set
  33.         (xmotif
  34.          (set! dir "Xm"))
  35.         (xaw
  36.          (set! dir "X11/Xaw")))
  37.       (if (pair? include)
  38.           (for-each
  39.         (lambda (i)
  40.               (if (char=? (string-ref (format #f "~a" i) 0) #\<)
  41.               (format f "#include ~a~%" i)
  42.               (format f "#include <~a/~a>~%" dir i)))
  43.         include)
  44.           (if (char=? (string-ref (format #f "~a" include) 0) #\<)
  45.           (format f "#include ~a~%" include)
  46.           (format f "#include <~a/~a>~%" dir include)))))
  47.     (newline f))
  48.  
  49. (define (prolog code)
  50.   (if (not type-name)
  51.       (error 'prolog "must define a widget-type first"))
  52.   (check-string 'prolog code 'code)
  53.   (display code f)
  54.   (format f "~%~%"))
  55.  
  56. (define (define-callback class name has-arg?)
  57.   (check-string 'define-callback class 'class)
  58.   (check-string 'define-callback name 'name)
  59.   (if (not (boolean? has-arg?))
  60.       (error 'define-callback "has-arg? must be boolean"))
  61.   (set! callbacks (cons (list class name has-arg?) callbacks)))
  62.  
  63. (define (c->scheme name body)
  64.   (check-string 'c->scheme name 'name)
  65.   (define c-name (scheme-to-c-name name))
  66.   (string-set! c-name 0 #\S)
  67.   (format f "static Object ~a (x) XtArgVal x; {~%" c-name)
  68.   (display body f)
  69.   (format f "~%}~%~%")
  70.   (define s
  71.     (format #f "    Define_Converter_To_Scheme (\"~a\", ~a);~%"
  72.         name c-name))
  73.   (set! converters (cons s converters)))
  74.  
  75. (define (scheme->c name body)
  76.   (check-string 'scheme->c name 'name)
  77.   (define c-name (scheme-to-c-name name))
  78.   (string-set! c-name 0 #\C)
  79.   (format f "static XtArgVal ~a (x) Object x; {~%" c-name)
  80.   (display body f)
  81.   (format f "~%}~%~%")
  82.   (define s
  83.     (format #f "    Define_Converter_To_C (\"~a\", ~a);~%"
  84.         name c-name))
  85.   (set! converters (cons s converters)))
  86.  
  87. (define (define-primitive scheme-name args body)
  88.   (check-string 'define-primitive scheme-name 'scheme-name)
  89.   (if (not (pair? args))
  90.       (error 'define-primitive "args must be a list"))
  91.   (define c-name (scheme-to-c-name scheme-name))
  92.   (format f "static Object ~a (" c-name)
  93.   (do ((a args a)) ((null? a))
  94.     (display (car a) f)
  95.     (set! a (cdr a))
  96.     (if a (display ", " f)))
  97.   (display ") " f)
  98.   (if args
  99.       (begin
  100.     (display "Object " f)
  101.     (do ((a args a)) ((null? a))
  102.       (display (car a) f)
  103.       (set! a (cdr a))
  104.       (if a (display ", " f)))
  105.     (display "; {" f)))
  106.   (newline f)
  107.   (display body f)
  108.   (format f "~%}~%~%")
  109.   (define s
  110.     (format #f "    Define_Primitive (~a, \"~a\", ~a, ~a, EVAL);~%"
  111.         c-name scheme-name (length args) (length args)))
  112.   (set! primitives (cons s primitives)))
  113.  
  114. ;;; [missing conversion from -> to "to"]
  115. (define (scheme-to-c-name s)
  116.   (if (symbol? s)
  117.       (set! s (symbol->string s)))
  118.   (define len (string-length s))
  119.   (if (char=? (string-ref s (1- len)) #\?)
  120.       (string-set! s (1- len) #\p))
  121.   (if (char=? (string-ref s (1- len)) #\!)
  122.       (set! len (1- len)))
  123.   (let loop ((ret "P") (i 0))
  124.     (if (>= i len)
  125.     ret
  126.     (define next
  127.       (do ((j i (1+ j))) ((or (= j len) (char=? (string-ref s j) #\-)) j)))
  128.     (loop (format #f "~a_~a~a" ret (char-upcase (string-ref s i))
  129.               (substring s (1+ i) next)) (1+ next)))))
  130.  
  131. (define (define-widget-class name class . sub-resources)
  132.   (check-string 'define-widget-class name 'name)
  133.   (check-string 'define-widget-class class 'class)
  134.   (set! classes (cons (list name class sub-resources) classes)))
  135.  
  136. (define args (command-line-args))
  137. (if (not (= (length args) 3))
  138.     (error 'make-widget "expected three arguments"))
  139. (define widget-set (string->symbol (caddr args)))
  140. (set! f (open-output-file (cadr args)))
  141. (load (car args))
  142. (if (not type-name)
  143.     (error 'make-widget "no widget type defined"))
  144. (format f "init_~a () {~%" type-name)
  145. (if (not (null? classes))
  146.     (format f "    XtResourceList r = 0;~%"))
  147. (do ((c classes (cdr c))) ((null? c))
  148.   (define cl (car c))
  149.   (define res (caddr cl))
  150.   (if res
  151.       (begin
  152.     (format f
  153.       "    r = (XtResourceList)XtMalloc (~a * sizeof (XtResource));~%"
  154.       (length res))
  155.     (do ((r res (cdr r)) (num 0 (1+ num))) ((null? r))
  156.       (define x (car r))
  157.       (if (not (= (length x) 3))
  158.           (error 'make-widget "bad sub-resource declaration"))
  159.       (for-each
  160.        (lambda (r)
  161.          (if (not (memq (type r) '(symbol string)))
  162.          (error 'make-widget "bad type in sub-resource declaration")))
  163.        x)
  164.       (format f "    r[~a].resource_name = \"~a\";~%" num (car x))
  165.       (format f "    r[~a].resource_class = \"~a\";~%" num (cadr x))
  166.       (format f "    r[~a].resource_type = \"~a\";~%" num (caddr x)))))
  167.   (format f "    Define_Class (\"~a\", ~a, r, ~a);~%" (car cl) (cadr cl)
  168.       (length res)))
  169. (do ((c callbacks (cdr c))) ((null? c))
  170.   (define cb (car c))
  171.   (format f "    Define_Callback (\"~a\", \"~a\", ~a);~%" (car cb) (cadr cb)
  172.       (if (caddr cb) 1 0)))
  173. (for-each (lambda (x) (display x f)) primitives)
  174. (for-each (lambda (x) (display x f)) converters)
  175. (format f "}~%")
  176.