-
Notifications
You must be signed in to change notification settings - Fork 0
/
red.r
871 lines (771 loc) · 22.5 KB
/
red.r
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
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
REBOL [
Title: "Red command-line front-end"
Author: "Nenad Rakocevic, Andreas Bolka"
File: %red.r
Tabs: 4
Rights: "Copyright (C) 2011-2015 Nenad Rakocevic, Andreas Bolka. All rights reserved."
License: "BSD-3 - https://github.com/red/red/blob/master/BSD-3-License.txt"
Usage: {
do/args %red.r "path/source.red"
}
Encap: [quiet secure none cgi title "Red" no-window]
]
unless value? 'encap-fs [do %system/utils/encap-fs.r]
unless all [value? 'red object? :red][
do-cache %compiler.r
]
redc: context [
crush-lib: none ;-- points to compiled crush library
crush-compress: none ;-- compression function
win-version: none ;-- Windows version extracted from "ver" command
SSE3?: yes
Windows?: system/version/4 = 3
macOS?: system/version/4 = 2
load-lib?: any [encap? find system/components 'Library]
if encap? [
temp-dir: switch/default system/version/4 [
2 [ ;-- MacOS X
libc: load/library %libc.dylib
sys-call: make routine! [cmd [string!]] libc "system"
join any [attempt [to-rebol-file get-env "HOME"] %/tmp] %/.red/
]
3 [ ;-- Windows
either lib?: find system/components 'Library [
sys-path: to-rebol-file get-env "SystemRoot"
shell32: load/library sys-path/System32/shell32.dll
kernel32: load/library sys-path/System32/kernel32.dll
libc: load/library sys-path/System32/msvcrt.dll
CSIDL_COMMON_APPDATA: to integer! #{00000023}
SHGetFolderPath: make routine! [
hwndOwner [integer!]
nFolder [integer!]
hToken [integer!]
dwFlags [integer!]
pszPath [string!]
return: [integer!]
] shell32 "SHGetFolderPathA"
ShellExecuteW: make routine! [
hwnd [integer!]
lpOperation [string!]
lpFile [string!]
lpParameters [string!]
lpDirectory [integer!]
nShowCmd [integer!]
return: [integer!]
] shell32 "ShellExecuteW"
GetCommandLineW: make routine! compose/deep [
return: [integer!]
] kernel32 "GetCommandLineW"
WideCharToMultiByte: make routine! [
CodePage [integer!]
dwFlags [integer!]
lpWideCharStr [integer!]
cchWideChar [integer!]
lpMultiByteStr [string!]
cbMultiByte [integer!]
lpDefaultChar [integer!]
lpUsedDefaultChar [integer!]
return: [integer!]
] kernel32 "WideCharToMultiByte"
_wsystem: make routine! [cmd [string!] return: [integer!]] libc "_wsystem"
IsProcessorFeaturePresent: make routine! [feat [integer!] return: [integer!]] kernel32 "IsProcessorFeaturePresent"
gui-sys-call: func [cmd [string!] args [string!]][
ShellExecuteW
0
utf8-to-utf16 "open"
utf8-to-utf16 cmd
utf8-to-utf16 args
0 1
]
sys-call: func [cmd [string!]][_wsystem utf8-to-utf16 cmd]
SSE3?: to logic! IsProcessorFeaturePresent 13
path: head insert/dup make string! 255 null 255
unless zero? SHGetFolderPath 0 CSIDL_COMMON_APPDATA 0 0 path [
fail "SHGetFolderPath failed: can't determine temp folder path"
]
append dirize to-rebol-file trim path %Red/
][
sys-call: func [cmd][call/wait cmd]
append to-rebol-file get-env "ALLUSERSPROFILE" %/Red/
]
]
][ ;-- Linux (default)
any [
exists? libc: %libc.so.6
exists? libc: %/lib32/libc.so.6
exists? libc: %/lib/i386-linux-gnu/libc.so.6 ; post 11.04 Ubuntu
exists? libc: %/usr/lib32/libc.so.6 ; e.g. 64-bit Arch Linux
exists? libc: %/lib/libc.so.6
exists? libc: %/System/Index/lib/libc.so.6 ; GoboLinux package
exists? libc: %/system/index/framework/libraries/libc.so.6 ; Syllable
exists? libc: %/lib/libc.so.5
]
libc: load/library libc
sys-call: make routine! [cmd [string!]] libc "system"
join any [attempt [to-rebol-file get-env "HOME"] %/tmp] %/.red/
]
]
if Windows? [
use [buf cmd][
cmd: "cmd /c ver"
buf: make string! 128
either load-lib? [
do-cache %utils/call.r ;@@ put `call.r` in proper place when we encap
win-call/output cmd buf
][
set 'win-call :call ;-- Rebol/Core compatible mode
win-call/output/show cmd buf ;-- not using /show would freeze CALL
]
parse/all buf [[thru "[" | thru "Version" | thru "ver" | thru "v" | thru "indows"] to #"." pos:]
win-version: any [
attempt [load copy/part back remove pos 2]
0
]
]
]
;; Select a default target based on the REBOL version.
default-target: does [
any [
switch/default system/version/4 [
2 ["Darwin"]
3 ["MSDOS"]
4 [either system/version/5 = 8 ["RPI"]["Linux"]]
7 ["FreeBSD"]
]["MSDOS"]
]
]
get-OS-name: does [
switch/default system/version/4 [
2 ['macOS]
3 ['Windows]
4 ['Linux]
]['Linux] ;-- usage related to lib suffixes
]
fail: func [value] [
print value
if system/options/args [quit/return 1]
halt
]
fail-try: func [component body /local err] [
if error? set/any 'err try body [
err: disarm err
foreach w [arg1 arg2 arg3][
set w either unset? get/any in err w [none][
get/any in err w
]
]
fail [
"***" component "Internal Error:"
system/error/(err/type)/type #":"
reduce system/error/(err/type)/(err/id) newline
"*** Where:" mold/flat err/where newline
"*** Near: " mold/flat err/near newline
]
]
]
format-time: func [time [time!]][
round (time/second * 1000) + (time/minute * 60000)
]
decorate-name: func [name [file!]][
rejoin [ ;-- filename: <name>-year-month-day(ISO format)-time
name #"-"
build-date/year "-"
build-date/month "-"
build-date/day "-"
to-integer build-date/time
]
]
load-filename: func [filename /local result] [
unless any [
all [
#"%" = first filename
attempt [result: load filename]
file? result
]
attempt [result: to-rebol-file filename]
][
fail ["Invalid filename:" filename]
]
result
]
load-targets: func [/local targets] [
targets: load-cache %system/config.r
if exists? %system/custom-targets.r [
insert targets load %system/custom-targets.r
]
targets
]
get-output-path: func [opts [object!] /local path][
case [
opts/build-basename [
path: first split-path opts/build-basename
either opts/build-prefix [join opts/build-prefix path][path]
]
opts/build-prefix [opts/build-prefix]
'else [%""]
]
]
red-system?: func [file [file!] /local ws rs?][
ws: charset " ^-^/^M"
parse/all/case read file [
some [
thru "Red"
opt ["/System" (rs?: yes)]
any ws
#"[" (return to logic! rs?)
to end
]
]
no
]
split-tokens: has [args unescape len s e][
args: system/script/args
unescape: to-paren [
if odd? len: offset? s e [len: len - 1]
e: skip e negate len / 2
e: remove/part s e
]
parse/all args: copy args [ ;-- preprocess escape chars
any [
s: {'"} thru {"'} e: (s/1: #"{" e/-1: #"}")
| s: #"'" [to #"'" e: (s/1: #"{" e/1: #"}") | to end]
| s: some #"\" e: {"} unescape :e
thru #"\" s: any #"\" e: {"} unescape :e
| skip
]
]
remove system/options/args: collect [ ;-- remove first entry
parse/all args [ ;-- tokenize and collect
some [[
some #"^"" s: to #"^"" e: (keep copy/part s e) some #"^""
| #"{" s: to #"}" e: (keep copy/part s e) skip
| s: [
to #" " e: (keep copy/part s e)
| to end e: (if s <> e [keep copy/part s e]) skip]
] any #" "
]
]
]
]
fetch-cmdline: has [cmd buffer size][
either Windows? [
cmd: GetCommandLineW
size: WideCharToMultiByte 65001 0 cmd -1 "" 0 0 0 ;-- CP_UTF8
buffer: make string! size + 1
insert/dup buffer null size + 1
WideCharToMultiByte 65001 0 cmd -1 buffer size 0 0 ;-- CP_UTF8
while [find " ^@" last buffer][remove back tail buffer]
system/script/args: buffer
split-tokens
][
]
]
safe-to-local-file: func [file [file! string!]][
if all [
find file: to-local-file file #" "
Windows?
][
file: rejoin [{"} file {"}] ;-- avoid issues with blanks in path
]
file
]
form-args: func [file /local args delim pos pos2 flag][
args: make string! 32
foreach arg pos: find system/options/args file [
case [
find arg #" " [
delim: pick {'"} to logic! find arg #"^""
repend args [delim arg delim]
]
find arg #"^"" [
repend args [#"'" arg #"'"]
]
'else [
append args arg
]
]
append args #" "
]
remove back tail args
all [
pos2: find system/options/args flag: "--catch"
positive? offset? pos2 pos
insert insert args flag #" "
]
args
]
add-legacy-flags: func [opts [object!] /local out ver][
if all [Windows? win-version <= 60][
either opts/legacy [ ;-- do not compile gesture support code for XP, Vista, Windows Server 2003/2008(R1)
append opts/legacy 'no-touch
][
opts/legacy: copy [no-touch]
]
]
if all [Windows? opts/OS = 'Windows not SSE3?][
opts/cpu-version: 1.0
]
if system/version/4 = 2 [ ;-- macOS version extraction
out: make string! 128
call/output "sw_vers -productVersion" out
attempt [
ver: load out
opts/OS-version: load rejoin [ver/1 #"." ver/2]
]
]
]
build-compress-lib: has [script basename filename text opts ext src][
src: %runtime/crush.reds
basename: either encap? [
unless exists? temp-dir [make-dir temp-dir]
script: temp-dir/crush.reds
decorate-name %crush
][
temp-dir: %./
script: %crush.reds
copy %crush
]
filename: append temp-dir/:basename case [
Windows? [%.dll]
system/version/4 = 2 [%.dylib]
'else [%.so]
]
if any [
not exists? filename
all [
not encap?
(modified? filename) < modified? src
]
][
if crush-lib [
free crush-lib
crush-lib: none
]
text: copy read-cache src
append text " #export [crush/compress]"
write script text
unless encap? [basename: head insert basename %../]
opts: make system-dialect/options-class [ ;-- minimal set of compilation options
link?: yes
config-name: to word! default-target
build-basename: basename
build-prefix: temp-dir
dev-mode?: no
]
opts: make opts select load-targets opts/config-name
opts/type: 'dll
if opts/OS <> 'Windows [opts/PIC?: yes]
add-legacy-flags opts
print "Compiling compression library..."
unless encap? [
change-dir %system/
script: head insert script %../
]
system-dialect/compile/options script opts
delete script
unless encap? [change-dir %../]
]
unless crush-lib [
crush-lib: load/library filename
crush-compress: make routine! [
in [binary!]
size [integer!] ;-- size in bytes
out [binary!] ;-- output buffer (pre-allocated)
return: [integer!] ;-- compressed data size
] crush-lib "crush/compress"
]
]
run-console: func [
gui? [logic!] /with file [string!]
/local opts result script filename exe console files source con-ui gui-target
][
script: temp-dir/red-console.red
filename: decorate-name pick [%gui-console %console] gui?
exe: temp-dir/:filename
if Windows? [append exe %.exe]
unless exists? temp-dir [make-dir temp-dir]
unless exists? exe [
console: %environment/console/
con-ui: pick [%gui-console.red %console.red] gui?
if gui? [
gui-target: select [
"Darwin" macOS
"MSDOS" Windows
;"Linux" Linux-GTK
] default-target
]
source: copy read-cache console/:con-ui
if all [any [Windows? macOS?] not gui?][insert find/tail source #"[" "Needs: 'View^/"]
write script source
files: [
%auto-complete.red %engine.red %help.red %input.red
%wcwidth.reds %win32.reds %POSIX.reds %terminal.reds
%windows.reds
]
foreach f files [write temp-dir/:f read-cache console/:f]
opts: make system-dialect/options-class [ ;-- minimal set of compilation options
link?: yes
unicode?: yes
config-name: any [gui-target to word! default-target]
build-basename: filename
build-prefix: temp-dir
red-help?: yes ;-- include doc-strings
gui-console?: gui?
dev-mode?: no
]
opts: make opts select load-targets opts/config-name
add-legacy-flags opts
print replace "Compiling Red $console..." "$" pick ["GUI " ""] gui?
result: red/compile script opts
system-dialect/compile/options/loaded script opts result
delete script
foreach f files [delete temp-dir/:f]
if all [Windows? not lib?][
print "Please run red.exe again to access the console."
quit/return 1
]
]
exe: safe-to-local-file exe
either gui? [
gui-sys-call exe any [all [file form-args file] ""]
][
if with [repend exe [" " form-args file]]
sys-call exe ;-- replace the buggy CALL native
]
quit/return 0
]
build-libRedRT: func [opts [object!] /local script result file path][
print "Compiling libRedRT..."
file: libRedRT/lib-file
path: get-output-path opts
opts: make opts [
build-prefix: path
build-basename: file
type: 'dll
libRedRT?: yes
link?: yes
unicode?: yes
]
if opts/OS <> 'Windows [opts/PIC?: yes]
all [
not empty? path: opts/build-prefix
slash <> first path
not encap?
opts/build-prefix: head insert copy path %../
]
script: switch/default opts/OS [ ;-- empty script for the lib
Windows macOS [ [[Needs: View]] ]
][ [[]] ]
result: red/compile script opts
print [
"...compilation time :" format-time result/2 "ms^/"
"^/Compiling to native code..."
]
unless encap? [change-dir %system/]
result: system-dialect/compile/options/loaded file opts result
unless encap? [change-dir %../]
show-stats result
]
needs-libRedRT?: func [opts [object!] /local file path lib lib? get-date ts date current?][
unless opts/dev-mode? [return no]
path: get-output-path opts
file: join path %libRedRT
libRedRT/root-dir: path
lib?: exists? lib: join file switch/default opts/OS [
Windows [%.dll]
macOS [%.dylib]
][%.so]
if lib? [
date: modified? lib
current?: any [not encap? date > build-date]
either all [load-lib? opts/OS = get-OS-name][
lib: load/library lib
get-date: make routine! [return: [string!]] lib "red/get-build-date"
ts: get-date
free lib
][
ts: date
]
if current? [print ["...using libRedRT built on" ts]]
]
not all [
lib?
current?
exists? join path libRedRT/include-file
exists? join path libRedRT/defs-file
]
]
show-stats: func [result][
print ["...compilation time :" format-time result/1 "ms"]
if result/2 [
print [
"...linking time :" format-time result/2 "ms^/"
"...output file size :" result/3 "bytes^/"
"...output file :" to-local-file result/4 lf
]
]
]
do-clear: func [args [block!] /local path file][
either empty? args [path: %""][
path: either args/1/1 = #"%" [
attempt [load args/1]
][
attempt [to-rebol-file args/1]
]
unless all [path exists? path][
fail "`red clear` command error: invalid path"
]
]
foreach ext [%.dll %.dylib %.so][
if exists? file: rejoin [path libRedRT/lib-file ext][delete file]
]
foreach file [include-file defs-file extras-file][
if exists? file: join path libRedRT/:file [delete file]
]
reduce [none none]
]
do-build: func [args [block!] /local cmd src][
switch/default args/1 [
"libRed" [
if all [encap? not exists? %libRed/][
make-dir path: %libRed/
foreach file [
%libRed.def
%libRed.red
%red.h
][
write path/:file read-cache path/:file
]
write/binary path/libRed.lib read-cache path/libRed.lib
]
cmd: copy "-r libRed/libRed.red"
if all [not tail? next args args/2 = "stdcall"][
insert at cmd 3 " --config [export-ABI: 'stdcall]"
]
parse-options cmd
]
][
fail reform ["command error: unknown command" args/1]
]
]
parse-tokens: func [cmds [string!] /local ws list s e token store][
ws: charset " ^/^M^-"
list: make block! 10
store: [
unless empty? token: trim copy/part s e [append list token]
s: e
]
parse/all cmds [
s: any [
e: some ws (do store)
| {"} thru {"} e: (do store)
| "[" thru "]" e: (do store)
| skip
] e: (do store)
]
list
]
parse-options: func [
args [string! none!]
/local src opts output target verbose filename config config-name base-path type
mode target? gui? cmd spec cmds ws ssp
][
unless args [
if encap? [fetch-cmdline] ;-- Fetch real command-line in UTF8 format
args: any [system/options/args system/script/args ""] ;-- ssa for quick-test.r
]
unless block? args [args: parse-tokens args]
target: default-target
opts: make system-dialect/options-class [
link?: yes
libRedRT-update?: no
]
gui?: Windows? ;-- use GUI console by default on Windows
unless empty? args [
if cmd: select [
"clear" do-clear
"build" do-build
"halt" 'halt
] first args [
return do reduce [cmd next args]
]
]
parse/case args [
any [
["-c" | "--compile"] (type: 'exe)
| ["-r" | "--release"] (type: 'exe opts/dev-mode?: no)
| ["-d" | "--debug-stabs" | "--debug"] (opts/debug?: yes)
| ["-o" | "--output"] [set output skip | (fail "Missing output filename")]
| ["-t" | "--target"] [set target skip | (fail "Missing target")] (target?: yes)
| ["-v" | "--verbose"] [set verbose skip | (fail "Missing verbosity")] ;-- 1-3: Red, >3: Red/System
| ["-h" | "--help"] (mode: 'help)
| ["-V" | "--version"] (mode: 'version)
| ["-u" | "--update-libRedRT"] (opts/libRedRT-update?: yes)
| ["-s" | "--show-expanded"] (opts/show: 'expanded)
| ["-dlib" | "--dynamic-lib"] (type: 'dll)
;| ["-slib" | "--static-lib"] (type 'lib)
| "--config" set spec skip (attempt [spec: load spec])
| "--red-only" (opts/red-only?: yes)
| "--dev" (opts/dev-mode?: yes)
| "--no-runtime" (opts/runtime?: no) ;@@ overridable by config!
| "--cli" (gui?: no)
| "--catch" ;-- just pass-thru
]
set filename skip (src: load-filename filename)
]
if mode [
switch mode [
help [print read-cache %usage.txt]
version [print load-cache %version.r]
]
quit/return 0
]
;; Process -t/--target first, so that all other command-line options
;; can potentially override the target config settings.
unless config: select load-targets config-name: to word! trim target [
fail ["Unknown target:" target]
]
if target? [unless type [type: 'exe]] ;-- implies compilation
base-path: either encap? [
system/options/path
][
ssp: system/script/parent
any [
all [ssp ssp/path]
system/script/path
]
]
opts: make opts config
opts/config-name: config-name
opts/build-prefix: base-path
if all [target? none? opts/dev-mode?][
opts/dev-mode?: opts/OS = get-OS-name ;-- forces release mode if other OS
]
;; Process -o/--output (if any).
if output [
either slash = last output [
attempt [opts/build-prefix: to-rebol-file output]
][
opts/build-basename: load-filename output
if slash = first opts/build-basename [
opts/build-prefix: %""
]
]
]
;; Process -v/--verbose (if any).
if verbose [
unless attempt [opts/verbosity: to integer! trim verbose] [
fail ["Invalid verbosity:" verbose]
]
]
;; Process -dlib/--dynamic-lib (if any).
if any [type = 'dll opts/type = 'dll][
if type = 'dll [opts/type: type]
if opts/OS <> 'Windows [opts/PIC?: yes]
]
;; Check common syntax mistakes
if all [
any [type output verbose target?] ;-- -c | -o | -dlib | -t | -v
none? src
][
fail "Source file is missing"
]
if all [output output/1 = #"-"][ ;-- -o (not followed by option)
fail "Missing output file or path"
]
;; Process input sources.
unless src [
either encap? [
if load-lib? [build-compress-lib]
run-console gui?
][
return reduce [none none]
]
]
if all [encap? none? output none? type][
if load-lib? [build-compress-lib]
run-console/with gui? filename
]
if slash <> first src [ ;-- if relative path
src: clean-path join base-path src ;-- add working dir path
]
unless exists? src [
fail ["Cannot access source file:" to-local-file src]
]
add-legacy-flags opts
if spec [
opts: make opts spec
opts/command-line: spec
]
if none? opts/dev-mode? [opts/dev-mode?: yes] ;-- fallback to dev mode if undefined
reduce [src opts]
]
compile: func [src opts /local result saved rs?][
print [ "Compiling" to-local-file src "..."]
unless rs?: red-system? src [
;--- 1st pass: Red compiler ---
if load-lib? [build-compress-lib]
if needs-libRedRT? opts [build-libRedRT opts]
fail-try "Red Compiler" [
result: red/compile src opts
]
print ["...compilation time :" format-time result/2 "ms"]
if opts/red-only? [probe result/1 return none]
]
;--- 2nd pass: Red/System compiler ---
print [
newline
"Target:" opts/config-name lf lf
"Compiling to native code..."
]
fail-try "Red/System Compiler" [
unless encap? [change-dir %system/]
result: either rs? [
system-dialect/compile/options src opts
][
opts/unicode?: yes ;-- force Red/System to use Red's Unicode API
opts/verbosity: max 0 opts/verbosity - 3 ;-- Red/System verbosity levels upped by 3
system-dialect/compile/options/loaded src opts result
]
unless encap? [change-dir %../]
]
result
]
main: func [/with cmd [string!] /local src opts build-dir prefix result][
set [src opts] parse-options cmd
unless src [do opts exit] ;-- run named command and terminates
rs?: red-system? src
;-- If we use a build directory, ensure it exists.
if all [prefix: opts/build-prefix find prefix %/] [
build-dir: copy/part prefix find/last prefix %/
unless attempt [make-dir/deep build-dir] [
fail ["Cannot access build dir:" to-local-file build-dir]
]
]
print [lf "-=== Red Compiler" read-cache %version.r "===-" lf]
;-- libRedRT updating mode
if opts/libRedRT-update? [
opts/dev-mode?: opts/link?: no
compile src opts
print ["libRedRT-extras.r file generated, recompiling..." lf]
opts/dev-mode?: opts/link?: yes
opts/libRedRT-update?: no
]
if result: compile src opts [
show-stats result
if all [word: in opts 'packager get word][
file: join %system/formats/ [opts/packager %.r]
unless exists?-cache file [fail ["Packager:" opts/packager "not found!"]]
do bind load-cache file 'self
packager/process opts src result/4
]
unless Windows? [print ""] ;-- extra LF for more readable output
]
]
set 'rc func [cmd [file! string! block!]][
fail-try "Driver" [redc/main/with reform cmd]
() ;-- return unset value
]
]
redc/fail-try "Driver" [redc/main]
if encap? [quit/return 0]