home *** CD-ROM | disk | FTP | other *** search
/ Stars of Shareware: Programmierung / SOURCE.mdf / programm / windows / c / aptery10 / pasgen.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-01-27  |  20.6 KB  |  779 lines
  1. ;;; Start
  2. ; Lisp Program. Copyright 1993,1994 Apteryx Lisp Ltd.
  3.  
  4. ; Pascal code generator. Examples of individual code
  5. ; macro useage are given after their definitions. A file
  6. ; generation example is given at the bottom of this file.
  7.  
  8.  
  9. (load "gen.lsp" :print nil)
  10.  
  11. ;;; Layout
  12.  
  13. ; This means that you can generate individual expressions
  14. ; into standard output to see what result they produce.
  15. (setq *pout* *standard-output*)
  16.  
  17. (setq *ind* 0)
  18.  
  19. (if (not (fboundp 'print-indent))
  20.   (defun print-indent (n out)
  21.     (dotimes (i n)
  22.       (princ " " out) ) ) )
  23.  
  24. (defun indent ()
  25.   (print-indent *ind* *pout*) )
  26.  
  27. (defun semicolon ()
  28.   (princ ";" *pout*)
  29.   (terpri *pout*) )
  30.  
  31. (defun nl ()
  32.   (terpri *pout*) (indent) )
  33.  
  34. (defmacro with-indent (&rest stmts)
  35.   `(progn
  36.      (setq *ind* (+ *ind* 2))
  37.      ,@stmts
  38.      (setq *ind* (- *ind* 2)) ) )
  39.  
  40. (defun /* (line1 &rest lines)
  41.   (nl) (princ "{ " *pout*) (princ line1 *pout*)
  42.   (dolist (line lines)
  43.     (nl) (princ "  " *pout*) (princ line *pout*) )
  44.   (princ " }" *pout*) (terpri *pout*)
  45.   `(comment ,@lines) )
  46.  
  47. (defun comment-producer ()
  48.   (/* "Produced using Apteryx Lisp") )
  49.  
  50. ;;; Declarations
  51.  
  52. (defmacro program (name)
  53.   `(progn
  54.      (princ "program " *pout*)
  55.      (prin1 ',name *pout*)
  56.      (semicolon) (terpri *pout*)
  57.      '(program ,name) ) )
  58.  
  59. ; (program myprog)
  60.  
  61.  
  62. (defmacro unit (name)
  63.   `(progn
  64.      (princ "unit " *pout*)
  65.      (prin1 ',name *pout*)
  66.      (semicolon) (terpri *pout*) 
  67.      '(unit ,name) ) )
  68.  
  69. ; (unit myunit)
  70.  
  71.  
  72. ; Use to print an arbitrary string to Pascal file
  73. (defmacro p (string)
  74.   (princ string *pout*) (terpri *pout*) )
  75.  
  76. (defmacro interface ()
  77.   `(progn
  78.      (princ "interface" *pout*)
  79.      (terpri *pout*) (terpri *pout*)
  80.      'interface ) )
  81.  
  82. ; (interface)
  83.  
  84. (defmacro implementation ()
  85.   `(progn
  86.      (princ "implementation" *pout*)
  87.      (terpri *pout*) (terpri *pout*)
  88.      'implementation ) )
  89.  
  90. ; (implementation)
  91.  
  92. (defmacro uses (&rest modules)
  93.   `(progn
  94.      (princ "uses " *pout*)
  95.      (prin1 (car ',modules) *pout*)
  96.      (dolist (module (cdr ',modules))
  97.        (if (eq module :nl)
  98.          (progn (terpri *pout*) (indent) )
  99.          (progn
  100.            (princ ", " *pout*)
  101.            (prin1 module *pout*) ) ) )
  102.      (semicolon) (terpri *pout*)
  103.      '(uses ,@ modules) ) )
  104.  
  105. ; (uses unit1 unit2)
  106.  
  107. (defun print-proc-name (name)
  108.   (cond
  109.     ( (symbolp name)
  110.       (prin1 name *pout*) )
  111.     ( (and (listp name) (eql 3 (length name)) (eq (car name) '%) )
  112.       (format *pout* "~A.~A" (second name) (third name)) )
  113.     (t
  114.       (error "Invalid proc/func name" name) ) ) )
  115.  
  116. (defmacro proc (name args &rest decs)
  117.   `(progn
  118.      (princ "procedure " *pout*)
  119.      (print-proc-name ',name)
  120.      (print-args ',args)
  121.      (princ "; " *pout*)
  122.      (with-indent
  123.        (progn ,@decs) )
  124.      (terpri *pout*)
  125.      '(procedure ,name) ) )
  126.  
  127. ; (proc dosomething ( (var n integer) ) (begin (writeln "hello")))
  128.  
  129. (defmacro constructor (name args &rest decs)
  130.   `(progn
  131.      (princ "constructor " *pout*)
  132.      (print-proc-name ',name)
  133.      (print-args ',args)
  134.      (princ "; " *pout*)
  135.      (with-indent
  136.        (progn ,@decs) )
  137.      (terpri *pout*)
  138.      '(procedure ,name) ) )
  139.  
  140. ; (constructor (% TThing Doit) ( (n integer) (i word) ) (begin (writeln)))
  141.  
  142. (defmacro destructor (name args &rest decs)
  143.   `(progn
  144.      (princ "destructor " *pout*)
  145.      (print-proc-name ',name)
  146.      (print-args ',args)
  147.      (princ "; " *pout*)
  148.      (with-indent
  149.        (progn ,@decs) )
  150.      (terpri *pout*)
  151.      '(procedure ,name) ) )
  152.  
  153. ; (constructor (% TThing Done) () (begin (writeln "Gone")))
  154.  
  155. (defmacro func (name args type &rest decs)
  156.   `(progn
  157.      (princ "function " *pout*)
  158.      (print-proc-name ',name)
  159.      (print-args ',args)
  160.      (princ " : " *pout*)
  161.      (prin1 ',type *pout*)
  162.      (princ "; " *pout*)
  163.      (with-indent
  164.        (progn ,@decs) )
  165.      (terpri *pout*)
  166.      '(procedure ,name) ) )
  167.  
  168. ; (func myfunc ( (var n integer) ) integer (begin (= myfunc (+ n 2))))
  169.  
  170. (defun print-const-dec (dec)
  171.   (indent)
  172.   (case (length dec)
  173.     (2 (prin1 (first dec) *pout*)
  174.       (princ " = " *pout*)
  175.       (print-value (second dec))
  176.       (semicolon) )
  177.     (3 (prin1 (first dec) *pout*) (princ " :" *pout*)
  178.       (print-type (second dec))
  179.       (princ " = " *pout*)
  180.       (print-value (third dec))
  181.       (semicolon) )
  182.     (t (error "invalid const declaration" dec)) ) )
  183.  
  184. (defmacro const (&rest const-decs)
  185.   `(progn
  186.      (nl) (princ "const " *pout*) (terpri *pout*)
  187.      (with-indent
  188.        (dolist (dec ',const-decs)
  189.          (print-const-dec dec) ) )
  190.      '(const ,@const-decs) ) )
  191.  
  192. ; (const (i 2) (n "Fred"))
  193.  
  194. (defun print-type-dec (type-dec)
  195.   (let ( (name (car type-dec))
  196.          (type (second type-dec)) )
  197.     (indent)
  198.     (prin1 name *pout*)
  199.     (princ " = " *pout*)
  200.     (with-indent 
  201.       (print-type type)
  202.       (semicolon) ) ) )
  203.  
  204. (defmacro type (&rest type-decs)
  205.   `(progn
  206.      (nl) (princ "type " *pout*) (terpri *pout*)
  207.      (with-indent
  208.        (dolist (dec ',type-decs)
  209.          (print-type-dec dec) ) ) 
  210.      '(type ,@type-decs) ) )
  211.  
  212. ; (type (mytype integer) (myarray (array ( (.. 1 20) ) integer)))
  213.  
  214. (defmacro begin (&rest stmts)
  215.   `(progn
  216.      (print-stmt (cons 'begin ',stmts))
  217.      (semicolon) ) )
  218.  
  219. ; (begin (= i 1) (writeln "hello" goodbye_string))
  220.  
  221. (defmacro far ()
  222.   `(princ " far; " *pout*) )
  223.  
  224. ; (proc myproc ( (i integer) ) (far) (begin (writeln "hello")))
  225.  
  226. (defmacro module-begin (&rest stmts)
  227.   `(progn
  228.      (print-stmt (cons 'begin ',stmts))
  229.      (princ "." *pout*) (terpri *pout*)
  230.      'module-begin ) )
  231.  
  232. ; (module-begin (= i 1) (writeln "hello"))
  233.  
  234. (defun print-args (args)
  235.   (when args
  236.     (princ " (" *pout*)
  237.     (print-arg (car args))
  238.     (dolist (arg (cdr args))
  239.       (if (eq :nl arg)
  240.         (progn (terpri *pout*) (indent) )
  241.         (progn
  242.           (princ "; " *pout*)
  243.           (print-arg arg) ) ) )
  244.     (princ ")" *pout*) ) )
  245.  
  246. (defun print-arg (arg)
  247.   (let ( (rest arg) num-vars)
  248.     (case (car rest)
  249.       ((var invar outvar inoutvar)
  250.         (princ "var " *pout*)
  251.         (setq rest (cdr rest)) )
  252.       (in
  253.         (setq rest (cdr rest)) ) )
  254.     (setq num-vars (1- (length rest)))
  255.     (dotimes (i num-vars)
  256.       (if (> i 0) (princ ", " *pout*))
  257.       (prin1 (nth i rest) *pout*) )
  258.     (princ " :" *pout*)
  259.     (prin1 (nth num-vars rest) *pout*) ) )
  260.  
  261. (defmacro var (&rest decs)
  262.   `(progn
  263.      (nl) (princ "var" *pout*) (terpri *pout*)
  264.      (with-indent
  265.        (dolist (dec ',decs)
  266.          (print-var dec) ) )
  267.      '(vars ,@decs) ) )
  268.  
  269. ; (var (i integer) (n word))
  270.  
  271. (defun print-var (dec)
  272.   (indent)
  273.   (let* ( (rev-dec (reverse dec))
  274.           (type (car rev-dec))
  275.           (vars (reverse (cdr rev-dec))) )
  276.     (prin1 (car vars) *pout*)
  277.     (dolist (var (cdr vars))
  278.       (princ ", " *pout*)
  279.       (prin1 var *pout*) )
  280.     (princ " :" *pout*)
  281.     (print-type type)
  282.     (semicolon) ) )
  283.  
  284. (defun print-virtual (dec)
  285.   (princ ";" *pout*)
  286.   (cond
  287.     ( (eq dec 'virtual)
  288.       (princ " virtual" *pout*) )
  289.     ( (and (listp dec) (eq (car dec) 'virtual) (eql 2 (length dec)))
  290.       (princ " virtual " *pout*)
  291.       (print-value (second dec)) )
  292.     ( t
  293.       (error "Invalid virtual dec" dec) ) ) )
  294.  
  295. (defun print-method (dec)
  296.   (indent)
  297.   (let* ( (method-type (first dec))
  298.           (name (second dec))
  299.           (arglist (third dec))
  300.           (virtual-dec (nthcdr 3 dec)) )
  301.     (format *pout* "~A ~A " method-type name)
  302.     (print-args arglist)
  303.     (if (not (null virtual-dec))
  304.       (print-virtual (car virtual-dec)) )
  305.     (semicolon) ) )
  306.  
  307. ; (print-method '(procedure jim ( (var tom integer) (fred char)) (virtual (+ 5 6)) ))
  308.  
  309. (defun print-type (type)
  310.   (case (type-of type)
  311.     (symbol (prin1 type *pout*))
  312.     (cons
  313.       (let ( (fun (get (car type) 'type-fun)) )
  314.         (if fun
  315.           (apply fun (cdr type))
  316.           (error "Unknown type function" (car type)) ) ) )
  317.     (t (error "invalid print-type arg" type)) ) )
  318.  
  319. ;;; def-type-fun
  320.  
  321. (defmacro def-type-fun (name args &rest body)
  322.   `(progn
  323.      (setf (get ',name 'type-fun )
  324.        #'(lambda ,args ,@body) )
  325.      '(type-fun ,name) ) )
  326.  
  327. (defmacro def-type-macro (name args expr)
  328.   `(progn
  329.      (setf (get ',name 'type-fun )
  330.        #'(lambda ,args (print-type ,expr)) )
  331.      '(type-macro ,name) ) )
  332.  
  333. (def-type-fun record (&rest var-decs)
  334.   (terpri) (indent) (princ "record" *pout*) (terpri *pout*)
  335.   (with-indent
  336.     (dolist (var-dec var-decs)
  337.       (print-var var-dec) ) )
  338.   (indent) (princ "end" *pout*) )
  339.  
  340. ; (var (n (record (i integer) (w word))))
  341.  
  342. (def-type-fun object (parent &rest members)
  343.   (terpri) (indent) (princ "object" *pout*) 
  344.   (if (not (null parent))
  345.     (format *pout* " (~A) " parent) )
  346.   (terpri *pout*)
  347.   (with-indent
  348.     (let ( (member-type 'var) )
  349.       (dolist (member members)
  350.         (cond
  351.           ((eq member 'methods) (setq member-type 'method))      
  352.           ((eq member-type 'var) (print-var member))
  353.           ((eq member-type 'method) (print-method member)) ) ) ) )
  354.   (indent) (princ "end" *pout*) )
  355.  
  356. '(var (z (object nil
  357.                 (x integer) (y char)
  358.                 methods
  359.                 (procedure jim ( (x integer) ) 
  360.                   (virtual (+ wm_first wmMouseDown)) ) )) )
  361.  
  362. (def-type-fun .. (first last)
  363.   (print-value first) (princ ".." *pout*) (print-value last) )
  364.  
  365. ; (var (n (.. 1 10)))
  366.  
  367. (def-type-fun array (indexes type)
  368.   (princ "array [" *pout*)
  369.   (print-type (car indexes))
  370.   (dolist (index (cdr indexes))
  371.     (princ ", " *pout*)
  372.     (print-type index) )
  373.   (princ "] of " *pout*);
  374.   (print-type type) )
  375.  
  376. ; (var (n (array ( (.. 1 10) (.. 2 45) ) word)))
  377.  
  378. (def-type-fun ^ (type)
  379.   (princ "^" *pout*)
  380.   (print-type type) )
  381.  
  382. ; (var (p (^ TObject)))
  383.  
  384. ;;; def-value-fun
  385.  
  386. (defun print-value (value)
  387.   (case (type-of value)
  388.     (nil (princ "nil" *pout*))
  389.     (symbol (prin1 value *pout*))
  390.     (fixnum (prin1 value *pout*))
  391.     (integer (prin1 value *pout*))
  392.     (string 
  393.       (princ "'" *pout*) (princ value *pout*)
  394.       (princ "'" *pout*) )
  395.     (flonum (prin1 value *pout*))
  396.     (float (prin1 value *pout*))
  397.     (cons
  398.       (let ( (fun (if (symbolp (car value)) (get (car value) 'value-fun) nil)) )
  399.         (if fun
  400.           (apply fun (cdr value))
  401.           (progn
  402.             (print-value (car value))
  403.             (let ( (args (cdr value)) )
  404.               (when args
  405.                 (princ " (" *pout*)
  406.                 (print-value (car args))
  407.                 (dolist (arg (cdr args))
  408.                   (if (eq arg :nl)
  409.                     (progn
  410.                       (terpri *pout*) (indent) )
  411.                     (progn
  412.                       (princ ", " *pout*)
  413.                       (print-value arg) ) ) )
  414.                 (princ ")" *pout*) ) ) ) ) ) )
  415.     (t (error "invalid print-value arg" value)) ) )
  416.  
  417. (defmacro def-value-fun (name args &rest body)
  418.   `(progn
  419.      (setf (get ',name  'value-fun)
  420.        #'(lambda ,args ,@body) )
  421.      '(value-fun ,name) ) )
  422.  
  423. (defmacro def-value-macro (name args expr)
  424.   `(progn
  425.      (setf (get ',name 'value-fun)
  426.        #'(lambda ,args (print-value ,expr)) )
  427.      '(value-macro ,name) ) )
  428.  
  429. (def-value-fun ch (number)
  430.   (princ "#" *pout*) (print-value number) )
  431.  
  432. ; (begin (= ch (ch 13)))
  433.  
  434. (def-value-fun @ (name)
  435.   (princ "@" *pout*) (print-value name) )
  436.  
  437. ; (begin (= ptr (@ variable)))
  438.  
  439. (def-value-fun ^ (name)
  440.   (print-value name) (princ "^" *pout*) )
  441.  
  442. ; (begin (= value (^ ptr)))
  443.  
  444. (def-value-fun concat (&rest vals)
  445.   (dolist (val vals)
  446.     (if (symbolp val)
  447.       (prin1 val *pout*)
  448.       (princ val *pout*) ) ) )
  449.  
  450. ; (begin (= string (concat #\' "jim " tom " and fred" #\')))
  451.  
  452. (def-value-fun not (name)
  453.   (princ "(not " *pout*)
  454.   (print-value name)
  455.   (princ ")" *pout*) )
  456.  
  457. ; (begin (= test (not (< 2 3))))
  458.  
  459. (def-value-fun [] (array &rest indexes)
  460.   (print-value array)
  461.   (princ "[" *pout*)
  462.   (print-value (car indexes))
  463.   (dolist (index (cdr indexes))
  464.     (princ "," *pout*)
  465.     (print-value index) )
  466.   (princ "]" *pout*) )
  467.  
  468. ; (begin (= i ([] arr n)))
  469.  
  470. (def-value-fun % (record field)
  471.   (print-value record)
  472.   (princ "." *pout*)
  473.   (print-value field) )
  474.  
  475. ; (begin (= val (% rec field)))
  476.  
  477. (def-value-macro []^ (array_ptr &rest indexes)
  478.   `([] (^ ,array_ptr) ,@indexes) )
  479.  
  480. ; (begin (= val ([]^ arr_ptr index)))
  481.  
  482. ;;; operators
  483.  
  484. (defmacro def-operator1 (name)
  485.   `(def-value-fun ,name (arg1 arg2)
  486.      (princ "(" *pout*)
  487.      (print-value arg1)
  488.      (princ " " *pout*)
  489.      (prin1 ',name *pout*)
  490.      (princ " " *pout*)
  491.      (print-value arg2)
  492.      (princ ")" *pout*) ) )
  493.  
  494. (defun def-operator (name)
  495.   (eval `(def-operator1 ,name)) )
  496.  
  497. (defmacro def-n-operator1 (name)
  498.   `(def-value-fun ,name (arg1 &rest args)
  499.      (princ "(" *pout*)
  500.      (print-value arg1)
  501.      (dolist (arg args)
  502.        (if (eq :nl arg)
  503.          (progn (terpri *pout*) (indent))
  504.          (progn
  505.            (princ " " *pout*)
  506.            (prin1 ',name *pout*)
  507.            (princ " " *pout*)
  508.            (print-value arg) ) ) )
  509.      (princ ")" *pout*) ) )
  510.  
  511. (defun def-n-operator (name)
  512.   (eval `(def-n-operator1 ,name)) )
  513.  
  514. (dolist (x '( - / div mod rem shl shr  in < > <= >= <> =))
  515.   (def-operator x) )
  516.  
  517. ; (begin (= i (+ (* n 20) 45)))
  518.  
  519. (dolist (x '(+ * and or xor))
  520.   (def-n-operator x) )
  521.  
  522. ; (begin (= i (+ 1 2 3 4 (* 5 6 7))))
  523.  
  524. ;;; def-stmt-fun
  525.  
  526. (defun print-stmt (stmt)
  527.   (case (type-of stmt)
  528.     (nil)
  529.     (cons
  530.       (let ( (fun (if (symbolp (car stmt)) (get (car stmt) 'stmt-fun) nil) ) )
  531.         (if fun
  532.           (apply fun (cdr stmt))
  533.           (progn
  534.             (print-value (car stmt))
  535.             (let ( (args (cdr stmt)) )
  536.               (when args
  537.                 (princ " (" *pout*)
  538.                 (print-value (car args))
  539.                 (dolist (arg (cdr args))
  540.                   (if (eq arg :nl)
  541.                     (progn (terpri *pout*) (indent))
  542.                     (progn
  543.                       (princ ", " *pout*)
  544.                       (print-value arg) ) ) )
  545.                 (princ ")" *pout*) ) ) ) ) ) )
  546.     (t (error "invalid print-stmt arg" stmt)) ) )
  547.  
  548. (defmacro def-stmt-fun (name args &rest body)
  549.   `(progn
  550.      (setf (get ',name 'stmt-fun)
  551.        #'(lambda ,args ,@body) )
  552.      '(stmt-fun ,name) ) )
  553.  
  554. (defmacro def-stmt-macro (name args expr)
  555.   `(progn
  556.      (setf (get ',name 'stmt-fun)
  557.        #'(lambda ,args (print-stmt ,expr)) )
  558.      '(stmt-macro ,name) ) )
  559.  
  560. (defun begin-block (stmts)
  561.   (nl) (princ "begin" *pout*) (terpri *pout*)
  562.   (with-indent
  563.     (dolist (stmt stmts)
  564.       (indent) (print-stmt stmt) (semicolon) ) )
  565.   (indent) (princ "end" *pout*) )
  566.  
  567. (def-stmt-fun = (var val)
  568.   (print-value var) (princ " := " *pout*)
  569.   (print-value val) )
  570.  
  571. ; (begin (= i (+ n 2)))
  572.  
  573. (def-stmt-fun begin (&rest stmts)
  574.   (begin-block stmts) )
  575.  
  576. ; (begin (= i n) (= y x) (writeln "hello"))
  577.  
  578. (def-stmt-fun for (header &rest stmts)
  579.   (let ( (var (first header))
  580.          (start (second header))
  581.          (end (third header)) )
  582.     (princ "for " *pout*) (print-value var)
  583.     (princ " := " *pout*) (print-value start)
  584.     (princ " to " *pout*) (print-value end)
  585.     (princ " do" *pout*)
  586.     (with-indent
  587.       (begin-block stmts) ) ) )
  588.  
  589. ; (begin (for (i 1 100) (writeln i) (= n (+ n i))))
  590.  
  591. (def-stmt-fun with (var &rest stmts)
  592.   (princ "with " *pout*)
  593.   (print-value var)
  594.   (princ " do " *pout*)
  595.   (with-indent
  596.     (begin-block stmts) ) )
  597.  
  598. ; (begin (with (^ ptr) (writeln field1) (writeln field2)))
  599.  
  600. (def-stmt-fun block (&rest stmts)
  601.   (print-stmt
  602.     (if (= (length stmts) 1)
  603.       (first stmts)
  604.       (cons 'begin stmts) ) ) )
  605.  
  606. ; (begin (block (writeln "hello")))
  607.  
  608. ; (begin (block (writeln "hello") (writeln "hello")))
  609.  
  610. ; call is not usually necessary, but it forces interpretation of
  611. ; first argument as a procedure or function
  612.  
  613. (def-stmt-fun call (proc-fun &rest args)
  614.   (print-value proc-fun)
  615.   (when args
  616.     (princ " (" *pout*)
  617.     (print-value (car args))
  618.     (dolist (arg (cdr args))
  619.       (princ ", " *pout*)
  620.       (print-value arg))
  621.     (princ ")" *pout*) ) )
  622.  
  623. ; (begin (call function n i))
  624.  
  625. (def-stmt-fun null-statement () )
  626.  
  627. ; (begin (for (i 1 10) (null-statement)))
  628.  
  629. (defun print-case-clause (values stmts)
  630.   (indent)
  631.   (if (eq values 'else)
  632.     (princ "else " *pout*)
  633.     (progn
  634.       (if (or (numberp values) (symbolp values) (stringp values))
  635.         (setq values (list values)) )
  636.       (print-value (car values))
  637.       (dolist (value (cdr values))
  638.         (princ ", " *pout*)
  639.         (print-value value) )
  640.       (princ ": " *pout*) ) )
  641.   (with-indent
  642.     (print-stmt (cons 'block stmts)) )
  643.   (semicolon) )
  644.  
  645. (def-stmt-fun case (val &rest clauses)
  646.   (princ "case " *pout*)
  647.   (print-value val)
  648.   (princ " of " *pout*) (terpri *pout*)
  649.   (with-indent
  650.     (dolist (clause clauses)
  651.       (print-case-clause (car clause) (cdr clause)) ) )
  652.   (indent) (princ "end" *pout*) )
  653.  
  654. ; (begin (case (+ i 2) (3 (writeln "three")) (21 (= i 3) (= y 4))))
  655.  
  656. ; (begin (case (+ i 2) (3 (writeln "three")) (else (= i 3) (= y 4))))
  657.  
  658. (def-stmt-fun while (var &rest stmts)
  659.   (princ "while " *pout*)
  660.   (print-value var)
  661.   (princ " do " *pout*)
  662.   (with-indent
  663.     (begin-block stmts) ) )
  664.  
  665. ; (begin (while (< i 5) (= i (+ i 1))))
  666.  
  667. (def-stmt-fun repeat-until (var &rest stmts)
  668.   (princ "repeat" *pout*) (terpri *pout*)
  669.   (with-indent
  670.     (dolist (stmt stmts)
  671.       (indent) (print-stmt stmt) (semicolon) ) )
  672.   (indent) (princ " until " *pout*) (print-value var) )
  673.  
  674. ; (begin (repeat-until (< i 5) (= i (+ i 1))))
  675.  
  676. (def-stmt-fun if (test then-stmt &optional else-stmt)
  677.   (princ "if " *pout*) (print-value test)
  678.   (nl) (princ " then " *pout*)
  679.   (with-indent
  680.     (print-stmt then-stmt) )
  681.   (when else-stmt
  682.     (progn (nl) (princ " else " *pout*))
  683.     (with-indent
  684.       (print-stmt else-stmt) ) ) )
  685.  
  686. ; (begin (if (< i 2) (writeln "less than 2") (writeln ">= 2")))
  687.  
  688. (def-stmt-macro addf (var value)
  689.   `(= ,var (+ ,var ,value)) )
  690.  
  691. ; (begin (addf i n))
  692.  
  693. (def-stmt-macro incf (var)
  694.   `(= ,var (+ ,var 1)) )
  695.  
  696. ; (begin (incf i))
  697.  
  698. ;;; string tables
  699.  
  700. ; The following code is for automatically generating string resource
  701. ; tables. It is desirable to use it for large programs because 
  702. ; constant strings use up precious data segment.
  703.  
  704. ; Call this function explicitly in the pascal file before any use of
  705. ; str. Choose start-no and limit-no to avoid clashes in different
  706. ; string tables.
  707.  
  708. (defun open-string-table (name start-no &optional limit-no)
  709.   (setq *string-index* start-no)
  710.   (setq *string-index-limit* 
  711.     (if limit-no limit-no (+ start-no 1000)) )
  712.   (setq *string-file-name* name)
  713.   (setq *string-file* (open (strcat name ".rc") :direction :output))
  714.   (format *pout* "{$R ~A.res}~%" name)
  715.   (princ "STRINGTABLE LOADONCALL MOVEABLE DISCARDABLE" *string-file*)
  716.   (terpri *string-file*)
  717.   (princ "BEGIN" *string-file*)
  718.   (terpri *string-file*) )
  719.  
  720. ; Calls rc.exe program provided with Borland Pascal to compile 
  721. ; generated .rc file into a .res file. (Automatically called by
  722. ; gen-pascal function.)
  723.  
  724. (defun finish-any-string-file ()
  725.   (when *string-file*
  726.     (princ "END" *string-file*)
  727.     (terpri *string-file*)
  728.     (close *string-file*)
  729.     (setq *string-file* nil)
  730.     (run-program (strcat "rc -r " *string-file-name* ".rc")) ) )
  731.  
  732. (setq *string-file* nil)
  733.  
  734. ; use (str "string") instead of "string" to generate a reference to a 
  735. ; resource string. Used with copy = nil, uses LString to retrieve 
  736. ; resource, used with copy = t uses LStringCopy to retrieve string.
  737. ; (You have to write LString and LStringCopy.)
  738.  
  739. (def-value-fun str (x &key copy)
  740.   (if *string-file*
  741.     (progn
  742.       (format *string-file* "  ~A, ~S~%" *string-index* x)
  743.       (if copy 
  744.         (format *pout* "LStringCopy (~A)" *string-index*)
  745.         (format *pout* "LString (~A)" *string-index*) )
  746.       (setq *string-index* (1+ *string-index*))
  747.       (if (>= *string-index* *string-index-limit*)
  748.         (error "String index limit exceeded" *string-index*) ) )
  749.     (print-value x) ) )
  750.  
  751. ; Example doesn't generate LString call because *string-file* = nil
  752. ; (begin (= a (str "Jim")))
  753.  
  754. ;;; gen-pascal
  755.  
  756. (defun gen-pascal (infile outfile)
  757.   (princ "Generating ") (prin1 outfile)
  758.   (princ " from ") (print infile)
  759.   (setq *string-file* nil)
  760.   (setq *ind* 1)
  761.   (let ( (pout-save *pout*)
  762.          (new-pout (open outfile :direction :output)) )
  763.     (unwind-protect
  764.       (progn
  765.         (setq *pout* new-pout)
  766.         (load infile :print t) )
  767.       (finish-any-string-file)
  768.       (close *pout*)
  769.       (setq *pout* pout-save) )
  770.     outfile) )
  771.  
  772. ; To see how this works, load this buffer and 
  773. ; evaluate the example below. Then compile 
  774. ; the newly generated example.pas in Turbo Pascal for Windows
  775. ; (registered Trademark of Borland)
  776.  
  777. ; (gen-pascal "example.ps" "example.pas")
  778.  
  779.