guile.org

Hacking Guile Scheme

(info “(guile) Top”)

(info “(guile) Guile and Scheme”)

Guile Scheme is:

• R5RS
• module system
• POSIX system calls
• network
• threads
• dynamic linking
• ffi
• string processing
• some support of R6RS
• SRFI

总而言之，Guile 是一个 R5RS 实现，外加很多扩展。

(info “(guile) Supporting Multiple Languages”) Emacs Lisp? what? how?

(info “(guile) Hello Guile!”)

(+ 1 2 3)

(define (factorial n)
  (if (zero? n)
      1
      (* n (factorial (- n 1)))))

(factorial 3)

;; POSIX
(getpwnam "root")

#!/usr/local/bin/guile -s
!#
(display "Hello, World!")
(newline)

/tmp/helloworld.scm

(guile) Linking Guile into Programs

#include <stdlib.h>
#include <libguile.h>

static SCM
my_hostname (void)
{
  char *s = getenv ("HOSTNAME");
  if (s == NULL)
    return SCM_BOOL_F;
  else
    return scm_from_locale_string (s);
}

static void
inner_main (void *data, int argc, char **argv)
{
  scm_c_define_gsubr ("my-hostname", 0, 0, 0, my_hostname);
  scm_shell (argc, argv);
}

int
main (int argc, char **argv)
{
  scm_boot_guile (argc, argv, inner_main, 0);
  return 0; /* never reached */
}

cc -o simple-guile simple-guile.c `pkg-config --cflags --libs guile-2.2`
HOSTNAME=HELLOHOST ./simple-guile -c '(display (my-hostname))'

(guile) Writing Guile Extensions

#include <math.h>
#include <libguile.h>

SCM
j0_wrapper (SCM x)
{
  return scm_from_double (j0 (scm_to_double (x)));
}

void
init_bessel()
{
  scm_c_define_gsubr ("j0", 1, 0, 0, j0_wrapper);
}

cc -shared -o libguile-bessel.so -fPIC bessel.c `pkg-config --cflags --libs guile-2.2`

what is “object library”? what is “shared library”?

(load-extension "libguile-bessel" "init_bessel")
(j0 2)

(guile) Using the Guile Module System

using module

(use-modules (ice-9 popen))
(use-modules (ice-9 rdelim))
(define p (open-input-pipe "ls -l"))
(read-line p)

(guile) Writing new Modules

the default load-path

%load-path

foo is the namespace

(define-module (foo bar)
  #:export (frob))

(define (frob x) (* 2 x))

(add-to-load-path "/tmp/guile")
(use-modules (foo bar))
(frob 12)

(info “(guile) Hello Scheme!”)

(guile) About Data

Define variable

(define x 1)

(define organization "Free Software Foundation")

(list x organization)

Change variable’s value

(set! x 42)

x

(guile) About Procedures

(use-modules (ice-9 rdelim))

(define (cat filename)
  "Display the contents of FILENAME."
  (let ((input (open-input-file filename)))
    (define (print-line)
      (let ((line (read-line input)))
        (unless (eof-object? line)
          (display line)
          (newline)
          (print-line))))
    (print-line)
    (close-input-port input)))

(string-append "hello" " world")

(string-length "hello")

((lambda (a b) (+ a b)) 1 2)

(define foo (lambda (a b) (+ a b)))
(define (bar a b) (+ a b))

(list (foo 1 2) (bar 1 2))

variable number of arguments

((lambda (n . ns) (list n ns)) 1 2 3)

((lambda args args) 1 2 3)

(guile) About Expressions

“properly tail recursive”

guile -c '(define (foo n) (display n) (newline) (foo (1+ n))) (foo)'

(define (my-last lst) 
  (if (null? (cdr lst))
      (car lst)
      (my-last (cdr lst))))

(my-last '(1 2 (3 (4 (5 (6 7))))))

(let ((a 1) 
      (b 2)
      (c 3))
  (set! c 100)
  (list a b c))

(let* ((a 1) (b 2) (c (+ a b)))
  c)

(let ((length
          (lambda (lst)
            (if (null? lst)
                0
                (1+ (length (cdr lst)))))))
  (length '(a b c d e f)))

(letrec ((even? (lambda (n)
                  (if (zero? n)
                      #t
                      (odd? (- n 1)))))
         (odd? (lambda (n)
                 (if (zero? n)
                     #f
                     (even? (- n 1))))))
  (even? 88))

(begin 1 2 3)

(if #f 2 3)

(cond (#f 2) (#t 3))

(guile) About Closure

(define foo (let ((n 0)) (lambda () (set! n (1+ n)) n)))
(list (foo) (foo) (foo))

(guile) Programming in Scheme

(guile) Guile Scheme

what is meaning of “POSIX-compliant network programming”?

(guile) Command-line Options

(display (command-line))

guile /tmp/cli.scm foo bar baz

guile -c '(display (command-line))' foo bar baz

(guile) Guile Scripting

#!/usr/local/bin/guile -s
!#
(display "Hello 世界")
(newline)

/tmp/foo.scm

(guile) The Meta Switch

This works on macOS

#!/usr/local/bin/guile -e main -s
!#
(define (main args)
  (map (lambda (arg) (display arg) (display " "))
       (cdr args))
  (newline))

/tmp/main.scm foo bar baz

This should work everywhere (\ is called “The meta switch”)

#!/usr/local/bin/guile \
-e main -s
!#
(define (main args)
  (map (lambda (arg) (display arg) (display " "))
       (cdr args))
  (newline))

/tmp/main2.scm a b c

guile -c '(write %load-path)'

(guile) API Reference

(guile) Data Types

Booleans

(list #t #f #true #false)

(list (if #f nil "hello")
      (if 0 "world"))

(r5rs) Numbers

number
  complex
    real
      rational
        integer

(map (lambda (f) (f 3)) (list number? complex? real? rational? integer?))

binary, octal, decimal, hexadecimal

(list #b10 #o10 #d10 #x10)

(list (sqrt 9.0)
      (expt 3.0 2)
      (random 9))

(guile) Characters

;; 'a' by name, octal number, and hex number
(list #\a #\141 #\x61)

(char=? #\a #\x61)

(guile) Strings

;; (display "hello\tworld!\n")
 
(display "\x61\x20")
;; 你好
(display "\u4F60\u597D")

(list (string? "")
      (string-null? ""))

build strings

(list (string #\x #\y #\z)
      (list->string '(#\x #\y #\z)))

(make-string 5 #\ )

(string-join '("hello" "world") " ")

(string->list "hello")

(string-split "foo bar baz" #\space)

(guile) Symbols

(guile) Keywords

(list #:foo #:bar #:baz)

(guile) Vectors

#(1 2 3)
#("hello" foo #xdeadbeef)

(guile) Prompt Primitives

(define cont
  (call-with-prompt 'foo
    (lambda ()
      (+ 34 (abort-to-prompt 'foo)))
    (lambda (k) k)))

(cont 8)

((call-with-prompt 'foo
   (lambda ()
     (map
      (lambda (x)
        (if (<= x 4)
            x
            (1+ (abort-to-prompt 'foo))))
      '(1 2 3 4 5 6)))
   (lambda (k) k))
 100)

(guile) Input and Output

(let ((port (open-output-file "/tmp/foo.txt")))
  (display "hello, world!\n" port)
  (close-port port))

cat /tmp/foo.txt

(call-with-output-file "/tmp/foo.txt"
  (lambda (port)
    (display "Hello, World!\n" port)))

#!/usr/local/bin/guile \
-e main -s
!#
(use-modules (ice-9 textual-ports))

(define (copy from to)
  (while (not (eof-object? (lookahead-char from)))
    (put-char to (get-char from))))

(define (main . args)
  (copy (current-input-port) (current-output-port)))

(call-with-output-string (lambda (port) (display "hello world" port)))

(with-output-to-string (lambda () (display "hello port")))

(guile) Regular Expressions

(provided? 'regex)

(use-modules (ice-9 regex))

(string-match "[0-9]{4}" "blah2020")

(make-regexp "[0-9][0-9][0-9][0-9]")

(make-regexp "[a-z][a-z]" regexp/icase)

(regexp-exec (make-regexp "ll") "hello")

(list-matches "[a-z]+" "abc 42 def 78")

(use-modules (ice-9 popen)
             (ice-9 rdelim))

(let* ((port (open-input-pipe "gdate --utc"))
       (str  (get-string-all port)))
  (close-pipe port)
  str)

(cond (123 => (lambda (x) (* 2 x))))

Toys

ls

A very simple ls -a -1

(use-modules (ice-9 ftw))

(display (string-join (scandir ".") "\n"))

wget

wget http://example.com

(use-modules (web client))

(call-with-values (lambda () (http-request "http://example.com"))
  (lambda (resp resp-body)
    (display resp-body)))

grep

grep example guile.org

(use-modules (ice-9 rdelim))

(call-with-input-file "/etc/shells"
  (lambda (port)
    (do ((line (read-line port) (read-line port))
         (rx (make-regexp "/.sh")))
        ((eof-object? line))
      (when (regexp-exec rx line)
        (display line)
        (newline)))))

date

gdate
gdate --utc

(strftime "%c" (localtime (current-time)))

(use-modules (srfi srfi-19))

(date->string (current-date) "~a ~b ~e ~H:~M:~S ~z ~Y")

wc

wc /etc/shells

(use-modules (ice-9 rdelim)
             (ice-9 textual-ports))

(call-with-input-file "/etc/shells"
  (lambda (port)
    (let ((line-number 0)
          (char-number 0)
          (word-number 0)
          (last-char #f))
      (while (not (eof-object? (lookahead-char port)))
        (let ((char (get-char port)))
          (set! char-number (1+ char-number))
          (when (char=? char #\newline)
            (set! line-number (1+ line-number)))
          (when (and (not (char-set-contains? char-set:whitespace char))
                     (or (not last-char)
                         (char-set-contains? char-set:whitespace last-char)))
            (set! word-number (1+ word-number)))
          (set! last-char char)))
      (values line-number word-number char-number))))

ydcv

curl 'http://fanyi.youdao.com/openapi.do?keyfrom=YouDaoCV&key=659600698&type=data&doctype=json&version=1.1&q=Hello' | jq

(use-modules (json)
             (web uri)
             (web client)
             (rnrs bytevectors)
             (ice-9 pretty-print))

(define (url query)
  (string-append
   "http://fanyi.youdao.com/openapi.do?keyfrom=YouDaoCV&key=659600698&type=data&doctype=json&version=1.1&q="
   (uri-encode query)))

;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=30076
(call-with-values (lambda () (http-request (url "hello")
                                      #:decode-body? #f))
  (lambda (resp resp-body)
    (pretty-print
     (json-string->scm (utf8->string resp-body)))))

port let-alist

需要学习 Macro

seq

(define (seq from to)
  (if (>= to from)
      (cons from (seq (1+ from) to))
      '()))

(seq from to)

(define (seq from to)
  (if (>= to from)
      (cons from (seq (1+ from) to))
      '()))

(for-each (lambda (n) (display n) (newline))
          (seq 1 10))

yes

(use-modules (ice-9 match))

(match (list 1 2 3 4 5)
  ((_ x . r) (list x r)))

(use-modules (ice-9 match))

(match (list 1 2 3 4 5)
  (_ "default match"))

#!/usr/local/bin/guile -s
!#
(use-modules (ice-9 match))

(let ([s (match (command-line)
           ((_ s . _) s)
           (_ "yes"))])
  (display s)
  (newline))

cut

;; 1, 1-3, 1-, -3
((lambda (s sep field)
   (list-ref (string-split s sep) field))
 "a b c d"
 #\space
 3)

#!/usr/local/bin/guile -e main -s
!#
(use-modules (ice-9 rdelim))

(define (get s sep n)
  (let ([fields (string-split s sep)])
    ;; (format #t "~a ~a ~a ~a\n" s sep n (length fields))
    (if (<= n (length fields))
        (list-ref fields (1- n))
        #f)))

(define (plist-get plist prop)
  (if (null? plist)
      (begin
        (write (list plist prop))
        #f)
      (let ([k (car plist)]
            [v (car (cdr plist))])
        (if (equal? k prop)
            v
            (plist-get (cdr (cdr plist)) prop)))))

;; cat /etc/passwd | cut -s -d : -f 7
(define (main args)
  (let ((port (current-input-port))
        (sep (string-ref (plist-get (cdr args) "-d") 0))
        (field (string->number (plist-get (cdr args) "-f"))))
    (do ((line (read-line port) (read-line port)))
        ((eof-object? line))
      (let ([x (get line sep field)])
        (when x
          (display x)
          (newline))))))

syntax-highlight-cat-scheme

#!/usr/local/bin/guile \
-e main -s
!#
(use-modules (syntax-highlight)
             (syntax-highlight scheme)
             (ice-9 format)
             (ice-9 textual-ports))

(define main
  (lambda (command . args)
    (colorize (get-string-all (current-input-port))
              (current-output-port))))

(define colorize
  (lambda (code port)
    (let f ([ls (highlight lex-scheme code)])
      (unless (null? ls)
        (if (string? (car ls))
            (display (car ls) port)
            (let ([type (caar ls) ]
                  [text (cadar ls)])
              (display
               (case (caar ls)
                 [(special)  (with-color text "#99cc99")]
                 [(string)   (with-color text "#66cccc")]
                 [(keyword)  (with-color text "#cc99cc")]
                 [(comment)  (with-color text "#999999")]
                 [else text])
               port)))
        (f (cdr ls))))))

(define with-color
  (lambda (s rgb)
    (string-append (rgb->esc rgb) s "\x1b[0m")))

(define rgb->esc
  (lambda (rgb)
    (format #f "\x1b[38;2;~d;~d;~dm"
            (string->number (substring rgb 1 3) 16)
            (string->number (substring rgb 3 5) 16)
            (string->number (substring rgb 5 7) 16))))