forked from janet-lang/janet
-
Notifications
You must be signed in to change notification settings - Fork 0
/
jpm
executable file
·1456 lines (1296 loc) · 48.5 KB
/
jpm
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
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
#!/usr/bin/env janet
# CLI tool for building janet projects.
#
# Basic Path Settings
#
# Windows is the OS outlier
(def- is-win (= (os/which) :windows))
(def- is-mac (= (os/which) :macos))
(def- sep (if is-win "\\" "/"))
(def- objext (if is-win ".obj" ".o"))
(def- modext (if is-win ".dll" ".so"))
(def- statext (if is-win ".static.lib" ".a"))
(def- absprefix (if is-win "C:\\" "/"))
#
# Defaults
#
###START###
# Overriden on some installs.
# To configure this script, replace the code between
# the START and END comments and define a function
# (install-paths) that gives the the default paths
# to use. Trailing directory separator not expected.
#
# Example.
#
# (defn- install-paths []
# {:headerpath "/usr/local/include/janet"
# :libpath "/usr/local/lib/janet"
# :binpath "/usr/local/bin"
#
(def- exe-dir
"Directory containing jpm script"
(do
(def exe (dyn :current-file))
(def i (last (string/find-all sep exe)))
(slice exe 0 i)))
(defn- try-real [path]
"If os/realpath fails just use normal path."
(try (os/realpath path) ([_] path)))
(defn- install-paths []
{:headerpath (try-real (string exe-dir "/../include/janet"))
:libpath (try-real (string exe-dir "/../lib"))
:binpath exe-dir})
###END###
# Default based on janet binary location
(def JANET_HEADERPATH (or (os/getenv "JANET_HEADERPATH")
(get (install-paths) :headerpath)))
(def JANET_LIBPATH (or (os/getenv "JANET_LIBPATH")
(get (install-paths) :libpath)))
# We want setting JANET_PATH to contain installed binaries. However, it is convenient
# to have globally installed binaries got to the same place as jpm itself, which is on
# the $PATH.
(def JANET_BINPATH (or (os/getenv "JANET_BINPATH")
(if-let [mp (os/getenv "JANET_MODPATH")] (string mp "/bin"))
(if-let [mp (os/getenv "JANET_PATH")] (string mp "/bin"))
(get (install-paths) :binpath)))
# modpath should only be derived from the syspath being used or an environment variable.
(def JANET_MODPATH (or (os/getenv "JANET_MODPATH") (dyn :syspath)))
#
# Utilities
#
(defn find-manifest-dir
"Get the path to the directory containing manifests for installed
packages."
[]
(string (dyn :modpath JANET_MODPATH) sep ".manifests"))
(defn find-manifest
"Get the full path of a manifest file given a package name."
[name]
(string (find-manifest-dir) sep name ".jdn"))
(defn find-cache
"Return the path to the global cache."
[]
(def path (dyn :modpath JANET_MODPATH))
(string path sep ".cache"))
(defn rm
"Remove a directory and all sub directories."
[path]
(case (os/lstat path :mode)
:directory (do
(each subpath (os/dir path)
(rm (string path sep subpath)))
(os/rmdir path))
nil nil # do nothing if file does not exist
# Default, try to remove
(os/rm path)))
(defn- rimraf
"Hard delete directory tree"
[path]
(if is-win
# windows get rid of read-only files
(when (os/stat path :mode)
(os/shell (string `rmdir /S /Q "` path `"`)))
(rm path)))
(defn clear-cache
"Clear the global git cache."
[]
(def cache (find-cache))
(print "clearing cache " cache "...")
(rimraf cache))
(defn clear-manifest
"Clear the global installation manifest."
[]
(def manifest (find-manifest-dir))
(print "clearing manifests " manifest "...")
(rimraf manifest))
(def- default-pkglist
(or (os/getenv "JANET_PKGLIST") "https://github.com/janet-lang/pkgs.git"))
(defn- pslurp
"Like slurp, but with file/popen instead file/open. Also trims output"
[cmd]
(string/trim (with [f (file/popen cmd)] (:read f :all))))
(def- path-splitter
"split paths on / and \\."
(peg/compile ~(any (* '(any (if-not (set `\/`) 1)) (+ (set `\/`) -1)))))
(defn create-dirs
"Create all directories needed for a file (mkdir -p)."
[dest]
(def segs (peg/match path-splitter dest))
(for i 1 (length segs)
(def path (string/join (slice segs 0 i) sep))
(unless (empty? path) (os/mkdir path))))
(def- filepath-replacer
"Convert url with potential bad characters into a file path element."
(peg/compile ~(% (any (+ (/ '(set "<>:\"/\\|?*") "_") '1)))))
(def- entry-replacer
"Convert url with potential bad characters into an entry-name"
(peg/compile ~(% (any (+ '(range "AZ" "az" "09" "__") (/ '1 ,|(string "_" ($ 0) "_")))))))
(defn entry-replace
"Escape special characters in the entry-name"
[name]
(get (peg/match entry-replacer name) 0))
(defn filepath-replace
"Remove special characters from a string or path
to make it into a path segment."
[repo]
(get (peg/match filepath-replacer repo) 0))
(defn shell
"Do a shell command"
[& args]
(if (dyn :verbose)
(print ;(interpose " " args)))
(os/execute args :px))
(defn copy
"Copy a file or directory recursively from one location to another."
[src dest]
(print "copying " src " to " dest "...")
(if is-win
(let [end (last (peg/match path-splitter src))
isdir (= (os/stat src :mode) :directory)]
(shell "C:\\Windows\\System32\\xcopy.exe"
(string/replace "/" "\\" src) (string/replace "/" "\\" (if isdir (string dest "\\" end) dest))
"/y" "/s" "/e" "/i"))
(shell "cp" "-rf" src dest)))
(defn mkdir
"Create a directory if it doesn't exist. If it does exist, do nothing.
If we can't create it, give a friendly error. Return true if created, false if
existing. Throw an error if we can't create it."
[dir]
(os/mkdir dir))
(defn- abspath
"Create an absolute path. Does not resolve . and .. (useful for
generating entries in install manifest file)."
[path]
(if (if is-win
(peg/match '(+ "\\" (* (range "AZ" "az") ":\\")) path)
(string/has-prefix? "/" path))
path
(string (os/cwd) sep path)))
#
# Rule Engine
#
(defn- getrules []
(if-let [rules (dyn :rules)] rules (setdyn :rules @{})))
(defn- gettarget [target]
(def item ((getrules) target))
(unless item (error (string "No rule for target " target)))
item)
(defn add-dep
"Add a dependency to an existing rule. Useful for extending phony
rules or extending the dependency graph of existing rules."
[target dep]
(def [deps] (gettarget target))
(unless (find |(= dep $) deps)
(array/push deps dep)))
(defn- add-thunk
[target more &opt phony]
(def item (gettarget target))
(def [_ thunks pthunks] item)
(array/push (if phony pthunks thunks) more)
item)
(defn- rule-impl
[target deps thunk &opt phony]
(def rules (getrules))
(unless (rules target) (put rules target @[(array/slice deps) @[] @[]]))
(each d deps (add-dep target d))
(add-thunk target thunk phony))
(defmacro rule
"Add a rule to the rule graph."
[target deps & body]
~(,rule-impl ,target ,deps (fn [] ,;body)))
(defmacro phony
"Add a phony rule to the rule graph. A phony rule will run every time
(it is always considered out of date). Phony rules are good for defining
user facing tasks."
[target deps & body]
~(,rule-impl ,target ,deps (fn [] nil ,;body) true))
(defmacro sh-rule
"Add a rule that invokes a shell command, and fails if the command returns non-zero."
[target deps & body]
~(,rule-impl ,target ,deps (fn [] (,assert (,zero? (,os/shell (,string ,;body)))))))
(defmacro sh-phony
"Add a phony rule that invokes a shell command, and fails if the command returns non-zero."
[target deps & body]
~(,rule-impl ,target ,deps (fn [] (,assert (,zero? (,os/shell (,string ,;body))))) true))
(defmacro add-body
"Add recipe code to an existing rule. This makes existing rules do more but
does not modify the dependency graph."
[target & body]
~(,add-thunk ,target (fn [] ,;body)))
(defn- needs-build
[dest src]
(let [mod-dest (os/stat dest :modified)
mod-src (os/stat src :modified)]
(< mod-dest mod-src)))
(defn- needs-build-some
[dest sources]
(def f (file/open dest))
(if (not f) (break true))
(file/close f)
(some (partial needs-build dest) sources))
(defn do-rule
"Evaluate a given rule."
[target]
(def item ((getrules) target))
(unless item
(if (os/stat target :mode)
(break target)
(error (string "No rule for file " target " found."))))
(def [deps thunks phony] item)
(def realdeps (seq [dep :in deps :let [x (do-rule dep)] :when x] x))
(each thunk phony (thunk))
(unless (empty? thunks)
(when (needs-build-some target realdeps)
(each thunk thunks (thunk))
target)))
#
# Importing a file
#
(def- _env (fiber/getenv (fiber/current)))
(defn- proto-flatten
[into x]
(when x
(proto-flatten into (table/getproto x))
(merge-into into x))
into)
(defn make-jpm-env
"Build an environment table with jpm functions preloaded."
[&opt no-deps]
(def env (make-env))
(put env :jpm-no-deps no-deps)
(loop [k :keys _env :when (symbol? k)]
(unless ((_env k) :private) (put env k (_env k))))
env)
(defn require-jpm
"Require a jpm file project file. This is different from a normal require
in that code is loaded in the jpm environment."
[path &opt no-deps]
(unless (os/stat path :mode)
(error (string "cannot open " path)))
(def env (make-jpm-env no-deps))
(def currenv (proto-flatten @{} (fiber/getenv (fiber/current))))
(loop [k :keys currenv :when (keyword? k)]
(put env k (currenv k)))
(dofile path :env env :exit true)
env)
(defn import-rules
"Import another file that defines more rules. This ruleset
is merged into the current ruleset."
[path &opt no-deps]
(def env (require-jpm path no-deps))
(when-let [rules (env :rules)] (merge-into (getrules) rules))
env)
(defmacro post-deps
"Run code at the top level if jpm dependencies are installed. Build
code that imports dependencies should be wrapped with this macro, as project.janet
needs to be able to run successfully even without dependencies installed."
[& body]
(unless (dyn :jpm-no-deps)
~',(reduce |(eval $1) nil body)))
#
# C Compilation
#
(def default-compiler (or (os/getenv "CC") (if is-win "cl.exe" "cc")))
(def default-cpp-compiler (or (os/getenv "CXX") (if is-win "cl.exe" "c++")))
(def default-linker (or (os/getenv "CC") (if is-win "link.exe" "cc")))
(def default-cpp-linker (or (os/getenv "CXX") (if is-win "link.exe" "c++")))
(def default-archiver (or (os/getenv "AR") (if is-win "lib.exe" "ar")))
# Detect threads
(def env (fiber/getenv (fiber/current)))
(def threads? (not (not (env 'thread/new))))
(def- thread-flags
(if is-win []
(if threads? ["-lpthread"] [])))
# flags needed for the janet binary and compiling standalone
# executables.
(def janet-lflags
(case (os/which)
:macos ["-ldl" "-lm" ;thread-flags]
:windows [;thread-flags]
:linux ["-lm" "-ldl" "-lrt" ;thread-flags]
["-lm" ;thread-flags]))
(def janet-ldflags [])
(def janet-cflags [])
# Default flags for natives, but not required
# How can we better detect the need for -pthread?
# we probably want to better detect compiler
(def default-lflags (if is-win ["/nologo"] []))
(def default-cflags
(if is-win
["/nologo" "/MD"]
["-std=c99" "-Wall" "-Wextra"]))
(def default-cppflags
(if is-win
["/nologo" "/MD" "/EHsc"]
["-std=c++11" "-Wall" "-Wextra"]))
(def default-ldflags [])
# Required flags for dynamic libraries. These
# are used no matter what for dynamic libraries.
(def- dynamic-cflags
(if is-win
["/LD"]
["-fPIC"]))
(def- dynamic-lflags
(if is-win
["/DLL"]
(if is-mac
["-shared" "-undefined" "dynamic_lookup" ;thread-flags]
["-shared" ;thread-flags])))
(defn- opt
"Get an option, allowing overrides via dynamic bindings AND some
default value dflt if no dynamic binding is set."
[opts key dflt]
(def ret (or (opts key) (dyn key dflt)))
(if (= nil ret)
(error (string "option :" key " not set")))
ret)
(defn check-cc
"Ensure we have a c compiler."
[]
(if is-win
(do
(if (os/getenv "INCLUDE") (break))
(error "Run jpm inside a Developer Command Prompt.
jpm needs a c compiler to compile natives. You can install the MSVC compiler from
microsoft.com"))
(do)))
(defn- embed-name
"Rename a janet symbol for embedding."
[path]
(->> path
(string/replace-all "\\" "___")
(string/replace-all "/" "___")
(string/replace-all ".janet" "")))
(defn- out-path
"Take a source file path and convert it to an output path."
[path from-ext to-ext]
(->> path
(string/replace-all "\\" "___")
(string/replace-all "/" "___")
(string/replace-all from-ext to-ext)
(string "build" sep)))
(defn- make-define
"Generate strings for adding custom defines to the compiler."
[define value]
(if value
(string "-D" define "=" value)
(string "-D" define)))
(defn- make-defines
"Generate many defines. Takes a dictionary of defines. If a value is
true, generates -DNAME (/DNAME on windows), otherwise -DNAME=value."
[defines]
(seq [[d v] :pairs defines] (make-define d (if (not= v true) v))))
(defn- getcflags
"Generate the c flags from the input options."
[opts]
@[;(opt opts :cflags default-cflags)
(string "-I" (dyn :headerpath JANET_HEADERPATH))
(string "-O" (opt opts :optimize 2))])
(defn- getcppflags
"Generate the cpp flags from the input options."
[opts]
@[;(opt opts :cppflags default-cppflags)
(string "-I" (dyn :headerpath JANET_HEADERPATH))
(string "-O" (opt opts :optimize 2))])
(defn- entry-name
"Name of symbol that enters static compilation of a module."
[name]
(string "janet_module_entry_" (entry-replace name)))
(defn- compile-c
"Compile a C file into an object file."
[opts src dest &opt static?]
(def cc (opt opts :compiler default-compiler))
(def cflags [;(getcflags opts) ;(if static? [] dynamic-cflags)])
(def entry-defines (if-let [n (and static? (opts :entry-name))]
[(make-define "JANET_ENTRY_NAME" n)]
[]))
(def defines [;(make-defines (opt opts :defines {})) ;entry-defines])
(def headers (or (opts :headers) []))
(rule dest [src ;headers]
(check-cc)
(print "compiling " src " to " dest "...")
(create-dirs dest)
(if is-win
(shell cc ;defines "/c" ;cflags (string "/Fo" dest) src)
(shell cc "-c" src ;defines ;cflags "-o" dest))))
(defn- compile-cpp
"Compile a C++ file into an object file."
[opts src dest &opt static?]
(def cpp (opt opts :cpp-compiler default-cpp-compiler))
(def cflags [;(getcppflags opts) ;(if static? [] dynamic-cflags)])
(def entry-defines (if-let [n (and static? (opts :entry-name))]
[(make-define "JANET_ENTRY_NAME" n)]
[]))
(def defines [;(make-defines (opt opts :defines {})) ;entry-defines])
(def headers (or (opts :headers) []))
(rule dest [src ;headers]
(check-cc)
(print "compiling " src " to " dest "...")
(create-dirs dest)
(if is-win
(shell cpp ;defines "/c" ;cflags (string "/Fo" dest) src)
(shell cpp "-c" src ;defines ;cflags "-o" dest))))
(defn- libjanet
"Find libjanet.a (or libjanet.lib on windows) at compile time"
[]
(def libpath (dyn :libpath JANET_LIBPATH))
(unless libpath
(error "cannot find libpath: provide --libpath or JANET_LIBPATH"))
(string (dyn :libpath JANET_LIBPATH)
sep
(if is-win "libjanet.lib" "libjanet.a")))
(defn- win-import-library
"On windows, an import library is needed to link to a dll statically."
[]
(def hpath (dyn :headerpath JANET_HEADERPATH))
(unless hpath
(error "cannot find headerpath: provide --headerpath or JANET_HEADERPATH"))
(string hpath `\\janet.lib`))
(defn- link-c
"Link C object files together to make a native module."
[opts target & objects]
(def linker (opt opts (if is-win :linker :compiler) default-linker))
(def cflags (getcflags opts))
(def lflags [;(opt opts :lflags default-lflags)
;(if (opts :static) [] dynamic-lflags)])
(def ldflags [;(opt opts :ldflags [])])
(rule target objects
(check-cc)
(print "linking " target "...")
(create-dirs target)
(if is-win
(shell linker ;ldflags (string "/OUT:" target) ;objects (win-import-library) ;lflags)
(shell linker ;cflags ;ldflags `-o` target ;objects ;lflags))))
(defn- link-cpp
"Link C++ object files together to make a native module."
[opts target & objects]
(def linker (opt opts (if is-win :cpp-linker :cpp-compiler) default-cpp-linker))
(def cflags (getcppflags opts))
(def lflags [;(opt opts :lflags default-lflags)
;(if (opts :static) [] dynamic-lflags)])
(def ldflags [;(opt opts :ldflags [])])
(rule target objects
(check-cc)
(print "linking " target "...")
(create-dirs target)
(if is-win
(shell linker ;ldflags (string "/OUT:" target) ;objects (win-import-library) ;lflags)
(shell linker ;cflags ;ldflags `-o` target ;objects ;lflags))))
(defn- archive-c
"Link object files together to make a static library."
[opts target & objects]
(def ar (opt opts :archiver default-archiver))
(rule target objects
(check-cc)
(print "creating static library " target "...")
(create-dirs target)
(if is-win
(shell ar "/nologo" (string "/out:" target) ;objects)
(shell ar "rcs" target ;objects))))
(defn- create-buffer-c-impl
[bytes dest name]
(create-dirs dest)
(def out (file/open dest :w))
(def chunks (seq [b :in bytes] (string b)))
(file/write out
"#include <janet.h>\n"
"static const unsigned char bytes[] = {"
(string/join (interpose ", " chunks))
"};\n\n"
"const unsigned char *" name "_embed = bytes;\n"
"size_t " name "_embed_size = sizeof(bytes);\n")
(file/close out))
(defn- create-buffer-c
"Inline raw byte file as a c file."
[source dest name]
(rule dest [source]
(print "generating " dest "...")
(create-dirs dest)
(with [f (file/open source :r)]
(create-buffer-c-impl (:read f :all) dest name))))
(def- root-env (table/getproto (fiber/getenv (fiber/current))))
(defn- modpath-to-meta
"Get the meta file path (.meta.janet) corresponding to a native module path (.so)."
[path]
(string (string/slice path 0 (- (length modext))) "meta.janet"))
(defn- modpath-to-static
"Get the static library (.a) path corresponding to a native module path (.so)."
[path]
(string (string/slice path 0 (- -1 (length modext))) statext))
(defn- make-bin-source
[declarations lookup-into-invocations no-core]
(string
declarations
```
int main(int argc, const char **argv) {
#if defined(JANET_PRF)
uint8_t hash_key[JANET_HASH_KEY_SIZE + 1];
#ifdef JANET_REDUCED_OS
char *envvar = NULL;
#else
char *envvar = getenv("JANET_HASHSEED");
#endif
if (NULL != envvar) {
strncpy((char *) hash_key, envvar, sizeof(hash_key) - 1);
} else if (janet_cryptorand(hash_key, JANET_HASH_KEY_SIZE) != 0) {
fputs("unable to initialize janet PRF hash function.\n", stderr);
return 1;
}
janet_init_hash_key(hash_key);
#endif
janet_init();
```
(if no-core
```
/* Get core env */
JanetTable *env = janet_table(8);
JanetTable *lookup = janet_core_lookup_table(NULL);
JanetTable *temptab;
int handle = janet_gclock();
```
```
/* Get core env */
JanetTable *env = janet_core_env(NULL);
JanetTable *lookup = janet_env_lookup(env);
JanetTable *temptab;
int handle = janet_gclock();
```)
lookup-into-invocations
```
/* Unmarshal bytecode */
Janet marsh_out = janet_unmarshal(
janet_payload_image_embed,
janet_payload_image_embed_size,
0,
lookup,
NULL);
/* Verify the marshalled object is a function */
if (!janet_checktype(marsh_out, JANET_FUNCTION)) {
fprintf(stderr, "invalid bytecode image - expected function.");
return 1;
}
JanetFunction *jfunc = janet_unwrap_function(marsh_out);
/* Check arity */
janet_arity(argc, jfunc->def->min_arity, jfunc->def->max_arity);
/* Collect command line arguments */
JanetArray *args = janet_array(argc);
for (int i = 0; i < argc; i++) {
janet_array_push(args, janet_cstringv(argv[i]));
}
/* Create enviornment */
temptab = env;
janet_table_put(temptab, janet_ckeywordv("args"), janet_wrap_array(args));
janet_gcroot(janet_wrap_table(temptab));
/* Unlock GC */
janet_gcunlock(handle);
/* Run everything */
JanetFiber *fiber = janet_fiber(jfunc, 64, argc, argc ? args->data : NULL);
fiber->env = temptab;
#ifdef JANET_EV
janet_gcroot(janet_wrap_fiber(fiber));
janet_schedule(fiber, janet_wrap_nil());
janet_loop();
int status = janet_fiber_status(fiber);
janet_deinit();
return status;
#else
Janet out;
JanetSignal result = janet_continue(fiber, janet_wrap_nil(), &out);
if (result != JANET_SIGNAL_OK && result != JANET_SIGNAL_EVENT) {
janet_stacktrace(fiber, out);
janet_deinit();
return result;
}
janet_deinit();
return 0;
#endif
}
```))
(defn- create-executable
"Links an image with libjanet.a (or .lib) to produce an
executable. Also will try to link native modules into the
final executable as well."
[opts source dest no-core]
# Create executable's janet image
(def cimage_dest (string dest ".c"))
(def no-compile (opts :no-compile))
(rule (if no-compile cimage_dest dest) [source]
(check-cc)
(print "generating executable c source...")
(create-dirs dest)
# Load entry environment and get main function.
(def entry-env (dofile source))
(def main ((entry-env 'main) :value))
(def dep-lflags @[])
(def dep-ldflags @[])
# Create marshalling dictionary
(def mdict1 (invert (env-lookup root-env)))
(def mdict
(if no-core
(let [temp @{}]
(eachp [k v] mdict1
(if (or (cfunction? k) (abstract? k))
(put temp k v)))
temp)
mdict1))
# Load all native modules
(def prefixes @{})
(def static-libs @[])
(loop [[name m] :pairs module/cache
:let [n (m :native)]
:when n
:let [prefix (gensym)]]
(print "found native " n "...")
(put prefixes prefix n)
(array/push static-libs (modpath-to-static n))
(def oldproto (table/getproto m))
(table/setproto m nil)
(loop [[sym value] :pairs (env-lookup m)]
(put mdict value (symbol prefix sym)))
(table/setproto m oldproto))
# Find static modules
(var has-cpp false)
(def declarations @"")
(def lookup-into-invocations @"")
(loop [[prefix name] :pairs prefixes]
(def meta (eval-string (slurp (modpath-to-meta name))))
(if (meta :cpp) (set has-cpp true))
(buffer/push-string lookup-into-invocations
" temptab = janet_table(0);\n"
" temptab->proto = env;\n"
" " (meta :static-entry) "(temptab);\n"
" janet_env_lookup_into(lookup, temptab, \""
prefix
"\", 0);\n\n")
(when-let [lfs (meta :lflags)]
(array/concat dep-lflags lfs))
(when-let [lfs (meta :ldflags)]
(array/concat dep-ldflags lfs))
(buffer/push-string declarations
"extern void "
(meta :static-entry)
"(JanetTable *);\n"))
# Build image
(def image (marshal main mdict))
# Make image byte buffer
(create-buffer-c-impl image cimage_dest "janet_payload_image")
# Append main function
(spit cimage_dest (make-bin-source declarations lookup-into-invocations no-core) :ab)
(def oimage_dest (out-path cimage_dest ".c" ".o"))
# Compile and link final exectable
(unless no-compile
(def ldflags [;dep-ldflags ;(opt opts :ldflags []) ;janet-ldflags])
(def lflags [;static-libs (libjanet) ;dep-lflags ;(opt opts :lflags default-lflags) ;janet-lflags])
(def defines (make-defines (opt opts :defines {})))
(def cc (opt opts :compiler default-compiler))
(def cflags [;(getcflags opts) ;janet-cflags])
(check-cc)
(print "compiling " cimage_dest " to " oimage_dest "...")
(create-dirs oimage_dest)
(if is-win
(shell cc ;defines "/c" ;cflags (string "/Fo" oimage_dest) cimage_dest)
(shell cc "-c" cimage_dest ;defines ;cflags "-o" oimage_dest))
(if has-cpp
(let [linker (opt opts (if is-win :cpp-linker :cpp-compiler) default-cpp-linker)
cppflags [;(getcppflags opts) ;janet-cflags]]
(print "linking " dest "...")
(if is-win
(shell linker ;ldflags (string "/OUT:" dest) oimage_dest ;lflags)
(shell linker ;cppflags ;ldflags `-o` dest oimage_dest ;lflags)))
(let [linker (opt opts (if is-win :linker :compiler) default-linker)]
(print "linking " dest "...")
(create-dirs dest)
(if is-win
(shell linker ;ldflags (string "/OUT:" dest) oimage_dest ;lflags)
(shell linker ;cflags ;ldflags `-o` dest oimage_dest ;lflags)))))))
#
# Installation and Dependencies
#
(var- stored-git-path nil)
(defn- git-path
"Get the location of git such that it can be passed as an argument to os/execute."
"(Some builds/configurations of windows don't like just the string 'git')"
[]
(if stored-git-path (break stored-git-path))
(set stored-git-path
(if is-win
(or (os/getenv "JANET_GIT") (first (string/split "\n" (pslurp "where git"))))
(os/getenv "JANET_GIT" "git"))))
(defn uninstall
"Uninstall bundle named name"
[name]
(def manifest (find-manifest name))
(when-with [f (file/open manifest)]
(def man (parse (:read f :all)))
(each path (get man :paths [])
(print "removing " path)
(rm path))
(print "removing manifest " manifest)
(:close f) # I hate windows
(rm manifest)
(print "Uninstalled.")))
(defn install-git
"Install a bundle from git. If the bundle is already installed, the bundle
is reinistalled (but not rebuilt if artifacts are cached)."
[repotab &opt recurse no-deps]
(def repo (if (string? repotab) repotab (repotab :repo)))
(def tag (unless (string? repotab) (repotab :tag)))
# prevent infinite recursion (very unlikely, but consider
# 'my-package "my-package" in the package listing)
(when (> (or recurse 0) 100)
(error "too many references resolving package url"))
# Handle short names
(unless (string/find ":" repo)
(def pkgs
(try (require "pkgs")
([err f]
(install-git (dyn :pkglist default-pkglist))
(require "pkgs"))))
(def next-repo (get-in pkgs ['packages :value (symbol repo)]))
(unless next-repo
(error (string "package " repo " not found.")))
(unless (or (string? next-repo) (dictionary? next-repo))
(error (string "expected string or table for repository, got " next-repo)))
(break (install-git next-repo (if recurse (inc recurse) 0))))
(def cache (find-cache))
(mkdir cache)
(def id (filepath-replace repo))
(def module-dir (string cache sep id))
(var fresh false)
(if (dyn :offline)
(if (not= :directory (os/stat module-dir :mode))
(error (string "did not find cached repo for dependency " repo))
(set fresh true))
(when (mkdir module-dir)
(set fresh true)
(print "cloning repository " repo " to " module-dir)
(unless (zero? (os/execute [(git-path) "clone" repo module-dir] :p))
(rimraf module-dir)
(error (string "could not clone git dependency " repo)))))
(def olddir (os/cwd))
(try
(with-dyns [:rules @{}
:modpath (abspath (dyn :modpath JANET_MODPATH))
:headerpath (abspath (dyn :headerpath JANET_HEADERPATH))
:libpath (abspath (dyn :libpath JANET_LIBPATH))
:binpath (abspath (dyn :binpath JANET_BINPATH))]
(os/cd module-dir)
(unless fresh
(os/execute [(git-path) "pull" "origin" "master" "--ff-only"] :p))
(when tag
(os/execute [(git-path) "reset" "--hard" tag] :p))
(unless (dyn :offline)
(os/execute [(git-path) "submodule" "update" "--init" "--recursive"] :p))
(import-rules "./project.janet" true)
(unless no-deps (do-rule "install-deps"))
(do-rule "build")
(do-rule "install"))
([err f] (print "Error building git repository dependency: " err) (propagate err f)))
(os/cd olddir))
(defn install-rule
"Add install and uninstall rule for moving file from src into destdir."
[src destdir]
(def parts (peg/match path-splitter src))
(def name (last parts))
(def path (string destdir sep name))
(array/push (dyn :installed-files) path)
(phony "install" []
(mkdir destdir)
(copy src destdir)))
(defn- make-lockfile
[&opt filename]
(default filename "lockfile.jdn")
(def cwd (os/cwd))
(def packages @[])
# Read installed modules from manifests
(def mdir (find-manifest-dir))
(each man (os/dir mdir)
(def package (parse (slurp (string mdir sep man))))
(if (and (dictionary? package) (package :repo) (package :sha))
(array/push packages package)
(print "Cannot add local or malformed package " mdir sep man " to lockfile, skipping...")))
# Put in correct order, such that a package is preceded by all of its dependencies
(def ordered-packages @[])
(def resolved @{})
(while (< (length ordered-packages) (length packages))
(var made-progress false)
(each p packages
(def {:repo r :sha s :dependencies d} p)
(def dep-urls (map |(if (string? $) $ ($ :repo)) d))
(unless (resolved r)
(when (all resolved dep-urls)
(array/push ordered-packages {:repo r :sha s})
(set made-progress true)
(put resolved r true))))
(unless made-progress
(error (string/format "could not resolve package order for: %j"
(filter (complement resolved) (map |($ :repo) packages))))))
# Write to file, manual format for better diffs.
(with [f (file/open filename :w)]
(with-dyns [:out f]
(prin "@[")
(eachk i ordered-packages
(unless (zero? i)
(prin "\n "))
(prinf "%j" (ordered-packages i)))
(print "]"))))
(defn- load-lockfile
[&opt filename]
(default filename "lockfile.jdn")
(def lockarray (parse (slurp filename)))
(each {:repo url :sha sha} lockarray
(install-git {:repo url :tag sha} nil true)))
#
# Declaring Artifacts - used in project.janet, targets specifically
# tailored for janet.
#
(defn declare-native
"Declare a native module. This is a shared library that can be loaded
dynamically by a janet runtime. This also builds a static libary that
can be used to bundle janet code and native into a single executable."
[&keys opts]
(def sources (opts :source))
(def name (opts :name))
(def path (dyn :modpath JANET_MODPATH))
# Make dynamic module
(def lname (string "build" sep name modext))
# Get objects to build with
(var has-cpp false)
(def objects
(seq [src :in sources]
(cond
(string/has-suffix? ".cpp" src)
(let [op (out-path src ".cpp" objext)]
(compile-cpp opts src op)
(set has-cpp true)
op)
(string/has-suffix? ".c" src)
(let [op (out-path src ".c" objext)]
(compile-c opts src op)
op)
(errorf "unknown source file type: %s, expected .c or .cpp" src))))
(when-let [embedded (opts :embedded)]
(loop [src :in embedded]
(def c-src (out-path src ".janet" ".janet.c"))
(def o-src (out-path src ".janet" (if is-win ".janet.obj" ".janet.o")))
(array/push objects o-src)
(create-buffer-c src c-src (embed-name src))
(compile-c opts c-src o-src)))
((if has-cpp link-cpp link-c) opts lname ;objects)
(add-dep "build" lname)
(install-rule lname path)
# Add meta file
(def metaname (modpath-to-meta lname))
(def ename (entry-name name))
(rule metaname []
(print "generating meta file " metaname "...")
(spit metaname (string/format
"# Metadata for static library %s\n\n%.20p"