cyclone/scheme/cyclone/util.sld

;;;; Cyclone Scheme
;;;; https://github.com/justinethier/cyclone
;;;;
;;;; Copyright (c) 2014-2016, Justin Ethier
;;;; All rights reserved.
;;;;
;;;; This module contains various utility functions.
;;;;
(define-library (scheme cyclone util)
  (import (scheme base)
          (scheme char))
  (export
    ;; Code analysis
    tagged-list?
    if?
    begin?
    lambda?
    pair->list 
    formals->list
    lambda-formals->list
    lambda-varargs?
    lambda->formals
    lambda-formals-type
    lambda-varargs-var
    pack-lambda-arguments
    ;; Environments
    env:enclosing-environment
    env:first-frame
    env:the-empty-environment
    env:make-frame
    env:frame-variables
    env:frame-values 
    env:add-binding-to-frame! 
    env:all-variables
    env:extend-environment 
    env:lookup
    env:lookup-variable-value 
    env:_lookup-variable-value 
    env:set-variable-value! 
    env:define-variable! 
    ;; Syntactic closures
    make-syntactic-closure
    strip-syntactic-closures
    identifier->symbol
    identifier?
    identifier=?
    ;; ER macro supporting functions
    Cyc-er-rename
    Cyc-er-compare?
    ;; Code generation
    mangle
    mangle-global
    ;; Scheme library functions
    gensym
    delete
    delete-duplicates
    flatten
    length/obj
    list-index2
    list-insert-at!
    list-prefix?
    string-replace-all
    take
    filter)
  (begin

(define (tagged-list? tag exp)
  (if (pair? exp)
      (equal? (car exp) tag)
      #f))

; if? : exp -> boolean
(define (if? exp)
  (tagged-list? 'if exp))

; begin? : exp -> boolean
(define (begin? exp) 
  (tagged-list? 'begin exp))

; lambda? : exp -> boolean
(define (lambda? exp)
  (tagged-list? 'lambda exp))

;; Create a proper copy of an improper list
;; EG: (1 2 . 3) ==> (1 2 3)
(define (pair->list p)
  (let loop ((lst p))
    (if (not (pair? lst))
        (cons lst '())
        (cons (car lst) (loop (cdr lst))))))

; lambda->formals : lambda-exp -> list[symbol]
(define (lambda->formals exp)
  (cadr exp))

(define (lambda-varargs-var exp)
  (if (lambda-varargs? exp)
    (if (equal? (lambda-formals-type exp) 'args:varargs)
        (lambda->formals exp) ; take symbol directly
        (car (reverse (lambda-formals->list exp)))) ; Last arg is varargs
    #f))

;(define (lambda-varargs? exp)
;  (and (lambda? exp)
;       (or (symbol? (lambda->formals exp))
;           (and (pair? (lambda->formals exp))
;                (not (list? (lambda->formals exp)))))))
; Alternate definition, works even if exp is not a lambda (IE, an AST):
(define (lambda-varargs? exp)
  (let ((type (lambda-formals-type exp)))
    (or (equal? type 'args:varargs)
        (equal? type 'args:fixed-with-varargs))))

(define (lambda-formals-type exp)
 (let ((args (lambda->formals exp)))
   (cond
     ((symbol? args) 'args:varargs)
     ((list? args)   'args:fixed)
     ((pair? args)   'args:fixed-with-varargs)
     (else
       (error `(Unexpected formals list in lambda-formals-type: ,args))))))

(define (lambda-formals->list exp)
  (if (lambda-varargs? exp)
      (let ((args (lambda->formals exp)))
        (if (symbol? args)
            (list args)
            (pair->list args)))
      (lambda->formals exp)))

;; object -> list
;; Accept only args instead of a whole lambda
(define (formals->list args)
  (cond
   ((symbol? args) (list args))
   ((list? args) args)
   (else (pair->list args))))

;; Take arguments for a lambda and pack them depending upon lambda type
(define (pack-lambda-arguments formals args)
  (cond
    ((symbol? formals)
     (list args))
    ((list? formals)
     args)
    (else
     (let ((num-req-args (length/obj formals))
           (num-args (length args)))
      (if (> num-req-args num-args)
          (error "Too few arguments supplied" formals args))
      (append 
        (take args num-req-args) ;; Required args
        (list (list-tail args num-req-args)) ;; Optional args
      )))))

(define (length/obj l)
  (let loop ((lis l)
             (len 0))
    (cond
      ((pair? lis)
       (loop (cdr lis) (+ len 1)))
      (else
       len))))

; take : list -> integer -> list
; The take function from SRFI 1
(define (take lis k)
  ;(check-arg integer? k take)
  (let recur ((lis lis) (k k))
    (if (zero? k) '()
        (cons (car lis)
              (recur (cdr lis) (- k 1))))))

; char->natural : char -> natural
(define (char->natural c)
  (let ((i (char->integer c)))
    (if (< i 0)
        (* -2 i)
        (+ (* 2 i) 1))))

; integer->char-list : integer -> string
(define (integer->char-list n)
  (string->list (number->string n)))

;; Simplified version of filter from SRFI 1
(define (filter pred lis)
  (letrec ((recur (lambda (lis)
                    (if (null? lis)
                     lis
                     (let ((head (car lis))
                           (tail (cdr lis)))
                       (if (pred head)
                           (let ((new-tail (recur tail)))
                         (if (eq? tail new-tail) lis
                             (cons head new-tail)))
                           (recur tail)))))))
    (recur lis)))

;; Based off corresponding SRFI-1 definition
(define (delete x lis)
  (filter (lambda (y) (not (equal? x y))) lis))

;; Inefficient version based off code from SRFI-1
(define (delete-duplicates lis)
  (define (recur lis) ; ((lis lis))
    (if (null? lis) lis
        (let* ((x (car lis))
               (tail (cdr lis))
               (new-tail (recur (delete x tail))))
          (if (eq? tail new-tail) lis (cons x new-tail)))))
  (recur lis))

(define (flatten x)
  (cond ((null? x) '())
        ((pair? x) (append (flatten (car x)) (flatten (cdr x))))
        (else (list x))))

;; Insert obj at index k of list, increasing length of list by one.
(define (list-insert-at! lis obj k)
  (cond
   ((null? lis) (error "list-insert-at!, lis cannot be null"))
   ((and (> k 0) (null? (cdr lis)))
    (set-cdr! lis (cons obj '())))
   ((zero? k)
    (let ((old-car (car lis)))
      (set-car! lis obj)
      (set-cdr! lis (cons old-car (cdr lis)))))
   (else
    (list-insert-at! (cdr lis) obj (- k 1)))))

;; Find index of element in list, or -1 if not found
(define list-index2
  (lambda (e lst)
    (if (null? lst)
      -1
      (if (eq? (car lst) e)
        0
        (if (= (list-index2 e (cdr lst)) -1) 
          -1
          (+ 1 (list-index2 e (cdr lst))))))))

;; Replace all instances of needle within haystack.
;; Based on code from: 
;; http://stackoverflow.com/a/32320936/101258
(define (string-replace-all haystack needle replacement)    
  ;; most of the processing works on lists 
  ;; of char, not strings.
  (let ((haystack (string->list haystack))
        (needle (string->list needle))
        (replacement (string->list replacement))
        (needle-len (string-length needle)))
    (let loop ((haystack haystack) (acc '()))
      (cond ((null? haystack)
             (list->string (reverse acc)))
            ((list-prefix? haystack needle)
             (loop (list-tail haystack needle-len)
                   (reverse-append replacement acc)))
            (else
             (loop (cdr haystack) (cons (car haystack) acc)))))))

(define (reverse-append pre lis)
  (append (reverse pre) lis))

(define (list-prefix? lis prefix)
  (call/cc 
    (lambda (return)
      (for-each
        (lambda (x y)
          (if (not (equal? x y))
              (return #f)))
        lis
        prefix)
      (return #t))))
; Tests -
;(write (list-prefix? '(1 2 3 4 5) '(1 2)))
;(write (list-prefix? '(1 2 3) '(a 1 2 3 4)))
;(write (string-replace-all "The cat looks like a cat." "cat" "dog"))

; gensym-count : integer
(define gensym-count 0)

; gensym : symbol -> symbol
(define gensym (lambda params
                 (cond
                  ((null? params)
                       (set! gensym-count (+ gensym-count 1))
                       (string->symbol (string-append
                                        "$"
                                        (number->string gensym-count))))
                  (else
                       (set! gensym-count (+ gensym-count 1))
                       (string->symbol (string-append 
                                        (if (symbol? (car params))
                                            (symbol->string (car params))
                                            (car params))
                                        "$"
                                        (number->string gensym-count)))))))

;;;; Environments
;;;; TODO: longer-term, move these into their own module
(define (env:enclosing-environment env) (cdr env))
(define (env:first-frame env) (car env))
(define env:the-empty-environment '())

(define (env:make-frame variables values)
  (cons variables values))
(define (env:frame-variables frame) (car frame))
(define (env:frame-values frame) (cdr frame))
(define (env:add-binding-to-frame! var val frame)
  (set-car! frame (cons var (car frame)))
  (set-cdr! frame (cons val (cdr frame))))

(define (env:all-variables env)
  (flatten 
    (env:frame-variables
      (env:first-frame env))))

(define (env:extend-environment vars vals base-env)
  (if (= (length vars) (length vals))
      (cons (env:make-frame vars vals) base-env)
      (if (< (length vars) (length vals))
          (error "Too many arguments supplied" vars vals)
          (error "Too few arguments supplied" vars vals))))

(define (env:lookup-variable-value var env)
  (env:_lookup-variable-value var env 
    (lambda ()
      (error "Unbound variable" var))))

(define (env:_lookup-variable-value var env not-found)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (env:enclosing-environment env)))
            ((eq? var (car vars))
             (cond-expand
               (cyclone
                 (Cyc-get-cvar (car vals)))
               (else 
                 (car vals))))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env env:the-empty-environment)
        (not-found)
        (let ((frame (env:first-frame env)))
          (scan (env:frame-variables frame)
                (env:frame-values frame)))))
  (env-loop env))

(define (env:lookup var env default-value)
  (env:_lookup-variable-value var env (lambda () default-value)))

(define (env:set-variable-value! var val env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (env:enclosing-environment env)))
            ((eq? var (car vars))
             (cond-expand
               (cyclone
                 (if (Cyc-cvar? (car vals))
                   (Cyc-set-cvar! (car vals) val)
                   (set-car! vals val)))
               (else
                 (set-car! vals val))))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env env:the-empty-environment)
        (error "Unbound variable -- SET!" var)
        (let ((frame (env:first-frame env)))
          (scan (env:frame-variables frame)
                (env:frame-values frame)))))
  (env-loop env))

(define (env:define-variable! var val env)
  (let ((frame (env:first-frame env)))
    (define (scan vars vals)
      (cond ((null? vars)
             (env:add-binding-to-frame! var val frame))
            ((eq? var (car vars))
             ;; TODO: update compiled var
             ;; cond-expand
             ;;  if cvar
             ;;     set-cvar
             (set-car! vals val))
            (else (scan (cdr vars) (cdr vals)))))
    (scan (env:frame-variables frame)
          (env:frame-values frame))))
;;;; END Environments


;;;; Syntactic closures
;;
;; For now, we are implementing a limited form of SC that only accepts
;; a symbol as the expression. This is good enough for explicit renaming
;; macros, but more work is needed if we ever wanted to have a stand alone
;; syntactic closures macro system.

(define-record-type <syn-clo>
  (make-sc env free-names expr)
  sc?
  (env sc-env)
  (free-names sc-free-names)
  (expr sc-expr))
(define (make-syntactic-closure env free-names expr)
  ;; TODO: what if expr is a syn closure?
  (make-sc env free-names expr))
(define (strip-syntactic-closures expr)
  ;; TODO: no, recursively traverse form and replace the sc's
  (identifier->symbol expr))
(define (identifier? expr)
  (or (symbol? expr)
      (sc? expr)))
(define (identifier->symbol id)
  (cond
    ((sc? id) (sc-expr id))
    ((symbol? id) id)
    (else
      (error "Invalid parameter to identifier->symbol" id))))
(define (identifier=? env1 id1 env2 id2)
  (let ((val1 (env:lookup (identifier->symbol id1) env1 #f))
        (val2 (env:lookup (identifier->symbol id2) env2 #f)))
    (eq? val1 val2)))

;;; Explicit renaming macros

;; ER macro rename function, based on code from Chibi scheme
;  (lambda (sym) sym)) ; TODO: temporary placeholder, see below

;TODO: I think we're ready to cut back over to this now?

;(define (Cyc-er-rename mac-env)
; Notes:
;
; need to figure out what to return from this function so that renaming
; actually does what it is supposed to do (or a close approximation).
; then need to figure out what needs to change in the rest of the code to
; support that.
; 
; how renaming should work:
;
;  - ideally, add a closure from the macro-env for identifier
;  - practically, if identifier is defined in mac-env, gensym but
;    update mac-env so renamed variable points to original.
;    if not defined, is it the same as a gensym? or nothing at all???
;
;in order for this to work:
;
; - compiler needs to maintain env consisting of at least macros,
;   and pass this along. presumably this env would be used instead of
;   *defined-macros*.
; - interpreter can use a-env and global-env??????
;   there are open questions about extending a-env, but without eval being
;   able to define-syntax (yet), I think we can defer that until later.
;
;   can pass mac-env, useenv in to this guy (and compare as well), and possibly add renamed bindings to it.
;
; mac-env is 
;  - global env for interpreted macros, at least for now until
;    they can be recognized by eval
;  - ?? for compiled macros
;
; use-env is:
;  - current env for eval, can be passed in.
;    is this really a-env though? or do we need to extend it when
;    a new lambda scope is introduced?
;  - need to keep track of it for compiled macro expansion
;
(define (Cyc-er-rename use-env mac-env)
  ((lambda (renames)
     (lambda (identifier)
;(Cyc-write `(ER rename ,identifier) (current-output-port))
;(Cyc-display "\n"  (current-output-port))
       ((lambda (cell)
          (if cell
              (cdr cell)
              ((lambda (name)
                 (set! renames (cons (cons identifier name) renames))
                 name)

;; TODO: rename variables in use-env. do we need a cleanup env as well?
               (let ((val (env:lookup identifier mac-env 'not-defined)))
                 (cond
                   ((tagged-list? 'macro val)
                    (let ((renamed (gensym identifier)))
                      (env:define-variable! renamed val mac-env)
                      renamed))
                   #;((not (eq? val 'not-defined))
                     ;; Unrenamed variable identifier
                     (let ((renamed (gensym identifier)))
                       (env:define-variable! renamed identifier use-env)
;                       (env:define-variable! renamed identifier mac-env) ;; TODO: renamed val?
(Cyc-write `(ER rename ,identifier to ,renamed) (current-output-port))
(Cyc-display "\n"  (current-output-port))
                       renamed)
                     ;identifier ;; TESTING!
                   )
                   (else
                     identifier)))
               ; 
               ;(gensym identifier)
               ; gensym not good enough, need to also preserve ref trans.
               ; also note that an identifier can be an object, it does not
               ; just have to be a symbol. although, of course, the rest
               ; of the code needs to be able to handle identifiers in
               ; forms other than symbols, if that is done.
               ;
               ;(make-syntactic-closure mac-env '() identifier)
              )))
        (assq identifier renames))
       ))
   ;; TODO: For now, do not allow renaming of special form symbols to 
   ;; prevent issues within the compiler
   '(
     (define . define)
     (define-syntax . define-syntax)
     (define-c . define-c)
     (if . if)
     (lambda . lambda)
     (quote . quote)
     (set! . set!)
     (begin . begin) ;; TODO: just a quick-fix, not a long-term solution
    )))

(define (Cyc-er-compare? use-env)
  ;; TODO: this is not good enough, need to determine if these symbols
  ;; are the same identifier in their *environment of use*
  (lambda (a b)
    (eq? a b)))

;; Name-mangling.

;; We have to "mangle" Scheme identifiers into
;; C-compatible identifiers, because names like
;; foo-bar/baz are not identifiers in C.

; mangle : symbol -> string
(define (mangle symbol)
 (letrec
   ((m (lambda (chars)
      (if (null? chars)
        '()
        (if (or (and (char-alphabetic? (car chars)) (not (char=? (car chars) #\_)))
                (char-numeric? (car chars)))
            (cons (car chars) (m (cdr chars)))
            (cons #\_ (append (integer->char-list (char->natural (car chars)))
                              (m (cdr chars))))))))
    (ident (list->string (m (string->list (symbol->string symbol))))))
   (if (member (string->symbol ident) *c-keywords*)
     (string-append "_" ident)
     ident)))

(define (mangle-global symbol)
  (string-append "__glo_" (mangle symbol)))

(define *c-keywords* 
 '(auto _Bool break case char _Complex const continue default do double else
   enum extern float for goto if _Imaginary inline int long register restrict
   return short signed sizeof static struct switch typedef union unsigned
   void volatile while
   list  ;; Not a keyword but reserved type
   ))
;; END name mangling section

    ))