Remove chicken back end

(Which was commented out anyway)
Three scheme back ends is enough to maintain, and Gambit does the same
job as chicken (fast startup of the interpreter, generating via C) but
seems to deal with the code Idris generates better.

Makefile

@@ -141,11 +141,9 @@ install-fromc: all-fromc install-all
 
 install-support:
 	mkdir -p ${PREFIX}/idris2-${IDRIS2_VERSION}/support/chez
-	mkdir -p ${PREFIX}/idris2-${IDRIS2_VERSION}/support/chicken
 	mkdir -p ${PREFIX}/idris2-${IDRIS2_VERSION}/support/racket
 	mkdir -p ${PREFIX}/idris2-${IDRIS2_VERSION}/support/gambit
 	install support/chez/* ${PREFIX}/idris2-${IDRIS2_VERSION}/support/chez
-	install support/chicken/* ${PREFIX}/idris2-${IDRIS2_VERSION}/support/chicken
 	install support/racket/* ${PREFIX}/idris2-${IDRIS2_VERSION}/support/racket
 	install support/gambit/* ${PREFIX}/idris2-${IDRIS2_VERSION}/support/gambit
 

idris2.ipkg

@@ -7,7 +7,6 @@ modules =
     Compiler.Inline,
     Compiler.LambdaLift,
     Compiler.Scheme.Chez,
---     Compiler.Scheme.Chicken,
     Compiler.Scheme.Racket,
     Compiler.Scheme.Gambit,
     Compiler.Scheme.Common,

src/Compiler/Scheme/Chicken.idr

@@ -1,112 +0,0 @@
-module Compiler.Scheme.Chicken
-
-import Compiler.Common
-import Compiler.CompileExpr
-import Compiler.Inline
-import Compiler.Scheme.Common
-
-import Core.Context
-import Core.Directory
-import Core.Name
-import Core.Options
-import Core.TT
-
-import Utils.Hex
-
-import Data.NameMap
-import Data.Vect
-import System
-import System.Info
-
-%default covering
-
-findCSI : IO String
-findCSI =
-  do env <- getEnv "CHICKEN_CSI"
-     pure $ fromMaybe "/usr/bin/env -S csi" env
-
-findCSC : IO String
-findCSC =
-  do env <- getEnv "CHICKEN_CSC"
-     pure $ fromMaybe "/usr/bin/env -S csc" env
-
-schHeader : List String -> String
-schHeader ds
-  = "(use numbers)\n" ++ unlines ds ++ "\n" ++
-    "(let ()\n"
-
-schFooter : String
-schFooter = ")"
-
-showChickenChar : Char -> String -> String
-showChickenChar '\\' = ("\\\\" ++)
-showChickenChar c
-   = if c < chr 32 || c > chr 126
-        then (("\\u" ++ pad (asHex (cast c))) ++)
-        else strCons c
-  where
-    pad : String -> String
-    pad str
-        = case isLTE (length str) 4 of
-               Yes _ => cast (List.replicate (4 - length str) '0') ++ str
-               No _ => str
-
-showChickenString : List Char -> String -> String
-showChickenString [] = id
-showChickenString ('"'::cs) = ("\\\"" ++) . showChickenString cs
-showChickenString (c ::cs) = (showChickenChar c) . showChickenString cs
-
-chickenString : String -> String
-chickenString cs = strCons '"' (showChickenString (unpack cs) "\"")
-
-mutual
-  chickenPrim : Int -> SVars vars -> ExtPrim -> List (CExp vars) -> Core String
-  chickenPrim i vs CCall [ret, fn, args, world]
-      = throw (InternalError ("Can't compile C FFI calls to Chicken Scheme yet"))
-  chickenPrim i vs SysCodegen []
-      = pure $ "\"chicken\""
-  chickenPrim i vs prim args
-      = schExtCommon chickenPrim chickenString i vs prim args
-
-compileToSCM : Ref Ctxt Defs ->
-               ClosedTerm -> (outfile : String) -> Core ()
-compileToSCM c tm outfile
-    = do ds <- getDirectives Chicken
-         (ns, tags) <- findUsedNames tm
-         defs <- get Ctxt
-         compdefs <- traverse (getScheme chickenPrim chickenString defs) ns
-         let code = concat compdefs
-         main <- schExp chickenPrim chickenString 0 [] !(compileExp tags tm)
-         support <- readDataFile "chicken/support.scm"
-         let scm = schHeader ds ++ support ++ code ++ main ++ schFooter
-         Right () <- coreLift $ writeFile outfile scm
-            | Left err => throw (FileErr outfile err)
-         coreLift $ chmod outfile 0o755
-         pure ()
-
-compileExpr : Ref Ctxt Defs -> (execDir : String) ->
-              ClosedTerm -> (outfile : String) -> Core (Maybe String)
-compileExpr c execDir tm outfile
-    = do tmp <- coreLift $ tmpName
-         let outn = tmp ++ ".scm"
-         compileToSCM c tm outn
-         csc <- coreLift findCSC
-         ok <- coreLift $ system (csc ++ " " ++ outn ++ " -o " ++ outfile)
-         if ok == 0
-            then pure (Just outfile)
-            else pure Nothing
-
-executeExpr : Ref Ctxt Defs -> (execDir : String) -> ClosedTerm -> Core ()
-executeExpr c execDir tm
-    = do tmp <- coreLift $ tmpName
-         let outn = tmp ++ ".scm"
-         compileToSCM c tm outn
-         csi <- coreLift findCSI
-         coreLift $ system (csi ++ " -s " ++ outn)
-         pure ()
-
-export
-codegenChicken : Codegen
-codegenChicken = MkCG compileExpr executeExpr
-
-

src/Core/Options.idr

@@ -33,14 +33,12 @@ toString (MkDirs wdir sdir bdir edir dfix edirs ldirs ddirs) =
 
 public export
 data CG = Chez
-        | Chicken
         | Racket
         | Gambit
 
 export
 Eq CG where
   Chez == Chez = True
-  Chicken == Chicken = True
   Racket == Racket = True
   Gambit == Gambit = True
   _ == _ = False
@@ -49,7 +47,6 @@ export
 availableCGs : List (String, CG)
 availableCGs
     = [("chez", Chez),
-       ("chicken", Chicken),
        ("racket", Racket),
        ("gambit", Gambit)]
 

src/Core/TTC.idr

@@ -716,14 +716,12 @@ TTC CDef where
 export
 TTC CG where
   toBuf b Chez = tag 0
-  toBuf b Chicken = tag 1
   toBuf b Racket = tag 2
   toBuf b Gambit = tag 3
 
   fromBuf b
       = case !getTag of
              0 => pure Chez
-             1 => pure Chicken
              2 => pure Racket
              3 => pure Gambit
              _ => corrupt "CG"

src/Idris/IDEMode/REPL.idr

@@ -1,7 +1,6 @@
 module Idris.IDEMode.REPL
 
 import Compiler.Scheme.Chez
--- import Compiler.Scheme.Chicken
 import Compiler.Scheme.Racket
 import Compiler.Scheme.Gambit
 import Compiler.Common

src/Idris/REPL.idr

@@ -1,7 +1,6 @@
 module Idris.REPL
 
 import Compiler.Scheme.Chez
--- import Compiler.Scheme.Chicken
 import Compiler.Scheme.Racket
 import Compiler.Scheme.Gambit
 import Compiler.Common
@@ -242,8 +241,6 @@ findCG
     = do defs <- get Ctxt
          case codegen (session (options defs)) of
               Chez => pure codegenChez
-              Chicken => throw (InternalError "Chicken CG not available")
-                         -- pure codegenChicken
               Racket => pure codegenRacket
               Gambit => pure codegenGambit
 

support/chicken/support.scm

@@ -1,143 +0,0 @@
-(define blodwen-read-args (lambda (desc)
-  (case (vector-ref desc 0)
-    ((0) '())
-    ((1) (cons (vector-ref desc 2)
-               (blodwen-read-args (vector-ref desc 3)))))))
-(define b+ (lambda (x y bits) (remainder (+ x y) (expt 2 bits))))
-(define b- (lambda (x y bits) (remainder (- x y) (expt 2 bits))))
-(define b* (lambda (x y bits) (remainder (* x y) (expt 2 bits))))
-(define b/ (lambda (x y bits) (remainder (exact-floor (/ x y)) (expt 2 bits))))
-
-(define blodwen-shl (lambda (x y) (arithmetic-shift x y)))
-(define blodwen-shr (lambda (x y) (arithmetic-shift x (- y))))
-(define blodwen-and (lambda (x y) (bitwise-and x y)))
-(define blodwen-or (lambda (x y) (bitwise-or x y)))
-(define blodwen-xor (lambda (x y) (bitwise-xor x y)))
-
-(define cast-num
-  (lambda (x)
-    (if (number? x) x 0)))
-(define destroy-prefix
-  (lambda (x)
-    (cond
-      ((equal? x "") "")
-      ((equal? (string-ref x 0) #\#) "")
-      (else x))))
-(define cast-string-int
-  (lambda (x)
-    (floor (cast-num (string->number (destroy-prefix x))))))
-(define exact-floor
-  (lambda (x)
-    (inexact->exact (floor x))))
-(define cast-string-double
-  (lambda (x)
-    (cast-num (string->number (destroy-prefix x)))))
-(define string-cons (lambda (x y) (string-append (string x) y)))
-(define get-tag (lambda (x) (vector-ref x 0)))
-(define string-reverse (lambda (x)
-  (list->string (reverse (string->list x)))))
-(define (string-substr off len s)
-    (let* ((l (string-length s))
-          (b (max 0 off))
-          (x (max 0 len))
-          (end (min l (+ b x))))
-          (substring s b end)))
-
-(define either-left
-  (lambda (x)
-    (vector 0 #f #f x)))
-
-(define either-right
-  (lambda (x)
-    (vector 1 #f #f x)))
-
-(define blodwen-error-quit
-  (lambda (msg)
-    (display msg)
-    (newline)
-    (exit 1)))
-
-;; Files: Much of the following adapted from idris-chez, thanks to Niklas
-;; Larsson
-
-;; All the file operations are implemented as primitives which return
-;; Either Int x, where the Int is an error code
-
-;; If the file operation raises an error, catch it and return an appropriate
-;; error code
-(define (blodwen-file-op op)
-  (handle-exceptions exn
-        (begin (either-left 255)) ; TODO: Calculate proper code!
-        (either-right (op))))
-
-(define (blodwen-get-n n p)
-    (if (input-port? p) (get-string-n p n) ""))
-
-(define (blodwen-putstring p s)
-    (if (output-port? p) (put-string p s) void)
-    0)
-
-(define (blodwen-open file mode bin)
-    (cond
-        ((string=? mode "r") (open-input-file file))
-        ((string=? mode "w") (open-output-file file))
-        (else (abort "I haven't worked that one out yet, sorry..."))))
-
-(define (blodwen-close-port p)
-    (cond
-      ((input-port? p) (close-input-port p))
-      ((output-port? p) (close-output-port p))))
-
-(define (blodwen-get-line p)
-    (if (port? p)
-        (let ((str (read-line p)))
-            (if (eof-object? str)
-                ""
-                str))
-        void))
-
-(define (blodwen-get-char p)
-    (if (port? p)
-        (let ((chr (read-char p)))
-            (if (eof-object? chr)
-                #\nul
-                chr))
-        void))
-
-(define (blodwen-eof p)
-  (if (eof-object? (peek-char p))
-      1
-      0))
-
-;; Threads
-
-(define (blodwen-thread p)
-    (thread-start! (make-thread (lambda () (p (vector 0))))))
-
-(define (blodwen-set-thread-data p)
-    (thread-specific-set! (current-thread) p))
-
-(define (blodwen-get-thread-data)
-    (thread-specific (current-thread)))
-
-(define (blodwen-mutex) (make-mutex))
-(define (blodwen-lock m) (mutex-lock! m))
-(define (blodwen-unlock m) (mutex-unlock! m))
-(define (blodwen-thisthread) (current-thread))
-
-(define (blodwen-condition) (make-condition-variable))
-(define (blodwen-condition-wait c m)
-  (mutex-unlock! m c)
-  (mutex-lock! m)) ;; lock again, for consistency with other CGs
-(define (blodwen-condition-wait-timeout c m t) (mutex-unlock! m c t))
-(define (blodwen-condition-signal c) (condition-variable-signal! c))
-(define (blodwen-condition-broadcast c) (condition-variable-broadcast! c))
-
-(define (blodwen-sleep s) (sleep s))
-
-(define (blodwen-args)
-  (define (blodwen-build-args args)
-    (if (null? args)
-        (vector 0 '())
-        (vector 1 '() (car args) (blodwen-build-args (cdr args)))))
-    (blodwen-build-args (argv)))