10. Subroutines

; Note: Some of the examples will show code blocks in this style:
;
;  (define
;    ... code here ...
;  )
;
; This is not generally considered good style, and is not recommended;
; it is only used here to more clearly highlight block scope 

; By convention a 'global variable' i.e. a variable that is defined at
; the top-level, and as such, visible within any scope, is named with
; beginning and ending asterisks [and one to be used as a constant
; with beginning and ending plus signs]

(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")

; Subroutine parameters are named [whether directly, or indirectly in
; the case of variable arguments - see next example]; this is the only
; means of access [This contrasts with languages like Perl and REXX which
; allow access to arguments via array subscripting, and function calls,
; respectively]
(define (hypotenuse side1 side2)
  (sqrt (sum (* side1 side1) (* side2 side2))))

(define *diag* (hypotenuse 3 4))

;; ----

; 'other-sides' is the name of a list of containing any additional
; parameters. Note that a name is still used to access values
(define (hypotenuse side1 . other-sides)
  (let ((all-sides (cons side1 other-sides)))
    (for-each
      (lambda (side) 
        ;; ...
        '())
      all-sides)
  ;; ...
  '()))

;; ----

(define *diag* (hypotenuse 3 4))

;; ----

; Possible to pack parameters into a single structure [e.g. list or
; array], and access values contained therein
(define (hypotenuse sides)
  (let ((side1 (car sides)) (side2 (caar sides)))
    (sqrt (sum (* side1 side1) (* side2 side2)))))

;; ----

(define *args* '(3 4))
(define *diag* (hypotenuse *args*))

;; ------------

; Parameters passed by reference, however, whether original object is
; modified depends on choice of functions used to manipulate them
; [most functions create copies and return these; mutating versions of
; same functions may also exist [see next example] 
(define *nums* (vector 1.4 3.5 6.7))

(define (int-all vec)
  (vector-map-in-order
    (lambda (element) (inexact->exact (round element)))
    vec))

; Copy created
(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))

; Original modified
(trunc-all *nums*)

; Scheme is lexically-scoped; variables defined within a block are
; visible only within that block. Whilst nested / subordinate blocks
; have access to those variables, neither the caller, nor any called
; procedures have direct access to those same variables

(define (some-func parm1 parm2 parm3)
  ;; ... paramaters visible here ...

  (let ((var1 1) (var2 2) (var3 3))
    ;; ... parameters also visible here, but variables, 'var1' etc
    ;;     only visible within this block ...
  )
  ;; ... paramaters also visible here, but still within procedure body ...
)

;; ------------

; Top-level definitions - accessable globally 
(define *name* (caar (command-line)))
(define *age* (cadr (command-line)))

(define *start* (fetch-time))

;; ----

; Lexical binding - accessable only within this block
(let ((name (caar (command-line)))
      (age (cadr (command-line)))
      (start (fetch-time)))
   ;; ... variables only visible here ...
   '()
)

;; ------------

(define *pair* '(1 . 2))

; 'a' and 'b' need to be dereferenced and separately defined [Also,
; since globally defined, should really be named, '*a*', '*b*', etc]
(define a (car *pair*))
(define b (cdr *pair*))
(define c (fetch-time))

(define (run-check)
  ;; ... do something with 'a', 'b', and 'c' ...
  '()
)

(define (check-x x y)
  (if (run-check)
    (print "got" x)))

; Calling 'check-x'; 'run-check' has access to 'a', 'b', and 'c'
(check-x 1 2)

;; ----

; If defined within a block, variables 'a', 'b', and 'c' are no longer
; accessable anywhere except that scope. Therefore, 'run-check' as
; defined above can no longer access these variables [in fact, the code
; will fail because variables 'a', 'b', and 'c' do not exist when
; 'run-check' is defined]
(let ((a (car *pair*))
      (b (cdr *pair*))
      (c (fetch-time)))
   ;; ...
   (check-x 1 2)  
   ;; ...
   '()
)

;; ----

; The procedures, 'run-check' and 'check-x' are defined within the
; same block as variables, 'a', 'b', and 'c', so have direct access to
; them
(let* ((a (car *pair*))
       (b (cdr *pair*))
       (c (fetch-time))

       (run-check
         (lambda () 
           ;; ... do something with 'a', 'b', and 'c' ...
           '()))

       (check-x
         (lambda (x y)
           (if (run-check)
             (print "got" x)))) )
   ;; ...
   (check-x 1 2)  
   ;; ...
   '()
)

; Ordinarily, a variable must be initialised when it is defined,
; whether at the top-level: 
(define *variable* 1)

; ... or within a 'let' binding
(let* ((variable 1)
       (mysub
         (lambda () 
           ;; ... accessing 'variable' ...
         '())))
  ;; ... do stuff ...
  '()
)

; However, since Scheme allows syntactic extensions via 'macros' [of
; which there are two varieties: hygenic and LISP-based], it is
; possible to create new forms which alter this behaviour. For example,
; in this tutorial: http://home.comcast.net/~prunesquallor/macro.txt
; there is a macro implementation equivalent to 'let, 'called,
; 'bind-values', which allows variables to be defined without initial
; values; an example follows:

; Initialisation values for 'a' and 'b' not specified
(bind-values ((a) b (c (+ *global* 5)))
  ;; ... do stuff ...
  '()
)

; In Scheme many things are possible, but not all those things are
; offered as standard features :) !

;; ------------

(let* ((counter 42)
       (next-counter
         (lambda () (set! counter (+ counter 1)) counter))
       (prev-counter
         (lambda () (set! counter (- counter 1)) counter)))

  ;; ... do stuff with 'next-counter' and 'prev-counter' ...
  '()
)

;; ----

; A more complete, and practical, variation of the above code:

; 'counter' constructor
(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"))) ))))

; Interface functions to 'counter' functionality
(define (prev-counter counter) (apply (counter 'prev) '()))
(define (next-counter counter) (apply (counter 'next) '()))

; Create a 'counter'
(define *counter* (make-counter 42))

; Use the 'counter' ...
(print (prev-counter *counter*))
(print (prev-counter *counter*))
(print (next-counter *counter*))

; Scheme interpreters generally provide a rich collection of procedure
; metadata, as well as easy access to a program's current 'execution
; state'. Put simply, provision of a powerful, highly customisable
; debugging / tracing facility is almost taken for granted. However, using
; it to perform as trivial a task as obtaining the current function name
; is less than trivial [at least it seems so in Guile] as it appears to
; require quite some setup work. Additionally, the documentation talks
; about facilities e.g. trap installation, that don't appear to be
; available [at least, I couldn't find them].
;
; Example below uses in-built debugging facilities to dump a backtrace
; to a string port and extract the caller's name from the resulting
; string. Not exactly elegant ...

; Execute using: guile --debug ... else no useful output seen
(use-modules (ice-9 debug))

(define (child num)
  ; Create stack [i.e. activation record] object, discarding
  ; irrelevant frames
  (let ((s (make-stack #t 3 1))
        (trace-string-port (open-output-string))
        (parent-name ""))

    ; Dump backtrace to string port
    (display-backtrace s trace-string-port)

    ; Extract caller's name from backtrace data
    ; [shamefully crude - don't do this at home !]
    (set! parent-name
      (caddr (string-tokenize
               (cadr (string-split
                       (get-output-string trace-string-port)
                       #\newline))
               char-set:graphic)))

    ; Who's your daddy ?
    (print parent-name)))

; Each invocation of 'child' should see 'parent' displayed as
; the caller
(define (parent)
  (child 1)
  (child 2)
  (child 3))

(parent) 

; Procedure parameters are references to entities, so there is no special
; treatment required. If an argument represents a mutable object such
; as an array, then care should be taken to not mutate the object within
; the procedure, or a copy of the object be made and used

(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))
  ;else
    (print "usage: add-vector-pair a1 a2"))

  ;; ...

; AFAIK there is no Scheme equivalent to Perl's 'return context' where
; it is possible to use language primitives [e.g. 'wantarray'] to 
; dynamically specify the return type of a procedure. It is, however,
; possible to:
; * Return one of several types from a procedure, whether based on 
;   processing results [e.g. 'false' on error, numeric on success], or
;   perhaps specified via control argument
; * Check procedure return type and take appropriate action

(define (my-sub)
  (let* ((datatype (vector '() 7 '(1 2 3) "abc" 'sym)))
    (vector-ref datatype (random (vector-length datatype))) ))

;; ----

; '*result*' is bound to a randomly chosen datatype
(define *result* (my-sub))

(cond
  ; It is common to return an empty list to represent 'void'
  ((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")))

; Keyword parameters are fully supported. Note that pairs have
; replaced Perl strings in the examples since they are easier to
; manipulate

(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))

;; @@INCOMPLETE@@
;; @@INCOMPLETE@@

; The return of multiple values, whether arrays or other items, may be 
; achieved via:
; * Packaging return items as a single list, structure or array, an
;   approach which is usable across many languages, though can be
;   clunky because the procedure caller must manually extract all
;   items
; * The 'values' procedure, a more Schemish idiom, is usually used in
;   conjunction with the 'call-with-values' procedure [the former combines
;   multiple values, the latter captures and cleanly extracts them]. It
;   comes into its own, however, when used to create a 'macro' [an
;   extension to the Scheme language] like 'let-values', a variation of
;   the 'let' form that allows multiple return values to be placed directly
;   into separate variables. Implementation shown here is from 'The
;   Scheme Programming Language, 3rd Edition' by R. Kent Dybvig, though
;   there exists a more standard implementation in SRFI-11. There is also
;   the 'receive' functionality accessable via: (use-modules (ice-9 receive))

; [1] Implementation of 'somefunc' returning muliple values via packaging
; items within a list that is returned
(define (somefunc)
  (let ((a (make-vector 5))
        (h (make-hash-table 5)))
    (list a h) ))

; Retrieving procedure values requires that the return list be captured
; and each contained item separately extracted ['let*' used in place of
; 'let' to ensure correct retrieval order]
(let* ((return-list (somefunc))
       (a (car return-list))
       (b (cadr return-list)))

  ;; ... do something with 'a' and 'b' ...
  '())

;; ----------------------------

; [2] Implementation of 'somefunc' returning muliple values using the
; 'values' procedure 

(use-syntax (ice-9 syncase)) 

; 'let-values' from: http://www.scheme.com/tspl3/syntax.html#fullletvalues
(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) ))

; Multiple return items placed directly into separate variables
(let-values ( ((a h) (somefunc)) )
  (print (array? a))
  (print (hash-table? h)))

; Like most modern languages, Scheme supports exceptions for handling
; failure, something that will be illustrated in another section. However,
; conventions exist as to the choice of value used to indicate failure:
; * Empty list i.e. '() is often used for this task, as is it's string
;   counterpart, "", the empty string
; * Return false i.e. #f to indicate failed / not found etc, and a valid
;   value otherwise [e.g. testing set membership: if not a member, return
;   #f, but if a member, return the item itself rather than #t]

; Return empty list as indicating 'failure'
(define (sub-failed) '())

;; ------------

(define (look-for-something)
  ...
  (if (something-found)
    ; Item found, return the item
    something
  ;else
    ; Not found, indicate failure
    #f
  ))

;; ----

(if (not (look-for-something))
  (print "Item could not be found ...")
;else
  ;; do something with item ...
  ;; ...
  '()

;; ------------

; An interesting variation on returning #f as a failure indicator is
; in using the, 'false-if-exception' procedure whereby a procedure is
; executed, any exceptions it may throw caught, and handled by simply
; returning #f. See example in section on Exception Handling below.

;; ------------

(define (ioctl) 
  ;; ...
  #f)

(or (ioctl) (begin (print "can't ioctl") (exit 1)))

; Whether Scheme is seen to support prototyping depends on the definition
; of this term used:
; * Prototyping along the lines used in Ada, Modula X, and even C / C++,
;   in which a procedure's interface is declared separately from its
;   implementation, is *not* supported
; * Prototyping in which, as part of the procedure definition, parameter 
;   information must be supplied. This is a requirement in Scheme in that
;   parameter number and names must be given, though there is no need to
;   supply type information [optional and keyword parameters muddy the
;   waters somewhat, but the general principle applies]

(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) ...)

; Not exactly like the Perl example, but a way of immediately
; exiting from an application
(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")

;; ------------

; An exception is thrown via 'throw'; argument must be a symbol
(throw 'some-exception)

; Invalid attempts - these, themselves force a 'wrong-type-arg
; exception to be thrown
(throw #t)
(throw "my message")
(throw 1)

;; ------------

; Example of a 'catch all' handler - 'proc' is executed, and any
; exception thrown is handled, in this case by simply returning false
(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"))

;; ------------

; More typical exception handling example in which:
; * 'func' is executed
; * 'catch' either:
;   - returns return value of 'func' [if successful]
;   - executes handler(s)

(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)

; Scheme is lexically-scoped, so same-name, higher-level variables
; are merely shadowed in lower-level blocks. Upon exit from those
; blocks the higher-level values are again available. Therefore, the
; saving of global variables, as required by Perl, is not necessary

; Global variable
(define age 18)

; Procedure definition creates a closure - it captures the earlier
; version of, age', and will retain it
(define (func)
  (print age))

(if (condition)
  ; New 'local' variable created which acts to shadow the global
  ; version
  (let ((age 23))

    ; Prints 23 because the global variable is shadowed within 
    ; this block 
    (print age)

    ; However, lexical-scoping ensures 'func' still accesses the
    ; 'age' which was active when it was defined
    (func) ))

; The use of 'fluid-let' allows for similar behaviour to Perl's i.e.
; it mimics dynamic scope, but it does so cleanly in that once its
; scope ends any affected global variables are restored to previous
; values
(if (condition)

  ; This does not create a new 'local' variables but temporarily
  ; sets the global variable, 'age' to 23
  (fluid-let ((age 23))

    ; Prints 23 because it is accessing the global version of 'age'
    (print age)

    ; Prints 23 because it is its lexically-scoped version of 'age'
    ; that has its value altered, albeit temporarily
    (func) ))

; Define two procedures, bind them to identifiers
(define (grow) (print "grow"))
(define (shrink) (print "shrink"))

; Separate procedures executed
(grow)
(shrink)

; Rebind identifier; now acts as alias for latter
(define grow shrink)

; Same procedure executed in both cases
(grow)
(shrink)

;; ------------

; As for previous except that rebinding is localised and
; ends once local scope exited
(let ((grow shrink))
  (grow)
  (shrink))

;; ----------------------------

; Example of dynamically creating [from text data] and binding
; procedures. The example here is conceptually similar to the Perl
; example in that it makes use of an 'eval' type of facility to
; generate code from text. In Scheme such tasks are generally better
; dealt with using macros 

; List of procedure name / first argument pairs
(define *colours*
  (list
    '("red" . "baron")
    '("blue" . "zephyr")
    '("green" . "beret")
    '("yellow" . "ribbon")
    '("orange" . "county")
    '("purple" . "haze")
    '("violet" . "temper") ))

; Build a series of procedures dynamically by traversing the
; *colours* list and obtaining:
; * Procedure name from first item of pair
; * Procedure argument from second item of pair
(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*)

; Apply each of the dynamically-built procedures
(for-each
  (lambda (colour)
    (print (apply (string->procedure (car colour)) '())))
  *colours*)

; AFAICT Guile doesn't implement an AUTOLOAD facility in which a
; 'replacement' function is available should another one fail to
; load [though there is an autoload feature available with modules
; which is a load-on-demand facility aimed at conserving memory and
; speeding up initial program load time].
;
; One might think it would be feasable, however, to use exception
; handling to provide roughly similar functionality:

; Catch all exceptions
(catch #t
  ; Undefined procedure, 'x'
  x
  ; Exception handler could load missing code ?
  (lambda (key . args) ... ))

; However, an undefined function call is reported as:
;
;    ERROR: Unbound variable: ...
;
; and this situation doesn't appear to be user-trappable. 
;

; Both implementations below  are correct, and exhibit identical
; behaviour 

(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))))

;; @@INCOMPLETE@@
;; @@INCOMPLETE@@