Thunderchez: Hex Artifact Content

Artifact e2e3d8d3eb7fffa53ee8b1173927eb4688c22951:

File c-eval.sls — part of check-in [cd7a31d87b] at 2017-05-03 18:01:41 on branch trunk — many fixes to usb.sls (user: aldo size: 1749)
0000: 3b 3b 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20  ;;.;; Copyright 
0010: 32 30 31 36 20 41 6c 64 6f 20 4e 69 63 6f 6c 61  2016 Aldo Nicola
0020: 73 20 42 72 75 6e 6f 0a 3b 3b 0a 3b 3b 20 4c 69  s Bruno.;;.;; Li
0030: 63 65 6e 73 65 64 20 75 6e 64 65 72 20 74 68 65  censed under the
0040: 20 41 70 61 63 68 65 20 4c 69 63 65 6e 73 65 2c   Apache License,
0050: 20 56 65 72 73 69 6f 6e 20 32 2e 30 20 28 74 68   Version 2.0 (th
0060: 65 20 22 4c 69 63 65 6e 73 65 22 29 3b 0a 3b 3b  e "License");.;;
0070: 20 79 6f 75 20 6d 61 79 20 6e 6f 74 20 75 73 65   you may not use
0080: 20 74 68 69 73 20 66 69 6c 65 20 65 78 63 65 70   this file excep
0090: 74 20 69 6e 20 63 6f 6d 70 6c 69 61 6e 63 65 20  t in compliance 
00a0: 77 69 74 68 20 74 68 65 20 4c 69 63 65 6e 73 65  with the License
00b0: 2e 0a 3b 3b 20 59 6f 75 20 6d 61 79 20 6f 62 74  ..;; You may obt
00c0: 61 69 6e 20 61 20 63 6f 70 79 20 6f 66 20 74 68  ain a copy of th
00d0: 65 20 4c 69 63 65 6e 73 65 20 61 74 0a 3b 3b 0a  e License at.;;.
00e0: 3b 3b 20 20 20 20 20 68 74 74 70 3a 2f 2f 77 77  ;;     http://ww
00f0: 77 2e 61 70 61 63 68 65 2e 6f 72 67 2f 6c 69 63  w.apache.org/lic
0100: 65 6e 73 65 73 2f 4c 49 43 45 4e 53 45 2d 32 2e  enses/LICENSE-2.
0110: 30 0a 3b 3b 0a 3b 3b 20 55 6e 6c 65 73 73 20 72  0.;;.;; Unless r
0120: 65 71 75 69 72 65 64 20 62 79 20 61 70 70 6c 69  equired by appli
0130: 63 61 62 6c 65 20 6c 61 77 20 6f 72 20 61 67 72  cable law or agr
0140: 65 65 64 20 74 6f 20 69 6e 20 77 72 69 74 69 6e  eed to in writin
0150: 67 2c 20 73 6f 66 74 77 61 72 65 0a 3b 3b 20 64  g, software.;; d
0160: 69 73 74 72 69 62 75 74 65 64 20 75 6e 64 65 72  istributed under
0170: 20 74 68 65 20 4c 69 63 65 6e 73 65 20 69 73 20   the License is 
0180: 64 69 73 74 72 69 62 75 74 65 64 20 6f 6e 20 61  distributed on a
0190: 6e 20 22 41 53 20 49 53 22 20 42 41 53 49 53 2c  n "AS IS" BASIS,
01a0: 0a 3b 3b 20 57 49 54 48 4f 55 54 20 57 41 52 52  .;; WITHOUT WARR
01b0: 41 4e 54 49 45 53 20 4f 52 20 43 4f 4e 44 49 54  ANTIES OR CONDIT
01c0: 49 4f 4e 53 20 4f 46 20 41 4e 59 20 4b 49 4e 44  IONS OF ANY KIND
01d0: 2c 20 65 69 74 68 65 72 20 65 78 70 72 65 73 73  , either express
01e0: 20 6f 72 20 69 6d 70 6c 69 65 64 2e 0a 3b 3b 20   or implied..;; 
01f0: 53 65 65 20 74 68 65 20 4c 69 63 65 6e 73 65 20  See the License 
0200: 66 6f 72 20 74 68 65 20 73 70 65 63 69 66 69 63  for the specific
0210: 20 6c 61 6e 67 75 61 67 65 20 67 6f 76 65 72 6e   language govern
0220: 69 6e 67 20 70 65 72 6d 69 73 73 69 6f 6e 73 20  ing permissions 
0230: 61 6e 64 0a 3b 3b 20 6c 69 6d 69 74 61 74 69 6f  and.;; limitatio
0240: 6e 73 20 75 6e 64 65 72 20 74 68 65 20 4c 69 63  ns under the Lic
0250: 65 6e 73 65 2e 0a 0a 28 6c 69 62 72 61 72 79 20  ense...(library 
0260: 28 63 2d 65 76 61 6c 29 0a 09 28 65 78 70 6f 72  (c-eval)..(expor
0270: 74 20 63 2d 65 76 61 6c 20 63 2d 65 76 61 6c 2d  t c-eval c-eval-
0280: 70 72 69 6e 74 66 20 63 2d 65 76 61 6c 2d 69 6e  printf c-eval-in
0290: 63 6c 75 64 65 73 29 0a 09 28 69 6d 70 6f 72 74  cludes)..(import
02a0: 20 28 63 68 65 7a 73 63 68 65 6d 65 29 0a 09 09   (chezscheme)...
02b0: 28 70 6f 73 69 78 29 0a 09 09 28 6f 6e 6c 79 20  (posix)...(only 
02c0: 28 64 61 74 61 2d 73 74 72 75 63 74 75 72 65 73  (data-structures
02d0: 29 20 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70  ) string-intersp
02e0: 65 72 73 65 20 2d 3e 73 74 72 69 6e 67 29 29 0a  erse ->string)).
02f0: 0a 09 28 64 65 66 69 6e 65 20 63 2d 65 76 61 6c  ..(define c-eval
0300: 2d 69 6e 63 6c 75 64 65 73 20 28 6d 61 6b 65 2d  -includes (make-
0310: 70 61 72 61 6d 65 74 65 72 20 27 28 22 73 74 64  parameter '("std
0320: 69 6f 2e 68 22 29 29 29 0a 09 0a 09 28 64 65 66  io.h")))....(def
0330: 69 6e 65 20 28 63 2d 65 76 61 6c 2d 70 72 69 6e  ine (c-eval-prin
0340: 74 66 20 66 6f 72 6d 61 74 20 2e 20 76 61 6c 75  tf format . valu
0350: 65 73 29 0a 09 20 20 28 63 2d 65 76 61 6c 20 28  es)..  (c-eval (
0360: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 22 70  string-append "p
0370: 72 69 6e 74 66 20 28 5c 22 22 20 66 6f 72 6d 61  rintf (\"" forma
0380: 74 20 22 5c 22 2c 22 20 28 73 74 72 69 6e 67 2d  t "\"," (string-
0390: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70  intersperse (map
03a0: 20 2d 3e 73 74 72 69 6e 67 20 76 61 6c 75 65 73   ->string values
03b0: 29 20 22 2c 22 29 20 22 29 3b 22 29 29 29 0a 09  ) ",") ");")))..
03c0: 0a 09 28 64 65 66 69 6e 65 20 28 63 2d 65 76 61  ..(define (c-eva
03d0: 6c 20 65 78 70 72 29 0a 09 20 20 28 77 69 74 68  l expr)..  (with
03e0: 2d 6d 6b 74 65 6d 70 0a 09 20 20 20 22 2f 74 6d  -mktemp..   "/tm
03f0: 70 2f 63 2d 65 76 61 6c 2d 58 58 58 58 58 58 22  p/c-eval-XXXXXX"
0400: 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 28 66 69  ..   (lambda (fi
0410: 6c 65 29 0a 09 20 20 20 20 20 28 61 70 70 6c 79  le)..     (apply
0420: 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20  ..      (lambda 
0430: 28 69 6e 20 6f 75 74 20 70 69 64 29 0a 09 09 28  (in out pid)...(
0440: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61  for-each (lambda
0450: 20 28 78 29 0a 09 09 09 20 20 20 20 28 66 70 72   (x)....    (fpr
0460: 69 6e 74 66 20 6f 75 74 20 22 23 69 6e 63 6c 75  intf out "#inclu
0470: 64 65 20 3c 7e 61 3e 7e 25 22 20 78 29 29 20 28  de <~a>~%" x)) (
0480: 63 2d 65 76 61 6c 2d 69 6e 63 6c 75 64 65 73 29  c-eval-includes)
0490: 29 0a 09 09 28 66 70 72 69 6e 74 66 20 6f 75 74  )...(fprintf out
04a0: 20 22 69 6e 74 20 6d 61 69 6e 28 29 20 7b 7e 25   "int main() {~%
04b0: 22 29 0a 09 09 28 66 70 72 69 6e 74 66 20 6f 75  ")...(fprintf ou
04c0: 74 20 22 7e 61 7e 25 22 20 65 78 70 72 29 0a 09  t "~a~%" expr)..
04d0: 09 28 66 70 72 69 6e 74 66 20 6f 75 74 20 22 7d  .(fprintf out "}
04e0: 7e 25 22 29 0a 09 09 28 63 6c 6f 73 65 2d 70 6f  ~%")...(close-po
04f0: 72 74 20 6f 75 74 29 0a 09 09 28 64 69 73 70 6c  rt out)...(displ
0500: 61 79 20 28 63 6f 6e 64 20 5b 28 67 65 74 2d 73  ay (cond [(get-s
0510: 74 72 69 6e 67 2d 61 6c 6c 20 69 6e 20 29 20 3d  tring-all in ) =
0520: 3e 20 28 6c 61 6d 62 64 61 20 28 78 29 20 28 69  > (lambda (x) (i
0530: 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 78  f (eof-object? x
0540: 29 20 22 22 20 78 29 29 5d 29 29 0a 09 09 28 75  ) "" x))]))...(u
0550: 6e 6c 65 73 73 20 28 7a 65 72 6f 3f 20 28 77 61  nless (zero? (wa
0560: 69 74 2d 66 6f 72 2d 70 69 64 20 70 69 64 29 29  it-for-pid pid))
0570: 0a 09 09 09 28 65 72 72 6f 72 66 20 27 63 2d 72  ....(errorf 'c-r
0580: 65 70 6c 20 22 63 6f 6d 70 69 6c 61 74 69 6f 6e  epl "compilation
0590: 20 66 61 69 6c 65 64 22 29 29 0a 09 09 28 61 70   failed"))...(ap
05a0: 70 6c 79 20 28 6c 61 6d 62 64 61 20 28 70 2d 69  ply (lambda (p-i
05b0: 6e 20 70 2d 6f 75 74 20 70 2d 70 69 64 29 0a 09  n p-out p-pid)..
05c0: 09 09 20 28 67 65 74 2d 73 74 72 69 6e 67 2d 61  .. (get-string-a
05d0: 6c 6c 20 70 2d 69 6e 29 29 0a 09 09 20 20 20 20  ll p-in))...    
05e0: 20 20 20 28 70 72 6f 63 65 73 73 20 28 66 6f 72     (process (for
05f0: 6d 61 74 20 22 7e 61 22 20 66 69 6c 65 29 29 29  mat "~a" file)))
0600: 29 0a 09 20 20 20 20 20 20 28 70 72 6f 63 65 73  )..      (proces
0610: 73 20 28 66 6f 72 6d 61 74 20 23 66 20 22 67 63  s (format #f "gc
0620: 63 20 2d 6f 20 7e 61 20 2d 78 20 63 20 2d 22 20  c -o ~a -x c -" 
0630: 66 69 6c 65 29 29 29 29 29 29 0a 0a 09 20 20 0a  file))))))...  .
0640: 09 20 20 29 20 3b 3b 6c 69 62 72 61 72 79 20 63  .  ) ;;library c
0650: 2d 65 76 61 6c 0a 0a 23 7c 0a 28 69 6d 70 6f 72  -eval..#|.(impor
0660: 74 20 28 63 2d 65 76 61 6c 29 29 0a 28 63 2d 65  t (c-eval)).(c-e
0670: 76 61 6c 2d 69 6e 63 6c 75 64 65 73 20 27 28 22  val-includes '("
0680: 73 74 64 69 6f 2e 68 22 20 22 73 74 64 69 6e 74  stdio.h" "stdint
0690: 2e 68 22 29 29 0a 28 73 74 72 69 6e 67 2d 3e 6e  .h")).(string->n
06a0: 75 6d 62 65 72 20 28 63 2d 65 76 61 6c 2d 70 72  umber (c-eval-pr
06b0: 69 6e 74 66 20 20 22 25 64 22 20 22 73 69 7a 65  intf  "%d" "size
06c0: 6f 66 20 28 75 69 6e 74 33 32 5f 74 29 22 29 29  of (uint32_t)"))
06d0: 0a 0a 7c 23 0a                                   ..|#.