Merge branch 'development' into pixel_with_deftype_defgeneric

.github/workflows/build.yml

@@ -0,0 +1,34 @@
+name: Build and test on Ubuntu
+
+on: [push, pull_request]
+
+jobs:
+  build-linux:
+    runs-on: ubuntu-latest
+
+    steps:
+    - name: Checkout code
+      uses: actions/checkout@v2
+      with:
+        submodules: true
+        fetch-depth: 0
+
+    - name: Update repos
+      run: sudo apt-get update -y
+
+    - name: Set up prerequisites
+      run: sudo apt-get install -y sbcl
+
+    - name: Set up Github environment
+      id: setup_environment
+      run: |
+        SHORT_SHA=$(git rev-parse --short HEAD)
+        DATE=`date +"%Y-%m-%d"`
+        echo "TRE_DEVELOPMENT=1" >> $GITHUB_ENV
+        echo "TRE_DEBUG=1" >> $GITHUB_ENV
+
+    - name: Build
+      run: ./make.sh boot
+
+    - name: Install
+      run: sudo ./make.sh install

NEWS → Changelog.md

@@ -1,4 +1,33 @@
-Changes relative to tre-0.20:
+# Changelog
+
+All notable changes to this project will be documented in
+this file.
+
+The format is based on
+[Keep a Changelog](https://keepachangelog.com/en/1.1.0/),
+and this project adheres to
+[Semantic Versioning](https://semver.org/spec/v2.0.0.html).
+
+[Lisp manual](src/bin/lisp/doc/manual.md)
+
+
+## [v0.0.21]
+
+### Fixed
+
+  * Fixed first time install.
+  * Examples: Updated docker-compose configurations to version 3.
+  * JS/PHP: SLOT-VALUE works correctly with objects of both worlds.
+
+### Changed
+
+  * PHP: JSON-DECODE: Make stdClass objects, not arrays.
+  * HTTP-FUNCALL: Use JSON instead of XML weirdness.
+
+
+## Former NEWS entries
+
+Changes relative to tre-0.19:
   * CL: *ARGV* has the command-line arguments.
   * DEFSTRUCT: Generated macro DEF-name does not require the first argument
     to be of the structs name any more.
@@ -61,8 +90,6 @@ Changes relative to tre-0.20:
   * Set *ASSERT?* to T by default.
   * Moved external modules back in.  Their separate
     repositories on Github will be removed.
-
-Changes of tre-0.20 relative to tre-0.19:
   * Works with PHP-8.
   * SUBSEQ (JS/PHP): Allow strings of any length.  (Ugly
     hack from the old days.)

environment/env-vars.lisp

@@ -1,2 +1,2 @@
-(var *tre-path* (| (getenv "TRE_PATH") "/usr/local/lib/tre/"))
+(var *tre-path* (| (getenv "TRE_PATH") "./"))
 (var *modules-path* (+ *tre-path* "/modules/"))

environment/math/sqrt.lisp

@@ -1,5 +1,3 @@
-; TODO: Move to math/?
-
 (fn close-enough? (x y precision)
   (> precision (abs (- x y))))
 

environment/stage1/do.lisp

@@ -1,17 +1,13 @@
 (defmacro do (vars (test &rest result) &body body)
   (let tag (gensym)
     `(block nil
-       (let* ,(mapcar [`(,_. ,._.)]
-                      vars)
+       (let* ,(mapcar [`(,_. ,._.)] vars)
          (tagbody
            ,tag
            (? ,test
-              (return (progn
-                        ,@result)))
+              (return (progn ,@result)))
            ,@body
-           ,@(mapcar [& .._.
-                        `(setq ,_. ,.._.)]
-                      vars)
+           ,@(mapcan [& .._.  `((setq ,_. ,.._.))] vars)
            (go ,tag))))))
 
 (defmacro while (test result &body body)

environment/stage1/list.lisp

@@ -144,9 +144,6 @@
       (*> #'mapcar func (mapcar #'array-list lists))
     (*> #'mapcar func lists)))
 
-(fn mapcan (func &rest lists)
-  (*> #'nconc (*> #'mapcar func lists)))
-
 (fn member-if (pred &rest lsts)
   (dolist (i lsts)
     (do ((j i .j))

environment/stage1/main.lisp

@@ -12,7 +12,7 @@
 (env-load "stage1/prog1.lisp")
 (env-load "stage1/let.lisp")
 (env-load "stage1/queue.lisp")
-(env-load "stage1/mapcar.lisp")
+(env-load "stage1/map.lisp")
 (env-load "stage1/do.lisp")
 (env-load "stage1/dolist.lisp")
 (env-load "stage1/anaphoric.lisp")

environment/stage1/map.lisp

@@ -0,0 +1,22 @@
+(fn %map-args (lists)
+  (block nil
+    (let* ((i  lists)
+           (nl (make-queue)))
+      (tagbody
+        start
+        (? (not i)
+           (return (queue-list nl)))
+        (? (not (car i))
+           (return nil))
+        (enqueue nl (car (car i)))
+        (rplaca i (cdr (car i)))
+        (setq i (cdr i))
+        (go start)))))
+
+(fn mapcar (func &rest lists)
+  (let-if args (%map-args lists)
+    (. (*> func args)
+       (*> #'mapcar func lists))))
+
+(fn mapcan (func &rest lists)
+  (*> #'append (*> #'mapcar func lists)))

environment/stage2/!aadjoin!.lisp

@@ -0,0 +1,6 @@
+(defmacro !aadjoin! (key init update al &key (test #'equal))
+  (with-gensym g-key
+    `(with (,g-key ,key)
+       (!? (assoc ,g-key ,al :test ,test)
+           ,update
+           (acons! ,g-key ,init ,al)))))

environment/stage2/dot-expand.lisp

@@ -1,3 +1,6 @@
+; TODO: Holy Moly!  Perhaps replace by this one:
+; https://github.com/SvenMichaelKlose/tunix/blob/main/src/bin/lisp/dotexpand.lsp
+
 (fn dot-expand-head-length (x &optional (num 0))
   (? (eql #\. x.)
      (dot-expand-head-length .x (++ num))

environment/stage2/main.lisp

@@ -13,6 +13,7 @@
 (env-load "stage2/sequence.lisp")
 (env-load "stage2/dot-expand.lisp")
 (env-load "stage2/assoc.lisp")
+(env-load "stage2/!aadjoin!.lisp")
 (env-load "stage2/in.lisp")
 (env-load "stage2/struct.lisp")
 (env-load "stage2/sort.lisp")

environment/stage4/main.lisp

@@ -11,6 +11,7 @@
 (env-load "stage4/hcache.lisp")
 (env-load "stage4/maptree.lisp")
 (env-load "stage4/pad.lisp")
+(env-load "stage4/reduce.lisp")
 (env-load "stage4/replace.lisp")
 (env-load "stage4/search.lisp")
 (env-load "stage4/trim.lisp")

environment/stage4/reduce.lisp

@@ -0,0 +1,9 @@
+(fn reduce (f l &optional initial-value)
+  "Reduce list L using function F, optionally starting with INITIAL-VALUE."
+  (? l
+     (with (result (? initial-value
+                      (funcall f initial-value l.)
+                      l.))
+      (@ (i .l result)
+        (= result (funcall f result i))))
+     initial-value))

environment/transpiler/targets/common-lisp/core/list.lisp

@@ -1,5 +1,8 @@
 (defbuiltin filter (fun x)
   (CL:MAPCAR fun x))
 
+(defbuiltin mapcan (fun x)
+  (CL:MAPCAN fun x))
+
 (defbuiltin append (&rest x)
   (*> #'CL:NCONC (CL:MAPCAR #'CL:COPY-LIST x)))

environment/transpiler/targets/common-lisp/imports.lisp

@@ -12,7 +12,7 @@
     '(apply
       cons car cdr rplaca rplacd
       length make-string
-      mod sqrt sin cos tan asin acos atan exp round floor
+      mod sqrt sin cos tan asin acos atan exp round floor ceiling
       aref char-code
       make-package package-name find-package
       print))
@@ -47,6 +47,7 @@
       (character==  CHAR=)
       (character<   CHAR<)
       (character>   CHAR>)
+      (log          LOG)
       (pow          EXPT)))
 
 (defconstant +cl-special-forms+

environment/transpiler/targets/javascript/codegen.lisp

@@ -190,6 +190,16 @@
                          (convert-identifier (make-symbol (symbol-name y) "TRE"))
                        y)))
 
+(def-js-codegen %=-slot-value (v x y)
+  `(%native ,x "." ,(?
+                       (%string? y)
+                         .y.
+                       (symbol? y)
+                         (convert-identifier (make-symbol (symbol-name y) "TRE"))
+                       y)
+            " = "
+            ,v))
+
 (def-js-codegen %try () ; TODO: Check if stale.
   '(%native "try {"))
 

environment/transpiler/targets/javascript/core.lisp

@@ -44,6 +44,7 @@
                               "../../../environment/make-array.lisp"
                               "sequence.lisp"
                               "../../../environment/list-string.lisp"
+                              "slot-value.lisp"
                               "string.lisp"
                               "hash.lisp"
                               "base64.lisp"

environment/transpiler/targets/javascript/core/env.lisp

@@ -1,2 +1,3 @@
 (fn getenv (x)
-  (%aref process.env x))
+  (? (defined? process)
+     (%aref process.env x)))

environment/transpiler/targets/javascript/core/slot-value.lisp

@@ -0,0 +1,5 @@
+(fn slot-value (x n)
+  (%aref x n))
+
+(fn =-slot-value (v x n)
+  (=-%aref v x n))