(define-module (ruther packages embedded)
  #:use-module (guix utils)
  #:use-module (guix gexp)
  #:use-module (guix memoization)
  #:use-module (guix packages)
  #:use-module (guix download)
  #:use-module (guix git-download)
  #:use-module (guix build-system trivial)
  #:use-module (gnu packages)
  #:use-module (gnu packages embedded)
  #:use-module (gnu packages flex)
  #:use-module (gnu packages cross-base)
  #:use-module (gnu packages texinfo)
  #:use-module (guix build-system gnu)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix build utils)
  #:use-module (gnu packages gcc)

  #:export (make-gcc-arm-none-eabi-12.3.rel1
            make-newlib-nano-arm-none-eabi-12.3.rel1
            make-newlib-arm-none-eabi-12.3.rel1
            arm-none-eabi-nano-toolchain-12.3.rel1
            arm-none-eabi-toolchain-12.3.rel1))

(define make-newlib-arm-none-eabi
  (mlambda ()
    (package
      (name "newlib")
      (version "2.4.0")
      (source (origin
                (method url-fetch)
                (uri (string-append "ftp://sourceware.org/pub/newlib/newlib-"
                                    version ".tar.gz"))
                (sha256
                 (base32
                  "01i7qllwicf05vsvh39qj7qp5fdifpvvky0x95hjq39mbqiksnsl"))))
      (build-system gnu-build-system)
      (arguments
       `(#:out-of-source? #t
         ;; The configure flags are identical to the flags used by the "GCC ARM
         ;; embedded" project.
         #:configure-flags '("--target=arm-none-eabi"
                             "--enable-newlib-io-long-long"
                             "--enable-newlib-register-fini"
                             "--disable-newlib-supplied-syscalls"
                             "--disable-nls")
         #:phases
         (modify-phases %standard-phases
           (add-after 'unpack 'fix-references-to-/bin/sh
             (lambda _
               (substitute* (find-files "libgloss" "^Makefile\\.in$")
                 (("/bin/sh") (which "sh")))
               #t)))))
      (native-inputs
       `(("xbinutils" ,(cross-binutils "arm-none-eabi"))
         ("xgcc" ,(make-gcc-arm-none-eabi-4.9))
         ("texinfo" ,texinfo)))
      (home-page "https://www.sourceware.org/newlib/")
      (synopsis "C library for use on embedded systems")
      (description "Newlib is a C library intended for use on embedded
systems.  It is a conglomeration of several library parts that are easily
usable on embedded products.")
      (license (license:non-copyleft
                "https://www.sourceware.org/newlib/COPYING.NEWLIB")))))

(define make-newlib-nano-arm-none-eabi
  (mlambda ()
    (let ((base (make-newlib-arm-none-eabi)))
      (package
        (inherit base)
        (name "newlib-nano")
        (arguments
         (substitute-keyword-arguments (package-arguments base)
           ;; The configure flags are identical to the flags used by the "GCC
           ;; ARM embedded" project.  They optimize newlib for use on small
           ;; embedded systems with limited memory.
           ((#:configure-flags _)
            ''("--target=arm-none-eabi"
               "--enable-multilib"
               "--disable-newlib-supplied-syscalls"
               "--enable-newlib-reent-small"
               "--disable-newlib-fvwrite-in-streamio"
               "--disable-newlib-fseek-optimization"
               "--disable-newlib-wide-orient"
               "--enable-newlib-nano-malloc"
               "--disable-newlib-unbuf-stream-opt"
               "--enable-lite-exit"
               "--enable-newlib-global-atexit"
               "--enable-newlib-nano-formatted-io"
               "--disable-nls"))
           ((#:phases phases)
            `(modify-phases ,phases
               ;; XXX: Most arm toolchains offer both *.a and *_nano.a as
               ;; newlib and newlib-nano respectively.  The headers are
               ;; usually arm-none-eabi/include/newlib.h for newlib and
               ;; arm-none-eabi/include/newlib-nano/newlib.h for newlib-nano.
               ;; We have two different toolchain packages for each which
               ;; works but is a little strange.
               (add-after 'install 'hardlink-newlib
                 (lambda* (#:key outputs #:allow-other-keys)
                   (let ((out (assoc-ref outputs "out")))
                     ;; The nano.specs file says that newlib-nano files should
                     ;; end in "_nano.a" instead of just ".a".  Note that this
                     ;; applies to all the multilib folders too.
                     (for-each
                      (lambda (file)
                        (link file
                              (string-append
                               ;; Strip ".a" off the end
                               (substring file 0 (- (string-length file) 2))
                               ;; Add "_nano.a" onto the end
                               "_nano.a")))
                      (find-files
                       out
                       "^(libc.a|libg.a|librdimon.a|libstdc\\+\\+.a|\
libsupc\\+\\+.a)$"))

                     ;; newlib.h is usually in this location instead so both
                     ;; newlib and newlib-nano can be in the toolchain at the
                     ;; same time
                     (mkdir (string-append
                             out "/arm-none-eabi/include/newlib-nano"))
                     (symlink
                      "../newlib.h"
                      (string-append
                       out
                       "/arm-none-eabi/include/newlib-nano/newlib.h")))))))))
        (synopsis "Newlib variant for small systems with limited memory")))))

(define make-base-newlib-arm-none-eabi-7-2018-q2-update
  ;; This is the same commit as used for the 7-2018-q2-update release
  ;; according to the release.txt.
  (mlambda (base)
    (let ((commit "3ccfb407af410ba7e54ea0da11ae1e40b554a6f4")
          (revision "0"))
      (package
        (inherit base)
        (version (git-version "3.0.0" revision commit))
        (source
         (origin
           (method git-fetch)
           (uri (git-reference
                 (url "http://sourceware.org/git/newlib-cygwin.git")
                 (commit commit)))
           (file-name (git-file-name "newlib" commit))
           (sha256
            (base32
             "1dq23fqrk75g1a4v7569fvnnw5q440zawbxi3w0g05n8jlqsmvcy"))))
        (arguments
         (substitute-keyword-arguments (package-arguments base)
           ;; The configure flags are identical to the flags used by the "GCC
           ;; ARM embedded" project.
           ((#:configure-flags flags)
            `(cons* "--enable-newlib-io-c99-formats"
                    "--enable-newlib-retargetable-locking"
                    "--with-headers=yes"
                    ,flags))))
        (native-inputs
         `(("xbinutils" ,(cross-binutils "arm-none-eabi"))
           ("xgcc" ,(make-gcc-arm-none-eabi-7-2018-q2-update))
           ("texinfo" ,texinfo)))))))

(define-public make-gcc-arm-none-eabi-12.3.rel1
  (mlambda ()
    (let ((base (make-gcc-arm-none-eabi-7-2018-q2-update))
          (xgcc-base (cross-gcc "arm-none-eabi"
                                #:xgcc gcc-12
                                #:xbinutils (cross-binutils "arm-none-eabi"))))
      (package
        (inherit base)
        (version "12.3.rel1")
        (source
         (origin
           (inherit (package-source xgcc-base))
           (method git-fetch)
           (uri (git-reference
                 (url "git://gcc.gnu.org/git/gcc.git")
                 (commit "0f54a73b998b72f7c8452a63730ec3b16fc47854")))
           (sha256
            (base32 "0r6q0m3d8g3k3rkmnqjw8aw5fcnsrmywf4ispdkxmk1al3whk1vk"))))
        (arguments
         (substitute-keyword-arguments (package-arguments base)
           ((#:phases phases)
            #~(modify-phases #$phases
                (replace 'expand-version-string
                  (lambda _
                    (make-file-writable "gcc/DEV-PHASE")
                    (with-output-to-file "gcc/DEV-PHASE"
                      (lambda ()
                        (display "12.3.rel1")))))))
           ((#:configure-flags flags)
            #~(cons* "--with-multilib-list=aprofile,rmprofile"
                     "--with-headers=yes"
                     "--enable-checking=release"
                     "--with-gnu-as"
                     "--with-gnu-ld"
                     (filter
                      (lambda (flag)
                        (not (member flag
                                     '("--with-multilib-list=rmprofile"
                                       "--enable-plugins"
                                       "--disable-libffi"))))
                      #$flags)))))))))

(define make-base-newlib-arm-none-eabi-12.3.rel1
  (mlambda (original-base)
    (let ((base (make-base-newlib-arm-none-eabi-7-2018-q2-update original-base))
          (commit "4c7d0dfec5793cbf5cf3930b91f930479126d8ce")
          (revision "0"))
      (package
        (inherit base)
        (version (git-version "4.3.0" revision commit))
        (source
         (origin
           (method git-fetch)
           (uri (git-reference
                 (url "http://sourceware.org/git/newlib-cygwin.git")
                 (commit commit)))
           (sha256
            (base32
             "0drs9v8avh4y2h5bs0ixjn9x662jzkkikx8z034wgl41dxmn6786"))))
        (arguments (substitute-keyword-arguments (package-arguments base)
                     ((#:configure-flags flags)
                      #~(cons* "--enable-newlib-mb"
                               "--enable-newlib-reent-check-verify"
                               "--enable-newlib-register-fini"
                               #$flags))))))))

(define make-newlib-arm-none-eabi-12.3.rel1
  (mlambda ()
    (make-base-newlib-arm-none-eabi-12.3.rel1 (make-newlib-arm-none-eabi))))

(define make-newlib-nano-arm-none-eabi-12.3.rel1
  (mlambda ()
    (make-base-newlib-arm-none-eabi-12.3.rel1 (make-newlib-nano-arm-none-eabi))))

(define make-libstdc++-arm-none-eabi
  (mlambda (xgcc newlib)
    (let* ((libstdc++ (make-libstdc++ xgcc))
           (src (package-source libstdc++)))
      (package
        (inherit libstdc++)
        (source
         (origin
           (inherit src)
           (patches (append
                     ; libstdc++ cannot be linked with since the configure phase
                     ; cannot detect properly the presence of getentropy function.
                     ; The function is inside of a header, but it's not present in the resulting
                     ; newlib. configure will conclude getentropy is present,
                     ; random will use getentropy, and any linking with random will fail.
                     (if (version>=? (package-version xgcc) "12.0")
                         (list
                          (local-file "patches/newlib-getentropy.patch"))
                         '())
                     (origin-patches src)))))
        (name "libstdc++-arm-none-eabi")
        (arguments
         (substitute-keyword-arguments (package-arguments libstdc++)
           ((#:make-flags flags #f)
            #~(cons* "CFLAGS=-g -O2 -fdata-sections -ffunction-sections"
                     "CXXFLAGS=-g -O2 -fdata-sections -ffunction-sections"
                     (or #$flags '())))
           ((#:configure-flags _)
            ``(; This is more of a hack. This option doesn't really seem
               ; to change what subdir is used eventually, but without it there is
               ; error: Link tests are not allowed after GCC_NO_EXECUTABLES with
               ; The 12.3 toolchain
               "--with-target-subdir=\".\""
               "--target=arm-none-eabi"
               "--host=arm-none-eabi"
               "--disable-libstdcxx-pch"
               "--enable-multilib"
               "--with-multilib-list=armv6-m,armv7-m,armv7e-m"
               "--disable-shared"
               "--disable-tls"
               "--disable-plugin"
               "--with-newlib"
               ,(string-append "--libdir="
                               (assoc-ref %outputs "out")
                               "/arm-none-eabi/lib")
               ,(string-append "--with-gxx-include-dir="
                               (assoc-ref %outputs "out")
                               "/arm-none-eabi/include/c++")))
           ((#:strip-directories _ #f)
            ''("arm-none-eabi/lib"))))
        (native-inputs
         `(("newlib" ,newlib)
           ("xgcc" ,xgcc)
           ,@(package-native-inputs libstdc++)))))))

(define make-libstdc++-nano-arm-none-eabi
  (mlambda (xgcc newlib-nano)
    (let ((base (make-libstdc++-arm-none-eabi xgcc newlib-nano)))
      (package
        (inherit base)
        (name "libstdc++-nano-arm-none-eabi")
        (arguments (substitute-keyword-arguments (package-arguments base)
                     ((#:make-flags flags)
                      #~(map (lambda (flag)
                               (if (or (string-prefix? "CFLAGS=" flag)
                                       (string-prefix? "CXXFLAGS=" flag))
                                   (string-append flag " -fno-exceptions")
                                   flag))
                             #$flags))
                     ((#:phases phases)
                      #~(modify-phases #$phases
                          (add-after 'install 'hardlink-libstdc++
                            ;; XXX: Most arm toolchains offer both *.a and *_nano.a as
                            ;; newlib and newlib-nano respectively.  The headers are
                            ;; usually arm-none-eabi/include/newlib.h for newlib and
                            ;; arm-none-eabi/include/newlib-nano/newlib.h for newlib-nano.
                            ;; We have two different toolchain packages for each which
                            ;; works but is a little strange.
                            (lambda* (#:key outputs #:allow-other-keys)
                              (let ((out (assoc-ref outputs "out")))
                                ;; The nano.specs file says that newlib-nano files should
                                ;; end in "_nano.a" instead of just ".a".  Note that this
                                ;; applies to all the multilib folders too.
                                (for-each
                                 (lambda (file)
                                   (link file
                                         (string-append
                                          ;; Strip ".a" off the end
                                          (substring file 0 (- (string-length file) 2))
                                          ;; Add "_nano.a" onto the end
                                          "_nano.a")))
                                 (find-files
                                  out "^(libstdc\\+\\+.a|libsupc\\+\\+.a)$")))))))))))))

(define make-arm-none-eabi-toolchain
  (mlambda (xgcc newlib)
    "Produce a cross-compiler toolchain package with the compiler XGCC and the
C library variant NEWLIB."
    (let* ((nano? (string=? (package-name newlib)
                            "newlib-nano"))
           (newlib-with-xgcc
            (package
              (inherit newlib)
              (native-inputs
               (alist-replace "xgcc" (list xgcc)
                              (package-native-inputs newlib)))))
           (libstdc++
            (if nano?
                (make-libstdc++-nano-arm-none-eabi xgcc newlib-with-xgcc)
                (make-libstdc++-arm-none-eabi xgcc newlib-with-xgcc))))
      (package
        (name (string-append "arm-none-eabi"
                             (if nano? "-nano" "")
                             "-toolchain"))
        (version (package-version xgcc))
        (source #f)
        (build-system trivial-build-system)
        (arguments
         '(#:modules ((guix build union))
           #:builder
           (begin
             (use-modules (ice-9 match)
                          (guix build union))
             (match %build-inputs
               (((names . directories) ...)
                (union-build (assoc-ref %outputs "out")
                             directories))))))
        (propagated-inputs
         `(("binutils" ,(cross-binutils "arm-none-eabi"))
           ("libstdc++" ,libstdc++)
           ("gcc" ,xgcc)
           ("newlib" ,newlib-with-xgcc)))
        (synopsis "Complete GCC tool chain for ARM bare metal development")
        (description "This package provides a complete GCC tool chain for ARM
bare metal development.  This includes the GCC arm-none-eabi cross compiler
and newlib (or newlib-nano) as the C library.  The supported programming
languages are C and C++.")
        (home-page (package-home-page xgcc))
        (license (package-license xgcc))))))

(define make-arm-none-eabi-toolchain-12.3.rel1
  (mlambda ()
    (make-arm-none-eabi-toolchain
     (make-gcc-arm-none-eabi-12.3.rel1)
     (make-newlib-arm-none-eabi-12.3.rel1))))

(define make-arm-none-eabi-nano-toolchain-12.3.rel1
  (mlambda ()
    (make-arm-none-eabi-toolchain
     (make-gcc-arm-none-eabi-12.3.rel1)
     (make-newlib-nano-arm-none-eabi-12.3.rel1))))

(define arm-none-eabi-toolchain-12.3.rel1
  (make-arm-none-eabi-toolchain-12.3.rel1))
(define arm-none-eabi-nano-toolchain-12.3.rel1
  (make-arm-none-eabi-nano-toolchain-12.3.rel1))