File: theme-d-compile.scm.in

package info (click to toggle)
theme-d 1.4.0-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 12,784 kB
  • sloc: lisp: 47,684; sh: 4,200; makefile: 455; ansic: 319
file content (140 lines) | stat: -rw-r--r-- 4,503 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
#!/usr/bin/guile-@guile_version@ \
-e main -s
!#

;; Copyright (C) 2008-2018 Tommi Höynälänmaa
;; Distributed under GNU General Public License version 3,
;; see file doc/GPL-3.


;; *** Theme compiler main program ***


(import (th-scheme-utilities stdutils)
	(th-scheme-utilities hrecord)
	(th-scheme-utilities parse-command-line)
	(theme-d common theme-d-config)
	(theme-d translator theme-d-compiler))


(init-theme-d-config)

(define gl-theme-d-translator-dir
  (get-theme-d-config-var 'translator-dir))

(define gl-theme-d-lib-dir
  (get-theme-d-config-var 'lib-dir))


(define (main args)
  (let ((module-search-path0 "")
	(source-filename "")
	(target-filename "")
	(unit-type '())
	(message-level 1)
	(expand-only? #f)
	(no-expansion? #f)
	(backtrace? #f)
	(pretty-print? #f)
	(err-expr? #t)
	(show-modules? #f))
    (let* ((argd1 (make-hrecord <argument-descriptor> #\m #t
				(lambda (option-arg)
				  (set! module-search-path0 option-arg))))
	   (argd2 (make-hrecord <argument-descriptor> "module-path" #t
				(lambda (option-arg)
				  (set! module-search-path0 option-arg))))
	   (argd3 (make-hrecord <argument-descriptor> #\o #t
				(lambda (option-arg)
				  (set! target-filename option-arg))))
	   (argd4 (make-hrecord <argument-descriptor> "output" #t
				(lambda (option-arg)
				  (set! target-filename option-arg))))
	   (argd5 (make-hrecord <argument-descriptor> #\l #t
				(lambda (option-arg)
				  (set! message-level
					(string->number option-arg)))))
	   (argd6 (make-hrecord <argument-descriptor> "message-level" #t
				(lambda (option-arg)
				  (set! message-level
					(string->number option-arg)))))
	   (argd7 (make-hrecord <argument-descriptor> #\u #t
				(lambda (option-arg)
				  (set! unit-type
					(string->symbol option-arg)))))
	   (argd8 (make-hrecord <argument-descriptor> "unit-type" #t
				(lambda (option-arg)
				  (set! unit-type
					(string->symbol option-arg)))))
	   (argd9 (make-hrecord <argument-descriptor> "backtrace" #f
				(lambda ()
				  (set! backtrace? #t))))
	   (argd10 (make-hrecord <argument-descriptor> "pretty-print" #f
				 (lambda ()
				   (set! pretty-print? #t))))
	   (argd11 (make-hrecord <argument-descriptor> "no-verbose-errors" #f
				 (lambda ()
				   (set! err-expr? #f))))
	   (argd12 (make-hrecord <argument-descriptor> "show-modules" #f
				 (lambda ()
				   (set! show-modules? #t))))
	   (argd13 (make-hrecord <argument-descriptor> "expand-only" #f
				 (lambda ()
				   (set! expand-only? #t))))
	   (argd14 (make-hrecord <argument-descriptor> "no-expansion" #f
				 (lambda ()
				   (set! no-expansion? #t))))
	   (arg-descs (list argd1 argd2 argd3 argd4 argd5 argd6 argd7 argd8
			    argd9 argd10 argd11 argd12 argd13 argd14))
	   (args-without-cmd (cdr args))
	   (handle-proper-args (lambda (proper-args)
				 (if (= (length proper-args) 1)
				     (set! source-filename (car proper-args))
				     (raise 'command-line-syntax-error)))))
      (parse-command-line args-without-cmd arg-descs handle-proper-args)
      (if (not (or (null? unit-type)
		   (and (symbol? unit-type)
			(memq unit-type (list 'proper-program 'script
					      'interface 'body)))))
	  (raise 'invalid-unit-type))
      (set! gl-show-info? (not (= message-level 0)))

      (if (> message-level 0)
	  (set! debug-level (- message-level 1))
	  (set! debug-level 0))

      (let ((module-search-path
	     (if (string-null? module-search-path0)
		 (list gl-theme-d-lib-dir ".")
		 (parse-search-path module-search-path0 gl-theme-d-lib-dir))))
	(dw1 "source filename: ")
	(dwl1 source-filename)
	(dw1 "target filename (empty to use default): ")
	(dwl1 target-filename)
	(dw1 "module search path: ")
	(dwl1 module-search-path)
	(dw1 "unit type: ")
	(dwl1 unit-type)
	(dw1 "message level: ")
	(dwl1 message-level)
	(dw1 "expand only: ")
	(dwl1 (if expand-only? "yes" "no"))
	(dw1 "no expansion: ")
	(dwl1 (if no-expansion? "yes" "no"))
	(dw1 "backtrace: ")
	(dwl1 (if backtrace? "yes" "no"))
	(dw1 "display erroneous expression: ")
	(dwl1 (if err-expr? "yes" "no"))
	(dw1 "pretty printing: ")
	(dwl1 (if pretty-print? "yes" "no"))
	(dw1 "show module processing: ")
	(dwl1 (if show-modules? "yes" "no"))
	;; We assume that indented debug info is displayed only for
	;; module loading.
	(set! gl-show-indented-debug-info? show-modules?)
	(theme-compile-unit gl-compiler source-filename target-filename
			    unit-type module-search-path
			    expand-only? no-expansion?
			    backtrace? err-expr?
			    pretty-print?))))
  0)