home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / os2pm.scm < prev    next >
Text File  |  1999-01-02  |  30KB  |  1,060 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: os2pm.scm,v 1.8 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1995-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Program to generate OS/2 PM interface code.
  23.  
  24. ;;; The Scheme OS/2 Presentation Manager interface is implemented in
  25. ;;; its own thread, which means that all operations involving the
  26. ;;; interface must by encoded into messages and communicated to the PM
  27. ;;; thread through its message queue.  This is reasonably
  28. ;;; straightforward, but the overhead for implementing a single
  29. ;;; operation is daunting: in addition to the procedure that performs
  30. ;;; the operation, the implementer must also write two additional
  31. ;;; procedures, three function prototypes, one or two message-type
  32. ;;; declarations, one or two message-structure declarations, and one
  33. ;;; or two case statements in the message dispatch.  The purpose of
  34. ;;; this file is to generate all of the overhead code automatically
  35. ;;; from a simple interface definition; the implementer supplies the
  36. ;;; definition and the operation's procedure, and this program takes
  37. ;;; care of the rest of the details.
  38.  
  39. ;;; The bulk of this file is the program to parse the interface
  40. ;;; specifications and to generate the appropriate code.  The
  41. ;;; specifications themselves appear on the last page of the file.
  42.  
  43. ;;; To generate the output files, just load this file.  The output
  44. ;;; files will be written into the working directory.
  45.  
  46. (declare (usual-integrations))
  47.  
  48. (load-option 'HASH-TABLE)
  49. (load-option 'FORMAT)
  50.  
  51. ;;;; Syntax
  52.  
  53. (define-macro (define-pm-procedure name . clauses)
  54.   (let ((external-name (if (pair? name) (car name) name))
  55.     (internal-name (if (pair? name) (cadr name) name)))
  56.     `(BEGIN
  57.        (HASH-TABLE/PUT! PM-PROCEDURES ',external-name
  58.      (MAKE-PMP (TRANSLATE-NAME ',external-name)
  59.            (TRANSLATE-NAME ',internal-name)
  60.            ,(let ((clause (assq 'VALUE clauses)))
  61.               (if clause
  62.               (let ((val (cadr clause)))
  63.                 (if (symbol? val)
  64.                 (if (eq? val 'SYNC)
  65.                     `',val
  66.                     `(TRANSLATE-TYPE/NAME ',`((ID ,val) ,val)))
  67.                 `(TRANSLATE-TYPE/NAME ',val)))
  68.               '#F))
  69.            ,(let ((args
  70.                (let ((clause (assq 'ARGUMENTS clauses)))
  71.                  (if (not clause)
  72.                  (error "ARGUMENTS clause is required:" name))
  73.                  (cdr clause))))
  74.               `(CONS (TRANSLATE-TYPE/NAME
  75.                   ',(if (symbol? (car args))
  76.                     `((ID ,(car args)) ,(car args))
  77.                     (car args)))
  78.                  (LIST ,@(map (lambda (arg)
  79.                         `(TRANSLATE-TYPE/NAME ',arg))
  80.                       (cdr args)))))))
  81.        ',external-name)))
  82.  
  83. (define (translate-type/name tn)
  84.   (cond ((and (pair? tn)
  85.           (pair? (cdr tn))
  86.           (null? (cddr tn)))
  87.      (list (translate-type (car tn))
  88.            (translate-name (cadr tn))))
  89.     ((and (pair? tn)
  90.           (pair? (cdr tn))
  91.           (pair? (cddr tn))
  92.           (null? (cdddr tn)))
  93.      (list (translate-type (car tn))
  94.            (translate-name (cadr tn))
  95.            (translate-name (caddr tn))))
  96.     (else
  97.      (error "Ill-formed type/name pair:" tn))))
  98.  
  99. (define (translate-type type)
  100.   (cond ((string? type)
  101.      type)
  102.     ((symbol? type)
  103.      (let ((abbrev (hash-table/get type-abbreviations type #f)))
  104.        (if abbrev
  105.            (translate-type abbrev)
  106.            (symbol->string type))))
  107.     ((and (pair? type)
  108.           (or (string? (car type))
  109.           (symbol? (car type)))
  110.           (pair? (cdr type))
  111.           (null? (cddr type)))
  112.      (if (eq? (car type) 'ID)
  113.          type
  114.          (list (if (or (string? (car type))
  115.                (memq (car type) '(POINTER ARRAY)))
  116.                (car type)
  117.                (symbol->string (car type)))
  118.            (translate-type (cadr type)))))
  119.     ((and (pair? type)
  120.           (eq? (car type) 'ARRAY)
  121.           (pair? (cdr type))
  122.           (pair? (cddr type))
  123.           (and (exact-integer? (caddr type))
  124.            (positive? (caddr type)))
  125.           (null? (cdddr type)))
  126.      (list (car type)
  127.            (translate-type (cadr type))
  128.            (number->string (caddr type))))
  129.     (else
  130.      (error "Ill-formed type:" type))))
  131.  
  132. (define (translate-name name)
  133.   (cond ((string? name)
  134.      name)
  135.     ((symbol? name)
  136.      (symbol->string name))
  137.     (else
  138.      (error "Ill-formed name:" name))))
  139.  
  140. (define (define-type-abbreviation name type)
  141.   (hash-table/put! type-abbreviations name type))
  142.  
  143. (define type-abbreviations
  144.   (make-eq-hash-table))
  145.  
  146. (define-type-abbreviation 'boolean 'int)
  147. (define-type-abbreviation 'uchar '(unsigned char))
  148. (define-type-abbreviation 'ushort '(unsigned short))
  149. (define-type-abbreviation 'uint '(unsigned int))
  150. (define-type-abbreviation 'ulong '(unsigned long))
  151.  
  152. (define (id-type? type) (and (pair? type) (eq? (car type) 'ID)))
  153. (define-integrable id-type-name cadr)
  154.  
  155. (define (pointer-type? type) (and (pair? type) (eq? (car type) 'POINTER)))
  156. (define (array-type? type) (and (pair? type) (eq? (car type) 'ARRAY)))
  157. (define-integrable subtype cadr)
  158.  
  159. (define (array-dimension type)
  160.   (and (pair? (cddr type))
  161.        (caddr type)))
  162.  
  163. (define (variable-length-array? arg)
  164.   (let ((type (pmp-arg-type arg)))
  165.     (and (array-type? type)
  166.      (not (array-dimension type)))))
  167.  
  168. ;;;; ID Types
  169.  
  170. (define (define-id internal-root external-root)
  171.   (hash-table/put! id-external-roots
  172.            internal-root
  173.            (symbol->string external-root)))
  174.  
  175. (define (id-internal-root type)
  176.   (symbol->string (id-type-name type)))
  177.  
  178. (define (id-external-root type)
  179.   (hash-table/get id-external-roots (id-type-name type) #f))
  180.  
  181. (define id-external-roots
  182.   (make-eq-hash-table))
  183.  
  184. (define (id-external-type type)
  185.   (list (id-external-root type) "_t"))
  186.  
  187. (define (id-internal-type type)
  188.   (if (eq? (id-type-name type) 'QID)
  189.       (id-external-type type)
  190.       (list (id-internal-root type) "_t *")))
  191.  
  192. (define-integrable (id-internal-name arg)
  193.   (pmp-arg-name arg))
  194.  
  195. (define (id-external-name arg)
  196.   (if (eq? (id-type-name (pmp-arg-type arg)) 'QID)
  197.       (pmp-arg-name arg)
  198.       (list (pmp-arg-name arg) "_id")))
  199.  
  200. (define (id-internal-expression arg)
  201.   (let ((type (pmp-arg-type arg)))
  202.     (if (eq? (id-type-name type) 'QID)
  203.     (id-external-name arg)
  204.     (list "("
  205.           (id-external-root type)
  206.           "_to_"
  207.           (id-internal-root type)
  208.           " ("
  209.           (id-external-name arg)
  210.           "))"))))
  211.  
  212. (define (id-external-expression arg)
  213.   (let ((type (pmp-arg-type arg)))
  214.     (if (eq? (id-type-name type) 'QID)
  215.     (id-internal-name arg)
  216.     (list "("
  217.           (string-upcase (id-internal-root type))
  218.           "_ID ("
  219.           (id-internal-name arg)
  220.           "))"))))
  221.  
  222. (define (id-qid-expression arg)
  223.   (let ((type (pmp-arg-type arg)))
  224.     (if (eq? (id-type-name type) 'QID)
  225.     (id-internal-name arg)
  226.     (list "("
  227.           (string-upcase (id-internal-root type))
  228.           "_QID ("
  229.           (id-internal-name arg)
  230.           "))"))))
  231.  
  232. (define-id 'QID 'QID)
  233. (define-id 'WINDOW 'WID)
  234. (define-id 'PS 'PSID)
  235. (define-id 'BITMAP 'BID)
  236.  
  237. ;;;; PM Procedures
  238.  
  239. (define pm-procedures
  240.   (make-eq-hash-table))
  241.  
  242. (define-structure pmp
  243.   (root-name #f read-only #t)
  244.   (internal-name #f read-only #t)
  245.   (value #f read-only #t)
  246.   (arguments #f read-only #t))
  247.  
  248. (define-integrable pmp-arg-type car)
  249. (define-integrable pmp-arg-name cadr)
  250. (define-integrable (pmp-value? pmp) (pair? (pmp-value pmp)))
  251. (define-integrable (pmp-sync? pmp) (eq? (pmp-value pmp) 'SYNC))
  252.  
  253. (define (pmp-arg-size-name arg)
  254.   (and (not (null? (cddr arg)))
  255.        (caddr arg)))
  256.  
  257. (define (pmp-request-struct-name pmp)
  258.   (list "sm_" (pmp-root-name pmp) "_request_t"))
  259.  
  260. (define (pmp-reply-struct-name pmp)
  261.   (list "sm_" (pmp-root-name pmp) "_reply_t"))
  262.  
  263. (define (pmp-request-message-name pmp)
  264.   (list "mt_" (pmp-root-name pmp) "_request"))
  265.  
  266. (define (pmp-reply-message-name pmp)
  267.   (list "mt_" (pmp-root-name pmp) "_reply"))
  268.  
  269. (define (pmp-external-name pmp)
  270.   (list "OS2_" (pmp-root-name pmp)))
  271.  
  272. (define (pmp-request-handler-name pmp)
  273.   (list "handle_" (pmp-root-name pmp) "_request"))
  274.  
  275. (define (for-each-pmp procedure)
  276.   (for-each procedure
  277.         (sort (hash-table/datum-list pm-procedures)
  278.           (lambda (x y)
  279.             (string<? (pmp-root-name x) (pmp-root-name y))))))
  280.  
  281. ;;;; Printing
  282.  
  283. (define (print tree port)
  284.   (if (list? tree)
  285.       (for-each (lambda (element) (print element port)) tree)
  286.       (display tree port)))
  287.  
  288. (define (indent n . tree)
  289.   (let ((indent (make-string n #\space)))
  290.     (let at-line-start ((objects (flatten-for-indentation tree)))
  291.       (if (null? objects)
  292.       '()
  293.       (cons indent
  294.         (let in-line ((objects objects))
  295.           (cons (car objects)
  296.             (cond ((eqv? (car objects) #\newline)
  297.                    (at-line-start (cdr objects)))
  298.                   ((null? (cdr objects))
  299.                    '())
  300.                   (else
  301.                    (in-line (cdr objects)))))))))))
  302.  
  303. (define (indent-following n . tree)
  304.   (let ((indent (make-string n #\space)))
  305.     (let in-line ((objects (flatten-for-indentation tree)))
  306.       (cons (car objects)
  307.         (cond ((eqv? (car objects) #\newline)
  308.            (let at-line-start ((objects (cdr objects)))
  309.              (if (null? objects)
  310.              '()
  311.              (cons indent (in-line objects)))))
  312.           ((null? (cdr objects))
  313.            '())
  314.           (else
  315.            (in-line (cdr objects))))))))
  316.  
  317. (define (flatten-for-indentation tree)
  318.   (cond ((list? tree)
  319.      (append-map flatten-for-indentation tree))
  320.     ((string? tree)
  321.      (reveal-embedded-newlines tree))
  322.     (else
  323.      (list tree))))
  324.  
  325. (define (reveal-embedded-newlines string)
  326.   (let ((indices (find-embedded-newlines string)))
  327.     (if (null? indices)
  328.     (list string)
  329.     (let loop ((start 0) (indices indices))
  330.       (if (null? indices)
  331.           (list (string-tail string start))
  332.           (cons* (substring string start (car indices))
  333.              #\newline
  334.              (loop (fix:+ (car indices) 1) (cdr indices))))))))
  335.  
  336. (define (find-embedded-newlines string)
  337.   (let ((end (string-length string)))
  338.     (let loop ((start 0))
  339.       (let ((index (substring-find-next-char string start end #\newline)))
  340.     (if index
  341.         (cons index (loop (fix:+ index 1)))
  342.         '())))))
  343.  
  344. (define (first-char-in-tree tree)
  345.   (cond ((list? tree)
  346.      (and (pair? tree)
  347.           (or (first-char-in-tree (car tree))
  348.           (first-char-in-tree (cdr tree)))))
  349.     ((string? tree)
  350.      (and (not (string-null? tree))
  351.           (string-ref tree 0)))
  352.     ((char? tree) tree)
  353.     (else #f)))
  354.  
  355. ;;;; C Syntax Combinators
  356.  
  357. (define (brace-group . body)
  358.   (list "{" #\newline
  359.     (apply indent 2 body)
  360.     "}" #\newline))
  361.  
  362. (define (statement . elements)
  363.   (list elements ";" #\newline))
  364.  
  365. (define (assignment target source)
  366.   (statement target " = " source))
  367.  
  368. (define (indented-assignment target source)
  369.   (statement target #\newline "  = " (indent-following 4 source)))
  370.  
  371. (define (function name static? value arguments . body)
  372.   (list (if static? "static " "") value #\newline
  373.     name " " arguments #\newline
  374.     (apply brace-group body)))
  375.  
  376. (define (funcall function . arguments)
  377.   (list "(" function " " (funcall-arguments arguments) ")"))
  378.  
  379. (define (indented-funcall function . arguments)
  380.   (list "(" function #\newline (indent 2 (funcall-arguments arguments) ")")))
  381.  
  382. (define (call function . arguments)
  383.   (statement function " " (funcall-arguments arguments)))
  384.  
  385. (define (indented-call function . arguments)
  386.   (statement function #\newline (indent 2 (funcall-arguments arguments))))
  387.  
  388. (define (funcall-arguments arguments)
  389.   (cond ((null? arguments)
  390.      (list "()"))
  391.     ((null? (cdr arguments))
  392.      (list (guarantee-parentheses (car arguments))))
  393.     (else
  394.      (let loop ((arguments arguments) (prefix "("))
  395.        (cons* prefix
  396.           (car arguments)
  397.           (if (null? (cdr arguments))
  398.               (list ")")
  399.               (loop (cdr arguments) ", ")))))))
  400.  
  401. (define (guarantee-parentheses expression)
  402.   (if (eqv? #\( (first-char-in-tree expression))
  403.       expression
  404.       (list "(" expression ")")))
  405.  
  406. (define (cast type expression)
  407.   (list "((" type ") " expression ")"))
  408.  
  409. ;;;; Per-Procedure Output
  410.  
  411. (define (generate-message-types pmp)
  412.   (cons* "  " (pmp-request-message-name pmp) "," #\newline
  413.      (if (pmp-value? pmp)
  414.          (list "  " (pmp-reply-message-name pmp) "," #\newline)
  415.          '())))
  416.  
  417. (define (generate-handler-prototype pmp)
  418.   (statement "static void "
  419.          (pmp-request-handler-name pmp)
  420.          #\newline "  ("
  421.          (pmp-request-struct-name pmp)
  422.          " *)"))
  423.  
  424. (define (generate-prototype pmp external?)
  425.   (statement (if external? "extern" "static")
  426.          " "
  427.          (val-type pmp external?)
  428.          " "
  429.          (if external? (pmp-external-name pmp) (pmp-internal-name pmp))
  430.          #\newline "  "
  431.          (arg-declarators (pmp-arguments pmp) external? #f)))
  432.  
  433. (define (generate-message-initializers pmp)
  434.   (indent 2
  435.       (let ((generate-init
  436.          (lambda (mn sn)
  437.            (statement "SET_MSG_TYPE_LENGTH (" mn "," #\newline
  438.                   "                     " sn ")"))))
  439.         (list (generate-init (pmp-request-message-name pmp)
  440.                  (pmp-request-struct-name pmp))
  441.           (if (pmp-value? pmp)
  442.               (generate-init (pmp-reply-message-name pmp)
  443.                      (pmp-reply-struct-name pmp))
  444.               '())))))
  445.  
  446. (define (generate-dispatch-case pmp)
  447.   (indent 8
  448.       "case " (pmp-request-message-name pmp) ":" #\newline
  449.       (indent 2
  450.           (indented-call
  451.            (pmp-request-handler-name pmp)
  452.            (cast (list (pmp-request-struct-name pmp) " *")
  453.              "message"))
  454.           (statement "break"))))
  455.  
  456. (define (generate-struct-definitions pmp)
  457.   (list (generate-struct-definition
  458.      (pmp-request-struct-name pmp)
  459.      (map (lambda (arg)
  460.         (let ((type (pmp-arg-type arg)))
  461.           (if (array-type? type)
  462.               (list (arg-type-1 (subtype type))
  463.                 " "
  464.                 (arg-name arg #f)
  465.                 " ["
  466.                 (or (array-dimension type) "1")
  467.                 "]")
  468.               (arg-declarator arg #f))))
  469.           (let ((args (pmp-arguments pmp)))
  470.         (let ((array
  471.                (list-search-positive args
  472.              variable-length-array?)))
  473.           (if array
  474.               (append (delq array args) (list array))
  475.               args)))))
  476.     (if (pmp-value? pmp)
  477.         (list #\newline
  478.           (generate-struct-definition
  479.            (pmp-reply-struct-name pmp)
  480.            (list (arg-declarator (pmp-value pmp) #f))))
  481.         '())))
  482.  
  483. (define (generate-struct-definition name elements)
  484.   (statement "typedef struct" #\newline
  485.          "{" #\newline
  486.          (indent 2
  487.              (map statement
  488.               (cons "DECLARE_MSG_HEADER_FIELDS" elements)))
  489.          "}" " " name))
  490.  
  491. (define (generate-request-procedure pmp)
  492.   (let ((args (pmp-arguments pmp)))
  493.     (function (pmp-external-name pmp)
  494.           #f
  495.           (val-type pmp #t)
  496.           (arg-declarators args #t #t)
  497.           (map (lambda (arg)
  498.              (let ((type (pmp-arg-type arg)))
  499.                (if (and (id-type? type)
  500.                 (not (eq? (id-type-name type) 'QID)))
  501.                (assignment (arg-declarator arg #f)
  502.                        (id-internal-expression arg))
  503.                '())))
  504.            args)
  505.           (indented-assignment
  506.            (list (pmp-request-struct-name pmp) " * request")
  507.            (message-creator pmp
  508.                 (pmp-request-struct-name pmp)
  509.                 (pmp-request-message-name pmp)
  510.                 (request-extra pmp)))
  511.           (map (lambda (arg) (request-initializer pmp arg)) args)
  512.           (if (pmp-value? pmp)
  513.           (let ((val (pmp-value pmp)))
  514.             (brace-group
  515.              (indented-assignment
  516.               (list (pmp-reply-struct-name pmp) " * reply")
  517.               (indented-funcall
  518.                "MESSAGE_TRANSACTION"
  519.                (id-qid-expression (car (pmp-arguments pmp)))
  520.                "request"
  521.                (pmp-reply-message-name pmp)))
  522.              (assignment (arg-declarator val #f)
  523.                  (reply-accessor val))
  524.              (call "DESTROY_MESSAGE" "reply")
  525.              (call "return"
  526.                (if (id-type? (pmp-arg-type val))
  527.                    (id-external-expression val)
  528.                    (arg-name val #f)))))
  529.           (call (if (pmp-sync? pmp)
  530.                 "SYNC_TRANSACTION"
  531.                 "SIMPLE_TRANSACTION")
  532.             (id-qid-expression (car (pmp-arguments pmp)))
  533.             "request")))))
  534.  
  535. (define (request-extra pmp)
  536.   (let ((array-arg
  537.      (list-search-positive (pmp-arguments pmp)
  538.        variable-length-array?)))
  539.     (and array-arg
  540.      (let ((size (pmp-arg-size-name array-arg)))
  541.        (if size
  542.            (list "(" size " - 1)")
  543.            (funcall "strlen" (arg-name array-arg #f)))))))
  544.  
  545. (define (request-initializer pmp arg)
  546.   (if (array-type? (pmp-arg-type arg))
  547.       (let ((source (arg-name arg #t))
  548.         (target (request-accessor arg))
  549.         (size (pmp-arg-size-name arg)))
  550.     (if size
  551.         (call "MEMCPY"
  552.           target
  553.           source
  554.           (list "((sizeof ("
  555.             (arg-type-1 (subtype (pmp-arg-type arg)))
  556.             ")) * "
  557.             size
  558.             ")"))
  559.         (call "STRCPY" target source)))
  560.       (assignment (request-accessor arg) (arg-name arg #f))))
  561.  
  562. (define (generate-request-handler pmp)
  563.   (function (pmp-request-handler-name pmp)
  564.         #t
  565.         "void"
  566.         (list "(" (list (pmp-request-struct-name pmp) " * request") ")")
  567.         (assignment "qid_t sender" (funcall "MSG_SENDER" "request"))
  568.         (if (pmp-value? pmp)
  569.         (list (indented-assignment
  570.                (list (pmp-reply-struct-name pmp) " * reply")
  571.                (message-creator pmp
  572.                     (pmp-reply-struct-name pmp)
  573.                     (pmp-reply-message-name pmp)
  574.                     #f))
  575.               (indented-assignment
  576.                (reply-accessor (pmp-value pmp))
  577.                (apply indented-funcall
  578.                   (pmp-internal-name pmp)
  579.                   (map (lambda (arg)
  580.                      (request-accessor arg))
  581.                    (pmp-arguments pmp))))
  582.               (call "DESTROY_MESSAGE" "request")
  583.               (call "SEND_MESSAGE" "sender" "reply"))
  584.         (list (apply indented-call
  585.                  (pmp-internal-name pmp)
  586.                  (map (lambda (arg) (request-accessor arg))
  587.                   (pmp-arguments pmp)))
  588.               (call "DESTROY_MESSAGE" "request")
  589.               (call (if (pmp-sync? pmp) "sync_reply" "simple_reply")
  590.                 "sender")))))
  591.  
  592. (define (message-creator pmp struct-type message-type extra)
  593.   (if extra
  594.       (funcall "CREATE_MESSAGE_1" message-type extra)
  595.       (funcall "CREATE_MESSAGE" message-type)))
  596.  
  597. (define (request-accessor arg)
  598.   (message-accessor "request" arg))
  599.  
  600. (define (reply-accessor arg)
  601.   (message-accessor "reply" arg))
  602.  
  603. (define (message-accessor message-name arg)
  604.   (list "(" message-name " -> " (arg-name arg #f) ")"))
  605.  
  606. (define (val-type pmp external?)
  607.   (if (pmp-value? pmp)
  608.       (arg-type (pmp-value pmp) external?)
  609.       "void"))
  610.  
  611. (define (arg-declarator arg external?)
  612.   (list (arg-type arg external?)
  613.     " "
  614.     (arg-name arg external?)))
  615.  
  616. (define (arg-declarators args external? names?)
  617.   (if (null? args)
  618.       "(void)"
  619.       (let ((do-arg
  620.          (lambda (arg)
  621.            (if names?
  622.            (arg-declarator arg external?)
  623.            (arg-type arg external?)))))
  624.     (cons* "("
  625.            (do-arg (car args))
  626.            (let loop ((args (cdr args)))
  627.          (if (null? args)
  628.              (list ")")
  629.              (cons* ", "
  630.                 (do-arg (car args))
  631.                 (loop (cdr args)))))))))
  632.  
  633. (define (arg-type arg external?)
  634.   (let ((type (pmp-arg-type arg)))
  635.     (if (id-type? type)
  636.     (if external?
  637.         (id-external-type type)
  638.         (id-internal-type type))
  639.     (arg-type-1 type))))
  640.  
  641. (define (arg-type-1 type)
  642.   (if (pair? type)
  643.       (case (car type)
  644.     ((POINTER ARRAY)
  645.      (list (arg-type-1 (subtype type)) " *"))
  646.     (else
  647.      (list (car type) " " (arg-type-1 (subtype type)))))
  648.       type))
  649.  
  650. (define (arg-name arg external?)
  651.   (let ((name (pmp-arg-name arg)))
  652.     (if (id-type? (pmp-arg-type arg))
  653.     (if external?
  654.         (id-external-name arg)
  655.         (id-internal-name arg))
  656.     (pmp-arg-name arg))))
  657.  
  658. ;;;; Top-Level Output
  659.  
  660. (define (generate-file filename per-pmp)
  661.   (call-with-output-file filename
  662.     (lambda (port)
  663.       (let ((time (get-decoded-time)))
  664.     (format port
  665.         file-header-format-string
  666.         (decoded-time/date-string time)
  667.         (decoded-time/time-string time)
  668.         (current-user-name)
  669.         (decoded-time/year time)))
  670.       (for-each-pmp (lambda (pmp) (print (per-pmp pmp) port))))))
  671.  
  672. (define file-header-format-string
  673.   "/* -*-C-*-
  674.  
  675. **** Do not edit this file.  It was generated by a program,
  676. **** on ~A at ~A by ~a.
  677.  
  678. Copyright (c) ~A Massachusetts Institute of Technology
  679.  
  680. This program is free software; you can redistribute it and/or modify
  681. it under the terms of the GNU General Public License as published by
  682. the Free Software Foundation; either version 2 of the License, or (at
  683. your option) any later version.
  684.  
  685. This program is distributed in the hope that it will be useful, but
  686. WITHOUT ANY WARRANTY; without even the implied warranty of
  687. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  688. General Public License for more details.
  689.  
  690. You should have received a copy of the GNU General Public License
  691. along with this program; if not, write to the Free Software
  692. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  693. */
  694. ")
  695.  
  696. (define (write-message-types-file)
  697.   (generate-file "os2pm-mt.h" generate-message-types))
  698.  
  699. (define (write-external-declarations-file)
  700.   (generate-file "os2pm-ed.h"
  701.     (lambda (pmp)
  702.       (list #\newline
  703.         (generate-prototype pmp #t)))))
  704.  
  705. (define (write-internal-declarations-file)
  706.   (generate-file "os2pm-id.h"
  707.     (lambda (pmp)
  708.       (list #\newline
  709.         (generate-struct-definitions pmp)
  710.         #\newline
  711.         (generate-handler-prototype pmp)
  712.         #\newline
  713.         (generate-prototype pmp #f)))))
  714.  
  715. (define (write-message-initializers-file)
  716.   (generate-file "os2pm-mi.h" generate-message-initializers))
  717.  
  718. (define (write-dispatch-cases-file)
  719.   (generate-file "os2pm-dc.h" generate-dispatch-case))
  720.  
  721. (define (write-request-procedures-file)
  722.   (generate-file "os2pm-rp.h"
  723.     (lambda (pmp)
  724.       (list #\newline
  725.         (generate-request-procedure pmp)
  726.         #\newline
  727.         (generate-request-handler pmp)))))
  728.  
  729. (define (write-all-files)
  730.   (write-message-types-file)
  731.   (write-external-declarations-file)
  732.   (write-internal-declarations-file)
  733.   (write-message-initializers-file)
  734.   (write-dispatch-cases-file)
  735.   (write-request-procedures-file))
  736.  
  737. ;;;; Interface Definitions
  738.  
  739. (define-pm-procedure pm_synchronize
  740.   (value sync)
  741.   (arguments qid))
  742.  
  743. ;;; Windows
  744.  
  745. (define-pm-procedure window_open
  746.   (value ("wid_t" wid))
  747.   (arguments qid
  748.          (qid_t event_qid)
  749.          (ulong flags)
  750.          ("HMODULE" module)
  751.          (ulong id)
  752.          (ulong style)
  753.          ((array (const char)) title)))
  754.  
  755. (define-pm-procedure window_close
  756.   (arguments window))
  757.  
  758. (define-pm-procedure window_show
  759.   (arguments window (boolean showp)))
  760.  
  761. (define-pm-procedure window_scroll
  762.   (arguments window
  763.          (short xl)
  764.          (short xh)
  765.          (short yl)
  766.          (short yh)
  767.          (short x_delta)
  768.          (short y_delta)))
  769.  
  770. (define-pm-procedure window_invalidate
  771.   (arguments window (short xl) (short xh) (short yl) (short yh)))
  772.  
  773. (define-pm-procedure window_set_grid
  774.   (arguments window (ushort x) (ushort y)))
  775.  
  776. (define-pm-procedure window_activate
  777.   (arguments window))
  778.  
  779. ;;; (define_pm_procedure window_pos ...)
  780.  
  781. (define-pm-procedure window_set_pos
  782.   (arguments window (short x) (short y)))
  783.  
  784. ;;; (define_pm_procedure window_size ...)
  785. ;;; (define_pm_procedure window_frame_size ...)
  786.  
  787. (define-pm-procedure window_set_size
  788.   (arguments window (ushort x) (ushort y)))
  789.  
  790. (define-pm-procedure window_focusp
  791.   (value (boolean focusp))
  792.   (arguments window))
  793.  
  794. (define-pm-procedure window_set_state
  795.   (arguments window (window_state_t state)))
  796.  
  797. (define-pm-procedure window_set_title
  798.   (arguments window ((array (const char)) title)))
  799.  
  800. (define-pm-procedure window_update_frame
  801.   (arguments window (ushort flags)))
  802.  
  803. (define-pm-procedure window_handle_from_id
  804.   (value ("HWND" child))
  805.   (arguments qid ("HWND" parent) (ulong id)))
  806.  
  807. (define-pm-procedure window_set_capture
  808.   (value ("BOOL" successp))
  809.   (arguments window (int capturep)))
  810.  
  811. (define-pm-procedure window_query_sys_value
  812.   (value ("LONG" sysval))
  813.   (arguments qid ("HWND" window) ("LONG" id)))
  814.  
  815. ;;; Text Cursors
  816.  
  817. (define-pm-procedure window_move_cursor
  818.   (arguments window (short x) (short y)))
  819.  
  820. (define-pm-procedure window_shape_cursor
  821.   (arguments window (ushort width) (ushort height) (ushort style)))
  822.  
  823. (define-pm-procedure window_show_cursor
  824.   (arguments window (boolean showp)))
  825.  
  826. ;;; Presentation Spaces
  827.  
  828. (define-pm-procedure create_memory_ps
  829.   (value ps)
  830.   (arguments qid))
  831.  
  832. (define-pm-procedure destroy_memory_ps
  833.   (arguments ps))
  834.  
  835. (define-pm-procedure create_bitmap
  836.   (value bitmap)
  837.   (arguments ps (ushort width) (ushort height)))
  838.  
  839. (define-pm-procedure destroy_bitmap
  840.   (arguments bitmap))
  841.  
  842. ;;; (define_pm_procedure ps_set_bitmap ...)
  843.  
  844. (define-pm-procedure ps_bitblt
  845.   (arguments ((id ps) target)
  846.          ((id ps) source)
  847.          (long npoints)
  848.          ((array "POINTL" 4) points npoints)
  849.          (long rop)
  850.          (ulong options)))
  851.  
  852. (define-pm-procedure ps_draw_text
  853.   (arguments ps
  854.          (short x)
  855.          (short y)
  856.          ((array (const char)) data size)
  857.          (ushort size)))
  858.  
  859. (define-pm-procedure ps_text_width
  860.   (value (ushort width))
  861.   (arguments ps
  862.          ((array (const char)) data size)
  863.          (ushort size)))
  864.  
  865. (define-pm-procedure ps_clear
  866.   (arguments ps (short xl) (short xh) (short yl) (short yh)))
  867.  
  868. (define-pm-procedure ps_get_foreground_color
  869.   (value ("COLOR" color))
  870.   (arguments ps))
  871.  
  872. (define-pm-procedure ps_get_background_color
  873.   (value ("COLOR" color))
  874.   (arguments ps))
  875.  
  876. (define-pm-procedure ps_set_colors
  877.   (arguments ps ("COLOR" foreground) ("COLOR" background)))
  878.  
  879. (define-pm-procedure ps_move_gcursor
  880.   (arguments ps (short x) (short y)))
  881.  
  882. (define-pm-procedure ps_draw_line
  883.   (arguments ps (short x) (short y)))
  884.  
  885. (define-pm-procedure ps_draw_point
  886.   (arguments ps (short x) (short y)))
  887.  
  888. (define-pm-procedure ps_poly_line
  889.   (value sync)
  890.   (arguments ps
  891.          (ulong npoints)
  892.          ((pointer "POINTL") points)))
  893.  
  894. (define-pm-procedure ps_poly_line_disjoint
  895.   (value sync)
  896.   (arguments ps
  897.          (ulong npoints)
  898.          ((pointer "POINTL") points)))
  899.  
  900. (define-pm-procedure ps_set_line_type
  901.   (arguments ps (long type)))
  902.  
  903. (define-pm-procedure ps_set_mix
  904.   (arguments ps (long mix)))
  905.  
  906. (define-pm-procedure ps_query_caps
  907.   (value sync)
  908.   (arguments ps (long start) (long count) ((pointer long) values)))
  909.  
  910. (define-pm-procedure ps_set_clip_rectangle
  911.   (arguments ps (short xl) (short xh) (short yl) (short yh)))
  912.  
  913. (define-pm-procedure ps_reset_clip_rectangle
  914.   (arguments ps))
  915.  
  916. (define-pm-procedure get_bitmap_parameters
  917.   (value sync)
  918.   (arguments bitmap ((pointer "BITMAPINFOHEADER") params)))
  919.  
  920. (define-pm-procedure ps_get_bitmap_bits
  921.   (value (ulong length))
  922.   (arguments ps
  923.          (ulong start)
  924.          (ulong length)
  925.          ((pointer "BYTE") data)
  926.          ((pointer "BITMAPINFO2") info)))
  927.  
  928. (define-pm-procedure ps_set_bitmap_bits
  929.   (value (ulong length))
  930.   (arguments ps
  931.          (ulong start)
  932.          (ulong length)
  933.          ((pointer "BYTE") data)
  934.          ((pointer "BITMAPINFO2") info)))
  935.  
  936. ;;; Clipboard
  937.  
  938. (define-pm-procedure clipboard_write_text
  939.   (value sync)
  940.   (arguments qid ((pointer (const char)) text)))
  941.  
  942. (define-pm-procedure clipboard_read_text
  943.   (value ((pointer (const char)) text))
  944.   (arguments qid))
  945.  
  946. ;;; Menus
  947.  
  948. (define-pm-procedure menu_create
  949.   (value ("HWND" menu))
  950.   (arguments qid ("HWND" owner) (ushort style) (ushort id)))
  951.  
  952. (define-pm-procedure menu_destroy
  953.   (value ("BOOL" successp))
  954.   (arguments qid ("HWND" menu)))
  955.  
  956. (define-pm-procedure menu_insert_item
  957.   (value (ushort position))
  958.   (arguments qid
  959.          ("HWND" menu)
  960.          (ushort position)
  961.          (ushort style)
  962.          (ushort attributes)
  963.          (ushort id)
  964.          ("HWND" submenu)
  965.          ((pointer char) text)))
  966.  
  967. (define-pm-procedure menu_remove_item
  968.   (value (ushort length))
  969.   (arguments qid
  970.          ("HWND" menu)
  971.          (ushort id)
  972.          (ushort submenup)
  973.          (ushort deletep)))
  974.  
  975. (define-pm-procedure menu_get_item
  976.   (value ((pointer "MENUITEM") item))
  977.   (arguments qid
  978.          ("HWND" menu)
  979.          (ushort id)
  980.          (ushort submenup)))
  981.  
  982. (define-pm-procedure menu_n_items
  983.   (value (ushort length))
  984.   (arguments qid ("HWND" menu)))
  985.  
  986. (define-pm-procedure menu_nth_item_id
  987.   (value (ushort id))
  988.   (arguments qid ("HWND" menu) (ushort position)))
  989.  
  990. (define-pm-procedure menu_get_item_attributes
  991.   (value (ushort attributes))
  992.   (arguments qid
  993.          ("HWND" menu)
  994.          (ushort id)
  995.          (ushort submenup)
  996.          (ushort mask)))
  997.  
  998. (define-pm-procedure menu_set_item_attributes
  999.   (value ("BOOL" successp))
  1000.   (arguments qid
  1001.          ("HWND" menu)
  1002.          (ushort id)
  1003.          (ushort submenup)
  1004.          (ushort mask)
  1005.          (ushort attributes)))
  1006.  
  1007. (define-pm-procedure window_load_menu
  1008.   (value ("HWND" menu))
  1009.   (arguments window ("HMODULE" module) (ulong id)))
  1010.  
  1011. (define-pm-procedure window_popup_menu
  1012.   (value ("BOOL" successp))
  1013.   (arguments qid
  1014.          ("HWND" parent)
  1015.          ("HWND" owner)
  1016.          ("HWND" menu)
  1017.          (long x)
  1018.          (long y)
  1019.          (long id)
  1020.          (ulong options)))
  1021.  
  1022. ;;; Font
  1023.  
  1024. (define-pm-procedure ps_get_font_metrics
  1025.   (value ((pointer font_metrics_t) metrics))
  1026.   (arguments ps))
  1027.  
  1028. (define-pm-procedure ps_set_font_internal
  1029.   (value ((pointer font_metrics_t) metrics))
  1030.   (arguments ps
  1031.          (ushort id)
  1032.          ((array (const char)) name)))
  1033.  
  1034. (define-pm-procedure window_font_dialog
  1035.   (value ((pointer (const char)) spec))
  1036.   (arguments window ((pointer (const char)) title)))
  1037.  
  1038. ;;; Pointers
  1039.  
  1040. (define-pm-procedure query_system_pointer
  1041.   (value ("HPOINTER" pointer))
  1042.   (arguments qid ("HWND" desktop) (long id) ("BOOL" copyp)))
  1043.  
  1044. (define-pm-procedure set_pointer
  1045.   (value ("BOOL" successp))
  1046.   (arguments qid ("HWND" desktop) ("HPOINTER" pointer)))
  1047.  
  1048. (define-pm-procedure window_load_pointer
  1049.   (value ("HPOINTER" pointer))
  1050.   (arguments qid ("HWND" desktop) ("HMODULE" module) (ulong id)))
  1051.  
  1052. (define-pm-procedure window_destroy_pointer
  1053.   (value ("BOOL" successp))
  1054.   (arguments qid ("HPOINTER" icon)))
  1055.  
  1056. (define-pm-procedure window_set_icon
  1057.   (value ("BOOL" successp))
  1058.   (arguments window ("HPOINTER" icon)))
  1059.  
  1060. (write-all-files)