stklos-compile.stk 6.06 KB
Newer Older
eg's avatar
eg committed
1
;;;;
Erick's avatar
Erick committed
2
;;;; stklos-compile.stk -- Call the stklos compiler
3
;;;;
Erick's avatar
Erick committed
4
;;;; Copyright © 2001-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
5 6
;;;;
;;;;
eg's avatar
eg committed
7 8 9 10
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
11
;;;;
eg's avatar
eg committed
12 13 14 15
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
16
;;;;
eg's avatar
eg committed
17 18
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
19
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
eg's avatar
eg committed
20
;;;; USA.
21
;;;;
eg's avatar
eg committed
22 23
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date:  4-Dec-2001 18:12 (eg)
Erick's avatar
Erick committed
24
;;;; Last file update: 10-Apr-2018 16:42 (eg)
eg's avatar
eg committed
25 26
;;;;

Erick's avatar
.  
Erick committed
27
(import STKLOS-COMPILER)
28

eg's avatar
eg committed
29
(define *output* "a.out")
Erick Gallesio's avatar
Erick Gallesio committed
30
(define *c-code* #f)
31
(define *expr* #f)
Erick Gallesio's avatar
Erick Gallesio committed
32 33

;; ----------------------------------------------------------------------
Erick's avatar
Erick committed
34
;;      convert-to-C ...
Erick Gallesio's avatar
Erick Gallesio committed
35 36 37 38 39 40 41 42 43 44 45 46 47
;; ----------------------------------------------------------------------
(define (convert-to-C src dst module-name)
  (define (header in out)
    (format out "/*  -*- C -*-\n")
    (format out "  This file was automatically generated on ~A\n" (date))
    (format out "  This is a dump of the image in file ~A\n" (port-file-name in))
    (format out "  ***DO NOT EDIT BY HAND***\n*/\n")
    (format out "#include <stklos.h>\n\n"))

  (define (footer out name)
    (format out "#ifdef MODULE_ENTRY\n")
    (format out "MODULE_ENTRY_START(~S) {\n" name)
    (format out "  STk_execute_C_bytecode(__module_consts, __module_code);\n")
48 49 50 51
    (format out "} MODULE_ENTRY_END\n\n")
    (format out "MODULE_ENTRY_INFO() {\n")
    (format out "   return STk_read_from_C_string(__module_infos);\n")
    (format out "}\n")
Erick Gallesio's avatar
Erick Gallesio committed
52 53
    (format out "#endif\n"))

54

Erick Gallesio's avatar
Erick Gallesio committed
55
  (let ((in   (open-input-file src))
Erick's avatar
Erick committed
56
        (out  (open-output-file dst)))
57 58 59
    ;; Output the header
    (header in out)
    ;; Skip the symbol STklos
60
    (read in)
61 62
    ;; Write file informations
    (let ((info (read in))
Erick's avatar
Erick committed
63
          (str  (open-output-string)))
64 65 66 67
      (write info str)
      (format out "static char* __module_infos = ~S;\n\n" (get-output-string str)))
    ;; Write constants
    (let ((v   (read in))
Erick's avatar
Erick committed
68
          (str (open-output-string)))
Erick Gallesio's avatar
Erick Gallesio committed
69 70
      (write v str)
      (format out "static char* __module_consts = ~S;\n\n" (get-output-string str)))
71
    ;; Write the code
Erick Gallesio's avatar
Erick Gallesio committed
72 73
    (let ((sz (read in)))
      (format out "static STk_instr __module_code [] = { \n")
Erick's avatar
Erick committed
74
      (read-byte in)  ; To skip the newline after size
Erick Gallesio's avatar
Erick Gallesio committed
75
      (dotimes (i sz)
Erick's avatar
Erick committed
76 77 78 79 80 81 82 83 84 85 86 87
        (let* ((c1 (read-byte in))
               (c2 (read-byte in)))
          (format out
                  "~5f"
                  (string-append
                   "0x"
                   (number->string (bit-or (bit-shift c1 8) c2)
                                   16)))
          (when (< i (- sz 1))
            (display ", " out))
          (when (= (modulo i 10) 9)
            (newline out))))
Erick Gallesio's avatar
Erick Gallesio committed
88 89 90 91 92
      (display "};\n\n" out))
    (footer out module-name)
    (flush-output-port out)
    (close-port out)))

93
;; ----------------------------------------------------------------------
Erick's avatar
Erick committed
94
;;      compile-to-bytecode ...
95 96 97 98 99
;; ----------------------------------------------------------------------
(define (compile-to-bytecode file out)
  (compile-file file out)
  (chmod out #o755))

Erick Gallesio's avatar
Erick Gallesio committed
100
;; ----------------------------------------------------------------------
Erick's avatar
Erick committed
101
;;      compile-to-C-code ...
Erick Gallesio's avatar
Erick Gallesio committed
102 103
;; ----------------------------------------------------------------------
(define (compile-to-C-code file out)
104
  (let ((tmp  (temporary-file-name))
Erick's avatar
Erick committed
105
        (name (file-prefix (basename file))))
Erick Gallesio's avatar
Erick Gallesio committed
106 107 108 109 110
    (compile-to-bytecode file tmp)
    (convert-to-C tmp out name)
    (remove-file tmp)))

;; ----------------------------------------------------------------------
Erick's avatar
Erick committed
111
;;      main ...
Erick Gallesio's avatar
Erick Gallesio committed
112
;; ----------------------------------------------------------------------
eg's avatar
eg committed
113 114 115 116 117
(define (main args)
  (parse-arguments args
     "Usage: stklos-compile [options] file"
     "Compile a stklos file to byte codes"
     ""
118
     "Input options"
eg's avatar
eg committed
119 120
     (("case-sensitive" :alternate "c"  :help "Be case sensitive on symbols")
        (read-case-sensitive #t))
121

122 123 124
     "Output options"
     (("output" :alternate "o" :arg file :help "Output compiled code in <file>")
        (set! *output* file))
Erick Gallesio's avatar
Erick Gallesio committed
125 126
     (("C-code" :alternate "C" :help "Produce C code")
        (set! *c-code* #t))
127

128 129
     "Compiling options"
     (("evaluate" :alternate "e" :arg expr
130
       :help "Evaluate <expr> before compiling file")
131
      (set! *expr* expr))
eg's avatar
eg committed
132 133
     (("line-info" :alternate "l" :help "Insert line numbers in generated file")
        (compiler:gen-line-number #t))
134
     (("show-instructions" :alternate "S" :help "Show instructions in generated file")
Erick's avatar
.  
Erick committed
135
        (compiler:show-assembly-code #t))
136

137 138 139 140 141 142 143 144 145
     "Path options"
     (("prepend-load-path" :alternate "L" :arg dir
       :help "Prepend <dir> to the loading path")
      (set! (load-path) (cons dir (load-path))))
     (("append-load-path"  :arg dir
       :help "Append <dir> to the loading path")
      (set! (load-path) (cons (load-path) (list dir))))

     "Misc. options"
eg's avatar
eg committed
146 147 148 149
     (("no-time" :help "Don't display compilation time")
        (compiler:time-display #f))
     (("help" :alternate "h" :help "This help")
        (arg-usage (current-error-port))
Erick's avatar
Erick committed
150
        (exit 1))
151

eg's avatar
eg committed
152 153
     (else
      (cond
Erick's avatar
Erick committed
154 155 156 157 158 159 160 161 162 163 164 165 166 167 168
        ((= (length other-arguments) 1)
         ;; Evaluate prelude code
         (when (string? *expr*)
           (with-handler (lambda (c)
                           (die (format "Error in --evaluate ~A option" *expr*)))
              (eval (read-from-string *expr*)
                    (interaction-environment))))
         ;; Produce code
         (if *c-code*
             (compile-to-C-code (car other-arguments) *output*)
             (compile-to-bytecode (car other-arguments) *output*))
         (exit 0))
        (else
          (arg-usage (current-error-port))
          (exit 1))))))