Small snippets of Guile Scheme

(define foo 'bar)
(format #t "foo: ~a\n" foo)
;; or
(display 'foo)(display foo)(newline)

(define-syntax-rule (log-exprs exp ...)
  (begin (format #t "~a: ~S\n" (quote exp) exp) ...))

(define foo 'bar)
(log-exprs foo)
;; => foo: bar
(define bar 'baz)
(log-exprs foo bar (list "hello"))
;; foo: bar
;; bar: baz
;; (list hello): ("hello")

--- 
 doe: "a deer, a female deer"
 ray: "a drop of golden sun"
 pi: 3.14159
 xmas: true
 french-hens: 3
 calling-birds: 
   - huey
   - dewey
   - louie
   - fred
 xmas-fifth-day: 
   calling-birds: four
   french-hens: 3
   golden-rings: 5
   partridges: 
     count: 1
     location: "a pear tree"
   turtle-doves: two

(import (yaml) (ice-9 match))
(define demo (read-yaml-file "demo1.yml"))
(let match-demo ((demo demo))
  (match demo
    ((("partridges" . b) c ...) b)
    (else (if (pair? demo)
              (or (match-demo (cdr demo)) (match-demo (car demo)))
              #f))))
;; => (("count" . "1") ("location" . "a pear tree"))

(define xydata '((1 . 1)(1 . 2)(1 . 3)(2 . 1)(2 . 2)))

(define (assoc-increment! key alist)
  "Increment the value of the key in the alist, set it to 1 if it does not exist."
  (define res (assoc key alist))
  (assoc-set! alist key (or (and=> (and=> res cdr) 1+) 1)))

(fold assoc-increment! '() (map car xydata))
;; => ((2 . 2) (1 . 3))

(apply map list '((1 2) (1 3)))

(map list '(1 2) (1 3))

(list (list 1 1) (list 2 3))

'((1 1) (2 3))

#!/usr/bin/env bash
exec -a "$0" guile -L $(dirname $(realpath "$0")) \
                   -C $(dirname $(realpath "$0")) \
                   -e '(hello-world)' -c '' "${@}"
# terminate the inline comment "started" with the #! line: !#
(define-module (hello-world)
  #:export (main))

(define (main args)
  (format #t "Hello ~a\n" (cdr args)))

chmod +x hello-world.scm
./hello-world.scm World
# => Hello (World)

# exclude single-time auto-compilation
./hello-world.scm World >/dev/null
{ time for i in {1..100}; do 
./hello-world.scm World > /dev/null
done } 2>&1

#!/usr/bin/env bash
# -*- scheme -*-
# set Guile if unset
if [ -z ${GUILE+x} ]; then
        GUILE=guile
fi

exec -a "$0" "${GUILE}" -L $(dirname $(realpath "$0")) -e '(scriptname)' -c '' "$@"
; !#

(define-module (scriptname) ;; same as filename!
   #:export (main))

(define (main args)
   (display args)
   (newline))

time for i in {1..100}; do scriptname.scm >/dev/null ; done
real    0m3,889s
user    0m3,172s
sys     0m1,508s

(define (hello typed-world) (string? string?)
  typed-world)

(import (srfi :11 let-values))
(define-syntax-rule (define-typed (procname args ...) (ret? types ...) body ...)
  (begin
    (define* (procname args ...)
      ;; create a sub-procedure to run after typecheck
      (define (helper)
        body ...)
      ;; use a typecheck prefix for the arguments   
      (map (λ (type? argument)
             (let ((is-keyword? (and (keyword? type?)
                                     (keyword? argument))))
               (when (and is-keyword? (not (equal? type? argument)))
                 (error "Keywords in arguments and types are not equal ~a ~a"
                   type? argument))
               (unless (or is-keyword? (type? argument))
                 (error "type error ~a ~a" type? argument))))
           (list types ...) (list args ...))
      ;; get the result
      (let-values ((res (helper)))
        ;; typecheck the result
        (unless (apply ret? res)
          (error "type error: return value ~a does not match ~a"
                 res ret?))
        ;; return the result
        (apply values res)))
    (unless (equal? (length (quote (args ...))) (length (quote (types ...))))
      (error "argument error: argument list ~a and type list ~a have different size"
        (quote (args ...)) (quote (types ...))))
    ;; add procedure properties via an inner procedure
    (let ((helper (lambda* (args ...) body ...)))
      (set-procedure-properties! procname (procedure-properties helper))
      ;; record the types
      (set-procedure-property! procname 'return-type ret?)
      (set-procedure-property! procname 'argument-types (list types ...))
      ;; preserve the name
      (set-procedure-property! procname 'name 'procname))))

(define-typed (hello typed-world) (string? string?)
  typed-world)
(hello "typed")
;; => "typed"
(hello 1337)
;; => type error ~a ~a #<procedure string? (_)> 1337
(define-typed (hello typed-world) (string? string?)
  "typed" ;; docstring
  #((props)) ;; more properties
  1337) ;; wrong return type
(procedure-documentation hello)
;; => "typed"
(procedure-properties hello)
;; =>((argument-types #<procedure string? (_)>)
;;    (return-type . #<procedure string? (_)>) 
;;    (name . hello) (documentation . "typed") (props))
(hello "typed")
;; type error: return value ~a does not match ~a (1337) #<procedure string? (_)>

(define-typed (multiple-values num) ((λ(a b) (> a b)) number?)
  (values (* 2 (abs num)) num))
(multiple-values -3)
;; => 6
;; => -3
(define-typed (hello #:key typed-world) (string? #:key string?) "typed" #((props)) typed-world)
(hello #:typed-world "foo")
;; => "foo"
;; unused keyword arguments are always boolean #f as input
(hello)
;; => type error ~a ~a #<procedure string? (_)> #f
;; typing optional keyword arguments
(define (optional-string? x) (or (not x) (string? x)))
(define-typed (hello #:key typed-world) (string? #:key optional-string?)
  (or typed-world "world"))
(hello)
;; => "world"
(hello #:typed-world "typed")
;; => "typed"
(hello #:typed-world #t)
;; => type error ~a ~a #<procedure optional-string? (x)> #t
;; optional arguments
(define-typed (hello #:optional typed-world) (string? #:optional optional-string?)
  (or typed-world "world"))
(hello)
;; => "world"
(hello "typed")
;; => "typed"
(hello #t)
;; => type error ~a ~a #<procedure optional-string? (x)> #t