(define (print item . rest)
(let ((all-item (cons item rest)))
(for-each
(lambda (item) (display item) (display " "))
all-item))
(newline))
(use-modules (ice-9 popen) (srfi srfi-1) (srfi srfi-13))
(define (drain-output port)
(let loop ((chars '())
(next (read-char port)))
(if (eof-object? next)
(list->string (reverse! (cdr chars)))
(loop (cons next chars)
(read-char port)))))
(define (qx pipeline)
(let* ((pipe (open-input-pipe pipeline))
(output (drain-output pipe)))
(close-pipe pipe)
output))
(define string "\\n") (define string "\n") (define string "Jon \"Maddog\" Orwant") (define string "Jon 'Maddog' Orwant")
(define a "This is a multiline here document
terminated by a closing double quote")
(substring str start end)
(substring str start)
(substring-move-right! str start end newstring newstart)
(substring-move-left! str start end newstring newstart)
(string-ref str pos)
(string-set! str pos char)
(string-fill! str char)
(substring-fill! str start end char)
(define s "This is what you have")
(define first (substring s 0 1)) (define start (substring s 5 7)) (define rest (substring s 13)) (define last (substring s (1- (string-length s)))) (define end (substring s (- (string-length s) 4))) (define piece (let ((len (string-length s)))
(substring s (- len 8) (- len 5))))
(use-modules (srfi srfi-13))
(define s "This is what you have")
(define first (string-take s 1)) (define start (xsubstring s 5 7)) (define rest (xsubstring s 13 -1)) (define last (string-take-right s 1)) (define end (string-take-right s 4)) (define piece (xsubstring s -8 -5))
(set! s (string-replace s "wasn't" 5 7))
(set! s (string-replace s "ondrous" 13 25))
(set! s (string-take-right s (1- (string-length s))))
(set! s (string-take s 9))
(define a (or b c))
(define a (if (defined? b) b c))
(define a (or (and (defined? b) b) c))
(let ((a b) (b a))
)
(let ((alpha beta) (beta production) (production alpha))
)
(define num (char->integer char))
(define char (integer->char num))
(use-modules (srfi srfi-13))
(let ((str "sample"))
(display (string-join
(map number->string
(map char->integer (string->list str))) " "))
(newline))
(let ((lst '(115 97 109 112 108 101)))
(display (list->string (map integer->char lst)))
(newline))
(letrec ((next (lambda (c) (integer->char (1+ (char->integer c))))))
(let* ((hal "HAL")
(ibm (list->string (map next (string->list hal)))))
(display ibm)
(newline)))
(map proc
(string->list str))
(use-modules (srfi srfi-1))
(format #t "unique chars are: ~A\n"
(apply string (sort (delete-duplicates
(string->list "an apple a day")) char<?)))
(let* ((str "an apple a day")
(sum (apply + (map char->integer (string->list str)))))
(format #t "sum is ~A\n" sum))
(use-modules (srfi srfi-13))
(let* ((str "an apple a day")
(sum (string-fold (lambda (c acc) (+ acc (char->integer c)))
0 str)))
(format #t "sum is ~A\n" sum))
#!/usr/local/bin/guile -s
!#
(use-modules (srfi srfi-13))
(define (checksum p)
(let loop ((line (read-line p 'concat)) (sum 0))
(if (eof-object? line)
(format #t "~A ~A\n" sum (port-filename p))
(let ((line-sum (string-fold (lambda (c acc)
(+ acc (char->integer c)))
0 line)))
(loop (read-line p 'concat) (modulo (+ sum line-sum)
(1- (expt 2 16))))))))
(let ((args (cdr (command-line))))
(if (null? args)
(checksum (current-input-port))
(for-each (lambda (f) (call-with-input-file f checksum)) args)))
#!/usr/local/bin/guile -s
!#
(use-modules (ice-9 regex) (srfi srfi-2) (srfi srfi-13))
(define args (cdr (command-line)))
(define delay 1)
(and-let* ((p (pair? args))
(m (string-match "^-([0-9]+)$" (car args))))
(set! delay (string->number (match:substring m 1)))
(set! args (cdr args)))
(define (slowcat p)
(let loop ((line (read-line p 'concat)))
(cond ((not (eof-object? line))
(string-for-each
(lambda (c) (display c) (usleep (* 5 delay))) line)
(loop (read-line p 'concat))))))
(if (null? args)
(slowcat (current-input-port))
(for-each (lambda (f) (call-with-input-file f slowcat)) args))
(define revbytes (list->string (reverse (string->list str))))
(use-modules (srfi srfi-13))
(define revbytes (string-reverse str))
(string-reverse! str)
(define revwords (string-join (reverse (string-tokenize str)) " "))
(with-input-from-file "/usr/share/dict/words"
(lambda ()
(do ((word (read-line) (read-line)))
((eof-object? word))
(if (and (> (string-length word) 5)
(string=? word (string-reverse word)))
(write-line word)))))
(regexp-substitute/global
#f "([^\t]*)(\t+)" str
(lambda (m)
(let* ((pre-string (match:substring m 1))
(pre-len (string-length pre-string))
(match-len (- (match:end m 2) (match:start m 2))))
(string-append
pre-string
(make-string
(- (* match-len 8)
(modulo pre-len 8))
#\space))))
'post)
(define (varsubst str)
(regexp-substitute/global #f "\\$(\\w+)" str
'pre (lambda (m) (eval (string->symbol (match:substring m 1))
(current-module)))
'post))
(define (safe-varsubst str)
(regexp-substitute/global #f "\\$(\\w+)" str
'pre (lambda (m)
(catch #t
(lambda () (eval (string->symbol (match:substring m 1))
(current-module)))
(lambda args
(format #f "[NO VARIABLE: ~A]" (match:substring m 1)))))
'post))
(define (interpolate str)
(regexp-substitute/global #f "\\${([^{}]+)}" str
'pre (lambda (m) (eval-string (match:substring m 1))) 'post))
(use-modules (srfi srfi-13))
(string-upcase "bo beep") (string-downcase "JOHN") (string-titlecase "bo") (string-titlecase "JOHN")
(string-titlecase "thIS is a loNG liNE")
#!/usr/local/bin/guile -s
!#
(use-modules (srfi srfi-13))
(seed->random-state (current-time))
(define (randcap p)
(let loop ((line (read-line p 'concat)))
(cond ((not (eof-object? line))
(display (string-map (lambda (c)
(if (= (random 5) 0)
(char-upcase c)
(char-downcase c)))
line))
(loop (read-line p 'concat))))))
(let ((args (cdr (command-line))))
(if (null? args)
(randcap (current-input-port))
(for-each (lambda (f) (call-with-input-file f randcap)) args)))
(format #f "I have ~A guanacos." n)
(define var "
your text
goes here")
(use-modules (ice-9 regexp))
(set! var (regexp-substitute/global #f "\n +" var 'pre "\n" 'post))
(use-modules (srfi srfi-13))
(set! var (string-join (map string-trim (string-tokenize var #\newline)) "\n"))
(use-modules (ice-9 regexp) (srfi srfi-13) (srfi srfi-14))
(define (dequote str)
(let* ((str (if (char=? (string-ref str 0) #\newline)
(substring str 1) str))
(lines (string-tokenize str #\newline))
(rx (let loop ((leader (car lines)) (lst (cdr lines)))
(cond ((string= leader "")
(let ((pos (or (string-skip (car lines)
char-set:whitespace) 0)))
(make-regexp (format #f "^[ \\t]{1,~A}" pos)
regexp/newline)))
((null? lst)
(make-regexp (string-append "^[ \\t]*"
(regexp-quote leader))
regexp/newline))
(else
(let ((pos (or (string-prefix-length leader (car lst))
0)))
(loop (substring leader 0 pos) (cdr lst))))))))
(regexp-substitute/global #f rx str 'pre 'post)))
(use-modules (srfi srfi-13))
(define text "Folding and splicing is the work of an editor,
not a mere collection of silicon
and
mobile electrons!")
(define (wrap str max-col)
(let* ((words (string-tokenize str))
(all '())
(first (car words))
(col (string-length first))
(line (list first)))
(for-each
(lambda (x)
(let* ((len (string-length x))
(new-col (+ col len 1)))
(cond ((> new-col max-col)
(set! all (cons (string-join (reverse! line) " ") all))
(set! line (list x))
(set! col len))
(else
(set! line (cons x line))
(set! col new-col)))))
(cdr words))
(set! all (cons (string-join (reverse! line) " ") all))
(string-join (reverse! all) "\n")))
(display (wrap text 20))
(define str "Mom said, \"Don't do that.\"")
(set! str (regexp-substitute/global #f "['\"]" str 'pre "\\"
match:substring 'post))
(set! str (regexp-substitute/global #f "[^A-Z]" str 'pre "\\"
match:substring 'post))
(set! str (string-append "this " (regexp-substitute/global
#f "\W" "is a test!" 'pre "\\"
match:substring 'post)))
(use-modules (srfi srfi-13))
(define str " space ")
(string-trim str) (string-trim-right str) (string-trim-both str)
(use-modules (srfi srfi-2) (srfi srfi-13) (ice-9 format))
(define parse-csv
(let* ((csv-match (string-join '("\"([^\"\\\\]*(\\\\.[^\"\\\\]*)*)\",?"
"([^,]+),?"
",")
"|"))
(csv-rx (make-regexp csv-match)))
(lambda (text)
(let ((start 0)
(result '()))
(let loop ((start 0))
(and-let* ((m (regexp-exec csv-rx text start)))
(set! result (cons (or (match:substring m 1)
(match:substring m 3))
result))
(loop (match:end m))))
(reverse result)))))
(define line "XYZZY,\"\",\"O'Reilly, Inc\",\"Wall,
Larry\",\"a \\\"glug\\\" bit,\",5,\"Error, Core Dumped\"")
(do ((i 0 (1+ i))
(fields (parse-csv line) (cdr fields)))
((null? fields))
(format #t "~D : ~A\n" i (car fields)))
(use-modules (srfi srfi-13) (srfi srfi-14))
(define soundex
(letrec ((chars "AEIOUYBFPVCGJKQSXZDTLMNR")
(nums "000000111122222222334556")
(skipchars (string->char-set "HW"))
(trans (lambda (c)
(let ((i (string-index chars c)))
(if i (string-ref nums i) c)))))
(lambda (str)
(let* ((ustr (string-upcase str))
(f (string-ref ustr 0))
(skip (trans f)))
(let* ((mstr (string-map trans (string-delete ustr skipchars 1)))
(dstr (string-map (lambda (c)
(cond ((eq? c skip) #\0)
(else (set! skip c) c)))
mstr))
(zstr (string-delete dstr #\0)))
(substring (string-append (make-string 1 f) zstr "000") 0 4))))))
(soundex "Knuth") (soundex "Kant") (soundex "Lloyd") (soundex "Ladd")
#!/usr/local/bin/guile -s
!#
(use-modules (srfi srfi-13)
(srfi srfi-14)
(ice-9 rw)
(ice-9 regex))
(define data "analysed => analyzed
built-in => builtin
chastized => chastised
commandline => command-line
de-allocate => deallocate
dropin => drop-in
hardcode => hard-code
meta-data => metadata
multicharacter => multi-character
multiway => multi-way
non-empty => nonempty
non-profit => nonprofit
non-trappable => nontrappable
pre-define => predefine
preextend => pre-extend
re-compiling => recompiling
reenter => re-enter
turnkey => turn-key")
(define input (if (null? (cdr (command-line)))
(current-input-port)
(open-input-file (cadr (command-line)))))
(let* ((newline-char-set (string->char-set "\n"))
(assoc-char-set (string->char-set " =>"))
(dict (map
(lambda (line)
(string-tokenize line assoc-char-set))
(string-tokenize data newline-char-set)))
(dict-match (string-join (map car dict) "|")))
(let loop ((line (read-line input)))
(cond ((not (eof-object? line))
(regexp-substitute/global
(current-output-port) dict-match line
'pre
(lambda (x)
(cadr (assoc (match:substring x 0) dict)))
'post)
(loop (read-line input 'concat))))))
(close-port input)
(if (string-match "[^\\d]" str) (display "has nondigits"))
(or (string-match "^\\d+$" str) (display "not a natural number"))
(or (string-match "^-?\\d+$" str) (display "not an integer"))
(or (string-match "^[\\-+]?\\d+$" str) (display "not an integer"))
(or (string-match "^-?\\d+\.?\d*$" str) (display "not a decimal number"))
(or (string-match "^-?(\d+(\.\d*)?|\.\d+)$" str)
(display "not a decimal number"))
(or (string-match "^([+-]?)(\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$" str)
(display "not a C float"))
(define num1 (string->number str))
(define num2 (read))
(define (approx-equal? num1 num2 accuracy)
(< (abs (- num1 num2)) (expt 10.0 (- accuracy))))
(define wage 536) (define week (* 40 wage)) (format #t "One week's wage is: $~$\n" (/ week 100.0))
(round num) (inexact->exact num)
(use-modules (ice-9 format))
(define a 0.255)
(define b (/ (round (* 100.0 a)) 100.0))
(format #t "Unrounded: ~F\nRounded: ~F\n" a b)
(format #t "Unrounded: ~F\nRounded: ~,2F\n" a a)
(define a '(3.3 3.5 3.7 -3.3))
(display "number\tint\tfloor\tceil\n")
(for-each
(lambda (n)
(format #t "~,1F\t~,1F\t~,1F\t~,1F\n"
n (round n) (floor n) (ceiling n)))
a)
(define (dec->bin num)
(number->string (string->number num 10) 2))
(define (bin->dec num)
(number->string (string->number num 2) 10))
(define num (bin->dec "0110110")) (define binstr (dec->bin "54"))
(do ((i x (1+ i))) ((> i y)) )
(let ((i x))
(while (<= i y)
(set! i (1+ i))))
(let loop ((i x))
(cond ((<= i y)
(loop (+ i 7)))))
(display "Infancy is: ")
(do ((i 0 (1+ i)))
((> i 2))
(format #t "~A " i))
(newline)
(display "Toddling is: ")
(let ((i 3))
(while (<= i 4)
(format #t "~A " i)
(set! i (1+ i))))
(newline)
(display "Childhood is: ")
(let loop ((i 5))
(cond ((<= i 12)
(format #t "~A " i)
(loop (1+ i)))))
(newline)
(use-modules (ice-9 format))
(format #t "Roman for ~R is ~:@R\n" 15 15)
(random 5) (random 5.0)
(use-modules (srfi srfi-13) (srfi srfi-14))
(define chars (char-set->string char-set:graphic))
(define size (char-set-size char-set:graphic))
(define password
(string-unfold (lambda (x) (= x 8))
(lambda (x) (string-ref chars (random size)))
1+ 0))
(seed->random-state (current-time))
(define state (copy-random-state))
(random:uniform)
(random:uniform state)
(use-modules (ice-9 rw))
(define make-true-random
(letrec ((bufsize 8)
(accum (lambda (c acc) (+ (* 256 acc)
(char->integer c))))
(getbuf (lambda ()
(call-with-input-file "/dev/urandom"
(lambda (p)
(let ((buf (make-string bufsize)))
(read-string!/partial buf p)
buf))))))
(lambda (rand-proc)
(lambda args
(let ((state (seed->random-state (string-fold accum 0 (getbuf)))))
(apply rand-proc (append args (list state))))))))
(define urandom (make-true-random random))
(define urandom:exp (make-true-random random:exp))
(define urandom:normal (make-true-random random:normal))
(define urandom:uniform (make-true-random random:uniform))
(random:exp) (random:normal) (random:uniform)
(random:hollow-sphere! v)
(random:normal-vector! v)
(random:solid-sphere! v)
(define pi 3.14159265358979)
(define (degrees->radians deg)
(* pi (/ deg 180.0)))
(define (radians->degrees rad)
(* 180.0 (/ rad pi)))
(define (degree-sine deg)
(sin (degrees->radians deg)))
(sin z)
(cos z)
(tan z)
(asin z)
(acos z)
(atan z)
(acos 3.7)
(log z) (log10 z)
(define (log-base n z)
(/ (log z) (log n)))
(define (make-log-base n)
(let ((divisor (log n)))
(lambda (z) (/ (log z) divisor))))
(define log2 (make-log-base 2))
(log2 1024)
(define a (make-array 0 rows cols))
(array-set! a 3 row col)
(array-ref a row col)
(define b (make-array 0.0 x y z))
'#2((#f #f) (#f #t))
(define (matrix-mult m1 m2)
(let* ((d1 (array-dimensions m1))
(d2 (array-dimensions m2))
(m1rows (car d1))
(m1cols (cadr d1))
(m2rows (car d2))
(m2cols (cadr d2)))
(if (not (= m1cols m2rows))
(error 'index-error "matrices don't match"))
(let ((result (make-array 0 m1rows m2cols)))
(do ((i 0 (1+ i)))
((= i m1rows))
(do ((j 0 (1+ j)))
((= j m2cols))
(do ((k 0 (1+ k)))
((= k m1cols))
(array-set! result (+ (array-ref result i j)
(* (array-ref m1 i k)
(array-ref m2 k j)))
i j))))
result)))
(matrix-mult '#2((3 2 3) (5 9 8)) '#2((4 7) (9 3) (8 1)))
(define i 0+1i) (define i (sqrt -1))
(complex? i) (real-part i) (imag-part i)
(* 3+5i 2-2i) (sqrt 3+4i)
(inexact->exact (real-part (- (exp (* pi 0+1i)))))
#b01101101 #o155 #d109 #x6d
(define number (string->number hexadecimal 16))
(define number (string->number octal 8))
(format #t "~B ~O ~D ~X\n" num num num num)
(let loop ((perm (read-line)))
(cond ((not (eof-object? perm))
(format #t "The decimal value is ~D\n" (string->number perm 8))
(loop (read-line)))))
(use-modules (ice-9 format))
(format #t "~:D\n" (random 10000000000000000))
(format #t "~,,'.:D\n" (random 10000000000000000))
(define (commify num)
(let ((int (inexact->exact (truncate num))))
(if (= num int)
(format #f "~:D" int)
(string-append (format #f "~:D" int)
(let ((str (format #f "~F" num)))
(substring str (or (string-index str #\.)
(string-length str))))))))
(format #t "It took ~D hour~P\n" hours hours)
(format #t "It took ~D centur~@P\n" centuries centuries)
(define noun-plural
(let* ((suffixes '(("ss" . "sses")
("ph" . "phes")
("sh" . "shes")
("ch" . "ches")
("z" . "zes")
("ff" . "ffs")
("f" . "ves")
("ey" . "eys")
("y" . "ies")
("ix" . "ices")
("s" . "ses")
("x" . "xes")
("ius" . "ii")))
(suffix-match
(string-append "(" (string-join (map car suffixes) "|") ")$"))
(suffix-rx (make-regexp suffix-match)))
(lambda (noun)
(let ((m (regexp-exec suffix-rx noun)))
(if m
(string-append (regexp-substitute #f m 'pre)
(cdr (assoc (match:substring m) suffixes)))
(string-append noun "s"))))))
#!/usr/local/bin/guile -s
!#
(define (factor n)
(let ((factors '())
(limit (inexact->exact (round (sqrt n))))
(twos 0))
(while (even? n)
(set! n (ash n -1))
(set! twos (1+ twos)))
(if (> twos 0) (set! factors (list (cons 2 twos))))
(let loop ((i 3))
(let ((r (remainder n i)))
(cond ((= r 0)
(set! n (quotient n i))
(let* ((old-val (assv i factors))
(new-val (if old-val (1+ (cdr old-val)) 1)))
(set! factors (assv-set! factors i new-val)))
(loop i))
((< i limit)
(loop (+ 2 i))))))
(if (> n 1) (set! factors (cons (cons n 1) factors)))
(reverse! factors)))
(define (pp-term pair)
(if (= (cdr pair) 1)
(number->string (car pair))
(format #f "~A^~A" (car pair) (cdr pair))))
(for-each
(lambda (n)
(let ((factors (factor n)))
(format #t "~A = ~A" n (pp-term (car factors)))
(for-each
(lambda (x) (format #t " * ~A" (pp-term x)))
(cdr factors))
(newline)))
(map string->number (cdr (command-line))))
(current-time) (gettimeofday)
(localtime time) (gmtime time)
(tm:sec time) (set-tm:sec time secs) (tm:min time) (set-tm:min time mins) (tm:hour time) (set-tm:hour time hours) (tm:mday time) (set-tm:mday time mday) (tm:mon time) (set-tm:mon time month) (tm:year time) (set-tm:year time year) (tm:wday time) (set-tm:wday time wday) (tm:yday time) (set-tm:yday time yday) (tm:isdst time) (set-tm:isdst time isdst) (tm:gmtoff time) (set-tm:gmtoff time off) (tm:zone time) (set-tm:zone time zone)
(format #t "Today is day ~A of the current year.\n"
(tm:yday (localtime (current-time))))
(use-modules (srfi srfi-19))
(define now (current-date))
(date-nanosecond now) (date-second now) (date-minute now) (date-hour now) (date-day now) (date-month now) (date-year now) (date-year-day now) (date-week-day now) (date-week-number now start) (date-zone-offset now)
(format #t "Today is day ~A of the current year.\n"
(date-year-day (current-date)))
(use-modules (ice-9 format))
(let ((now (localtime (current-time))))
(format #t "The current date is ~4'0D ~2'0D ~2'0D\n"
(+ 1900 (tm:year now)) (tm:mon now) (tm:mday now)))
(use-modules (srfi srfi-19) (ice-9 format))
(let ((now (current-date)))
(format #t "The current date is ~4'0d-~2'0D-~2'0D\n"
(date-year now) (date-month now) (date-day now)))
(display (strftime "%Y-%m-%d\n" (localtime (current-time))))
(define time (localtime (current-time)))
(set-tm:mday time mday)
(set-tm:mon time mon)
(set-tm:year time year)
(car (mktime time))
(use-modules (srfi srfi-19))
(date->time-monotonic
(make-date nanosecond second minute hour day month year zone-offset))
(let ((time (localtime seconds))) (format #t "Dateline: ~2'0d:~2'0d:~2'0d-~4'0d/~2'0d/~2'0d\n"
(tm:hour time) (tm:min time) (tm:sec time)
(+ 1900 (tm:year time)) (1+ (tm:mon time)) (tm:mday time)))
(use-modules (srfi srfi-19))
(let* ((time (make-time time-monotonic nanosecond second)))
(display (date->string (time-monotonic->date time) "~T-~1\n")))
(define when (+ now difference))
(define then (- now difference))
(define birthtime 96176750)
(define interval (+ 5 (* 17 60) (* 2 60 60) (* 55 60 60 24))) (define then (+ birthtime interval))
(format #t "Then is ~A\n" (strftime "%a %b %d %T %Y" (localtime then)))
(define bree 361535725)
(define nat 96201950)
(define difference (- bree nat))
(format #t "There were ~A seconds between Nat and Bree\n" difference)
(use-modules (srfi srfi-19))
(define time1 (make-time time-monotonic nano1 sec1))
(define time2 (make-time time-monotonic nano2 sec2))
(define duration (time-difference time1 time2))
(time=? (subtract-duration time1 duration) time2) (time=? (add-duration time2 duration) time1)
(use-modules (srfi srfi-19))
(date-day date)
(date-year-day date)
(date-week-day date)
(date-week-number date start-day-of-week)
(define time-pair (strptime "%Y-%m-%d" "1998-06-03"))
(format #t "Time is ~A\n." (strftime "%b %d, %Y" (car time-pair)))
(use-modules (srfi srfi-19))
(define date (string->date "1998-06-03" "~Y-~m-~d"))
(format #t "Time is ~A.\n" (date->string date))
(format #t "strftime gives: ~A\n"
(strftime "%A %D" (localtime (current-time))))
(use-modules (srfi srfi-19))
(format #t "default date->string gives: ~A\n" (date->string (current-date)))
(format #t "date->string gives: ~A\n"
(date->string (current-date) "~a ~b ~e ~H:~M:~S ~z ~Y"))
(define t0 (gettimeofday))
(define t1 (gettimeofday))
(format #t "You took ~A seconds and ~A microseconds\n"
(- (car t1) (car t0)) (- (cdr t1) (cdr t0)))
(define runtime (times))
(tms:clock runtime) (tms:utime runtime) (tms:stime runtime) (tms:cutime runtime) (tms:cstime runtime)
(use-modules (ice-9 time))
(time (sleep 3))
(sleep i) (usleep i)
(define nested '("this" "that" "the" "other"))
(define nested '("this" "that" ("the" "other")))
(define tune '("The" "Star-Spangled" "Banner"))
(define a '("quick" "brown" "fox"))
(define a '("Why" "are" "you" "teasing" "me?"))
(use-modules (srfi srfi-13))
(define lines
(map string-trim
(string-tokenize "\
The boy stood on the burning deck,
It was as hot as glass."
#\newline)))
(define bigarray
(with-input-from-file "mydatafile"
(lambda ()
(let loop ((lines '())
(next-line (read-line)))
(if (eof-object? next-line)
(reverse lines)
(loop (cons next-line lines)
(read-line)))))))
(define banner "The Mines of Moria")
(define name "Gandalf")
(define banner
(string-append "Speak, " name ", and enter!"))
(define banner
(format #f "Speak, ~A, and welcome!" name))
(use-modules (ice-9 popen))
(define (drain-output port)
(let loop ((chars '())
(next (read-char port)))
(if (eof-object? next)
(list->string (reverse! chars))
(loop (cons next chars)
(read-char port)))))
(define (qx pipeline)
(let* ((pipe (open-input-pipe pipeline))
(output (drain-output pipe)))
(close-pipe pipe)
output))
(define his-host "www.perl.com")
(define host-info (qx (format #f "nslookup ~A" his-host)))
(define perl-info (qx (format #f "ps ~A" (getpid))))
(define shell-info (qx "ps $$"))
(define banner '("Costs" "only" "$4.95"))
(define brax (map string (string->list "()<>{}[]")))
(define rings (string-tokenize "Nenya Narya Vilya"))
(define tags (string-tokenize "LI TABLE TR TD A IMG H1 P"))
(define sample
(string-tokenize "The vertical bar (|) looks and behaves like a pipe."))
(define ships '("Niña" "Pinta" "Santa María"))
(define array '("red" "yellow" "green"))
(begin
(display "I have ")
(for-each display array)
(display " marbles.\n"))
(begin
(display "I have ")
(for-each (lambda (colour)
(display colour)
(display " "))
array)
(display "marbles.\n"))
(define (commify strings)
(let ((len (length strings)))
(case len
((0) "")
((1) (car strings))
((2) (string-append (car strings) " and " (cadr strings)))
((3) (string-append (car strings) ", "
(cadr strings) ", and "
(caddr strings)))
(else
(string-append (car strings) ", "
(commify (cdr strings)))))))
(define lists '(("just one thing")
("Mutt" "Jeff")
("Peter" "Paul" "Mary")
("To our parents" "Mother Theresa" "God")
("pastrami" "ham and cheese" "peanut butter and jelly" "tuna")
("recycle tired, old phrases" "ponder big, happy thoughts")
("recycle tired, old phrases"
"ponder big, happy thoughts"
"sleep and dream peacefully")))
(for-each (lambda (list)
(display "The list is: ")
(display (commify list))
(display ".\n"))
lists)
(define (grow/shrink list new-size)
(let ((size (length list)))
(cond ((< size new-size)
(grow/shrink (cons "" list) new-size))
((> size new-size)
(grow/shrink (cdr list) new-size))
(else list))))
(define (element list i)
(list-ref list (- (length list) i 1)))
(define (set-element list i value)
(if (>= i (length list))
(set! list (grow/shrink list (- i 1))))
(set-car! (list-cdr-ref list (- (length list) i 1)))
list)
(define (what-about list)
(let ((len (length list)))
(format #t "The array now has ~A elements.\n" len)
(format #t "The index of the last element is ~A.\n" (- len 1))
(format #t "Element #3 is `~A'.\n" (if (> len 3)
(element list 3)
""))))
(define people (reverse '("Crosby" "Stills" "Nash" "Young")))
(what-about people)
(set! people (grow/shrink people 3))
(what-about people)
(set! people (grow/shrink people 10001))
(what-about people)
(define *mylist* '(1 2 3))
(for-each
(lambda (item) (print item))
*mylist*)
(define *bad-users* '#("lou" "mo" "sterling" "john"))
(define (complain user)
(print "You're a *bad user*," user))
(array-for-each
(lambda (user) (complain user))
*bad-users*)
(define *sorted-environ*
(sort (environ) string<?))
(for-each
(lambda (var) (display var) (newline))
*sorted-environ*)
(define (cons->env-string a)
(string-append (car a) "=" (cdr a)))
(define (env-string->cons s)
(let ((key-value (string-split s #\=)))
(cons (car key-value) (cadr key-value))))
(define *sorted-environ-assoc*
(sort
(map
(lambda (var) (env-string->cons var))
(environ))
(lambda (left right) (string<? (car left) (car right))) ))
(for-each
(lambda (var)
(print (car var) "=" (cdr var)))
*sorted-environ-assoc*)
(define *MAX-QUOTA* 100)
(define (get-all-users) ...)
(define (get-usage user) ...)
(define (complain user) ...)
(for-each
(lambda (user)
(let ((disk-usage (get-usage user)))
(if (> disk-usage *MAX-QUOTA*)
(complain user))))
(get-all-users))
(for-each
(lambda (user) (if (string=? user "tchrist") (print user)))
(string-split (qx "who|cut -d' ' -f1|uniq") #\newline))
(use-modules (srfi srfi-13) (srfi srfi-14))
(do ((line (read-line) (read-line)))
((eof-object? line))
(for-each
(lambda (word) (print (string-reverse word)))
(string-tokenize line char-set:graphic)))
(define (vector-map-in-order! proc vec . rest)
(let ((all-vec (cons vec rest)))
(for-each
(lambda (vec)
(let ((end (vector-length vec)))
(let loop ((idx 0))
(cond
((= idx end) '())
(else
(vector-set! vec idx
(apply proc (list (vector-ref vec idx))))
(loop (+ idx 1)))) )))
all-vec)))
(define (vector-map-in-order proc vec . rest)
(let* ((all-vec (cons vec rest))
(new-vec-len (reduce + 0 (map vector-length all-vec)))
(new-vec (make-vector new-vec-len))
(new-vec-idx 0))
(let loop ((all-vec all-vec))
(cond
((= new-vec-idx new-vec-len) new-vec)
(else
(array-for-each
(lambda (element)
(vector-set! new-vec new-vec-idx (apply proc (list element)))
(set! new-vec-idx (+ new-vec-idx 1)))
(car all-vec))
(loop (cdr all-vec)) ))) ))
(define *array* '#(1 2 3))
(array-for-each
(lambda (item)
(print "i =" item))
*array*)
(define *array* '#(1 2 3))
(array-for-each
(lambda (item)
(print "i =" item))
*array*)
(vector-map-in-order!
(lambda (item) (- item 1))
*array*)
(print *array*)
(define *a* '#(0.5 3))
(define *b* '#(0 1))
(vector-map-in-order!
(lambda (item) (* item 7))
*a* *b*)
(print *a* *b*)
(define *scalar* "123 ")
(define *array* '#(" 123 " "456 "))
(define *hash* (list (cons "key1" "123 ") (cons "key2" " 456")))
(for-each
(lambda (item)
(cond
((string? item) (do-stuff-with-string item))
((vector? item) (do-stuff-with-vector item))
((pair? item) (do-stuff-with-hash item))
(else (print "unknown type"))))
(list *scalar* *array* *hash*))
(define *array* '#(1 2 3))
(array-for-each
(lambda (item)
'())
*array*)
(vector-map-in-order!
(lambda (item)
'())
*array*)
(let ((vector-length (vector-length *array*)))
(do ((i 0 (+ i 1)))
((= i vector-length))
'()))
(let ((vector-length (vector-length *array*)))
(let loop ((i 0))
(cond
((= i vector-length) '())
(else
'()
(loop (+ i 1)))) ))
(define *fruits* '#("Apple" "Blackberry"))
(array-for-each
(lambda (fruit)
(print fruit "tastes good in a pie."))
*fruits*)
(let ((vector-length (vector-length *fruits*)))
(do ((i 0 (+ i 1)))
((= i vector-length))
(print (vector-ref *fruits* i) "tastes good in a pie.") ))
(define *rogue-cats* '("Blacky" "Ginger" "Puss"))
(define *name-list* (acons 'felines *rogue-cats* '()))
(for-each
(lambda (cat)
(print cat "purrs hypnotically.."))
(cdr (assoc 'felines *name-list*)))
(let loop ((felines (cdr (assoc 'felines *name-list*))))
(cond
((null? felines) '())
(else
(print (car felines) "purrs hypnotically..")
(loop (cdr felines)))))
(use-modules (srfi srfi-1))
(define *non-uniq-num-list* '(1 2 3 1 2 3))
(define *uniq* (delete-duplicates *my-non-uniq-num-list*)
(use-modules (srfi srfi-1))
(define *non-uniq-string-list* '("abc" "def" "ghi" "abc" "def" "ghi"))
(define *uniq*
(lset-union string=? *non-uniq-string-list* *non-uniq-string-list*))
(define *non-uniq-sym-list* '('a 'b 'c 'a 'b 'c))
(define *uniq*
(lset-union equal? *my-non-uniq-sym-list* *my-non-uniq-sym-list*))
(define *non-uniq-num-list* '(1 2 3 1 2 3))
(define *uniq*
(lset-union = *my-non-uniq-num-list* *my-non-uniq-num-list*))
(use-modules (srfi srfi-1))
(define *list* '(1 2 3 1 2 7 8 1 8 2 1 3))
(define *seen* '())
(for-each
(lambda (item)
(if (not (assoc-ref *seen* item))
(set! *seen* (assoc-set! *seen* item #t))))
*list*)
(define *uniq*
(fold-right
(lambda (pair accum) (cons (car pair) accum))
'()
*seen*))
(define *list* '(1 2 3 1 2 7 8 1 8 2 1 3))
(define *seen* '())
(for-each
(lambda (item)
(if (not (member item *seen*))
(set! *seen* (cons item *seen*))))
*list*)
(define *users*
(sort
(string-split (qx "who|cut -d' ' -f1") #\newline)
string<?))
(define *seen* '())
(for-each
(lambda (user)
(if (not (member user *seen*))
(set! *seen* (cons item *seen*))))
*list*)
(use-modules (srfi srfi-1))
(define *a* '(1 3 5 6 7 8))
(define *b* '(2 3 5 7 9))
(define *difference* (lset-difference = *a* *b*))
(set! *difference* (lset-difference = *b* *a*))
(use-modules (srfi srfi-1))
(define *a* '(1 3 5 6 7 8))
(define *b* '(2 3 5 7 9))
(define *a-only* '())
(for-each
(lambda (item)
(if (not (member item *b*))
(set! *a-only* (cons item *a-only*))))
*a*)
(use-modules (srfi srfi-1))
(define *a* '(1 3 5 6 7 8))
(define *b* '(2 3 5 7 9))
(define *union* (lset-union = *a* *b*))
(define *intersection* (lset-intersection = *a* *b*))
(define *difference* (lset-difference = *a* *b*))
(use-modules (srfi srfi-1))
(define *a* '(1 3 5 6 7 8))
(define *b* '(2 3 5 7 9))
(define *union* '())
(define *isect* '())
(define *diff* '())
(for-each
(lambda (item) (set! *union* (assoc-set! *union* item #t)))
*a*)
(for-each
(lambda (item)
(if (assoc-ref *union* item)
(set! *isect* (assoc-set! *isect* item #t)))
(set! *union* (assoc-set! *union* item #t)))
*b*)
(for-each
(lambda (item)
(if (not (assoc-ref *isect* item))
(set! *diff* (assoc-set! *diff* item #t))))
*a*)
(set! *union*
(fold
(lambda (pair accum) (cons (car pair) accum))
'()
*union*))
(set! *isect*
(fold
(lambda (pair accum) (cons (car pair) accum))
'()
*isect*))
(set! *diff*
(fold
(lambda (pair accum) (cons (car pair) accum))
'()
*diff*))
(print "Union count: " (length *union*))
(print "Intersection count:" (length *isect*))
(print "Difference count: " (length *diff*))
(define (vector-join vec . rest)
(let* ((all-vec (cons vec rest))
(new-vec-len (reduce + 0 (map vector-length all-vec)))
(new-vec (make-vector new-vec-len))
(new-vec-idx 0))
(let loop ((all-vec all-vec))
(cond
((= new-vec-idx new-vec-len) new-vec)
(else
(array-for-each
(lambda (element)
(vector-set! new-vec new-vec-idx element)
(set! new-vec-idx (+ new-vec-idx 1)))
(car all-vec))
(loop (cdr all-vec)) ))) ))
(define *array1* '#(1 2 3))
(define *array2* '#(4 5 6))
(define *newarray*
(vector-join *array1* *array2*))
(define *array1* '#(1 2 3))
(define *array2* '#(4 5 6))
(define *newarray*
(list->vector (append (vector->list *array1*) (vector->list *array2*)) ))
(define (vector-replace! vec pos item . rest)
(let* ((all-items (cons item rest))
(pos (if (< pos 0) (+ (vector-length vec) pos) pos))
(in-bounds
(not (> (+ pos (length all-items)) (vector-length vec)))))
(if in-bounds
(let loop ((i pos) (all-items all-items))
(cond
((null? all-items) vec)
(else
(vector-set! vec i (car all-items))
(loop (+ i 1) (cdr all-items))) ))
vec)))
(define (vector-delete vec pos len)
(let* ((new-vec-len (- (vector-length vec) len))
(new-vec #f)
(pos (if (< pos 0) (+ (vector-length vec) pos) pos)))
(cond
((< new-vec-len 0) vec)
(else
(set! new-vec (make-vector new-vec-len))
(let loop ((vec-idx 0) (new-vec-idx 0))
(cond
((= new-vec-idx new-vec-len) new-vec)
(else
(if (= vec-idx pos) (set! vec-idx (+ vec-idx len)))
(vector-set! new-vec new-vec-idx (vector-ref vec vec-idx))
(loop (+ vec-idx 1) (+ new-vec-idx 1)) ))) )) ))
(define (vector-insert vec pos cmd item . rest)
(let* ((all-item-vec (list->array 1 (cons item rest)))
(all-item-vec-len (vector-length all-item-vec))
(vec-len (vector-length vec))
(new-vec (make-vector (+ vec-len all-item-vec-len)))
(pos (if (< pos 0) (+ (vector-length vec) pos) pos)))
(if (eq? cmd 'after) (set! pos (+ pos 1)))
(vector-move-left! vec 0 pos new-vec 0)
(vector-move-left! all-item-vec 0 all-item-vec-len new-vec pos)
(vector-move-left! vec pos vec-len new-vec (+ pos all-item-vec-len))
new-vec))
(define *members* '#("Time" "Flies"))
(define *initiates* '#("An" "Arrow"))
(set! *members* (vector-join *members* *initiates*))
(set! *members* (vector-insert *members* 1 'after "Like" *initiates*))
(print *members*)
(set! *members* (vector-replace *members* 0 "Fruit"))
(set! *members* (vector-replace *members* -2 "A" "Banana"))
(print *members*)
(define (vector-reverse! vec)
(let loop ((i 0) (j (- (vector-length vec) 1)))
(cond
((>= i j) vec)
(else
(vector-ref-swap! vec i j)
(loop (+ i 1) (- j 1)))) ))
(define *array* '#(1 2 3))
(vector-reverse! *array*)
(define *array* '#(1 2 3))
(do ((i (- (vector-length *array*) 1) (- i 1)))
((< i 0))
'())
(define *array* '#(1 2 3))
(define *newarray*
(list->vector (reverse (sort (vector->list *array*) <)) ))
(define *array* '#(1 2 3 4 5 6 7 8))
(define *front* (vector-delete *array* 0 3))
(define *end* (vector-delete *array* -1 3))
(define (vector-slice vec pos len)
(let* ((vec-len (vector-length vec))
(pos (if (< pos 0) (+ vec-len pos) pos))
(in-bounds
(not (> (+ pos len) vec-len))))
(if in-bounds
(let ((new-vec (make-vector len)))
(let loop ((vec-idx pos) (new-vec-idx 0))
(cond
((= new-vec-idx len) new-vec)
(else
(vector-set! new-vec new-vec-idx (vector-ref vec vec-idx))
(loop (+ vec-idx 1) (+ new-vec-idx 1))) )))
vec)))
(define (shift2 vec)
(let ((vec (vector-slice vec 0 2)))
(values (vector-ref vec 0) (vector-ref vec 1)) ))
(define (pop2 vec)
(let ((vec (vector-slice vec -1 2)))
(values (vector-ref vec 0) (vector-ref vec 1)) ))
(define *friends* '#('Peter 'Paul 'Mary 'Jim 'Tim))
(let-values ( ((this that) (shift2 *friends*)) )
(print this ":" that))
(define *beverages* '#('Dew 'Jolt 'Cola 'Sprite 'Fresca))
(let-values ( ((d1 d2) (pop2 *beverages*)) )
(print d1 ":" d2))
(define (vector-first-idx pred vec)
(let ((vec-len (vector-length vec)))
(let loop ((idx 0))
(cond
((= idx vec-len) #f)
(else
(if (pred (vector-ref vec idx))
idx
(loop (+ idx 1))) )))))
(define (list-first-idx pred list)
(let loop ((idx 0) (list list))
(cond
((null? list) #f)
(else
(if (pred (car list))
idx
(loop (+ idx 1) (cdr list))) ))))
(define *array* '#(1 2 3 4 5 6 7 8))
(print
(vector-first-idx
(lambda (x) (= x 9))
*array*))
(define *list* '(1 2 3 4 5 6 7 8))
(print
(list-first-idx
(lambda (x) (= x 4))
*list*))
(use-modules (srfi srfi-1))
(print
(list-index
(lambda (x) (= x 4))
*list*))
(define +null-salary-rec+
(list '() 0 '()))
(define *salaries*
(list
(list 'engineer 43000 'Bob)
(list 'programmer 48000 'Andy)
(list 'engineer 35000 'Champ)
(list 'engineer 49000 'Bubbles)
(list 'programmer 47000 'Twig)
(list 'engineer 34000 'Axel) ))
(define *highest-paid-engineer*
(reduce
(lambda (salary-rec acc)
(if
(and
(eq? (car salary-rec) 'engineer)
(> (cadr salary-rec) (cadr acc)))
salary-rec
acc))
+null-salary-rec+
*salaries*))
(print *highest-paid-engineer*)
(define *highest-paid-engineer*
(fold-right
(lambda (salary-rec acc)
(if (> (cadr salary-rec) (cadr acc))
salary-rec
acc))
+null-salary-rec+
(filter
(lambda (salary-rec)
(eq? (car salary-rec) 'engineer))
*salaries*)) )
(print *highest-paid-engineer*)
(define *highest-paid-engineer* +null-salary-rec+)
(for-each
(lambda (salary-rec)
(if
(and
(eq? (car salary-rec) 'engineer)
(> (cadr salary-rec) (cadr *highest-paid-engineer*)))
(set! *highest-paid-engineer* salary-rec)))
*salaries*)
(print *highest-paid-engineer*)
(define *list-matching* (filter PRED LIST))
(define *vector-matching* (array-filter PRED ARRAY))
(define *nums* '(1e7 3e7 2e7 4e7 1e7 3e7 2e7 4e7))
(define *bigs*
(filter
(lambda (num) (> num 1000000))
*nums*))
(define *users*
(list
'(u1 . 2e7)
'(u2 . 1e7)
'(u3 . 4e7)
'(u4 . 3e7) ))
(define *pigs*
(fold-right
(lambda (pair accum) (cons (car pair) accum))
'()
(filter
(lambda (pair) (> (cdr pair) 1e7))
*users*)))
(print *pigs*)
(define *salaries*
(list
(list 'engineer 43000 'Bob)
(list 'programmer 48000 'Andy)
(list 'engineer 35000 'Champ)
(list 'engineer 49000 'Bubbles)
(list 'programmer 47000 'Twig)
(list 'engineer 34000 'Axel) ))
(define *engineers*
(filter
(lambda (salary-rec)
(eq? (car salary-rec) 'engineer))
*salaries*))
(print *engineers*)
(define *applicants*
(list
(list 'a1 26000 'Bob)
(list 'a2 28000 'Andy)
(list 'a3 24000 'Candy) ))
(define *secondary-assistance*
(filter
(lambda (salary-rec)
(and
(> (cadr salary-rec) 26000)
(< (cadr salary-rec) 30000)))
*applicants*))
(print *secondary-assistance*)
(define *unsorted* '(5 8 1 7 4 2 3 6))
(define *sorted*
(sort
*unsorted*
<))
(print *sorted*)
(define *sorted*
(sort
*unsorted*
>))
(print *sorted*)
(define *unordered* '( ... ))
(define *ordered*
(sort
*unordered*
(lambda (left right)
(COMPARE left right))))
(define *unordered*
(list
(cons 's 34)
(cons 'e 12)
(cons 'c 45)
(cons 'q 11)
(cons 'g 24) ))
(define *pre-computed*
(map
(lambda (element) element)
*unordered*))
(define *ordered-pre-computed*
(sort
*pre-computed*
(lambda (left right)
(string<?
(symbol->string (car left))
(symbol->string (car right))))))
(define *ordered*
(map
(lambda (element) (cdr element))
*ordered-pre-computed*))
(define *employees*
(list
(list 'Bob 43000 123 42)
(list 'Andy 48000 124 35)
(list 'Champ 35000 125 37)
(list 'Bubbles 49000 126 34)
(list 'Twig 47000 127 36)
(list 'Axel 34000 128 31) ))
(define *ordered*
(sort
*employees*
(lambda (left right)
(string<?
(symbol->string (car left))
(symbol->string (car right))))))
(for-each
(lambda (employee)
(print (car employee) "earns $" (cadr employee)))
(sort
*employees*
(lambda (left right)
(string<?
(symbol->string (car left))
(symbol->string (car right))))))
(define *bonus*
(list
'(125 . 1000)
'(127 . 1500) ))
(for-each
(lambda (employee)
(let ((bonus (assoc-ref *bonus* (caddr employee))))
(if (not bonus)
'()
(print (car employee) "earned bonus" bonus) )))
(sort
*employees*
(lambda (left right)
(string<?
(symbol->string (car left))
(symbol->string (car right))))))
(use-modules (srfi srfi-1) (ice-9 rdelim) (ice-9 regex))
(define *filename* "/etc/passwd")
(define *users* '())
(let ((port (open-input-file *filename*)))
(let loop ((line&terminator (read-line port 'split)))
(cond
((eof-object? (cdr line&terminator)) '())
(else
(set! *users*
(assoc-set!
*users*
(car (string-split (car line&terminator) #\:))
#t))
(loop (read-line port 'split)) )))
(close-input-port port))
(for-each
(lambda (user) (print (car user)))
(sort
*users*
(lambda (left right)
(string<?
(car left)
(car right)))))
(use-modules (srfi srfi-1))
(define *processes* (circular-list 1 2 3 4 5))
(let loop ((processes *processes*))
(print "Handling process" (car processes))
(sleep 1)
(loop (cdr processes)))
(use-modules (srfi srfi-1))
(define (vector-shuffle! vec)
(let ((vector-length (vector-length vec)))
(let loop ((i vector-length) (j (+ 1 (random vector-length))))
(cond
((= i 1) '())
((not (= i j))
(vector-ref-swap! vec (- i 1) (- j 1))
(loop (- i 1) (+ 1 (random (- i 1)))))
(else
(loop (- i 1) (+ 1 (random (- i 1))))) ))))
(define (vector-ref-swap! vec idx1 idx2)
(let ((tmp (vector-ref vec idx1)))
(vector-set! vec idx1 (vector-ref vec idx2))
(vector-set! vec idx2 tmp)))
(define *irange* (list->vector (iota 10 1 1)))
(vector-shuffle! *irange*)
(define *age*
(list
(cons 'Nat 24)
(cons 'Jules 25)
(cons 'Josh 17)))
(define *age*
(list
'(Nat . 24)
'(Jules . 25)
'(Josh . 17)))
(define *age* (acons 'Nat 24 '()))
(set! *age* (acons 'Jules 25 *age*))
(set! *age* (acons 'Josh 17 *age*))
(use-modules (srfi srfi-1))
(define *age* (alist-cons 'Nat 24 '()))
(set! *age* (alist-cons 'Jules 25 *age*))
(set! *age* (alist-cons 'Josh 17 *age*))
(define *food-colour*
(list
'(Apple . "red")
'(Banana . "yellow")
'(Lemon . "yellow")
'(Carrot . "orange")))
(define *age* (make-hash-table 20))
(define *age* (make-vector 20 '()))
(hash-set! *age* 'Nat 24)
(hash-set! *age* 'Jules 25)
(hash-set! *age* 'Josh 17)
(hash-for-each
(lambda (key value) (print key))
*age*)
(array-for-each
(lambda (pair)
(if (not (null? pair)) (print (car pair))))
*age*)
(define *food-colour* (make-hash-table 20))
(hash-set! *food-colour* 'Apple "red")
(hash-set! *food-colour* 'Banana "yellow")
(hash-set! *food-colour* 'Lemon "yellow")
(hash-set! *food-colour* 'Carrot "orange")
(set! *hash* (acons key value *hash*))
(set! *food-colour* (acons 'Raspberry "pink" *food-colour*))
(print "Known foods:")
(for-each
(lambda (pair) (print (car pair)))
*food-colour*)
(hash-set! *hash* key value)
(hash-set! *food-colour* 'Raspberry "pink")
(print "Known foods:")
(hash-for-each
(lambda (key value) (print key))
*food-colour*)
(if (assoc key hash)
'()
'()
(if (assoc-ref hash key)
'()
'()
(for-each
(lambda (name)
(let ((pair (assoc name *food-colour*)))
(if pair
(print (symbol->string (car pair)) "is a food")
(print (symbol->string name) "is a drink") )))
(list 'Banana 'Martini))
(if (hash-get-handle hash key)
'()
'()
(if (hash-ref hash key)
'()
'()
(for-each
(lambda (name)
(let ((value (hash-ref *food-colour* name)))
(if value
(print (symbol->string name) "is a food")
(print (symbol->string name) "is a drink") )))
(list 'Banana 'Martini))
(define *age* (make-hash-table 20))
(hash-set! *age* 'Toddler 3)
(hash-set! *age* 'Unborn 0)
(hash-set! *age* 'Phantasm '())
(for-each
(lambda (thing)
(let ((value (hash-ref *age* thing)))
(display thing)
(if value (display " Exists"))
(if (and value (not (string-null? value))) (display " Defined"))
(if (and value (not (eq? value 0))) (display " True"))
(print "") ))
(list 'Toddler 'Unborn 'Phantasm 'Relic))
(assoc-remove! hash key)
(use-modules (srfi srfi-1))
(define (print-foods)
(let ((foods
(fold-right
(lambda (pair accum) (cons (car pair) accum))
'()
*food-colour*)))
(display "Keys: ") (print foods)
(print "Values:")
(for-each
(lambda (food)
(let ((colour (assoc-ref *food-colour* food)))
(cond
((string-null? colour) (display "(undef) "))
(else (display (string-append colour " "))) )))
foods))
(newline))
(print "Initially:")
(print-foods)
(print "\nWith Banana undef")
(assoc-set! *food-colour* 'Banana "")
(print-foods)
(print "\nWith Banana deleted")
(assoc-remove! *food-colour* 'Banana)
(print-foods)
(hash-remove! hash key)
(use-modules (srfi srfi-1))
(define (print-foods)
(let ((foods
(hash-fold
(lambda (key value accum) (cons key accum))
'()
*food-colour*)))
(display "Keys: ") (print (reverse foods))
(print "Values:")
(for-each
(lambda (food)
(let ((colour (hash-ref *food-colour* food)))
(cond
((string-null? colour) (display "(undef) "))
(else (display (string-append colour " "))) )))
foods))
(newline))
(print "Initially:")
(print-foods)
(print "\nWith Banana undef")
(hash-set! *food-colour* 'Banana "")
(print-foods)
(print "\nWith Banana deleted")
(hash-remove! *food-colour* 'Banana)
(print-foods)
(for-each
(lambda (pair)
(let ((key (car pair))
(value (cdr pair)))
'()))
hash)
(hash-for-each
(lambda (key value)
'())
hash)
(array-for-each
(lambda (pair)
(if (not (null? pair)) ... do something with key / value ...))
hash)
(for-each
(lambda (pair)
(let ((food (car pair))
(colour (cdr pair)))
(print (symbol->string food) "is" colour) ))
*food-colour*)
(for-each
(lambda (food)
(print (symbol->string food) "is" (assoc-ref *food-colour* food)))
(sort
(fold-right
(lambda (pair accum) (cons (car pair) accum))
'()
*food-colour*)
(lambda (left right)
(string<? (symbol->string left) (symbol->string right)))))
(use-modules (srfi srfi-1) (ice-9 rdelim) (ice-9 regex))
(define *filename* "from.txt")
(define *from* '())
(let ((port (open-input-file *filename*)))
(let loop ((line&terminator (read-line port 'split)))
(cond
((eof-object? (cdr line&terminator)) '())
(else
(let* ((key (string->symbol
(match:substring
(string-match
"^From: (.*)" (car line&terminator))
1) ))
(value (assoc-ref *from* key)))
(if (not value) (set! value 0))
(set! *from* (assoc-set! *from* key (+ 1 value))))
(loop (read-line port 'split)) )))
(close-input-port port))
(for-each
(lambda (person)
(print (symbol->string person) ":"
(number->string (assoc-ref *from* person))))
(sort
(fold-right
(lambda (pair accum) (cons (car pair) accum))
'()
*from*)
(lambda (left right)
(string<? (symbol->string left) (symbol->string right)))))
(define *sorted-food-colour*
(sort
*food-colour*
(lambda (left right)
(string<?
(symbol->string (car left))
(symbol->string (car right)))) ))
(let loop ((hash *sorted-food-colour*))
(cond
((null? hash) '())
(else
(print
(symbol->string (car (car hash))) "=>" (cdr (car hash)) )
(loop (cdr hash))) ))
(define *food-colour* (acons 'Banana "Yellow" '()))
(set! *food-colour* (acons 'Apple "Green" *food-colour*))
(set! *food-colour* (acons 'Lemon "yellow" *food-colour*))
(print "In insertion order, the foods are:")
(for-each
(lambda (pair)
(let ((food (car pair))
(colour (cdr pair)))
(print " " (symbol->string food)) ))
*food-colour*)
(print "Still in insertion order, the food's colours are:")
(for-each
(lambda (pair)
(let ((food (car pair))
(colour (cdr pair)))
(print (symbol->string food) "is coloured" colour) ))
*food-colour*)
(define *ttys* '())
(for-each
(lambda (user-tty-pair)
(let* ((user-tty-pair (string-split user-tty-pair #\space))
(user (string->symbol (car user-tty-pair)))
(newtty (cadr user-tty-pair))
(current-ttys (assoc-ref *ttys* user)))
(set! *ttys*
(assoc-set! *ttys* user
(if (not current-ttys)
newtty
(string-append current-ttys " " newtty)) ))))
(string-split (qx "who|cut -d' ' -f1,2") #\newline))
(for-each
(lambda (user-ttys)
(print (symbol->string (car user-ttys)) ":" (cdr user-ttys)))
(sort
*ttys*
(lambda (left right)
(string<?
(symbol->string (car left))
(symbol->string (car right))))) )
(use-modules (ice-9 regex))
(define (multi-hash-delete hash key value)
(let ((value-found (assoc-ref hash key)))
(if value-found
(assoc-ref hash key
(regexp-substitute/global
#f (string-match value value-found) 'pre "" 'post "")))))
(define (assoc-invert assoc)
(map
(lambda (pair)
(cons
(string->symbol (cdr pair))
(symbol->string (car pair))))
assoc))
(define (assoc-invert assoc)
(let loop ((assoc assoc) (new-assoc '()))
(cond
((null? assoc) new-assoc)
(else
(loop (cdr assoc)
(acons
(string->symbol (cdar assoc))
(symbol->string (caar assoc)) new-assoc)) )) ))
(define *surname*
(list
'(Mickey . "Mantle")
'(Babe . "Ruth")))
(define *first-name* (assoc-invert *surname*))
(print (assoc-ref *first-name* 'Mantle))
(define *given* (string->symbol (cadr (command-line))))
(define *colour*
(list
'(Apple . "red")
'(Lemon . "yellow")
'(Carrot . "orange")))
(define *food* (assoc-invert *colour*))
(if (assoc-ref *colour* *given*)
(print
(symbol->string *given*)
"is a food with colour"
(assoc-ref *colour* *given*)))
(if (assoc-ref *food* *given*)
(print
(assoc-ref *food* *given*)
"is a food with colour"
(symbol->string *given*)))
(define *sorted-on-key:food-colour*
(sort
*food-colour*
(lambda (left right)
(string<?
(symbol->string (car left))
(symbol->string (car right)))) ))
(define *sorted-on-value:food-colour*
(sort
*food-colour*
(lambda (left right)
(string<?
(cdr left)
(cdr right))) ))
(for-each
(lambda (pair)
(let ((food (car pair))
(colour (cdr pair)))
(print
(symbol->string food)
"is"
colour)))
*sorted-on-key:food-colour*)
(define *sorted-food-colour-keys*
(sort
(fold-right
(lambda (pair accum) (cons (car pair) accum))
'()
*food-colour*)
(lambda (left right)
(string<?
(symbol->string left)
(symbol->string right))) ))
(define *sorted-food-colour-values*
(sort
(fold-right
(lambda (pair accum) (cons (cdr pair) accum))
'()
*food-colour*)
(lambda (left right)
(string<? left right)) ))
(for-each
(lambda (food)
(print (symbol->string food) "is" (assoc-ref *food-colour* food)))
*sorted-food-colour-keys*)
(define *food-colour*
(list
'(Apple . "red")
'(Banana . "yellow")
'(Lemon . "yellow")
'(Carrot . "orange")))
(define *drink-colour*
(list
'(Galliano . "yellow")
'(Mai Tai . "blue")))
(define *ingested-colour* (append *food-colour* *drink-colour*))
(define *food-colour* (make-vector 20 '())
(define *drink-colour* (make-vector 20 '())
(define *ingested-colour*
(vector-join *food-colour* *drink-colour*))
(define *common* '())
(define *this-not-that* '())
(define *dict1*
(list
'(Apple . "red")
'(Lemon . "yellow")
'(Carrot . "orange")))
(define *dict2*
(list
'(Apple . "red")
'(Carrot . "orange")))
(for-each
(lambda (pair)
(let ((key (car pair))
(value (cdr pair)))
(if (assoc-ref *dict2* key)
(set! *common* (cons key *common*))) ))
*dict1*)
(for-each
(lambda (pair)
(let ((key (car pair))
(value (cdr pair)))
(if (not (assoc-ref *dict2* key))
(set! *this-not-that* (cons key *this-not-that*))) ))
*dict1*)
(define *non-citrus* '())
(define *citrus-colour*
(list
'(Lemon . "yellow")
'(Orange . "orange")
'(Lime . "green")))
(define *food-colour*
(list
'(Apple . "red")
'(Banana . "yellow")
'(Lemon . "yellow")
'(Carrot . "orange")))
(for-each
(lambda (pair)
(let ((key (car pair))
(value (cdr pair)))
(if (not (assoc-ref *citrus-colour* key))
(set! *non-citrus* (cons key *non-citrus*))) ))
*food-colour*)
(use-modules (srfi srfi-1) (srfi srfi-13))
(define *ports* '())
(for-each
(lambda (filename)
(let ((port (open-input-file filename)))
(set! *ports* (assoc-set! *ports* port filename)) ))
'("/etc/termcap" "/vmlinux" "/bin/cat"))
(print
(string-append "open files: "
(string-drop
(fold-right
(lambda (pair accum) (string-append ", " (cdr pair) accum))
""
*ports*)
2)))
(for-each
(lambda (pair)
(let ((port (car pair))
(filename (cdr pair)))
(seek port 0 SEEK_END)
(print filename "is" (number->string (ftell port)) "bytes long.")
(close-input-port port) ))
*ports*)
(define *hash* '())
(define *hash* (list
'(Apple . "red")
'(Lemon . "yellow")
'(Carrot . "orange")))
(define *hash* (make-hash-table 100))
(define *hash* (make-vector 100 '()))
(define *array*
(list 'a 'b 'c 'd 'd 'a 'a 'c 'd 'd 'e))
(define *count* '())
(for-each
(lambda (element)
(let ((value (assoc-ref *count* element)))
(if (not value) (set! value 0))
(set! *count* (assoc-set! *count* element (+ 1 value)))))
*array*)
(define *count* (make-hash-table 20))
(for-each
(lambda (element)
(let ((value (hash-ref *count* element)))
(if (not value) (set! value 0))
(hash-set! *count* element (+ 1 value))))
*array*)
(define *father*
(list
'(Cain . Adam)
'(Abel . Adam)
'(Seth . Adam)
'(Enoch . Cain)
'(Irad . Enoch)
'(Mehujael . Irad)
'(Methusael . Mehujael)
'(Lamech . Methusael)
'(Jabal . Lamech)
'(Jubal . Lamech)
'(Tubalcain . Lamech)
'(Enos . Seth)))
(use-modules (srfi srfi-1) (ice-9 rdelim))
(let ((port (open-input-file *filename*)))
(let loop ((line&terminator (read-line port 'split)))
(cond
((eof-object? (cdr line&terminator)) '())
(else
(let ((person (string->symbol (car line&terminator))))
(let loop ((father (assoc-ref *father* person)))
(if father
(begin
(print father)
(loop (assoc-ref *father* father)) )))
(loop (read-line port 'split)) ))))
(close-input-port port))
(use-modules (srfi srfi-1) (ice-9 rdelim))
(define (assoc-invert-N:M assoc)
(let ((new-assoc '()))
(for-each
(lambda (pair)
(let* ((old-key (car pair))
(new-key (cdr pair))
(new-key-found (assoc-ref new-assoc new-key)))
(if (not new-key-found)
(set! new-assoc (acons new-key (list old-key) new-assoc))
(set! new-assoc (assoc-set! new-assoc new-key
(cons old-key new-key-found))) )))
assoc)
new-assoc))
(define *children* (assoc-invert-N:M *father*))
(let ((port (open-input-file *filename*)))
(let loop ((line&terminator (read-line port 'split)))
(cond
((eof-object? (cdr line&terminator)) '())
(else
(let* ((person (string->symbol (car line&terminator)))
(children-found (assoc-ref *children* person)))
(print (symbol->string person) "begat:")
(if (not children-found)
(print "nobody")
(for-each
(lambda (child) (print (symbol->string child) ","))
children-found))
(loop (read-line port 'split)) ))))
(close-input-port port))
(define input (open-input-file "/usr/local/widgets/data"))
(let loop ((line (read-line input 'concat)))
(cond ((not (eof-object? line))
(if (string-match "blue" line)
(display line))
(loop (read-line input 'concat)))))
(close input)
(let loop ((line (read-line))) (cond ((not (eof-object? line))
(if (not (string-match "[0-9]" line))
(display "No digit found.\n" (current-error-port))
(format #t "Read: ~A\n" line))
(loop (read-line)))))
(define logfile (open-output-file "/tmp/log"))
(close logfile) (close-port logfile) (close-output-port logfile)
(let ((old-out (current-output-port)))
(set-current-output-port logfile)
(display "Countdown initiated ...\n")
(set-current-output-port old-out)
(display "You have 30 seconds to reach minimum safety distance.\n"))
(with-output-to-file logfile
(lambda () (display "Countdown initiated ...\n")))
(display "You have 30 seconds to reach minimum safety distance.\n")
(define source (open-input-file path))
(define sink (open-output-file path))
(define source (open path O_RDONLY))
(define sink (open path O_WRONLY))
(define port (open-input-file path))
(define port (open-file path "r"))
(define port (open path O_RDONLY))
(define port (open-output-file path))
(define port (open-file path "w"))
(define port (open path (logior O_WRONLY O_TRUNC O_CREAT)))
(define port (open path (logior O_WRONLY O_EXCL O_CREAT)))
(define port (open-file path "a"))
(define port (open path (logior O_WRONLY O_APPEND O_CREAT)))
(define port (open path (logior O_WRONLY O_APPEND)))
(define port (open path O_RDWR))
(define port (open-file path "r+"))
(define port (open path (logior O_RDWR O_CREAT)))
(define port (open path (logior O_RDWR O_EXCL O_CREAT)))
(define expand-user
(let ((rx (make-regexp "^\\~([^/]+)?")))
(lambda (filename)
(let ((m (regexp-exec rx filename)))
(if m
(string-append
(if (match:substring m 1)
(passwd:dir (getpwnam (match:substring m 1)))
(or (getenv "HOME") (getenv "LOGDIR")
(passwd:dir (getpwuid (cuserid))) ""))
(substring filename (match:end m)))
filename)))))
(define port (open-file filename mode))
(catch 'system-error (lambda () (set! port (open-file filename mode))) (lambda (key . args) (let ((fmt (cadr args))
(msg&path (caddr args)))
(format (current-error-port) fmt (car msg&path) (cadr msg&path))
(newline))))
(let ((name (tmpnam)))
(call-with-output-file name
(lambda (port)
'())))
(define (open-temp-file)
(let loop ((name (tmpnam)))
(catch 'system-error
(lambda () (open name (logior O_RDWR O_CREAT O_EXCL)))
(lambda (key . args) (loop (tmpnam))))))
(define port (mkstemp! template-string-ending-in-XXXXXX))
(let* ((tmpl "/tmp/programXXXXXX")
(port (mkstemp! tmpl)))
(do ((i 0 (1+ i)))
((= i 10))
(format port "~A\n" i))
(seek port 0 SEEK_SET)
(display "Tmp file has:\n")
(do ((line (read-line port 'concat) (read-line port 'concat)))
((eof-object? line))
(display line))
(close port))
(define DATA "
your data goes here
")
(call-with-input-string
DATA
(lambda (port)
'()))
(with-input-from-string DATA
(lambda ()
'()))
(do ((line (read-line) (read-line)))
((eof-object? line))
'())
(define (body)
(do ((line (read-line) (read-line)))
((eof-object? line))
(display line)
(newline)))
(let ((args (cdr (command-line))))
(if (null? args)
(body) (for-each (lambda (file)
(catch 'system-error
(lambda ()
(with-input-from-file file
body))
(lambda (key . args)
(format (current-error-port) (cadr args) (caaddr args)
(car (cdaddr args)))
(newline (current-error-port)))))
args)))
(use-modules (srfi srfi-1) (srfi srfi-13) (ice-9 format) (ice-9 regex))
(define opt-append 0)
(define opt-ignore-ints 0)
(define opt-nostdout 0)
(define opt-unbuffer 0)
(define args (cdr (command-line)))
(do ((opts args (cdr opts)))
((or (null? opts) (not (eq? (string-ref (car opts) 0) #\-)))
(set! args opts))
(let ((opt (car opts)))
(cond ((string=? opt "-a") (set! opt-append (1+ opt-append)))
((string=? opt "-i") (set! opt-ignore-ints (1+ opt-ignore-ints)))
((string=? opt "-n") (set! opt-nostdout (1+ opt-nostdout)))
((string=? opt "-u") (set! opt-unbuffer (1+ opt-unbuffer)))
(else (throw 'usage-error "Unexpected argument: ~A" opt)))))
(if (null? args) (set! args (glob "*.[Cch]" ".")))
(define (find-login)
(do ((line (read-line) (read-line)))
((eof-object? line))
(cond ((string-match "login" line)
(display line)
(newline)))))
(define (lowercase)
(do ((line (read-line) (read-line)))
((eof-object? line))
(display (string-downcase line))
(newline)))
(define (count-chunks)
(do ((line (read-line) (read-line))
(chunks 0))
((or (eof-object? line)
(string=? line "__DATA__") (string=? line "__END__"))
(format #t "Found ~A chunks\n" chunks))
(let ((tokens
(string-tokenize (string-take line (or (string-index line #\#)
(string-length line))))))
(set! chunks (+ chunks (length tokens))))))
(if (null? args)
(count-chunks) (for-each
(lambda (file)
(catch 'system-error
(lambda ()
(with-input-from-file file
count-chunks))
(lambda (key . args)
(format (current-error-port) (cadr args) (caaddr args)
(car (cdaddr args)))
(newline (current-error-port)))))
args))
(with-input-from-file old
(lambda ()
(with-output-to-file new
(lambda ()
(do ((line (read-line) (read-line)))
((eof-object? line))
(write-line line))))))
(rename-file old (string-append old ".orig"))
(rename-file new old)
(let ((p (open-file file "r+"))
(lines '()))
(do ((line (read-line p) (read-line p)))
((eof-object? line))
(set! lines (cons line lines)))
(seek p 0 SEEK_SET)
(for-each (lambda (x) (write-line x p)) lines)
(truncate-file p)
(close p))
(let ((p (open-file "foo" "r+"))
(lines '())
(date (date->string (current-date))))
(do ((line (read-line p 'concat) (read-line p 'concat)))
((eof-object? line))
(set! lines (cons line lines)))
(seek p 0 SEEK_SET)
(for-each
(lambda (x)
(regexp-substitute/global p "DATE" x 'pre date 'post))
(reverse lines))
(truncate-file p)
(close p))
(define p (open-file path "r+"))
(flock p LOCK_EX)
(close p)
(define p (open "numfile" (logior O_RDWR O_CREAT)))
(flock p LOCK_EX)
(let* ((obj (read p))
(num (if (eof-object? obj) 0 obj)))
(seek p 0 SEEK_SET)
(truncate-file p)
(write (1+ num) p)
(newline p))
(close p)
(force-output p)
(flush-all-ports)
(select inputs outputs exceptions seconds)
(select (list p1 p2 p3) '() '())
(let* ((nfound (select (list inport) '() '()))
(inputs (car nfound)))
(if (not (null? inputs))
(let ((line (read-line inport)))
(format #t "I read ~A\n" line))))
(if (char-ready? p)
(format #t "I read ~A\n" (read-char p)))
(define modem (open "/dev/cua0" (logior O_RDWR O_NONBLOCK)))
(let ((flags (fcntl p F_GETFD)))
(fcntl p F_SETFD (logior flags O_NONBLOCK)))
(let ((buf (make-string (stat:size (stat p)))))
(read-string!/partial buf input))
(for-each (lambda (p) (display stuff-to-print p)) port-list)
(port-for-each (lambda (p) (if (output-port? p) (display stuff p))))
(define p (fdopen num mode))
(define p (fdopen 3 "r"))
(define p (fdopen (string->number (getenv "MHCONTEXTFD")) "r"))
(close p)
(define alias original)
(define old-in (current-input-port))
(define p1 (open-input-file path))
(define p2 (open-input-file path))
(define copy-of-p (fdopen (fileno p) mode))
(define old-out (current-output-port))
(define old-err (current-error-port))
(define new-out (open-output-file "/tmp/program.out"))
(set-current-output-port new-out)
(set-current-error-port new-out)
(system joe-random-program)
(close new-out)
(set-current-output-port old-out)
(set-current-error-port old-out)
(let ((p (open-input-file file)))
(do ((line (read-line p) (read-line p)))
((eof-object? line))
(format #t "~A\n" (string-length line)))
(close p))
(with-input-from-file file
(lambda ()
(do ((line (read-line) (read-line)))
((eof-object? line))
(format #t "~A\n" (string-length line)))))
(define (for-each-line proc file)
(with-input-from-file file
(lambda ()
(do ((line (read-line) (read-line)))
((eof-object? line))
(proc line)))))
(for-each-line (lambda (x) (format #t "~A\n" (string-length line))) file)
(define (read-lines file)
(let ((ls '()))
(with-input-from-file file
(lambda ()
(do ((line (read-line) (read-line)))
((eof-object? line))
(set! ls (cons line ls)))
(reverse ls)))))
(define (file-contents file)
(call-with-input-file file
(lambda (p)
(let* ((size (stat:size (stat p)))
(buf (make-string size)))
(read-string!/partial buf p)
buf))))
(display '("One" "two" "three") port) (display "Baa baa black sheep.\n")
(write '("One" "two" "three") port)
(use-modules (ice-9 rw))
(let ((buffer (make-string 4096)))
(read-string!/partial buffer port 4096))
(truncate-file port length) (truncate-file port)
(define pos (ftell port))
(format #t "I'm ~A bytes from the start of DATAFILE.\n" pos)
(seek log-port 0 SEEK_END) (seek data-port pos SEEK_SET) (seek out-port -20 SEEK_CUR)
(use-modules (ice-9 rw))
(write-string/partial mystring data-port (string-length mystring))
(read-string!/partial block 256 5)
(let ((rx (make-regexp "(.*)\\\\$"))) (with-input-from-file file
(lambda ()
(let loop ((line (read-line)))
(if (not (eof-object? line))
(let ((m (regexp-exec rx line))
(next (read-line)))
(cond ((and m (not (eof-object? next)))
(loop (string-append (match:substring m 1) next)))
(else
(loop next)))))))))
(do ((line (read-line p) (read-line p))
(i 0 (1+ i)))
((eof-object? line) i))
(use-modules (ice-9 rw) (srfi srfi-13))
(let ((buf (make-string (expt 2 16)))
(count 0))
(do ((len (read-string!/partial buf p) (read-string!/partial buf p)))
((not len) count)
(set! count (+ count (string-count buf #\newline 0 len)))))
(let loop ((line (read-line p)))
(if (eof-object? line) (port-line p) (loop (read-line p))))
(use-modules (srfi srfi-13))
(let loop ((line (read-line p)))
(cond ((not eof-object? line)
(for-each some-function-of-word (string-tokenize line))
(loop (read-line p)))))
(let ((table (make-hash-table 31)))
(let loop ((line (read-line p)))
(cond ((not (eof-object? line))
(for-each
(lambda (w) (hash-set! table w (1+ (hash-ref table w 0))))
(string-tokenize line))
(loop (read-line p)))))
(hash-fold (lambda (k v p) (format #t "~5D ~A\n" v k)) #f table))
(define lines (read-lines file))
(for-each (lambda (word) do-something-with-word) (reverse lines))
(fold (lambda (word acc) do-something-with-word) #f lines)
(define (tail file)
(call-with-input-file file
(lambda (p)
(let loop ((line (read-line p)))
(cond ((eof-object? line)
(sleep sometime)
(let ((pos (ftell p)))
(seek p 0 SEEK_SET)
(seek p pos SEEK_SET)))
(else
))
(loop (read-line p))))))
(let ((rand-line #f))
(let loop ((line (read-line p)))
(cond ((not (eof-object? line))
(if (= 0 (random (port-line p)))
(set! rand-line line))
(loop (read-line p)))))
)
(define (shuffle list)
(let ((v (list->vector list)))
(do ((i (1- (vector-length v)) (1- i)))
((< i 0) (vector->list v))
(let ((j (random (1+ i))))
(cond ((not (= i j))
(let ((temp (vector-ref v i)))
(vector-set! v i (vector-ref v j))
(vector-set! v j temp))))))))
(define rand-lines (shuffle (read-lines file))
(do ((line (read-line p) (read-line p)))
((= ((port-line p) desired-line-number) line)))
(define lines (read-lines file))
(list-ref lines desired-line-number)
(use-modules (srfi srfi-13) (srfi srfi-14))
(define fields (string-tokenize line (string->charset "+-")))
(define fields (string-tokenize line (string->charset ":")))
(define fields (string-tokenize line))
(let ((p (open-file file "r+")))
(let ((pos 0))
(let loop ((line (read-line p)))
(cond ((eof-object? (peek-char p))
(seek p 0 SEEK_SET)
(truncate-file p pos)
(close p))
(else
(set! pos (ftell p))
(loop (read-line p)))))))
(let* ((address (* recsize recno))
(buf (make-string recsize)))
(seek p address SEEK_SET)
(read-string!/partial buf p)
buf)
(let* ((address (* recsize recno))
(buf (make-string recsize)))
(seek p address SEEK_SET)
(read-string!/partial buf p)
(seek p address SEEK_SET)
(write-string/partial buf p)
(close p))
(seek p addr SEEK_SET)
(define str (read-delimited (make-string 1 #\nul) p))
#!/usr/local/bin/guile -s
!#
(use-modules (ice-9 format))
(define args (cdr (command-line)))
(define file (car args))
(define addrs (map string->number (cdr args)))
(define delims (make-string 1 #\nul))
(call-with-input-file file
(lambda (p)
(for-each
(lambda (addr)
(seek p addr SEEK_SET)
(format #t "~X ~O ~D ~S\n" addr addr addr
(read-delimited delims p)))
addrs)))
(define entry (stat "/usr/bin/vi"))
(define entry (stat "/usr/bin"))
(define entry (stat port))
(use-modules (ice-9 posix))
(define inode (stat "/usr/bin/vi"))
(define ctime (stat:ctime inode))
(define size (stat:size inode))
(define F (open-input-file filename))
(define dir (opendir "/usr/bin"))
(do ((filename (readdir dir) (readdir dir)))
((eof-object? filename))
(format #t "Inside /usr/bin is something called ~A\n" filename))
(closedir dir)
(define inode (stat filename))
(define readtime (stat:atime inode))
(define writetime (stat:mtime inode))
(utime newreadtime newwritetime filename)
(define seconds-per-day (* 60 60 24))
(define inode (stat file))
(define atime (stat:atime inode))
(define mtime (stat:mtime inode))
(set! atime (- atime (* 7 seconds-per-day)))
(set! mtime (- mtime (* 7 seconds-per-day)))
(utime file atime mtime)
(utime file (current-time))
(utime file (stat:atime (stat file)) (current-time))
#!/usr/local/bin/guile -s
!#
(define file (cadr (command-line)))
(define inode (stat file))
(define atime (stat:atime inode))
(define mtime (stat:mtime inode))
(system (string-append (or (getenv "EDITOR") "vi") " " file))
(utime file atime mtime)
(delete-file file)
(let ((count 0))
(for-each
(lambda (x)
(catch #t
(lambda () (delete-file x) (set! count (1+ count)))
(lambda (err . args) #f)))
file-list)
(if (not (= count (length file-list)))
(format (current-error-port) "could only delete ~A of ~A files"
count (length file-list))))
(copy-file oldfile newfile)
(rename-file oldfile newfile)
(use-modules (ice-9 rw) (ice-9 posix))
(with-input-from-file oldfile
(lambda ()
(call-with-output-file newfile
(lambda (p)
(let* ((inode (stat oldfile))
(blksize (if inode (stat:size inode) 16384))
(buf (make-string blksize)))
(let loop ((len (read-string!/partial buf)))
(cond ((and len (> len 0))
(write-string/partial buf p 0 len)
(loop (read-string!/partial buf))))))))))
(system (string-append "cp " oldfile " " newfile)) (system (string-append "copy " oldfile " " newfile))
(use-modules (ice-9 posix))
(let ((seen (make-hash-table 31)))
(for-each
(lambda (file)
(let* ((stats (stat file))
(key (cons (stat:dev stats) (stat:ino stats)))
(val (hash-ref seen key 0)))
(cond ((= val 0)
))
(hash-set! seen key (1+ val))))
file-names))
(let ((seen (make-hash-table 31)))
(for-each
(lambda (file)
(let* ((stats (stat file))
(key (cons (stat:dev stats) (stat:ino stats)))
(val (hash-ref seen key '())))
(hash-set! seen key (cons file val))))
file-names)
(hash-fold
(lambda (key value prior)
)
'() seen))
(let ((p (opendir dir)))
(let loop ((file (readdir p)))
(if (eof-object? file)
(close p)
)))
(define (directory-files dir)
(if (not (access? dir R_OK))
'()
(let ((p (opendir dir)))
(do ((file (readdir p) (readdir p))
(ls '()))
((eof-object? file) (closedir p) (reverse! ls))
(set! ls (cons file ls))))))
(cddr (directory-files dir))
(use-modules (ice-9 posix))
(define plain-files
(let ((rx (make-regexp "^\\.")))
(lambda (dir)
(sort (filter (lambda (x) (eq? 'regular (stat:type (stat x))))
(map (lambda (x) (string-append dir "/" x))
(remove (lambda (x) (regexp-exec rx x))
(cddr (directory-files dir)))))
string<))))
(define (glob->regexp pat)
(let ((len (string-length pat))
(ls '("^"))
(in-brace? #f))
(do ((i 0 (1+ i)))
((= i len))
(let ((char (string-ref pat i)))
(case char
((#\*) (set! ls (cons "[^.]*" ls)))
((#\?) (set! ls (cons "[^.]" ls)))
((#\[) (set! ls (cons "[" ls)))
((#\]) (set! ls (cons "]" ls)))
((#\\)
(set! i (1+ i))
(set! ls (cons (make-string 1 (string-ref pat i)) ls))
(set! ls (cons "\\" ls)))
(else
(set! ls (cons (regexp-quote (make-string 1 char)) ls))))))
(string-concatenate (reverse (cons "$" ls)))))
(define (glob pat dir)
(let ((rx (make-regexp (glob->regexp pat))))
(filter (lambda (x) (regexp-exec rx x)) (directory-files dir))))
(define files (glob "*.c" "."))
(define files (glob "*.[ch]" "."))
(define dirs (filter
(lambda (x) (eq? 'directory (stat:type (stat x))))
(map (lambda (x) (string-append dir "/" x))
(sort (filter (lambda (x) (string-match "^[0-9]+$" x))
(directory-files dir))
(lambda (a b)
(< (string->number a) (string->number b)))))))
(define (find proc . dirs)
(cond ((pair? dirs)
(for-each proc (map (lambda (x) (string-append (car dirs) "/" x))
(directory-files (car dirs))))
(apply find proc (cdr dirs)))))
(find (lambda (x) (format #t "~A~A\n" x
(if (equal? (stat:type (stat x)) 'directory)
"/" ""))) ".")
(define saved-size -1)
(define saved-name "")
(define (biggest file)
(let ((stats (stat file)))
(if (eq? (stat:type stats) 'regular)
(let ((size (stat:size (stat file))))
(cond ((> size saved-size)
(set! saved-size size)
(set! saved-name file)))))))
(apply find biggest (cdr (command-line)))
(format #t "Biggest file ~A in ~A is ~A bytes long.\n"
saved-name (cdr (command-line)) saved-size)
#!/usr/local/bin/guile -s
!#
(define (print-dirs f)
(if (eq? (stat:type (stat f)) 'directory)
(write-line f)))
(apply find print-dirs (cdr (command-line)))
#!/usr/local/bin/guile -s
!#
(define (finddepth proc . dirs)
(cond ((pair? dirs)
(apply finddepth proc (cdr dirs))
(for-each proc (map (lambda (x) (string-append (car dirs) "/" x))
(directory-files (car dirs)))))))
(define (zap f)
(let ((rm (if (eq? (stat:type (stat f)) 'directory) rmdir delete-file)))
(format #t "deleting ~A\n" f)
(catch #t
(lambda () (rm f))
(lambda args (format #t "couldn't delete ~A\n" f)))))
(let ((args (cdr (command-line))))
(if (null? args)
(error "usage: rmtree dir ..\n")
(apply finddepth zap args)))
(for-each
(lambda (file)
(let ((newname (function-of file)))
(catch #t
(lambda () (rename-file file newname))
(lambda args (format (current-error-port)
"couldn't rename ~A to ~A\n" file newname)))))
names)
#!/usr/local/bin/guile -s
!#
(use-modules (ice-9 regex)) (define args (cdr (command-line)))
(if (null? args) (error "usage: rename expr [files]\n"))
(define proc (eval-string (car args)))
(for-each
(lambda (old)
(let ((new (proc old)))
(if (not (string=? old new))
(catch #t
(lambda () (rename-file old new))
(lambda args (format (current-error-port)
"couldn't rename ~A to ~A\n" old new))))))
(cdr args))
#f "\\.orig\$" x (quote pre)))' *.orig
x
(string-downcase x)))' *
(define base (basename path))
(define base (dirname path ext))
(define dir (dirname path))
(define path "/usr/lib/libc.a")
(define file (basename path))
(define dir (dirname path))
(format #t "dir is ~A, file is ~A\n" dir file)
(basename path ".a")
(use-modules (ice-9 regex))
(define (file-parse path . args)
(let* ((ext (if (null? args) "\\..*" (car args)))
(rx1 (string-append "^((.*)/)?(.*)?(" ext ")$"))
(rx2 (string-append "^((.*)/)?(.*)?()$")))
(let ((m (or (string-match rx1 path) (string-match rx2 path))))
(list (match:substring m 2) (match:substring m 3)
(match:substring m 4)))))
(define (extension path . args)
(caddr (apply file-parse path args)))
(define *greeted* 0)
(define (hello)
(set! *greeted* (+ *greeted* 1))
(print "hi there!, this procedure has been called" *greeted* "times"))
(define (how-many-greetings) *greeted*)
(hello)
(define *greetings* (how-many-greetings))
(print "bye there!, there have been" *greetings* "greetings so far")
(define (hypotenuse side1 side2)
(sqrt (sum (* side1 side1) (* side2 side2))))
(define *diag* (hypotenuse 3 4))
(define (hypotenuse side1 . other-sides)
(let ((all-sides (cons side1 other-sides)))
(for-each
(lambda (side)
'())
all-sides)
'()))
(define *diag* (hypotenuse 3 4))
(define (hypotenuse sides)
(let ((side1 (car sides)) (side2 (caar sides)))
(sqrt (sum (* side1 side1) (* side2 side2)))))
(define *args* '(3 4))
(define *diag* (hypotenuse *args*))
(define *nums* (vector 1.4 3.5 6.7))
(define (int-all vec)
(vector-map-in-order
(lambda (element) (inexact->exact (round element)))
vec))
(define *ints* (int-all *nums*))
(print *nums*)
(print *ints*)
(define *nums* (vector 1.4 3.5 6.7))
(define (trunc-all vec)
(array-map-in-order!
(lambda (element) (inexact->exact (round element)))
vec))
(trunc-all *nums*)
(define (some-func parm1 parm2 parm3)
(let ((var1 1) (var2 2) (var3 3))
)
)
(define *name* (caar (command-line)))
(define *age* (cadr (command-line)))
(define *start* (fetch-time))
(let ((name (caar (command-line)))
(age (cadr (command-line)))
(start (fetch-time)))
'()
)
(define *pair* '(1 . 2))
(define a (car *pair*))
(define b (cdr *pair*))
(define c (fetch-time))
(define (run-check)
'()
)
(define (check-x x y)
(if (run-check)
(print "got" x)))
(check-x 1 2)
(let ((a (car *pair*))
(b (cdr *pair*))
(c (fetch-time)))
(check-x 1 2)
'()
)
(let* ((a (car *pair*))
(b (cdr *pair*))
(c (fetch-time))
(run-check
(lambda ()
'()))
(check-x
(lambda (x y)
(if (run-check)
(print "got" x)))) )
(check-x 1 2)
'()
)
(define *variable* 1)
(let* ((variable 1)
(mysub
(lambda ()
'())))
'()
)
(bind-values ((a) b (c (+ *global* 5)))
'()
)
(let* ((counter 42)
(next-counter
(lambda () (set! counter (+ counter 1)) counter))
(prev-counter
(lambda () (set! counter (- counter 1)) counter)))
'()
)
(define (make-counter start)
(let* ((counter 42)
(next-counter
(lambda () (set! counter (+ counter 1)) counter))
(prev-counter
(lambda () (set! counter (- counter 1)) counter)))
(lambda (op)
(cond
((eq? op 'prev) prev-counter)
((eq? op 'next) next-counter)
(else (lambda () (display "error:counter"))) ))))
(define (prev-counter counter) (apply (counter 'prev) '()))
(define (next-counter counter) (apply (counter 'next) '()))
(define *counter* (make-counter 42))
(print (prev-counter *counter*))
(print (prev-counter *counter*))
(print (next-counter *counter*))
(use-modules (ice-9 debug))
(define (child num)
(let ((s (make-stack #t 3 1))
(trace-string-port (open-output-string))
(parent-name ""))
(display-backtrace s trace-string-port)
(set! parent-name
(caddr (string-tokenize
(cadr (string-split
(get-output-string trace-string-port)
#\newline))
char-set:graphic)))
(print parent-name)))
(define (parent)
(child 1)
(child 2)
(child 3))
(parent)
(array-diff *array1* *array2*)
(define (add-vector-pair x y)
(let* ((vector-length (vector-length x))
(new-vec (make-vector vector-length)))
(let loop ((i 0))
(cond
((= i vector-length) new-vec)
(else
(vector-set! new-vec i (+ (vector-ref x i) (vector-ref y i)))
(loop (+ i 1)) ))) ))
(define *a* '#(1 2))
(define *b* '#(5 8))
(define *c* (add-vector-pair *a* *b*))
(print *c*)
(if (and (vector? a1) (vector? a2))
(print (add-vector-pair a1 a2))
(print "usage: add-vector-pair a1 a2"))
(define (my-sub)
(let* ((datatype (vector '() 7 '(1 2 3) "abc" 'sym)))
(vector-ref datatype (random (vector-length datatype))) ))
(define *result* (my-sub))
(cond
((null? *result*) (print "void context"))
((list? *result*) (print "list context"))
((number? *result*) (print "scalar context"))
((string? *result*) (print "string context"))
((symbol? *result*) (print "atom context"))
(else (print "Unknown type")))
(use-modules (ice-9 optargs))
(define* (the-func #:key (increment (cons 10 's))
(finish (cons 0 'm))
(start (cons 0 'm)))
(print increment)
(print finish)
(print start))
(the-func)
(the-func
#:increment (cons 20 's) #:start (cons 5 'm) #:finish (cons 30 'm))
(the-func #:start (cons 5 'm) #:finish (cons 30 'm))
(the-func #:finish (cons 30 'm))
(the-func #:start (cons 5 'm) #:increment (cons 20 's))
(define (somefunc)
(let ((a (make-vector 5))
(h (make-hash-table 5)))
(list a h) ))
(let* ((return-list (somefunc))
(a (car return-list))
(b (cadr return-list)))
'())
(use-syntax (ice-9 syncase))
(define-syntax let-values
(syntax-rules ()
((_ () f1 f2 ...) (let () f1 f2 ...))
((_ ((fmls1 expr1) (fmls2 expr2) ...) f1 f2 ...)
(lvhelp fmls1 () () expr1 ((fmls2 expr2) ...) (f1 f2 ...)))))
(define-syntax lvhelp
(syntax-rules ()
((_ (x1 . fmls) (x ...) (t ...) e m b)
(lvhelp fmls (x ... x1) (t ... tmp) e m b))
((_ () (x ...) (t ...) e m b)
(call-with-values
(lambda () e)
(lambda (t ...)
(let-values m (let ((x t) ...) . b)))))
((_ xr (x ...) (t ...) e m b)
(call-with-values
(lambda () e)
(lambda (t ... . tmpr)
(let-values m (let ((x t) ... (xr tmpr)) . b)))))))
(define (somefunc)
(let ((a (make-vector 5))
(h (make-hash-table 5)))
(values a h) ))
(let-values ( ((a h) (somefunc)) )
(print (array? a))
(print (hash-table? h)))
(define (sub-failed) '())
(define (look-for-something)
...
(if (something-found)
something
#f
))
(if (not (look-for-something))
(print "Item could not be found ...")
'()
(define (ioctl)
#f)
(or (ioctl) (begin (print "can't ioctl") (exit 1)))
(define (func-with-no-arg) ...)
(define (func-with-one-arg arg1) ...)
(define (func-with-two-arg arg1 arg2) ...)
(define (func-with-three-arg arg1 arg2 arg3) ...)
(define (die msg . error-code)
(display (string-append msg "\n") (current-error-port))
(exit (if (null? error-code) 1 (car error-code))))
(die "some message")
(throw 'some-exception)
(throw #t)
(throw "my message")
(throw 1)
(define (false-if-exception proc)
(catch #t
proc
(lambda (key . args) #f)))
(define (func)
(print "Starting 'func' ...")
(throw 'myexception 1)
(print "Leaving 'func' ..."))
(if (not (false-if-exception main))
(print "'func' raised an exception")
(print "'func' executed normally"))
(define (full-moon-exception-handler key . args)
(print "I'm executing after stack unwound !"))
(define (full-moon-exception-prewind-handler key . args)
(print "I'm executing with the stack still intact !"))
(define (func)
(print "Starting 'func' ...")
(throw 'full-moon-exception 1)
(print "Leaving 'func' ..."))
(catch 'full-moon-exception
func
full-moon-exception-handler
full-moon-exception-prewind-handler)
(define age 18)
(define (func)
(print age))
(if (condition)
(let ((age 23))
(print age)
(func) ))
(if (condition)
(fluid-let ((age 23))
(print age)
(func) ))
(define (grow) (print "grow"))
(define (shrink) (print "shrink"))
(grow)
(shrink)
(define grow shrink)
(grow)
(shrink)
(let ((grow shrink))
(grow)
(shrink))
(define *colours*
(list
'("red" . "baron")
'("blue" . "zephyr")
'("green" . "beret")
'("yellow" . "ribbon")
'("orange" . "county")
'("purple" . "haze")
'("violet" . "temper") ))
(for-each
(lambda (colour)
(let ((proc-string
(string-append
"(define " (car colour) " (lambda () "
"\"<FONT COLOR=" (car colour) ">" (cdr colour)
"</FONT>\"))" )))
(eval-string proc-string)))
*colours*)
(for-each
(lambda (colour)
(print (apply (string->procedure (car colour)) '())))
*colours*)
(catch #t
x
(lambda (key . args) ... ))
(define (outer arg)
(let* ((x (+ arg 35))
(inner (lambda () (* x 19))))
(+ x (inner))))
(define (outer arg)
(let ((x (+ arg 35)))
(define (inner) (* x 19))
(+ x (inner))))
(use-modules ((alpha)
:select (name)
:renamer (symbol-prefix-proc 'alpha:)) )
(use-modules ((omega)
:select (name)
:renamer (symbol-prefix-proc 'omega:)) )
(print
(string-append "Alpha is " alpha:name ", Omega is " omega:name))
(define-module (alpha))
(define-public name "first")
(define-module (omega))
(define-public name "last")
(use-modules ((omega))
(define-module (new-module)
#:autoload (mod-x) (mod-y))
(if (item-from-mod-x item)
#t
#f)
(define-module (your-module))
(define-public version "1.2")
(define-public (a-public-proc arg) "a-public-proc")
(define-public (another-public-proc arg) "another-public-proc")
(define a-private-var "...")
(define (a-private-proc arg) '())
(define-module (your-module))
(define version "1.2")
(define (a-public-proc arg) "a-public-proc")
(define (another-public-proc arg) "another-public-proc")
(export version a-public-proc another-public-proc)
(define a-private-var "...")
(define (a-private-proc arg) '())
(use-modules ((your-module)
:renamer (symbol-prefix-proc 'ym:)) )
(print ym:version)
(print (ym:a-public-proc 'x))
(print (ym:another-public-proc 'x))
(use-modules (your-module))
(print version)
(print (a-public-proc 'x))
(print (another-public-proc 'x))
(define (module-available? module-name)
(catch #t
(lambda () (resolve-interface module-name) #t)
(lambda (key . args) #f)))
(if (module-available? '(alpha))
(use-modules ((alpha)
:renamer (symbol-prefix-proc 'alpha:)) )
(print "Module does not exist / not in load path"))
(print alpha:aa)
(let ((num1 #f) (num2 #f))
(cond
((and
(= (length (command-line)) 3)
(begin (set! num1 (string->number (cadr (command-line)))) num1)
(begin (set! num2 (string->number (caddr (command-line)))) num2))
(use-modules ((some-module)
:renamer (symbol-prefix-proc 'some:)) )
(use-modules ((another-module)
:renamer (symbol-prefix-proc 'another:)) )
...)
(else
(die
(string-append
"usage: guile -s " (car (command-line)) " num1 num2")) )))
(cond
(opt-b
(use-modules ((bigmath)
:renamer (symbol-prefix-proc 'bigmath:)) )
(else
(define-module (alpha))
(define-public aa 10)
(define-public x "azure")
(define-module (beta))
(define-public bb 20)
(define-public x "blue")
(use-modules ((alpha)
:renamer (symbol-prefix-proc 'alpha:)) )
(use-modules ((beta)
:renamer (symbol-prefix-proc 'beta:)) )
(print
(string-append
(number->string alpha:aa) ", "
(number->string beta:bb) ", "
alpha:x ", "
beta:x))
@@INCOMPLETE@@
@@INCOMPLETE@@
@@INCOMPLETE@@
@@INCOMPLETE@@
#!
!#
(define (print item . rest)
(let ((all-item (cons item rest)))
(for-each
(lambda (item) (display item) (display " "))
all-item))
(newline))
(define (for-each-idx proc list . start-idx)
(let loop ((i (if (null? start-idx)
0
(car start-idx)))
(list list))
(cond
((null? list) '())
(else
(proc i (car list))
(loop (+ i 1) (cdr list)))) ))
(for-each-idx
(lambda (i item)
(print i item))
%load-path)
(print (current-time))
(define current-time
(lambda () "This isn't the current time !"))
(print (current-time))
(define-module (override))
(define-public current-time
(lambda () "This isn't the current time !"))
(define-public (return-current-time)
(current-time))
(use-modules ((override)
:renamer (symbol-prefix-proc 'override:)) )
(print (override:current-time))
(print (current-time))
(use-modules (override))
(print (current-time))
(define (die msg . error-code)
(display (string-append msg "\n") (current-error-port))
(exit (if (null? error-code) 1 (car error-code))))
(define (even-only num)
(or (= (modulo num 2) 0)
(die (string-append (number->string num) " is not even"))))
(even-only 2) (even-only 3)
(even-only '$) (even-only "34")
(define (even-only num)
(catch #t
(lambda () (= (modulo num 2) 0))
(lambda (key . args)
(let* ((snum
(cond
((number? num) (number->string num))
((symbol? num) (symbol->string num))
((string? num) (string-append "\"" num "\""))
(else "???") )))
(print (string-append snum " is not even"))
#f))))
(even-only 2) (even-only 3) (even-only '$) (even-only "34")
(define (false-if-exception proc)
(catch #t
proc
(lambda (key . args) #f)))
(define (even-only num)
(false-if-exception
(lambda () (= (modulo num 2) 0)) ))
(even-only 2) (even-only 3) (even-only '$) (even-only "34")
(define (load-module module-name)
(let ((name (string->symbol module-name))
(prefix (string->symbol (string-append module-name ":"))))
(primitive-eval
`(use-modules ((,name) :renamer (symbol-prefix-proc ',prefix)))) ))
(define (string->procedure proc-name)
(primitive-eval (string->symbol proc-name)))
(define (make-prefixed-proc prefix proc-name)
(string->procedure (string-append prefix ":" proc-name)))
(load-module "override")
(print (apply (make-prefixed-proc "override" "current-time") '()))
(print (override:current-time))
(define-module (main))
(define-public (log n) ...)
(define module-name "main")
(load-module module-name)
(define log-proc (make-prefixed-proc module-name "log"))
(let loop ((i 2))
(cond
((= i 1000) '())
(else
(print (apply log-proc (list i)))
(loop (+ i 1))) ))
(define blue colours:blue)
(define main-blue colours:azure)
@@INCOMPLETE@@
@@INCOMPLETE@@
@@INCOMPLETE@@
@@INCOMPLETE@@
@@INCOMPLETE@@
(define (sample-proc)
"This procedure does this, that, and the other ..."
... procedure code ...)
(procedure-documentation sample-proc)
(define-module (module))
(define private-variable "...")
(define (private-procedure arg1 arg2)
'())
(define-public exported-variable "...")
(define-public (exported-procedure arg1 arg2)
'())
(use-modules (oop goops))
(define-class <data-encoder> ())
(define obj (make <data-encoder>))
(define obj #(3 5))
(format #t "~A ~A\n" (class-of obj) (array-ref obj 1))
(change-class v <human-cannibal>) (format #t "~A ~A\n" (slot-ref obj stomach) (slot-ref obj name))
(slot-ref obj 'stomach)
(slot-set! obj 'stomach "Empty")
(name obj)
(set! (name obj) "Thag")
(define-class <lawyer> (<human-cannibal>))
(define lector (make <human-cannibal>))
(feed lector "Zak")
(move lector "New York")
(define-class <my-class> ()
(start #:init-form (current-time))
(age #:init-value 0))
(define-class <my-class> ()
(start #:init-form (current-time))
(age #:init-value 0)
(properties #:init-value '()))
(define (initialize (m <my-class>) initargs)
(and-let* ((extra (memq #:extra initargs)))
(slot-set! m 'properties (cdr extra))))
(slot-ref obj 'name)
(slot-set! obj 'name value)
(define-class <my-class> ()
(name #:accessor name))
(name obj)
(set! (name obj) value)
(define-class <my-class> ()
(name #:getter name)
(age #:setter age))
(name obj)
(set! (age obj) value)
(define-method ((setter name) (obj <my-class>) value)
(cond ((string-match "[^-\\w0-9']" value)
(warn "funny characters in name"))
((string-match "[0-9]" value)
(warn "numbers in name"))
((not (string-match "\\w+\\W+\\w+" value))
(warn "prefer multiword names"))
((not (string-match "\\w" value))
(warn "name is blank")))
(slot-set! obj 'name (string-downcase value)))
(define body-count 0)
(define-method (initialize (obj <person>) initargs)
(set! body-count (1+ body-count))
(next-method))
(define people '())
(do ((i 1 (1+ i)))
((> i 10))
(set! people (cons (make <person>) people)))
(format #t "There are ~A people alive.\n" body-count)
(define him (make <person>))
(slot-set! him 'gender "male")
(define her (make <person>))
(slot-set! her 'gender "female")
(slot-set! (make <fixed-array>) 'max-bounds 100) (define alpha (make <fixed-array>))
(format #t "Bound on alpha is ~D\n" (slot-ref alpha 'max-bounds))
(define beta (make <fixed-array>))
(slot-set! beta 'max-bounds 50) (format #t "Bound on alpha is ~D\n" (slot-ref alpha 'max-bounds))
(define-class <fixed-array> ()
(max-bounds #:init-value 7 #:allocation #:class))
(define-class <person> () name age peers)
(define p (make <person>))
(slot-set! p 'name "Jason Smythe")
(slot-set! p 'age 13)
(slot-set! p 'peers '("Wilbur" "Ralph" "Fred"))
(format #t "At age ~D, ~A's first friend is ~A.\n"
(slot-ref p 'age) (slot-ref p 'name) (car (slot-ref p 'peers)))
(define-class <person> ()
(name #:accessor name)
(age #:accessor age))
(define-method ((setter age) (p <person>) a)
(cond ((not (number? a))
(warn "age" a "isn't numeric"))
((> a 150)
(warn "age" a "is unreasonable")))
(slot-set! p 'age a))
(define-class <family> ()
(head #:init-form (make <person>) #:accessor head)
(address #:init-value "" #:accessor address)
(members #:init-value '() #:accessor members))
(define folks (make <family>))
(define dad (head folks))
(set! (name dad) "John")
(set! (age dad) 34)
(format #t "~A's age is ~D\n" (name dad) (age dad))
(define-macro (define-uniform-class name supers slots . options)
`(define-class ,name ,supers
,@(map (lambda (s) (cons s (map (lambda (o) (if (eq? o '_) s o)) options)))
slots)))
(define-uniform-class <card> (name color cost type release text)
#:accessor _ #:init-value "")
(define-macro (define-default-class name supers . default&slots)
`(define-class ,name ,supers
,@(map (lambda (d&s) (list (cadr d&s)
#:init-value (car d&s)
#:accessor (cadr d&s)))
default&slots)))
(define-default-class hostent ()
("" name)
('() aliases)
("" addrtype)
(0 length)
('() addr-list))
(define type addrtype)
(define-method (addr (h <hostent>))
(car (addr-list h)))
(define obj1 (make <some-class>))
(define obj2 (make (class-of obj1)))
(define obj1 (make <widget>))
(define obj2 (deep-clone obj1))
(define methname "flicker")
(apply-generic (eval-string methname) obj 10)
(for-each (lambda (m) (apply-generic obj (eval-string m)))
'("start" "run" "stop"))
(define methods '("name" "rank" "serno"))
(define his-info
(map (lambda (m) (cons m (apply-generic (eval-string m) obj)))
methods))
(define his-info (list (cons "name" (name obj))
(cons "rank" (rank obj))
(cons "serno" (serno obj))))
(define fnref (lambda args (method obj args)))
(fnref 10 "fred")
(method obj 10 fred)
(is-a? obj <http-message>)
(is-a? <http-response> <http-message>)